1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_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 := Empty;
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)
2837 Result : Node_Id := Empty;
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 pragma Assert (Present (Low_Bound));
3370 -- Now we can safely compute the upper bound, normally
3371 -- Low_Bound + Length - 1.
3376 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3378 Make_Op_Subtract (Loc,
3379 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3380 Right_Opnd => Make_Artyp_Literal (1))));
3382 -- Note that calculation of the high bound may cause overflow in some
3383 -- very weird cases, so in the general case we need an overflow check on
3384 -- the high bound. We can avoid this for the common case of string types
3385 -- and other types whose index is Positive, since we chose a wider range
3386 -- for the arithmetic type. If checks are suppressed we do not set the
3387 -- flag, and possibly superfluous warnings will be omitted.
3389 if Istyp /= Standard_Positive
3390 and then not Overflow_Checks_Suppressed (Istyp)
3392 Activate_Overflow_Check (High_Bound);
3395 -- Handle the exceptional case where the result is null, in which case
3396 -- case the bounds come from the last operand (so that we get the proper
3397 -- bounds if the last operand is super-flat).
3399 if Result_May_Be_Null then
3401 Make_If_Expression (Loc,
3402 Expressions => New_List (
3404 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3405 Right_Opnd => Make_Artyp_Literal (0)),
3406 Last_Opnd_Low_Bound,
3410 Make_If_Expression (Loc,
3411 Expressions => New_List (
3413 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3414 Right_Opnd => Make_Artyp_Literal (0)),
3415 Last_Opnd_High_Bound,
3419 -- Here is where we insert the saved up actions
3421 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3423 -- Now we construct an array object with appropriate bounds. We mark
3424 -- the target as internal to prevent useless initialization when
3425 -- Initialize_Scalars is enabled. Also since this is the actual result
3426 -- entity, we make sure we have debug information for the result.
3428 Ent := Make_Temporary (Loc, 'S');
3429 Set_Is_Internal (Ent);
3430 Set_Debug_Info_Needed (Ent);
3432 -- If the bound is statically known to be out of range, we do not want
3433 -- to abort, we want a warning and a runtime constraint error. Note that
3434 -- we have arranged that the result will not be treated as a static
3435 -- constant, so we won't get an illegality during this insertion.
3437 Insert_Action (Cnode,
3438 Make_Object_Declaration (Loc,
3439 Defining_Identifier => Ent,
3440 Object_Definition =>
3441 Make_Subtype_Indication (Loc,
3442 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3444 Make_Index_Or_Discriminant_Constraint (Loc,
3445 Constraints => New_List (
3447 Low_Bound => Low_Bound,
3448 High_Bound => High_Bound))))),
3449 Suppress => All_Checks);
3451 -- If the result of the concatenation appears as the initializing
3452 -- expression of an object declaration, we can just rename the
3453 -- result, rather than copying it.
3455 Set_OK_To_Rename (Ent);
3457 -- Catch the static out of range case now
3459 if Raises_Constraint_Error (High_Bound) then
3460 raise Concatenation_Error;
3463 -- Now we will generate the assignments to do the actual concatenation
3465 -- There is one case in which we will not do this, namely when all the
3466 -- following conditions are met:
3468 -- The result type is Standard.String
3470 -- There are nine or fewer retained (non-null) operands
3472 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3473 -- and the debug flag gnatd.c is not set.
3475 -- The corresponding System.Concat_n.Str_Concat_n routine is
3476 -- available in the run time.
3478 -- If all these conditions are met then we generate a call to the
3479 -- relevant concatenation routine. The purpose of this is to avoid
3480 -- undesirable code bloat at -O0.
3482 -- If the concatenation is within the declaration of a library-level
3483 -- object, we call the built-in concatenation routines to prevent code
3484 -- bloat, regardless of the optimization level. This is space efficient
3485 -- and prevents linking problems when units are compiled with different
3486 -- optimization levels.
3488 if Atyp = Standard_String
3489 and then NN in 2 .. 9
3490 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3491 and then not Debug_Flag_Dot_C)
3492 or else Library_Level_Target)
3495 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3506 if RTE_Available (RR (NN)) then
3508 Opnds : constant List_Id :=
3509 New_List (New_Occurrence_Of (Ent, Loc));
3512 for J in 1 .. NN loop
3513 if Is_List_Member (Operands (J)) then
3514 Remove (Operands (J));
3517 if Base_Type (Etype (Operands (J))) = Ctyp then
3519 Make_Aggregate (Loc,
3520 Component_Associations => New_List (
3521 Make_Component_Association (Loc,
3522 Choices => New_List (
3523 Make_Integer_Literal (Loc, 1)),
3524 Expression => Operands (J)))));
3527 Append_To (Opnds, Operands (J));
3531 Insert_Action (Cnode,
3532 Make_Procedure_Call_Statement (Loc,
3533 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3534 Parameter_Associations => Opnds));
3536 Result := New_Occurrence_Of (Ent, Loc);
3543 -- Not special case so generate the assignments
3545 Known_Non_Null_Operand_Seen := False;
3547 for J in 1 .. NN loop
3549 Lo : constant Node_Id :=
3551 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3552 Right_Opnd => Aggr_Length (J - 1));
3554 Hi : constant Node_Id :=
3556 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3558 Make_Op_Subtract (Loc,
3559 Left_Opnd => Aggr_Length (J),
3560 Right_Opnd => Make_Artyp_Literal (1)));
3563 -- Singleton case, simple assignment
3565 if Base_Type (Etype (Operands (J))) = Ctyp then
3566 Known_Non_Null_Operand_Seen := True;
3567 Insert_Action (Cnode,
3568 Make_Assignment_Statement (Loc,
3570 Make_Indexed_Component (Loc,
3571 Prefix => New_Occurrence_Of (Ent, Loc),
3572 Expressions => New_List (To_Ityp (Lo))),
3573 Expression => Operands (J)),
3574 Suppress => All_Checks);
3576 -- Array case, slice assignment, skipped when argument is fixed
3577 -- length and known to be null.
3579 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3582 Make_Assignment_Statement (Loc,
3586 New_Occurrence_Of (Ent, Loc),
3589 Low_Bound => To_Ityp (Lo),
3590 High_Bound => To_Ityp (Hi))),
3591 Expression => Operands (J));
3593 if Is_Fixed_Length (J) then
3594 Known_Non_Null_Operand_Seen := True;
3596 elsif not Known_Non_Null_Operand_Seen then
3598 -- Here if operand length is not statically known and no
3599 -- operand known to be non-null has been processed yet.
3600 -- If operand length is 0, we do not need to perform the
3601 -- assignment, and we must avoid the evaluation of the
3602 -- high bound of the slice, since it may underflow if the
3603 -- low bound is Ityp'First.
3606 Make_Implicit_If_Statement (Cnode,
3610 New_Occurrence_Of (Var_Length (J), Loc),
3611 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3612 Then_Statements => New_List (Assign));
3615 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3621 -- Finally we build the result, which is a reference to the array object
3623 Result := New_Occurrence_Of (Ent, Loc);
3626 pragma Assert (Present (Result));
3627 Rewrite (Cnode, Result);
3628 Analyze_And_Resolve (Cnode, Atyp);
3631 when Concatenation_Error =>
3633 -- Kill warning generated for the declaration of the static out of
3634 -- range high bound, and instead generate a Constraint_Error with
3635 -- an appropriate specific message.
3637 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3638 Apply_Compile_Time_Constraint_Error
3640 Msg => "concatenation result upper bound out of range??",
3641 Reason => CE_Range_Check_Failed);
3642 end Expand_Concatenate;
3644 ---------------------------------------------------
3645 -- Expand_Membership_Minimize_Eliminate_Overflow --
3646 ---------------------------------------------------
3648 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3649 pragma Assert (Nkind (N) = N_In);
3650 -- Despite the name, this routine applies only to N_In, not to
3651 -- N_Not_In. The latter is always rewritten as not (X in Y).
3653 Result_Type : constant Entity_Id := Etype (N);
3654 -- Capture result type, may be a derived boolean type
3656 Loc : constant Source_Ptr := Sloc (N);
3657 Lop : constant Node_Id := Left_Opnd (N);
3658 Rop : constant Node_Id := Right_Opnd (N);
3660 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3661 -- is thus tempting to capture these values, but due to the rewrites
3662 -- that occur as a result of overflow checking, these values change
3663 -- as we go along, and it is safe just to always use Etype explicitly.
3665 Restype : constant Entity_Id := Etype (N);
3669 -- Bounds in Minimize calls, not used currently
3671 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3672 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3675 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3677 -- If right operand is a subtype name, and the subtype name has no
3678 -- predicate, then we can just replace the right operand with an
3679 -- explicit range T'First .. T'Last, and use the explicit range code.
3681 if Nkind (Rop) /= N_Range
3682 and then No (Predicate_Function (Etype (Rop)))
3685 Rtyp : constant Entity_Id := Etype (Rop);
3690 Make_Attribute_Reference (Loc,
3691 Attribute_Name => Name_First,
3692 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3694 Make_Attribute_Reference (Loc,
3695 Attribute_Name => Name_Last,
3696 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3697 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3701 -- Here for the explicit range case. Note that the bounds of the range
3702 -- have not been processed for minimized or eliminated checks.
3704 if Nkind (Rop) = N_Range then
3705 Minimize_Eliminate_Overflows
3706 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3707 Minimize_Eliminate_Overflows
3708 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3710 -- We have A in B .. C, treated as A >= B and then A <= C
3714 if Is_RTE (Etype (Lop), RE_Bignum)
3715 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3716 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3719 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3720 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3721 L : constant Entity_Id :=
3722 Make_Defining_Identifier (Loc, Name_uL);
3723 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3724 Lbound : constant Node_Id :=
3725 Convert_To_Bignum (Low_Bound (Rop));
3726 Hbound : constant Node_Id :=
3727 Convert_To_Bignum (High_Bound (Rop));
3729 -- Now we rewrite the membership test node to look like
3732 -- Bnn : Result_Type;
3734 -- M : Mark_Id := SS_Mark;
3735 -- L : Bignum := Lopnd;
3737 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3745 -- Insert declaration of L into declarations of bignum block
3748 (Last (Declarations (Blk)),
3749 Make_Object_Declaration (Loc,
3750 Defining_Identifier => L,
3751 Object_Definition =>
3752 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3753 Expression => Lopnd));
3755 -- Insert assignment to Bnn into expressions of bignum block
3758 (First (Statements (Handled_Statement_Sequence (Blk))),
3759 Make_Assignment_Statement (Loc,
3760 Name => New_Occurrence_Of (Bnn, Loc),
3764 Make_Function_Call (Loc,
3766 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3767 Parameter_Associations => New_List (
3768 New_Occurrence_Of (L, Loc),
3772 Make_Function_Call (Loc,
3774 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3775 Parameter_Associations => New_List (
3776 New_Occurrence_Of (L, Loc),
3779 -- Now rewrite the node
3782 Make_Expression_With_Actions (Loc,
3783 Actions => New_List (
3784 Make_Object_Declaration (Loc,
3785 Defining_Identifier => Bnn,
3786 Object_Definition =>
3787 New_Occurrence_Of (Result_Type, Loc)),
3789 Expression => New_Occurrence_Of (Bnn, Loc)));
3790 Analyze_And_Resolve (N, Result_Type);
3794 -- Here if no bignums around
3797 -- Case where types are all the same
3799 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3801 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3805 -- If types are not all the same, it means that we have rewritten
3806 -- at least one of them to be of type Long_Long_Integer, and we
3807 -- will convert the other operands to Long_Long_Integer.
3810 Convert_To_And_Rewrite (LLIB, Lop);
3811 Set_Analyzed (Lop, False);
3812 Analyze_And_Resolve (Lop, LLIB);
3814 -- For the right operand, avoid unnecessary recursion into
3815 -- this routine, we know that overflow is not possible.
3817 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3818 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3819 Set_Analyzed (Rop, False);
3820 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3823 -- Now the three operands are of the same signed integer type,
3824 -- so we can use the normal expansion routine for membership,
3825 -- setting the flag to prevent recursion into this procedure.
3827 Set_No_Minimize_Eliminate (N);
3831 -- Right operand is a subtype name and the subtype has a predicate. We
3832 -- have to make sure the predicate is checked, and for that we need to
3833 -- use the standard N_In circuitry with appropriate types.
3836 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3838 -- If types are "right", just call Expand_N_In preventing recursion
3840 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3841 Set_No_Minimize_Eliminate (N);
3846 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3848 -- For X in T, we want to rewrite our node as
3851 -- Bnn : Result_Type;
3854 -- M : Mark_Id := SS_Mark;
3855 -- Lnn : Long_Long_Integer'Base
3861 -- if not Bignum_In_LLI_Range (Nnn) then
3864 -- Lnn := From_Bignum (Nnn);
3866 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3867 -- and then T'Base (Lnn) in T;
3876 -- A bit gruesome, but there doesn't seem to be a simpler way
3879 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3880 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3881 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3882 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3883 T : constant Entity_Id := Etype (Rop);
3884 TB : constant Entity_Id := Base_Type (T);
3888 -- Mark the last membership operation to prevent recursion
3892 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3893 Right_Opnd => New_Occurrence_Of (T, Loc));
3894 Set_No_Minimize_Eliminate (Nin);
3896 -- Now decorate the block
3899 (Last (Declarations (Blk)),
3900 Make_Object_Declaration (Loc,
3901 Defining_Identifier => Lnn,
3902 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
3905 (Last (Declarations (Blk)),
3906 Make_Object_Declaration (Loc,
3907 Defining_Identifier => Nnn,
3908 Object_Definition =>
3909 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3912 (First (Statements (Handled_Statement_Sequence (Blk))),
3914 Make_Assignment_Statement (Loc,
3915 Name => New_Occurrence_Of (Nnn, Loc),
3916 Expression => Relocate_Node (Lop)),
3918 Make_Implicit_If_Statement (N,
3922 Make_Function_Call (Loc,
3925 (RTE (RE_Bignum_In_LLI_Range), Loc),
3926 Parameter_Associations => New_List (
3927 New_Occurrence_Of (Nnn, Loc)))),
3929 Then_Statements => New_List (
3930 Make_Assignment_Statement (Loc,
3931 Name => New_Occurrence_Of (Bnn, Loc),
3933 New_Occurrence_Of (Standard_False, Loc))),
3935 Else_Statements => New_List (
3936 Make_Assignment_Statement (Loc,
3937 Name => New_Occurrence_Of (Lnn, Loc),
3939 Make_Function_Call (Loc,
3941 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3942 Parameter_Associations => New_List (
3943 New_Occurrence_Of (Nnn, Loc)))),
3945 Make_Assignment_Statement (Loc,
3946 Name => New_Occurrence_Of (Bnn, Loc),
3951 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3956 Make_Attribute_Reference (Loc,
3957 Attribute_Name => Name_First,
3959 New_Occurrence_Of (TB, Loc))),
3963 Make_Attribute_Reference (Loc,
3964 Attribute_Name => Name_Last,
3966 New_Occurrence_Of (TB, Loc))))),
3968 Right_Opnd => Nin))))));
3970 -- Now we can do the rewrite
3973 Make_Expression_With_Actions (Loc,
3974 Actions => New_List (
3975 Make_Object_Declaration (Loc,
3976 Defining_Identifier => Bnn,
3977 Object_Definition =>
3978 New_Occurrence_Of (Result_Type, Loc)),
3980 Expression => New_Occurrence_Of (Bnn, Loc)));
3981 Analyze_And_Resolve (N, Result_Type);
3985 -- Not bignum case, but types don't match (this means we rewrote the
3986 -- left operand to be Long_Long_Integer).
3989 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
3991 -- We rewrite the membership test as (where T is the type with
3992 -- the predicate, i.e. the type of the right operand)
3994 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3995 -- and then T'Base (Lop) in T
3998 T : constant Entity_Id := Etype (Rop);
3999 TB : constant Entity_Id := Base_Type (T);
4003 -- The last membership test is marked to prevent recursion
4007 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
4008 Right_Opnd => New_Occurrence_Of (T, Loc));
4009 Set_No_Minimize_Eliminate (Nin);
4011 -- Now do the rewrite
4022 Make_Attribute_Reference (Loc,
4023 Attribute_Name => Name_First,
4025 New_Occurrence_Of (TB, Loc))),
4028 Make_Attribute_Reference (Loc,
4029 Attribute_Name => Name_Last,
4031 New_Occurrence_Of (TB, Loc))))),
4032 Right_Opnd => Nin));
4033 Set_Analyzed (N, False);
4034 Analyze_And_Resolve (N, Restype);
4038 end Expand_Membership_Minimize_Eliminate_Overflow;
4040 ---------------------------------
4041 -- Expand_Nonbinary_Modular_Op --
4042 ---------------------------------
4044 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is
4045 Loc : constant Source_Ptr := Sloc (N);
4046 Typ : constant Entity_Id := Etype (N);
4048 procedure Expand_Modular_Addition;
4049 -- Expand the modular addition, handling the special case of adding a
4052 procedure Expand_Modular_Op;
4053 -- Compute the general rule: (lhs OP rhs) mod Modulus
4055 procedure Expand_Modular_Subtraction;
4056 -- Expand the modular addition, handling the special case of subtracting
4059 -----------------------------
4060 -- Expand_Modular_Addition --
4061 -----------------------------
4063 procedure Expand_Modular_Addition is
4065 -- If this is not the addition of a constant then compute it using
4066 -- the general rule: (lhs + rhs) mod Modulus
4068 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4071 -- If this is an addition of a constant, convert it to a subtraction
4072 -- plus a conditional expression since we can compute it faster than
4073 -- computing the modulus.
4075 -- modMinusRhs = Modulus - rhs
4076 -- if lhs < modMinusRhs then lhs + rhs
4077 -- else lhs - modMinusRhs
4081 Mod_Minus_Right : constant Uint :=
4082 Modulus (Typ) - Intval (Right_Opnd (N));
4084 Exprs : constant List_Id := New_List;
4085 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4086 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4087 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4090 -- To prevent spurious visibility issues, convert all
4091 -- operands to Standard.Unsigned.
4093 Set_Left_Opnd (Cond_Expr,
4094 Unchecked_Convert_To (Standard_Unsigned,
4095 New_Copy_Tree (Left_Opnd (N))));
4096 Set_Right_Opnd (Cond_Expr,
4097 Make_Integer_Literal (Loc, Mod_Minus_Right));
4098 Append_To (Exprs, Cond_Expr);
4100 Set_Left_Opnd (Then_Expr,
4101 Unchecked_Convert_To (Standard_Unsigned,
4102 New_Copy_Tree (Left_Opnd (N))));
4103 Set_Right_Opnd (Then_Expr,
4104 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4105 Append_To (Exprs, Then_Expr);
4107 Set_Left_Opnd (Else_Expr,
4108 Unchecked_Convert_To (Standard_Unsigned,
4109 New_Copy_Tree (Left_Opnd (N))));
4110 Set_Right_Opnd (Else_Expr,
4111 Make_Integer_Literal (Loc, Mod_Minus_Right));
4112 Append_To (Exprs, Else_Expr);
4115 Unchecked_Convert_To (Typ,
4116 Make_If_Expression (Loc, Expressions => Exprs)));
4119 end Expand_Modular_Addition;
4121 -----------------------
4122 -- Expand_Modular_Op --
4123 -----------------------
4125 procedure Expand_Modular_Op is
4126 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc);
4127 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc);
4129 Target_Type : Entity_Id;
4132 -- Convert nonbinary modular type operands into integer values. Thus
4133 -- we avoid never-ending loops expanding them, and we also ensure
4134 -- the back end never receives nonbinary modular type expressions.
4136 if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then
4137 Set_Left_Opnd (Op_Expr,
4138 Unchecked_Convert_To (Standard_Unsigned,
4139 New_Copy_Tree (Left_Opnd (N))));
4140 Set_Right_Opnd (Op_Expr,
4141 Unchecked_Convert_To (Standard_Unsigned,
4142 New_Copy_Tree (Right_Opnd (N))));
4143 Set_Left_Opnd (Mod_Expr,
4144 Unchecked_Convert_To (Standard_Integer, Op_Expr));
4147 -- If the modulus of the type is larger than Integer'Last use a
4148 -- larger type for the operands, to prevent spurious constraint
4149 -- errors on large legal literals of the type.
4151 if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
4152 Target_Type := Standard_Long_Integer;
4154 Target_Type := Standard_Integer;
4157 Set_Left_Opnd (Op_Expr,
4158 Unchecked_Convert_To (Target_Type,
4159 New_Copy_Tree (Left_Opnd (N))));
4160 Set_Right_Opnd (Op_Expr,
4161 Unchecked_Convert_To (Target_Type,
4162 New_Copy_Tree (Right_Opnd (N))));
4164 -- Link this node to the tree to analyze it
4166 -- If the parent node is an expression with actions we link it to
4167 -- N since otherwise Force_Evaluation cannot identify if this node
4168 -- comes from the Expression and rejects generating the temporary.
4170 if Nkind (Parent (N)) = N_Expression_With_Actions then
4171 Set_Parent (Op_Expr, N);
4176 Set_Parent (Op_Expr, Parent (N));
4181 -- Force generating a temporary because in the expansion of this
4182 -- expression we may generate code that performs this computation
4185 Force_Evaluation (Op_Expr, Mode => Strict);
4187 Set_Left_Opnd (Mod_Expr, Op_Expr);
4190 Set_Right_Opnd (Mod_Expr,
4191 Make_Integer_Literal (Loc, Modulus (Typ)));
4194 Unchecked_Convert_To (Typ, Mod_Expr));
4195 end Expand_Modular_Op;
4197 --------------------------------
4198 -- Expand_Modular_Subtraction --
4199 --------------------------------
4201 procedure Expand_Modular_Subtraction is
4203 -- If this is not the addition of a constant then compute it using
4204 -- the general rule: (lhs + rhs) mod Modulus
4206 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4209 -- If this is an addition of a constant, convert it to a subtraction
4210 -- plus a conditional expression since we can compute it faster than
4211 -- computing the modulus.
4213 -- modMinusRhs = Modulus - rhs
4214 -- if lhs < rhs then lhs + modMinusRhs
4219 Mod_Minus_Right : constant Uint :=
4220 Modulus (Typ) - Intval (Right_Opnd (N));
4222 Exprs : constant List_Id := New_List;
4223 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4224 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4225 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4228 Set_Left_Opnd (Cond_Expr,
4229 Unchecked_Convert_To (Standard_Unsigned,
4230 New_Copy_Tree (Left_Opnd (N))));
4231 Set_Right_Opnd (Cond_Expr,
4232 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4233 Append_To (Exprs, Cond_Expr);
4235 Set_Left_Opnd (Then_Expr,
4236 Unchecked_Convert_To (Standard_Unsigned,
4237 New_Copy_Tree (Left_Opnd (N))));
4238 Set_Right_Opnd (Then_Expr,
4239 Make_Integer_Literal (Loc, Mod_Minus_Right));
4240 Append_To (Exprs, Then_Expr);
4242 Set_Left_Opnd (Else_Expr,
4243 Unchecked_Convert_To (Standard_Unsigned,
4244 New_Copy_Tree (Left_Opnd (N))));
4245 Set_Right_Opnd (Else_Expr,
4246 Unchecked_Convert_To (Standard_Unsigned,
4247 New_Copy_Tree (Right_Opnd (N))));
4248 Append_To (Exprs, Else_Expr);
4251 Unchecked_Convert_To (Typ,
4252 Make_If_Expression (Loc, Expressions => Exprs)));
4255 end Expand_Modular_Subtraction;
4257 -- Start of processing for Expand_Nonbinary_Modular_Op
4260 -- No action needed if front-end expansion is not required or if we
4261 -- have a binary modular operand.
4263 if not Expand_Nonbinary_Modular_Ops
4264 or else not Non_Binary_Modulus (Typ)
4271 Expand_Modular_Addition;
4273 when N_Op_Subtract =>
4274 Expand_Modular_Subtraction;
4278 -- Expand -expr into (0 - expr)
4281 Make_Op_Subtract (Loc,
4282 Left_Opnd => Make_Integer_Literal (Loc, 0),
4283 Right_Opnd => Right_Opnd (N)));
4284 Analyze_And_Resolve (N, Typ);
4290 Analyze_And_Resolve (N, Typ);
4291 end Expand_Nonbinary_Modular_Op;
4293 ------------------------
4294 -- Expand_N_Allocator --
4295 ------------------------
4297 procedure Expand_N_Allocator (N : Node_Id) is
4298 Etyp : constant Entity_Id := Etype (Expression (N));
4299 Loc : constant Source_Ptr := Sloc (N);
4300 PtrT : constant Entity_Id := Etype (N);
4302 procedure Rewrite_Coextension (N : Node_Id);
4303 -- Static coextensions have the same lifetime as the entity they
4304 -- constrain. Such occurrences can be rewritten as aliased objects
4305 -- and their unrestricted access used instead of the coextension.
4307 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4308 -- Given a constrained array type E, returns a node representing the
4309 -- code to compute a close approximation of the size in storage elements
4310 -- for the given type; for indexes that are modular types we compute
4311 -- 'Last - First (instead of 'Length) because for large arrays computing
4312 -- 'Last -'First + 1 causes overflow. This is done without using the
4313 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4316 -------------------------
4317 -- Rewrite_Coextension --
4318 -------------------------
4320 procedure Rewrite_Coextension (N : Node_Id) is
4321 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4322 Temp_Decl : Node_Id;
4326 -- Cnn : aliased Etyp;
4329 Make_Object_Declaration (Loc,
4330 Defining_Identifier => Temp_Id,
4331 Aliased_Present => True,
4332 Object_Definition => New_Occurrence_Of (Etyp, Loc));
4334 if Nkind (Expression (N)) = N_Qualified_Expression then
4335 Set_Expression (Temp_Decl, Expression (Expression (N)));
4338 Insert_Action (N, Temp_Decl);
4340 Make_Attribute_Reference (Loc,
4341 Prefix => New_Occurrence_Of (Temp_Id, Loc),
4342 Attribute_Name => Name_Unrestricted_Access));
4344 Analyze_And_Resolve (N, PtrT);
4345 end Rewrite_Coextension;
4347 ------------------------------
4348 -- Size_In_Storage_Elements --
4349 ------------------------------
4351 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4353 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4354 -- However, the reason for the existence of this function is
4355 -- to construct a test for sizes too large, which means near the
4356 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4357 -- is that we get overflows when sizes are greater than 2**31.
4359 -- So what we end up doing for array types is to use the expression:
4361 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4363 -- which avoids this problem. All this is a bit bogus, but it does
4364 -- mean we catch common cases of trying to allocate arrays that
4365 -- are too large, and which in the absence of a check results in
4366 -- undetected chaos ???
4368 -- Note in particular that this is a pessimistic estimate in the
4369 -- case of packed array types, where an array element might occupy
4370 -- just a fraction of a storage element???
4373 Idx : Node_Id := First_Index (E);
4375 Res : Node_Id := Empty;
4378 for J in 1 .. Number_Dimensions (E) loop
4380 if not Is_Modular_Integer_Type (Etype (Idx)) then
4382 Make_Attribute_Reference (Loc,
4383 Prefix => New_Occurrence_Of (E, Loc),
4384 Attribute_Name => Name_Length,
4385 Expressions => New_List
4386 (Make_Integer_Literal (Loc, J)));
4388 -- For indexes that are modular types we cannot generate code
4389 -- to compute 'Length since for large arrays 'Last -'First + 1
4390 -- causes overflow; therefore we compute 'Last - 'First (which
4391 -- is not the exact number of components but it is valid for
4392 -- the purpose of this runtime check on 32-bit targets).
4396 Len_Minus_1_Expr : Node_Id;
4402 Make_Attribute_Reference (Loc,
4403 Prefix => New_Occurrence_Of (E, Loc),
4404 Attribute_Name => Name_Last,
4406 New_List (Make_Integer_Literal (Loc, J))),
4407 Make_Attribute_Reference (Loc,
4408 Prefix => New_Occurrence_Of (E, Loc),
4409 Attribute_Name => Name_First,
4411 New_List (Make_Integer_Literal (Loc, J))));
4414 Convert_To (Standard_Unsigned,
4415 Make_Op_Subtract (Loc,
4416 Make_Attribute_Reference (Loc,
4417 Prefix => New_Occurrence_Of (E, Loc),
4418 Attribute_Name => Name_Last,
4421 (Make_Integer_Literal (Loc, J))),
4422 Make_Attribute_Reference (Loc,
4423 Prefix => New_Occurrence_Of (E, Loc),
4424 Attribute_Name => Name_First,
4427 (Make_Integer_Literal (Loc, J)))));
4429 -- Handle superflat arrays, i.e. arrays with such bounds
4430 -- as 4 .. 2, to ensure that the result is correct.
4433 -- (if X'Last > X'First then X'Last - X'First else 0)
4436 Make_If_Expression (Loc,
4437 Expressions => New_List (
4440 Make_Integer_Literal (Loc, Uint_0)));
4448 pragma Assert (Present (Res));
4450 Make_Op_Multiply (Loc,
4459 Make_Op_Multiply (Loc,
4462 Make_Attribute_Reference (Loc,
4463 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4464 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4466 end Size_In_Storage_Elements;
4470 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4474 Rel_Typ : Entity_Id;
4477 -- Start of processing for Expand_N_Allocator
4480 -- Warn on the presence of an allocator of an anonymous access type when
4481 -- enabled, except when it's an object declaration at library level.
4483 if Warn_On_Anonymous_Allocators
4484 and then Ekind (PtrT) = E_Anonymous_Access_Type
4485 and then not (Is_Library_Level_Entity (PtrT)
4486 and then Nkind (Associated_Node_For_Itype (PtrT)) =
4487 N_Object_Declaration)
4489 Error_Msg_N ("?use of an anonymous access type allocator", N);
4492 -- RM E.2.3(22). We enforce that the expected type of an allocator
4493 -- shall not be a remote access-to-class-wide-limited-private type
4495 -- Why is this being done at expansion time, seems clearly wrong ???
4497 Validate_Remote_Access_To_Class_Wide_Type (N);
4499 -- Processing for anonymous access-to-controlled types. These access
4500 -- types receive a special finalization master which appears in the
4501 -- declarations of the enclosing semantic unit. This expansion is done
4502 -- now to ensure that any additional types generated by this routine or
4503 -- Expand_Allocator_Expression inherit the proper type attributes.
4505 if (Ekind (PtrT) = E_Anonymous_Access_Type
4506 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4507 and then Needs_Finalization (Dtyp)
4509 -- Detect the allocation of an anonymous controlled object where the
4510 -- type of the context is named. For example:
4512 -- procedure Proc (Ptr : Named_Access_Typ);
4513 -- Proc (new Designated_Typ);
4515 -- Regardless of the anonymous-to-named access type conversion, the
4516 -- lifetime of the object must be associated with the named access
4517 -- type. Use the finalization-related attributes of this type.
4519 if Nkind_In (Parent (N), N_Type_Conversion,
4520 N_Unchecked_Type_Conversion)
4521 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4523 E_General_Access_Type)
4525 Rel_Typ := Etype (Parent (N));
4530 -- Anonymous access-to-controlled types allocate on the global pool.
4531 -- Note that this is a "root type only" attribute.
4533 if No (Associated_Storage_Pool (PtrT)) then
4534 if Present (Rel_Typ) then
4535 Set_Associated_Storage_Pool
4536 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4538 Set_Associated_Storage_Pool
4539 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4543 -- The finalization master must be inserted and analyzed as part of
4544 -- the current semantic unit. Note that the master is updated when
4545 -- analysis changes current units. Note that this is a "root type
4548 if Present (Rel_Typ) then
4549 Set_Finalization_Master
4550 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4552 Build_Anonymous_Master (Root_Type (PtrT));
4556 -- Set the storage pool and find the appropriate version of Allocate to
4557 -- call. Do not overwrite the storage pool if it is already set, which
4558 -- can happen for build-in-place function returns (see
4559 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4561 if No (Storage_Pool (N)) then
4562 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4564 if Present (Pool) then
4565 Set_Storage_Pool (N, Pool);
4567 if Is_RTE (Pool, RE_SS_Pool) then
4568 Check_Restriction (No_Secondary_Stack, N);
4569 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4571 -- In the case of an allocator for a simple storage pool, locate
4572 -- and save a reference to the pool type's Allocate routine.
4574 elsif Present (Get_Rep_Pragma
4575 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4578 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4579 Alloc_Op : Entity_Id;
4581 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4582 while Present (Alloc_Op) loop
4583 if Scope (Alloc_Op) = Scope (Pool_Type)
4584 and then Present (First_Formal (Alloc_Op))
4585 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4587 Set_Procedure_To_Call (N, Alloc_Op);
4590 Alloc_Op := Homonym (Alloc_Op);
4595 elsif Is_Class_Wide_Type (Etype (Pool)) then
4596 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4599 Set_Procedure_To_Call (N,
4600 Find_Prim_Op (Etype (Pool), Name_Allocate));
4605 -- Under certain circumstances we can replace an allocator by an access
4606 -- to statically allocated storage. The conditions, as noted in AARM
4607 -- 3.10 (10c) are as follows:
4609 -- Size and initial value is known at compile time
4610 -- Access type is access-to-constant
4612 -- The allocator is not part of a constraint on a record component,
4613 -- because in that case the inserted actions are delayed until the
4614 -- record declaration is fully analyzed, which is too late for the
4615 -- analysis of the rewritten allocator.
4617 if Is_Access_Constant (PtrT)
4618 and then Nkind (Expression (N)) = N_Qualified_Expression
4619 and then Compile_Time_Known_Value (Expression (Expression (N)))
4620 and then Size_Known_At_Compile_Time
4621 (Etype (Expression (Expression (N))))
4622 and then not Is_Record_Type (Current_Scope)
4624 -- Here we can do the optimization. For the allocator
4628 -- We insert an object declaration
4630 -- Tnn : aliased x := y;
4632 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4633 -- marked as requiring static allocation.
4635 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4636 Desig := Subtype_Mark (Expression (N));
4638 -- If context is constrained, use constrained subtype directly,
4639 -- so that the constant is not labelled as having a nominally
4640 -- unconstrained subtype.
4642 if Entity (Desig) = Base_Type (Dtyp) then
4643 Desig := New_Occurrence_Of (Dtyp, Loc);
4647 Make_Object_Declaration (Loc,
4648 Defining_Identifier => Temp,
4649 Aliased_Present => True,
4650 Constant_Present => Is_Access_Constant (PtrT),
4651 Object_Definition => Desig,
4652 Expression => Expression (Expression (N))));
4655 Make_Attribute_Reference (Loc,
4656 Prefix => New_Occurrence_Of (Temp, Loc),
4657 Attribute_Name => Name_Unrestricted_Access));
4659 Analyze_And_Resolve (N, PtrT);
4661 -- We set the variable as statically allocated, since we don't want
4662 -- it going on the stack of the current procedure.
4664 Set_Is_Statically_Allocated (Temp);
4668 -- Same if the allocator is an access discriminant for a local object:
4669 -- instead of an allocator we create a local value and constrain the
4670 -- enclosing object with the corresponding access attribute.
4672 if Is_Static_Coextension (N) then
4673 Rewrite_Coextension (N);
4677 -- Check for size too large, we do this because the back end misses
4678 -- proper checks here and can generate rubbish allocation calls when
4679 -- we are near the limit. We only do this for the 32-bit address case
4680 -- since that is from a practical point of view where we see a problem.
4682 if System_Address_Size = 32
4683 and then not Storage_Checks_Suppressed (PtrT)
4684 and then not Storage_Checks_Suppressed (Dtyp)
4685 and then not Storage_Checks_Suppressed (Etyp)
4687 -- The check we want to generate should look like
4689 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4690 -- raise Storage_Error;
4693 -- where 3.5 gigabytes is a constant large enough to accommodate any
4694 -- reasonable request for. But we can't do it this way because at
4695 -- least at the moment we don't compute this attribute right, and
4696 -- can silently give wrong results when the result gets large. Since
4697 -- this is all about large results, that's bad, so instead we only
4698 -- apply the check for constrained arrays, and manually compute the
4699 -- value of the attribute ???
4701 -- The check on No_Initialization is used here to prevent generating
4702 -- this runtime check twice when the allocator is locally replaced by
4703 -- the expander with another one.
4705 if Is_Array_Type (Etyp) and then not No_Initialization (N) then
4708 Ins_Nod : Node_Id := N;
4709 Siz_Typ : Entity_Id := Etyp;
4713 -- For unconstrained array types initialized with a qualified
4714 -- expression we use its type to perform this check
4716 if not Is_Constrained (Etyp)
4717 and then not No_Initialization (N)
4718 and then Nkind (Expression (N)) = N_Qualified_Expression
4720 Expr := Expression (Expression (N));
4721 Siz_Typ := Etype (Expression (Expression (N)));
4723 -- If the qualified expression has been moved to an internal
4724 -- temporary (to remove side effects) then we must insert
4725 -- the runtime check before its declaration to ensure that
4726 -- the check is performed before the execution of the code
4727 -- computing the qualified expression.
4729 if Nkind (Expr) = N_Identifier
4730 and then Is_Internal_Name (Chars (Expr))
4732 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
4734 Ins_Nod := Parent (Entity (Expr));
4740 if Is_Constrained (Siz_Typ)
4741 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype
4743 -- For CCG targets, the largest array may have up to 2**31-1
4744 -- components (i.e. 2 gigabytes if each array component is
4745 -- one byte). This ensures that fat pointer fields do not
4746 -- overflow, since they are 32-bit integer types, and also
4747 -- ensures that 'Length can be computed at run time.
4749 if Modify_Tree_For_C then
4752 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4753 Right_Opnd => Make_Integer_Literal (Loc,
4754 Uint_2 ** 31 - Uint_1));
4756 -- For native targets the largest object is 3.5 gigabytes
4761 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4762 Right_Opnd => Make_Integer_Literal (Loc,
4763 Uint_7 * (Uint_2 ** 29)));
4766 Insert_Action (Ins_Nod,
4767 Make_Raise_Storage_Error (Loc,
4769 Reason => SE_Object_Too_Large));
4771 if Entity (Cond) = Standard_True then
4773 ("object too large: Storage_Error will be raised at "
4781 -- If no storage pool has been specified, or the storage pool
4782 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4783 -- No_Standard_Allocators_After_Elaboration is present, then generate
4784 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4786 if Nkind (N) = N_Allocator
4787 and then (No (Storage_Pool (N))
4788 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
4789 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4792 Make_Procedure_Call_Statement (Loc,
4794 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4797 -- Handle case of qualified expression (other than optimization above)
4798 -- First apply constraint checks, because the bounds or discriminants
4799 -- in the aggregate might not match the subtype mark in the allocator.
4801 if Nkind (Expression (N)) = N_Qualified_Expression then
4803 Exp : constant Node_Id := Expression (Expression (N));
4804 Typ : constant Entity_Id := Etype (Expression (N));
4807 Apply_Constraint_Check (Exp, Typ);
4808 Apply_Predicate_Check (Exp, Typ);
4811 Expand_Allocator_Expression (N);
4815 -- If the allocator is for a type which requires initialization, and
4816 -- there is no initial value (i.e. operand is a subtype indication
4817 -- rather than a qualified expression), then we must generate a call to
4818 -- the initialization routine using an expressions action node:
4820 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4822 -- Here ptr_T is the pointer type for the allocator, and T is the
4823 -- subtype of the allocator. A special case arises if the designated
4824 -- type of the access type is a task or contains tasks. In this case
4825 -- the call to Init (Temp.all ...) is replaced by code that ensures
4826 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4827 -- for details). In addition, if the type T is a task type, then the
4828 -- first argument to Init must be converted to the task record type.
4831 T : constant Entity_Id := Etype (Expression (N));
4837 Init_Arg1 : Node_Id;
4838 Init_Call : Node_Id;
4839 Temp_Decl : Node_Id;
4840 Temp_Type : Entity_Id;
4843 if No_Initialization (N) then
4845 -- Even though this might be a simple allocation, create a custom
4846 -- Allocate if the context requires it.
4848 if Present (Finalization_Master (PtrT)) then
4849 Build_Allocate_Deallocate_Proc
4851 Is_Allocate => True);
4854 -- Optimize the default allocation of an array object when pragma
4855 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4856 -- in-place initialization aggregate which may be convert into a fast
4857 -- memset by the backend.
4859 elsif Init_Or_Norm_Scalars
4860 and then Is_Array_Type (T)
4862 -- The array must lack atomic components because they are treated
4863 -- as non-static, and as a result the backend will not initialize
4864 -- the memory in one go.
4866 and then not Has_Atomic_Components (T)
4868 -- The array must not be packed because the invalid values in
4869 -- System.Scalar_Values are multiples of Storage_Unit.
4871 and then not Is_Packed (T)
4873 -- The array must have static non-empty ranges, otherwise the
4874 -- backend cannot initialize the memory in one go.
4876 and then Has_Static_Non_Empty_Array_Bounds (T)
4878 -- The optimization is only relevant for arrays of scalar types
4880 and then Is_Scalar_Type (Component_Type (T))
4882 -- Similar to regular array initialization using a type init proc,
4883 -- predicate checks are not performed because the initialization
4884 -- values are intentionally invalid, and may violate the predicate.
4886 and then not Has_Predicates (Component_Type (T))
4888 -- The component type must have a single initialization value
4890 and then Needs_Simple_Initialization
4891 (Typ => Component_Type (T),
4892 Consider_IS => True)
4895 Temp := Make_Temporary (Loc, 'P');
4898 -- Temp : Ptr_Typ := new ...;
4903 Make_Object_Declaration (Loc,
4904 Defining_Identifier => Temp,
4905 Object_Definition => New_Occurrence_Of (PtrT, Loc),
4906 Expression => Relocate_Node (N)),
4907 Suppress => All_Checks);
4910 -- Temp.all := (others => ...);
4915 Make_Assignment_Statement (Loc,
4917 Make_Explicit_Dereference (Loc,
4918 Prefix => New_Occurrence_Of (Temp, Loc)),
4923 Size => Esize (Component_Type (T)))),
4924 Suppress => All_Checks);
4926 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4927 Analyze_And_Resolve (N, PtrT);
4929 -- Case of no initialization procedure present
4931 elsif not Has_Non_Null_Base_Init_Proc (T) then
4933 -- Case of simple initialization required
4935 if Needs_Simple_Initialization (T) then
4936 Check_Restriction (No_Default_Initialization, N);
4937 Rewrite (Expression (N),
4938 Make_Qualified_Expression (Loc,
4939 Subtype_Mark => New_Occurrence_Of (T, Loc),
4940 Expression => Get_Simple_Init_Val (T, N)));
4942 Analyze_And_Resolve (Expression (Expression (N)), T);
4943 Analyze_And_Resolve (Expression (N), T);
4944 Set_Paren_Count (Expression (Expression (N)), 1);
4945 Expand_N_Allocator (N);
4947 -- No initialization required
4950 Build_Allocate_Deallocate_Proc
4952 Is_Allocate => True);
4955 -- Case of initialization procedure present, must be called
4957 -- NOTE: There is a *huge* amount of code duplication here from
4958 -- Build_Initialization_Call. We should probably refactor???
4961 Check_Restriction (No_Default_Initialization, N);
4963 if not Restriction_Active (No_Default_Initialization) then
4964 Init := Base_Init_Proc (T);
4966 Temp := Make_Temporary (Loc, 'P');
4968 -- Construct argument list for the initialization routine call
4971 Make_Explicit_Dereference (Loc,
4973 New_Occurrence_Of (Temp, Loc));
4975 Set_Assignment_OK (Init_Arg1);
4978 -- The initialization procedure expects a specific type. if the
4979 -- context is access to class wide, indicate that the object
4980 -- being allocated has the right specific type.
4982 if Is_Class_Wide_Type (Dtyp) then
4983 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4986 -- If designated type is a concurrent type or if it is private
4987 -- type whose definition is a concurrent type, the first
4988 -- argument in the Init routine has to be unchecked conversion
4989 -- to the corresponding record type. If the designated type is
4990 -- a derived type, also convert the argument to its root type.
4992 if Is_Concurrent_Type (T) then
4994 Unchecked_Convert_To (
4995 Corresponding_Record_Type (T), Init_Arg1);
4997 elsif Is_Private_Type (T)
4998 and then Present (Full_View (T))
4999 and then Is_Concurrent_Type (Full_View (T))
5002 Unchecked_Convert_To
5003 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
5005 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
5007 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
5010 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
5011 Set_Etype (Init_Arg1, Ftyp);
5015 Args := New_List (Init_Arg1);
5017 -- For the task case, pass the Master_Id of the access type as
5018 -- the value of the _Master parameter, and _Chain as the value
5019 -- of the _Chain parameter (_Chain will be defined as part of
5020 -- the generated code for the allocator).
5022 -- In Ada 2005, the context may be a function that returns an
5023 -- anonymous access type. In that case the Master_Id has been
5024 -- created when expanding the function declaration.
5026 if Has_Task (T) then
5027 if No (Master_Id (Base_Type (PtrT))) then
5029 -- The designated type was an incomplete type, and the
5030 -- access type did not get expanded. Salvage it now.
5032 if not Restriction_Active (No_Task_Hierarchy) then
5033 if Present (Parent (Base_Type (PtrT))) then
5034 Expand_N_Full_Type_Declaration
5035 (Parent (Base_Type (PtrT)));
5037 -- The only other possibility is an itype. For this
5038 -- case, the master must exist in the context. This is
5039 -- the case when the allocator initializes an access
5040 -- component in an init-proc.
5043 pragma Assert (Is_Itype (PtrT));
5044 Build_Master_Renaming (PtrT, N);
5049 -- If the context of the allocator is a declaration or an
5050 -- assignment, we can generate a meaningful image for it,
5051 -- even though subsequent assignments might remove the
5052 -- connection between task and entity. We build this image
5053 -- when the left-hand side is a simple variable, a simple
5054 -- indexed assignment or a simple selected component.
5056 if Nkind (Parent (N)) = N_Assignment_Statement then
5058 Nam : constant Node_Id := Name (Parent (N));
5061 if Is_Entity_Name (Nam) then
5063 Build_Task_Image_Decls
5066 (Entity (Nam), Sloc (Nam)), T);
5068 elsif Nkind_In (Nam, N_Indexed_Component,
5069 N_Selected_Component)
5070 and then Is_Entity_Name (Prefix (Nam))
5073 Build_Task_Image_Decls
5074 (Loc, Nam, Etype (Prefix (Nam)));
5076 Decls := Build_Task_Image_Decls (Loc, T, T);
5080 elsif Nkind (Parent (N)) = N_Object_Declaration then
5082 Build_Task_Image_Decls
5083 (Loc, Defining_Identifier (Parent (N)), T);
5086 Decls := Build_Task_Image_Decls (Loc, T, T);
5089 if Restriction_Active (No_Task_Hierarchy) then
5091 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
5095 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
5098 Append_To (Args, Make_Identifier (Loc, Name_uChain));
5100 Decl := Last (Decls);
5102 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
5104 -- Has_Task is false, Decls not used
5110 -- Add discriminants if discriminated type
5113 Dis : Boolean := False;
5114 Typ : Entity_Id := Empty;
5117 if Has_Discriminants (T) then
5121 -- Type may be a private type with no visible discriminants
5122 -- in which case check full view if in scope, or the
5123 -- underlying_full_view if dealing with a type whose full
5124 -- view may be derived from a private type whose own full
5125 -- view has discriminants.
5127 elsif Is_Private_Type (T) then
5128 if Present (Full_View (T))
5129 and then Has_Discriminants (Full_View (T))
5132 Typ := Full_View (T);
5134 elsif Present (Underlying_Full_View (T))
5135 and then Has_Discriminants (Underlying_Full_View (T))
5138 Typ := Underlying_Full_View (T);
5144 -- If the allocated object will be constrained by the
5145 -- default values for discriminants, then build a subtype
5146 -- with those defaults, and change the allocated subtype
5147 -- to that. Note that this happens in fewer cases in Ada
5150 if not Is_Constrained (Typ)
5151 and then Present (Discriminant_Default_Value
5152 (First_Discriminant (Typ)))
5153 and then (Ada_Version < Ada_2005
5155 Object_Type_Has_Constrained_Partial_View
5156 (Typ, Current_Scope))
5158 Typ := Build_Default_Subtype (Typ, N);
5159 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
5162 Discr := First_Elmt (Discriminant_Constraint (Typ));
5163 while Present (Discr) loop
5164 Nod := Node (Discr);
5165 Append (New_Copy_Tree (Node (Discr)), Args);
5167 -- AI-416: when the discriminant constraint is an
5168 -- anonymous access type make sure an accessibility
5169 -- check is inserted if necessary (3.10.2(22.q/2))
5171 if Ada_Version >= Ada_2005
5173 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
5175 Apply_Accessibility_Check
5176 (Nod, Typ, Insert_Node => Nod);
5184 -- We set the allocator as analyzed so that when we analyze
5185 -- the if expression node, we do not get an unwanted recursive
5186 -- expansion of the allocator expression.
5188 Set_Analyzed (N, True);
5189 Nod := Relocate_Node (N);
5191 -- Here is the transformation:
5192 -- input: new Ctrl_Typ
5193 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5194 -- Ctrl_TypIP (Temp.all, ...);
5195 -- [Deep_]Initialize (Temp.all);
5197 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5198 -- is the subtype of the allocator.
5201 Make_Object_Declaration (Loc,
5202 Defining_Identifier => Temp,
5203 Constant_Present => True,
5204 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
5207 Set_Assignment_OK (Temp_Decl);
5208 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
5210 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
5212 -- If the designated type is a task type or contains tasks,
5213 -- create block to activate created tasks, and insert
5214 -- declaration for Task_Image variable ahead of call.
5216 if Has_Task (T) then
5218 L : constant List_Id := New_List;
5221 Build_Task_Allocate_Block (L, Nod, Args);
5223 Insert_List_Before (First (Declarations (Blk)), Decls);
5224 Insert_Actions (N, L);
5229 Make_Procedure_Call_Statement (Loc,
5230 Name => New_Occurrence_Of (Init, Loc),
5231 Parameter_Associations => Args));
5234 if Needs_Finalization (T) then
5237 -- [Deep_]Initialize (Init_Arg1);
5241 (Obj_Ref => New_Copy_Tree (Init_Arg1),
5244 -- Guard against a missing [Deep_]Initialize when the
5245 -- designated type was not properly frozen.
5247 if Present (Init_Call) then
5248 Insert_Action (N, Init_Call);
5252 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5253 Analyze_And_Resolve (N, PtrT);
5258 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5259 -- object that has been rewritten as a reference, we displace "this"
5260 -- to reference properly its secondary dispatch table.
5262 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
5263 Displace_Allocator_Pointer (N);
5267 when RE_Not_Available =>
5269 end Expand_N_Allocator;
5271 -----------------------
5272 -- Expand_N_And_Then --
5273 -----------------------
5275 procedure Expand_N_And_Then (N : Node_Id)
5276 renames Expand_Short_Circuit_Operator;
5278 ------------------------------
5279 -- Expand_N_Case_Expression --
5280 ------------------------------
5282 procedure Expand_N_Case_Expression (N : Node_Id) is
5283 function Is_Copy_Type (Typ : Entity_Id) return Boolean;
5284 -- Return True if we can copy objects of this type when expanding a case
5291 function Is_Copy_Type (Typ : Entity_Id) return Boolean is
5293 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5294 -- large objects, as long as they are constrained and not limited.
5297 Is_Elementary_Type (Underlying_Type (Typ))
5299 (Minimize_Expression_With_Actions
5300 and then Is_Constrained (Underlying_Type (Typ))
5301 and then not Is_Limited_Type (Underlying_Type (Typ)));
5306 Loc : constant Source_Ptr := Sloc (N);
5307 Par : constant Node_Id := Parent (N);
5308 Typ : constant Entity_Id := Etype (N);
5312 Case_Stmt : Node_Id;
5316 Target_Typ : Entity_Id;
5318 In_Predicate : Boolean := False;
5319 -- Flag set when the case expression appears within a predicate
5321 Optimize_Return_Stmt : Boolean := False;
5322 -- Flag set when the case expression can be optimized in the context of
5323 -- a simple return statement.
5325 -- Start of processing for Expand_N_Case_Expression
5328 -- Check for MINIMIZED/ELIMINATED overflow mode
5330 if Minimized_Eliminated_Overflow_Check (N) then
5331 Apply_Arithmetic_Overflow_Check (N);
5335 -- If the case expression is a predicate specification, and the type
5336 -- to which it applies has a static predicate aspect, do not expand,
5337 -- because it will be converted to the proper predicate form later.
5339 if Ekind_In (Current_Scope, E_Function, E_Procedure)
5340 and then Is_Predicate_Function (Current_Scope)
5342 In_Predicate := True;
5344 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
5350 -- When the type of the case expression is elementary, expand
5352 -- (case X is when A => AX, when B => BX ...)
5367 -- In all other cases expand into
5370 -- type Ptr_Typ is access all Typ;
5371 -- Target : Ptr_Typ;
5374 -- Target := AX'Unrestricted_Access;
5376 -- Target := BX'Unrestricted_Access;
5379 -- in Target.all end;
5381 -- This approach avoids extra copies of potentially large objects. It
5382 -- also allows handling of values of limited or unconstrained types.
5383 -- Note that we do the copy also for constrained, nonlimited types
5384 -- when minimizing expressions with actions (e.g. when generating C
5385 -- code) since it allows us to do the optimization below in more cases.
5387 -- Small optimization: when the case expression appears in the context
5388 -- of a simple return statement, expand into
5399 Make_Case_Statement (Loc,
5400 Expression => Expression (N),
5401 Alternatives => New_List);
5403 -- Preserve the original context for which the case statement is being
5404 -- generated. This is needed by the finalization machinery to prevent
5405 -- the premature finalization of controlled objects found within the
5408 Set_From_Conditional_Expression (Case_Stmt);
5413 if Is_Copy_Type (Typ) then
5416 -- ??? Do not perform the optimization when the return statement is
5417 -- within a predicate function, as this causes spurious errors. Could
5418 -- this be a possible mismatch in handling this case somewhere else
5419 -- in semantic analysis?
5421 Optimize_Return_Stmt :=
5422 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
5424 -- Otherwise create an access type to handle the general case using
5425 -- 'Unrestricted_Access.
5428 -- type Ptr_Typ is access all Typ;
5431 if Generate_C_Code then
5433 -- We cannot ensure that correct C code will be generated if any
5434 -- temporary is created down the line (to e.g. handle checks or
5435 -- capture values) since we might end up with dangling references
5436 -- to local variables, so better be safe and reject the construct.
5439 ("case expression too complex, use case statement instead", N);
5442 Target_Typ := Make_Temporary (Loc, 'P');
5445 Make_Full_Type_Declaration (Loc,
5446 Defining_Identifier => Target_Typ,
5448 Make_Access_To_Object_Definition (Loc,
5449 All_Present => True,
5450 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5453 -- Create the declaration of the target which captures the value of the
5457 -- Target : [Ptr_]Typ;
5459 if not Optimize_Return_Stmt then
5460 Target := Make_Temporary (Loc, 'T');
5463 Make_Object_Declaration (Loc,
5464 Defining_Identifier => Target,
5465 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
5466 Set_No_Initialization (Decl);
5468 Append_To (Acts, Decl);
5471 -- Process the alternatives
5473 Alt := First (Alternatives (N));
5474 while Present (Alt) loop
5476 Alt_Expr : Node_Id := Expression (Alt);
5477 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
5482 -- Take the unrestricted access of the expression value for non-
5483 -- scalar types. This approach avoids big copies and covers the
5484 -- limited and unconstrained cases.
5487 -- AX'Unrestricted_Access
5489 if not Is_Copy_Type (Typ) then
5491 Make_Attribute_Reference (Alt_Loc,
5492 Prefix => Relocate_Node (Alt_Expr),
5493 Attribute_Name => Name_Unrestricted_Access);
5497 -- return AX['Unrestricted_Access];
5499 if Optimize_Return_Stmt then
5501 Make_Simple_Return_Statement (Alt_Loc,
5502 Expression => Alt_Expr));
5505 -- Target := AX['Unrestricted_Access];
5508 LHS := New_Occurrence_Of (Target, Loc);
5509 Set_Assignment_OK (LHS);
5512 Make_Assignment_Statement (Alt_Loc,
5514 Expression => Alt_Expr));
5517 -- Propagate declarations inserted in the node by Insert_Actions
5518 -- (for example, temporaries generated to remove side effects).
5519 -- These actions must remain attached to the alternative, given
5520 -- that they are generated by the corresponding expression.
5522 if Present (Actions (Alt)) then
5523 Prepend_List (Actions (Alt), Stmts);
5526 -- Finalize any transient objects on exit from the alternative.
5527 -- This is done only in the return optimization case because
5528 -- otherwise the case expression is converted into an expression
5529 -- with actions which already contains this form of processing.
5531 if Optimize_Return_Stmt then
5532 Process_If_Case_Statements (N, Stmts);
5536 (Alternatives (Case_Stmt),
5537 Make_Case_Statement_Alternative (Sloc (Alt),
5538 Discrete_Choices => Discrete_Choices (Alt),
5539 Statements => Stmts));
5545 -- Rewrite the parent return statement as a case statement
5547 if Optimize_Return_Stmt then
5548 Rewrite (Par, Case_Stmt);
5551 -- Otherwise convert the case expression into an expression with actions
5554 Append_To (Acts, Case_Stmt);
5556 if Is_Copy_Type (Typ) then
5557 Expr := New_Occurrence_Of (Target, Loc);
5561 Make_Explicit_Dereference (Loc,
5562 Prefix => New_Occurrence_Of (Target, Loc));
5568 -- in Target[.all] end;
5571 Make_Expression_With_Actions (Loc,
5575 Analyze_And_Resolve (N, Typ);
5577 end Expand_N_Case_Expression;
5579 -----------------------------------
5580 -- Expand_N_Explicit_Dereference --
5581 -----------------------------------
5583 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5585 -- Insert explicit dereference call for the checked storage pool case
5587 Insert_Dereference_Action (Prefix (N));
5589 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5590 -- we set the atomic sync flag.
5592 if Is_Atomic (Etype (N))
5593 and then not Atomic_Synchronization_Disabled (Etype (N))
5595 Activate_Atomic_Synchronization (N);
5597 end Expand_N_Explicit_Dereference;
5599 --------------------------------------
5600 -- Expand_N_Expression_With_Actions --
5601 --------------------------------------
5603 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5604 Acts : constant List_Id := Actions (N);
5606 procedure Force_Boolean_Evaluation (Expr : Node_Id);
5607 -- Force the evaluation of Boolean expression Expr
5609 function Process_Action (Act : Node_Id) return Traverse_Result;
5610 -- Inspect and process a single action of an expression_with_actions for
5611 -- transient objects. If such objects are found, the routine generates
5612 -- code to clean them up when the context of the expression is evaluated
5615 ------------------------------
5616 -- Force_Boolean_Evaluation --
5617 ------------------------------
5619 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
5620 Loc : constant Source_Ptr := Sloc (N);
5621 Flag_Decl : Node_Id;
5622 Flag_Id : Entity_Id;
5625 -- Relocate the expression to the actions list by capturing its value
5626 -- in a Boolean flag. Generate:
5627 -- Flag : constant Boolean := Expr;
5629 Flag_Id := Make_Temporary (Loc, 'F');
5632 Make_Object_Declaration (Loc,
5633 Defining_Identifier => Flag_Id,
5634 Constant_Present => True,
5635 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5636 Expression => Relocate_Node (Expr));
5638 Append (Flag_Decl, Acts);
5639 Analyze (Flag_Decl);
5641 -- Replace the expression with a reference to the flag
5643 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
5644 Analyze (Expression (N));
5645 end Force_Boolean_Evaluation;
5647 --------------------
5648 -- Process_Action --
5649 --------------------
5651 function Process_Action (Act : Node_Id) return Traverse_Result is
5653 if Nkind (Act) = N_Object_Declaration
5654 and then Is_Finalizable_Transient (Act, N)
5656 Process_Transient_In_Expression (Act, N, Acts);
5659 -- Avoid processing temporary function results multiple times when
5660 -- dealing with nested expression_with_actions.
5662 elsif Nkind (Act) = N_Expression_With_Actions then
5665 -- Do not process temporary function results in loops. This is done
5666 -- by Expand_N_Loop_Statement and Build_Finalizer.
5668 elsif Nkind (Act) = N_Loop_Statement then
5675 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5681 -- Start of processing for Expand_N_Expression_With_Actions
5684 -- Do not evaluate the expression when it denotes an entity because the
5685 -- expression_with_actions node will be replaced by the reference.
5687 if Is_Entity_Name (Expression (N)) then
5690 -- Do not evaluate the expression when there are no actions because the
5691 -- expression_with_actions node will be replaced by the expression.
5693 elsif No (Acts) or else Is_Empty_List (Acts) then
5696 -- Force the evaluation of the expression by capturing its value in a
5697 -- temporary. This ensures that aliases of transient objects do not leak
5698 -- to the expression of the expression_with_actions node:
5701 -- Trans_Id : Ctrl_Typ := ...;
5702 -- Alias : ... := Trans_Id;
5703 -- in ... Alias ... end;
5705 -- In the example above, Trans_Id cannot be finalized at the end of the
5706 -- actions list because this may affect the alias and the final value of
5707 -- the expression_with_actions. Forcing the evaluation encapsulates the
5708 -- reference to the Alias within the actions list:
5711 -- Trans_Id : Ctrl_Typ := ...;
5712 -- Alias : ... := Trans_Id;
5713 -- Val : constant Boolean := ... Alias ...;
5714 -- <finalize Trans_Id>
5717 -- Once this transformation is performed, it is safe to finalize the
5718 -- transient object at the end of the actions list.
5720 -- Note that Force_Evaluation does not remove side effects in operators
5721 -- because it assumes that all operands are evaluated and side effect
5722 -- free. This is not the case when an operand depends implicitly on the
5723 -- transient object through the use of access types.
5725 elsif Is_Boolean_Type (Etype (Expression (N))) then
5726 Force_Boolean_Evaluation (Expression (N));
5728 -- The expression of an expression_with_actions node may not necessarily
5729 -- be Boolean when the node appears in an if expression. In this case do
5730 -- the usual forced evaluation to encapsulate potential aliasing.
5733 Force_Evaluation (Expression (N));
5736 -- Process all transient objects found within the actions of the EWA
5739 Act := First (Acts);
5740 while Present (Act) loop
5741 Process_Single_Action (Act);
5745 -- Deal with case where there are no actions. In this case we simply
5746 -- rewrite the node with its expression since we don't need the actions
5747 -- and the specification of this node does not allow a null action list.
5749 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5750 -- the expanded tree and relying on being able to retrieve the original
5751 -- tree in cases like this. This raises a whole lot of issues of whether
5752 -- we have problems elsewhere, which will be addressed in the future???
5754 if Is_Empty_List (Acts) then
5755 Rewrite (N, Relocate_Node (Expression (N)));
5757 end Expand_N_Expression_With_Actions;
5759 ----------------------------
5760 -- Expand_N_If_Expression --
5761 ----------------------------
5763 -- Deal with limited types and condition actions
5765 procedure Expand_N_If_Expression (N : Node_Id) is
5766 Cond : constant Node_Id := First (Expressions (N));
5767 Loc : constant Source_Ptr := Sloc (N);
5768 Thenx : constant Node_Id := Next (Cond);
5769 Elsex : constant Node_Id := Next (Thenx);
5770 Typ : constant Entity_Id := Etype (N);
5779 -- Check for MINIMIZED/ELIMINATED overflow mode
5781 if Minimized_Eliminated_Overflow_Check (N) then
5782 Apply_Arithmetic_Overflow_Check (N);
5786 -- Fold at compile time if condition known. We have already folded
5787 -- static if expressions, but it is possible to fold any case in which
5788 -- the condition is known at compile time, even though the result is
5791 -- Note that we don't do the fold of such cases in Sem_Elab because
5792 -- it can cause infinite loops with the expander adding a conditional
5793 -- expression, and Sem_Elab circuitry removing it repeatedly.
5795 if Compile_Time_Known_Value (Cond) then
5797 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5798 -- Fold at compile time. Assumes condition known. Return True if
5799 -- folding occurred, meaning we're done.
5801 ----------------------
5802 -- Fold_Known_Value --
5803 ----------------------
5805 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5807 if Is_True (Expr_Value (Cond)) then
5809 Actions := Then_Actions (N);
5812 Actions := Else_Actions (N);
5817 if Present (Actions) then
5819 -- To minimize the use of Expression_With_Actions, just skip
5820 -- the optimization as it is not critical for correctness.
5822 if Minimize_Expression_With_Actions then
5827 Make_Expression_With_Actions (Loc,
5828 Expression => Relocate_Node (Expr),
5829 Actions => Actions));
5830 Analyze_And_Resolve (N, Typ);
5833 Rewrite (N, Relocate_Node (Expr));
5836 -- Note that the result is never static (legitimate cases of
5837 -- static if expressions were folded in Sem_Eval).
5839 Set_Is_Static_Expression (N, False);
5841 end Fold_Known_Value;
5844 if Fold_Known_Value (Cond) then
5850 -- If the type is limited, and the back end does not handle limited
5851 -- types, then we expand as follows to avoid the possibility of
5852 -- improper copying.
5854 -- type Ptr is access all Typ;
5858 -- Cnn := then-expr'Unrestricted_Access;
5861 -- Cnn := else-expr'Unrestricted_Access;
5864 -- and replace the if expression by a reference to Cnn.all.
5866 -- This special case can be skipped if the back end handles limited
5867 -- types properly and ensures that no incorrect copies are made.
5869 if Is_By_Reference_Type (Typ)
5870 and then not Back_End_Handles_Limited_Types
5872 -- When the "then" or "else" expressions involve controlled function
5873 -- calls, generated temporaries are chained on the corresponding list
5874 -- of actions. These temporaries need to be finalized after the if
5875 -- expression is evaluated.
5877 Process_If_Case_Statements (N, Then_Actions (N));
5878 Process_If_Case_Statements (N, Else_Actions (N));
5881 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
5882 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
5886 -- type Ann is access all Typ;
5889 Make_Full_Type_Declaration (Loc,
5890 Defining_Identifier => Ptr_Typ,
5892 Make_Access_To_Object_Definition (Loc,
5893 All_Present => True,
5894 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5900 Make_Object_Declaration (Loc,
5901 Defining_Identifier => Cnn,
5902 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
5906 -- Cnn := <Thenx>'Unrestricted_Access;
5908 -- Cnn := <Elsex>'Unrestricted_Access;
5912 Make_Implicit_If_Statement (N,
5913 Condition => Relocate_Node (Cond),
5914 Then_Statements => New_List (
5915 Make_Assignment_Statement (Sloc (Thenx),
5916 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5918 Make_Attribute_Reference (Loc,
5919 Prefix => Relocate_Node (Thenx),
5920 Attribute_Name => Name_Unrestricted_Access))),
5922 Else_Statements => New_List (
5923 Make_Assignment_Statement (Sloc (Elsex),
5924 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5926 Make_Attribute_Reference (Loc,
5927 Prefix => Relocate_Node (Elsex),
5928 Attribute_Name => Name_Unrestricted_Access))));
5930 -- Preserve the original context for which the if statement is
5931 -- being generated. This is needed by the finalization machinery
5932 -- to prevent the premature finalization of controlled objects
5933 -- found within the if statement.
5935 Set_From_Conditional_Expression (New_If);
5938 Make_Explicit_Dereference (Loc,
5939 Prefix => New_Occurrence_Of (Cnn, Loc));
5942 -- If the result is an unconstrained array and the if expression is in a
5943 -- context other than the initializing expression of the declaration of
5944 -- an object, then we pull out the if expression as follows:
5946 -- Cnn : constant typ := if-expression
5948 -- and then replace the if expression with an occurrence of Cnn. This
5949 -- avoids the need in the back end to create on-the-fly variable length
5950 -- temporaries (which it cannot do!)
5952 -- Note that the test for being in an object declaration avoids doing an
5953 -- unnecessary expansion, and also avoids infinite recursion.
5955 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
5956 and then (Nkind (Parent (N)) /= N_Object_Declaration
5957 or else Expression (Parent (N)) /= N)
5960 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5964 Make_Object_Declaration (Loc,
5965 Defining_Identifier => Cnn,
5966 Constant_Present => True,
5967 Object_Definition => New_Occurrence_Of (Typ, Loc),
5968 Expression => Relocate_Node (N),
5969 Has_Init_Expression => True));
5971 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
5975 -- For other types, we only need to expand if there are other actions
5976 -- associated with either branch.
5978 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5980 -- We now wrap the actions into the appropriate expression
5982 if Minimize_Expression_With_Actions
5983 and then (Is_Elementary_Type (Underlying_Type (Typ))
5984 or else Is_Constrained (Underlying_Type (Typ)))
5986 -- If we can't use N_Expression_With_Actions nodes, then we insert
5987 -- the following sequence of actions (using Insert_Actions):
5992 -- Cnn := then-expr;
5998 -- and replace the if expression by a reference to Cnn
6001 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
6005 Make_Object_Declaration (Loc,
6006 Defining_Identifier => Cnn,
6007 Object_Definition => New_Occurrence_Of (Typ, Loc));
6010 Make_Implicit_If_Statement (N,
6011 Condition => Relocate_Node (Cond),
6013 Then_Statements => New_List (
6014 Make_Assignment_Statement (Sloc (Thenx),
6015 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6016 Expression => Relocate_Node (Thenx))),
6018 Else_Statements => New_List (
6019 Make_Assignment_Statement (Sloc (Elsex),
6020 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6021 Expression => Relocate_Node (Elsex))));
6023 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
6024 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
6026 New_N := New_Occurrence_Of (Cnn, Loc);
6029 -- Regular path using Expression_With_Actions
6032 if Present (Then_Actions (N)) then
6034 Make_Expression_With_Actions (Sloc (Thenx),
6035 Actions => Then_Actions (N),
6036 Expression => Relocate_Node (Thenx)));
6038 Set_Then_Actions (N, No_List);
6039 Analyze_And_Resolve (Thenx, Typ);
6042 if Present (Else_Actions (N)) then
6044 Make_Expression_With_Actions (Sloc (Elsex),
6045 Actions => Else_Actions (N),
6046 Expression => Relocate_Node (Elsex)));
6048 Set_Else_Actions (N, No_List);
6049 Analyze_And_Resolve (Elsex, Typ);
6055 -- If no actions then no expansion needed, gigi will handle it using the
6056 -- same approach as a C conditional expression.
6062 -- Fall through here for either the limited expansion, or the case of
6063 -- inserting actions for nonlimited types. In both these cases, we must
6064 -- move the SLOC of the parent If statement to the newly created one and
6065 -- change it to the SLOC of the expression which, after expansion, will
6066 -- correspond to what is being evaluated.
6068 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
6069 Set_Sloc (New_If, Sloc (Parent (N)));
6070 Set_Sloc (Parent (N), Loc);
6073 -- Make sure Then_Actions and Else_Actions are appropriately moved
6074 -- to the new if statement.
6076 if Present (Then_Actions (N)) then
6078 (First (Then_Statements (New_If)), Then_Actions (N));
6081 if Present (Else_Actions (N)) then
6083 (First (Else_Statements (New_If)), Else_Actions (N));
6086 Insert_Action (N, Decl);
6087 Insert_Action (N, New_If);
6089 Analyze_And_Resolve (N, Typ);
6090 end Expand_N_If_Expression;
6096 procedure Expand_N_In (N : Node_Id) is
6097 Loc : constant Source_Ptr := Sloc (N);
6098 Restyp : constant Entity_Id := Etype (N);
6099 Lop : constant Node_Id := Left_Opnd (N);
6100 Rop : constant Node_Id := Right_Opnd (N);
6101 Static : constant Boolean := Is_OK_Static_Expression (N);
6103 procedure Substitute_Valid_Check;
6104 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6105 -- test for the left operand being in range of its subtype.
6107 ----------------------------
6108 -- Substitute_Valid_Check --
6109 ----------------------------
6111 procedure Substitute_Valid_Check is
6112 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
6113 -- Determine whether arbitrary node Nod denotes a source object that
6114 -- may safely act as prefix of attribute 'Valid.
6116 ----------------------------
6117 -- Is_OK_Object_Reference --
6118 ----------------------------
6120 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
6124 -- Inspect the original operand
6126 Obj_Ref := Original_Node (Nod);
6128 -- The object reference must be a source construct, otherwise the
6129 -- codefix suggestion may refer to nonexistent code from a user
6132 if Comes_From_Source (Obj_Ref) then
6134 -- Recover the actual object reference. There may be more cases
6138 if Nkind_In (Obj_Ref, N_Type_Conversion,
6139 N_Unchecked_Type_Conversion)
6141 Obj_Ref := Expression (Obj_Ref);
6147 return Is_Object_Reference (Obj_Ref);
6151 end Is_OK_Object_Reference;
6153 -- Start of processing for Substitute_Valid_Check
6157 Make_Attribute_Reference (Loc,
6158 Prefix => Relocate_Node (Lop),
6159 Attribute_Name => Name_Valid));
6161 Analyze_And_Resolve (N, Restyp);
6163 -- Emit a warning when the left-hand operand of the membership test
6164 -- is a source object, otherwise the use of attribute 'Valid would be
6165 -- illegal. The warning is not given when overflow checking is either
6166 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6167 -- eliminated above.
6169 if Is_OK_Object_Reference (Lop)
6170 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
6173 ("??explicit membership test may be optimized away", N);
6174 Error_Msg_N -- CODEFIX
6175 ("\??use ''Valid attribute instead", N);
6177 end Substitute_Valid_Check;
6184 -- Start of processing for Expand_N_In
6187 -- If set membership case, expand with separate procedure
6189 if Present (Alternatives (N)) then
6190 Expand_Set_Membership (N);
6194 -- Not set membership, proceed with expansion
6196 Ltyp := Etype (Left_Opnd (N));
6197 Rtyp := Etype (Right_Opnd (N));
6199 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6200 -- type, then expand with a separate procedure. Note the use of the
6201 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6203 if Overflow_Check_Mode in Minimized_Or_Eliminated
6204 and then Is_Signed_Integer_Type (Ltyp)
6205 and then not No_Minimize_Eliminate (N)
6207 Expand_Membership_Minimize_Eliminate_Overflow (N);
6211 -- Check case of explicit test for an expression in range of its
6212 -- subtype. This is suspicious usage and we replace it with a 'Valid
6213 -- test and give a warning for scalar types.
6215 if Is_Scalar_Type (Ltyp)
6217 -- Only relevant for source comparisons
6219 and then Comes_From_Source (N)
6221 -- In floating-point this is a standard way to check for finite values
6222 -- and using 'Valid would typically be a pessimization.
6224 and then not Is_Floating_Point_Type (Ltyp)
6226 -- Don't give the message unless right operand is a type entity and
6227 -- the type of the left operand matches this type. Note that this
6228 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6229 -- checks have changed the type of the left operand.
6231 and then Nkind (Rop) in N_Has_Entity
6232 and then Ltyp = Entity (Rop)
6234 -- Skip this for predicated types, where such expressions are a
6235 -- reasonable way of testing if something meets the predicate.
6237 and then not Present (Predicate_Function (Ltyp))
6239 Substitute_Valid_Check;
6243 -- Do validity check on operands
6245 if Validity_Checks_On and Validity_Check_Operands then
6246 Ensure_Valid (Left_Opnd (N));
6247 Validity_Check_Range (Right_Opnd (N));
6250 -- Case of explicit range
6252 if Nkind (Rop) = N_Range then
6254 Lo : constant Node_Id := Low_Bound (Rop);
6255 Hi : constant Node_Id := High_Bound (Rop);
6257 Lo_Orig : constant Node_Id := Original_Node (Lo);
6258 Hi_Orig : constant Node_Id := Original_Node (Hi);
6260 Lcheck : Compare_Result;
6261 Ucheck : Compare_Result;
6263 Warn1 : constant Boolean :=
6264 Constant_Condition_Warnings
6265 and then Comes_From_Source (N)
6266 and then not In_Instance;
6267 -- This must be true for any of the optimization warnings, we
6268 -- clearly want to give them only for source with the flag on. We
6269 -- also skip these warnings in an instance since it may be the
6270 -- case that different instantiations have different ranges.
6272 Warn2 : constant Boolean :=
6274 and then Nkind (Original_Node (Rop)) = N_Range
6275 and then Is_Integer_Type (Etype (Lo));
6276 -- For the case where only one bound warning is elided, we also
6277 -- insist on an explicit range and an integer type. The reason is
6278 -- that the use of enumeration ranges including an end point is
6279 -- common, as is the use of a subtype name, one of whose bounds is
6280 -- the same as the type of the expression.
6283 -- If test is explicit x'First .. x'Last, replace by valid check
6285 -- Could use some individual comments for this complex test ???
6287 if Is_Scalar_Type (Ltyp)
6289 -- And left operand is X'First where X matches left operand
6290 -- type (this eliminates cases of type mismatch, including
6291 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6292 -- type of the left operand.
6294 and then Nkind (Lo_Orig) = N_Attribute_Reference
6295 and then Attribute_Name (Lo_Orig) = Name_First
6296 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
6297 and then Entity (Prefix (Lo_Orig)) = Ltyp
6299 -- Same tests for right operand
6301 and then Nkind (Hi_Orig) = N_Attribute_Reference
6302 and then Attribute_Name (Hi_Orig) = Name_Last
6303 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
6304 and then Entity (Prefix (Hi_Orig)) = Ltyp
6306 -- Relevant only for source cases
6308 and then Comes_From_Source (N)
6310 Substitute_Valid_Check;
6314 -- If bounds of type are known at compile time, and the end points
6315 -- are known at compile time and identical, this is another case
6316 -- for substituting a valid test. We only do this for discrete
6317 -- types, since it won't arise in practice for float types.
6319 if Comes_From_Source (N)
6320 and then Is_Discrete_Type (Ltyp)
6321 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
6322 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
6323 and then Compile_Time_Known_Value (Lo)
6324 and then Compile_Time_Known_Value (Hi)
6325 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
6326 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
6328 -- Kill warnings in instances, since they may be cases where we
6329 -- have a test in the generic that makes sense with some types
6330 -- and not with other types.
6332 -- Similarly, do not rewrite membership as a validity check if
6333 -- within the predicate function for the type.
6335 -- Finally, if the original bounds are type conversions, even
6336 -- if they have been folded into constants, there are different
6337 -- types involved and 'Valid is not appropriate.
6341 or else (Ekind (Current_Scope) = E_Function
6342 and then Is_Predicate_Function (Current_Scope))
6346 elsif Nkind (Lo_Orig) = N_Type_Conversion
6347 or else Nkind (Hi_Orig) = N_Type_Conversion
6352 Substitute_Valid_Check;
6357 -- If we have an explicit range, do a bit of optimization based on
6358 -- range analysis (we may be able to kill one or both checks).
6360 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
6361 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
6363 -- If either check is known to fail, replace result by False since
6364 -- the other check does not matter. Preserve the static flag for
6365 -- legality checks, because we are constant-folding beyond RM 4.9.
6367 if Lcheck = LT or else Ucheck = GT then
6369 Error_Msg_N ("?c?range test optimized away", N);
6370 Error_Msg_N ("\?c?value is known to be out of range", N);
6373 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6374 Analyze_And_Resolve (N, Restyp);
6375 Set_Is_Static_Expression (N, Static);
6378 -- If both checks are known to succeed, replace result by True,
6379 -- since we know we are in range.
6381 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6383 Error_Msg_N ("?c?range test optimized away", N);
6384 Error_Msg_N ("\?c?value is known to be in range", N);
6387 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6388 Analyze_And_Resolve (N, Restyp);
6389 Set_Is_Static_Expression (N, Static);
6392 -- If lower bound check succeeds and upper bound check is not
6393 -- known to succeed or fail, then replace the range check with
6394 -- a comparison against the upper bound.
6396 elsif Lcheck in Compare_GE then
6397 if Warn2 and then not In_Instance then
6398 Error_Msg_N ("??lower bound test optimized away", Lo);
6399 Error_Msg_N ("\??value is known to be in range", Lo);
6405 Right_Opnd => High_Bound (Rop)));
6406 Analyze_And_Resolve (N, Restyp);
6409 -- If upper bound check succeeds and lower bound check is not
6410 -- known to succeed or fail, then replace the range check with
6411 -- a comparison against the lower bound.
6413 elsif Ucheck in Compare_LE then
6414 if Warn2 and then not In_Instance then
6415 Error_Msg_N ("??upper bound test optimized away", Hi);
6416 Error_Msg_N ("\??value is known to be in range", Hi);
6422 Right_Opnd => Low_Bound (Rop)));
6423 Analyze_And_Resolve (N, Restyp);
6427 -- We couldn't optimize away the range check, but there is one
6428 -- more issue. If we are checking constant conditionals, then we
6429 -- see if we can determine the outcome assuming everything is
6430 -- valid, and if so give an appropriate warning.
6432 if Warn1 and then not Assume_No_Invalid_Values then
6433 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
6434 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
6436 -- Result is out of range for valid value
6438 if Lcheck = LT or else Ucheck = GT then
6440 ("?c?value can only be in range if it is invalid", N);
6442 -- Result is in range for valid value
6444 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6446 ("?c?value can only be out of range if it is invalid", N);
6448 -- Lower bound check succeeds if value is valid
6450 elsif Warn2 and then Lcheck in Compare_GE then
6452 ("?c?lower bound check only fails if it is invalid", Lo);
6454 -- Upper bound check succeeds if value is valid
6456 elsif Warn2 and then Ucheck in Compare_LE then
6458 ("?c?upper bound check only fails for invalid values", Hi);
6463 -- For all other cases of an explicit range, nothing to be done
6467 -- Here right operand is a subtype mark
6471 Typ : Entity_Id := Etype (Rop);
6472 Is_Acc : constant Boolean := Is_Access_Type (Typ);
6473 Cond : Node_Id := Empty;
6475 Obj : Node_Id := Lop;
6476 SCIL_Node : Node_Id;
6479 Remove_Side_Effects (Obj);
6481 -- For tagged type, do tagged membership operation
6483 if Is_Tagged_Type (Typ) then
6485 -- No expansion will be performed for VM targets, as the VM
6486 -- back ends will handle the membership tests directly.
6488 if Tagged_Type_Expansion then
6489 Tagged_Membership (N, SCIL_Node, New_N);
6491 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks);
6493 -- Update decoration of relocated node referenced by the
6496 if Generate_SCIL and then Present (SCIL_Node) then
6497 Set_SCIL_Node (N, SCIL_Node);
6503 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6504 -- This reason we do this is that the bounds may have the wrong
6505 -- type if they come from the original type definition. Also this
6506 -- way we get all the processing above for an explicit range.
6508 -- Don't do this for predicated types, since in this case we
6509 -- want to check the predicate.
6511 elsif Is_Scalar_Type (Typ) then
6512 if No (Predicate_Function (Typ)) then
6516 Make_Attribute_Reference (Loc,
6517 Attribute_Name => Name_First,
6518 Prefix => New_Occurrence_Of (Typ, Loc)),
6521 Make_Attribute_Reference (Loc,
6522 Attribute_Name => Name_Last,
6523 Prefix => New_Occurrence_Of (Typ, Loc))));
6524 Analyze_And_Resolve (N, Restyp);
6529 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6530 -- a membership test if the subtype mark denotes a constrained
6531 -- Unchecked_Union subtype and the expression lacks inferable
6534 elsif Is_Unchecked_Union (Base_Type (Typ))
6535 and then Is_Constrained (Typ)
6536 and then not Has_Inferable_Discriminants (Lop)
6539 Make_Raise_Program_Error (Loc,
6540 Reason => PE_Unchecked_Union_Restriction));
6542 -- Prevent Gigi from generating incorrect code by rewriting the
6543 -- test as False. What is this undocumented thing about ???
6545 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6549 -- Here we have a non-scalar type
6552 Typ := Designated_Type (Typ);
6555 if not Is_Constrained (Typ) then
6556 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6557 Analyze_And_Resolve (N, Restyp);
6559 -- For the constrained array case, we have to check the subscripts
6560 -- for an exact match if the lengths are non-zero (the lengths
6561 -- must match in any case).
6563 elsif Is_Array_Type (Typ) then
6564 Check_Subscripts : declare
6565 function Build_Attribute_Reference
6568 Dim : Nat) return Node_Id;
6569 -- Build attribute reference E'Nam (Dim)
6571 -------------------------------
6572 -- Build_Attribute_Reference --
6573 -------------------------------
6575 function Build_Attribute_Reference
6578 Dim : Nat) return Node_Id
6582 Make_Attribute_Reference (Loc,
6584 Attribute_Name => Nam,
6585 Expressions => New_List (
6586 Make_Integer_Literal (Loc, Dim)));
6587 end Build_Attribute_Reference;
6589 -- Start of processing for Check_Subscripts
6592 for J in 1 .. Number_Dimensions (Typ) loop
6593 Evolve_And_Then (Cond,
6596 Build_Attribute_Reference
6597 (Duplicate_Subexpr_No_Checks (Obj),
6600 Build_Attribute_Reference
6601 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
6603 Evolve_And_Then (Cond,
6606 Build_Attribute_Reference
6607 (Duplicate_Subexpr_No_Checks (Obj),
6610 Build_Attribute_Reference
6611 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
6620 Right_Opnd => Make_Null (Loc)),
6621 Right_Opnd => Cond);
6625 Analyze_And_Resolve (N, Restyp);
6626 end Check_Subscripts;
6628 -- These are the cases where constraint checks may be required,
6629 -- e.g. records with possible discriminants
6632 -- Expand the test into a series of discriminant comparisons.
6633 -- The expression that is built is the negation of the one that
6634 -- is used for checking discriminant constraints.
6636 Obj := Relocate_Node (Left_Opnd (N));
6638 if Has_Discriminants (Typ) then
6639 Cond := Make_Op_Not (Loc,
6640 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
6643 Cond := Make_Or_Else (Loc,
6647 Right_Opnd => Make_Null (Loc)),
6648 Right_Opnd => Cond);
6652 Cond := New_Occurrence_Of (Standard_True, Loc);
6656 Analyze_And_Resolve (N, Restyp);
6659 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6660 -- expression of an anonymous access type. This can involve an
6661 -- accessibility test and a tagged type membership test in the
6662 -- case of tagged designated types.
6664 if Ada_Version >= Ada_2012
6666 and then Ekind (Ltyp) = E_Anonymous_Access_Type
6669 Expr_Entity : Entity_Id := Empty;
6671 Param_Level : Node_Id;
6672 Type_Level : Node_Id;
6675 if Is_Entity_Name (Lop) then
6676 Expr_Entity := Param_Entity (Lop);
6678 if not Present (Expr_Entity) then
6679 Expr_Entity := Entity (Lop);
6683 -- If a conversion of the anonymous access value to the
6684 -- tested type would be illegal, then the result is False.
6686 if not Valid_Conversion
6687 (Lop, Rtyp, Lop, Report_Errs => False)
6689 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6690 Analyze_And_Resolve (N, Restyp);
6692 -- Apply an accessibility check if the access object has an
6693 -- associated access level and when the level of the type is
6694 -- less deep than the level of the access parameter. This
6695 -- only occur for access parameters and stand-alone objects
6696 -- of an anonymous access type.
6699 if Present (Expr_Entity)
6702 (Effective_Extra_Accessibility (Expr_Entity))
6703 and then UI_Gt (Object_Access_Level (Lop),
6704 Type_Access_Level (Rtyp))
6708 (Effective_Extra_Accessibility (Expr_Entity), Loc);
6711 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6713 -- Return True only if the accessibility level of the
6714 -- expression entity is not deeper than the level of
6715 -- the tested access type.
6719 Left_Opnd => Relocate_Node (N),
6720 Right_Opnd => Make_Op_Le (Loc,
6721 Left_Opnd => Param_Level,
6722 Right_Opnd => Type_Level)));
6724 Analyze_And_Resolve (N);
6727 -- If the designated type is tagged, do tagged membership
6730 -- *** NOTE: we have to check not null before doing the
6731 -- tagged membership test (but maybe that can be done
6732 -- inside Tagged_Membership?).
6734 if Is_Tagged_Type (Typ) then
6737 Left_Opnd => Relocate_Node (N),
6741 Right_Opnd => Make_Null (Loc))));
6743 -- No expansion will be performed for VM targets, as
6744 -- the VM back ends will handle the membership tests
6747 if Tagged_Type_Expansion then
6749 -- Note that we have to pass Original_Node, because
6750 -- the membership test might already have been
6751 -- rewritten by earlier parts of membership test.
6754 (Original_Node (N), SCIL_Node, New_N);
6756 -- Update decoration of relocated node referenced
6757 -- by the SCIL node.
6759 if Generate_SCIL and then Present (SCIL_Node) then
6760 Set_SCIL_Node (New_N, SCIL_Node);
6765 Left_Opnd => Relocate_Node (N),
6766 Right_Opnd => New_N));
6768 Analyze_And_Resolve (N, Restyp);
6777 -- At this point, we have done the processing required for the basic
6778 -- membership test, but not yet dealt with the predicate.
6782 -- If a predicate is present, then we do the predicate test, but we
6783 -- most certainly want to omit this if we are within the predicate
6784 -- function itself, since otherwise we have an infinite recursion.
6785 -- The check should also not be emitted when testing against a range
6786 -- (the check is only done when the right operand is a subtype; see
6787 -- RM12-4.5.2 (28.1/3-30/3)).
6789 Predicate_Check : declare
6790 function In_Range_Check return Boolean;
6791 -- Within an expanded range check that may raise Constraint_Error do
6792 -- not generate a predicate check as well. It is redundant because
6793 -- the context will add an explicit predicate check, and it will
6794 -- raise the wrong exception if it fails.
6796 --------------------
6797 -- In_Range_Check --
6798 --------------------
6800 function In_Range_Check return Boolean is
6804 while Present (P) loop
6805 if Nkind (P) = N_Raise_Constraint_Error then
6808 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
6809 or else Nkind (P) = N_Procedure_Call_Statement
6810 or else Nkind (P) in N_Declaration
6823 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6826 -- Start of processing for Predicate_Check
6830 and then Current_Scope /= PFunc
6831 and then Nkind (Rop) /= N_Range
6833 if not In_Range_Check then
6834 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
6836 R_Op := New_Occurrence_Of (Standard_True, Loc);
6841 Left_Opnd => Relocate_Node (N),
6842 Right_Opnd => R_Op));
6844 -- Analyze new expression, mark left operand as analyzed to
6845 -- avoid infinite recursion adding predicate calls. Similarly,
6846 -- suppress further range checks on the call.
6848 Set_Analyzed (Left_Opnd (N));
6849 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6851 -- All done, skip attempt at compile time determination of result
6855 end Predicate_Check;
6858 --------------------------------
6859 -- Expand_N_Indexed_Component --
6860 --------------------------------
6862 procedure Expand_N_Indexed_Component (N : Node_Id) is
6863 Loc : constant Source_Ptr := Sloc (N);
6864 Typ : constant Entity_Id := Etype (N);
6865 P : constant Node_Id := Prefix (N);
6866 T : constant Entity_Id := Etype (P);
6870 -- A special optimization, if we have an indexed component that is
6871 -- selecting from a slice, then we can eliminate the slice, since, for
6872 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6873 -- the range check required by the slice. The range check for the slice
6874 -- itself has already been generated. The range check for the
6875 -- subscripting operation is ensured by converting the subject to
6876 -- the subtype of the slice.
6878 -- This optimization not only generates better code, avoiding slice
6879 -- messing especially in the packed case, but more importantly bypasses
6880 -- some problems in handling this peculiar case, for example, the issue
6881 -- of dealing specially with object renamings.
6883 if Nkind (P) = N_Slice
6885 -- This optimization is disabled for CodePeer because it can transform
6886 -- an index-check constraint_error into a range-check constraint_error
6887 -- and CodePeer cares about that distinction.
6889 and then not CodePeer_Mode
6892 Make_Indexed_Component (Loc,
6893 Prefix => Prefix (P),
6894 Expressions => New_List (
6896 (Etype (First_Index (Etype (P))),
6897 First (Expressions (N))))));
6898 Analyze_And_Resolve (N, Typ);
6902 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6903 -- function, then additional actuals must be passed.
6905 if Is_Build_In_Place_Function_Call (P) then
6906 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6908 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
6909 -- containing build-in-place function calls whose returned object covers
6912 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
6913 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
6916 -- If the prefix is an access type, then we unconditionally rewrite if
6917 -- as an explicit dereference. This simplifies processing for several
6918 -- cases, including packed array cases and certain cases in which checks
6919 -- must be generated. We used to try to do this only when it was
6920 -- necessary, but it cleans up the code to do it all the time.
6922 if Is_Access_Type (T) then
6923 Insert_Explicit_Dereference (P);
6924 Analyze_And_Resolve (P, Designated_Type (T));
6925 Atp := Designated_Type (T);
6930 -- Generate index and validity checks
6932 Generate_Index_Checks (N);
6934 if Validity_Checks_On and then Validity_Check_Subscripts then
6935 Apply_Subscript_Validity_Checks (N);
6938 -- If selecting from an array with atomic components, and atomic sync
6939 -- is not suppressed for this array type, set atomic sync flag.
6941 if (Has_Atomic_Components (Atp)
6942 and then not Atomic_Synchronization_Disabled (Atp))
6943 or else (Is_Atomic (Typ)
6944 and then not Atomic_Synchronization_Disabled (Typ))
6945 or else (Is_Entity_Name (P)
6946 and then Has_Atomic_Components (Entity (P))
6947 and then not Atomic_Synchronization_Disabled (Entity (P)))
6949 Activate_Atomic_Synchronization (N);
6952 -- All done if the prefix is not a packed array implemented specially
6954 if not (Is_Packed (Etype (Prefix (N)))
6955 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
6960 -- For packed arrays that are not bit-packed (i.e. the case of an array
6961 -- with one or more index types with a non-contiguous enumeration type),
6962 -- we can always use the normal packed element get circuit.
6964 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6965 Expand_Packed_Element_Reference (N);
6969 -- For a reference to a component of a bit packed array, we convert it
6970 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6971 -- want to do this for simple references, and not for:
6973 -- Left side of assignment, or prefix of left side of assignment, or
6974 -- prefix of the prefix, to handle packed arrays of packed arrays,
6975 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6977 -- Renaming objects in renaming associations
6978 -- This case is handled when a use of the renamed variable occurs
6980 -- Actual parameters for a subprogram call
6981 -- This case is handled in Exp_Ch6.Expand_Actuals
6983 -- The second expression in a 'Read attribute reference
6985 -- The prefix of an address or bit or size attribute reference
6987 -- The following circuit detects these exceptions. Note that we need to
6988 -- deal with implicit dereferences when climbing up the parent chain,
6989 -- with the additional difficulty that the type of parents may have yet
6990 -- to be resolved since prefixes are usually resolved first.
6993 Child : Node_Id := N;
6994 Parnt : Node_Id := Parent (N);
6998 if Nkind (Parnt) = N_Unchecked_Expression then
7001 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then
7004 elsif Nkind (Parnt) in N_Subprogram_Call
7005 or else (Nkind (Parnt) = N_Parameter_Association
7006 and then Nkind (Parent (Parnt)) in N_Subprogram_Call)
7010 elsif Nkind (Parnt) = N_Attribute_Reference
7011 and then Nam_In (Attribute_Name (Parnt), Name_Address,
7014 and then Prefix (Parnt) = Child
7018 elsif Nkind (Parnt) = N_Assignment_Statement
7019 and then Name (Parnt) = Child
7023 -- If the expression is an index of an indexed component, it must
7024 -- be expanded regardless of context.
7026 elsif Nkind (Parnt) = N_Indexed_Component
7027 and then Child /= Prefix (Parnt)
7029 Expand_Packed_Element_Reference (N);
7032 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
7033 and then Name (Parent (Parnt)) = Parnt
7037 elsif Nkind (Parnt) = N_Attribute_Reference
7038 and then Attribute_Name (Parnt) = Name_Read
7039 and then Next (First (Expressions (Parnt))) = Child
7043 elsif Nkind (Parnt) = N_Indexed_Component
7044 and then Prefix (Parnt) = Child
7048 elsif Nkind (Parnt) = N_Selected_Component
7049 and then Prefix (Parnt) = Child
7050 and then not (Present (Etype (Selector_Name (Parnt)))
7052 Is_Access_Type (Etype (Selector_Name (Parnt))))
7056 -- If the parent is a dereference, either implicit or explicit,
7057 -- then the packed reference needs to be expanded.
7060 Expand_Packed_Element_Reference (N);
7064 -- Keep looking up tree for unchecked expression, or if we are the
7065 -- prefix of a possible assignment left side.
7068 Parnt := Parent (Child);
7071 end Expand_N_Indexed_Component;
7073 ---------------------
7074 -- Expand_N_Not_In --
7075 ---------------------
7077 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7078 -- can be done. This avoids needing to duplicate this expansion code.
7080 procedure Expand_N_Not_In (N : Node_Id) is
7081 Loc : constant Source_Ptr := Sloc (N);
7082 Typ : constant Entity_Id := Etype (N);
7083 Cfs : constant Boolean := Comes_From_Source (N);
7090 Left_Opnd => Left_Opnd (N),
7091 Right_Opnd => Right_Opnd (N))));
7093 -- If this is a set membership, preserve list of alternatives
7095 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
7097 -- We want this to appear as coming from source if original does (see
7098 -- transformations in Expand_N_In).
7100 Set_Comes_From_Source (N, Cfs);
7101 Set_Comes_From_Source (Right_Opnd (N), Cfs);
7103 -- Now analyze transformed node
7105 Analyze_And_Resolve (N, Typ);
7106 end Expand_N_Not_In;
7112 -- The only replacement required is for the case of a null of a type that
7113 -- is an access to protected subprogram, or a subtype thereof. We represent
7114 -- such access values as a record, and so we must replace the occurrence of
7115 -- null by the equivalent record (with a null address and a null pointer in
7116 -- it), so that the back end creates the proper value.
7118 procedure Expand_N_Null (N : Node_Id) is
7119 Loc : constant Source_Ptr := Sloc (N);
7120 Typ : constant Entity_Id := Base_Type (Etype (N));
7124 if Is_Access_Protected_Subprogram_Type (Typ) then
7126 Make_Aggregate (Loc,
7127 Expressions => New_List (
7128 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
7132 Analyze_And_Resolve (N, Equivalent_Type (Typ));
7134 -- For subsequent semantic analysis, the node must retain its type.
7135 -- Gigi in any case replaces this type by the corresponding record
7136 -- type before processing the node.
7142 when RE_Not_Available =>
7146 ---------------------
7147 -- Expand_N_Op_Abs --
7148 ---------------------
7150 procedure Expand_N_Op_Abs (N : Node_Id) is
7151 Loc : constant Source_Ptr := Sloc (N);
7152 Expr : constant Node_Id := Right_Opnd (N);
7155 Unary_Op_Validity_Checks (N);
7157 -- Check for MINIMIZED/ELIMINATED overflow mode
7159 if Minimized_Eliminated_Overflow_Check (N) then
7160 Apply_Arithmetic_Overflow_Check (N);
7164 -- Deal with software overflow checking
7166 if Is_Signed_Integer_Type (Etype (N))
7167 and then Do_Overflow_Check (N)
7169 -- The only case to worry about is when the argument is equal to the
7170 -- largest negative number, so what we do is to insert the check:
7172 -- [constraint_error when Expr = typ'Base'First]
7174 -- with the usual Duplicate_Subexpr use coding for expr
7177 Make_Raise_Constraint_Error (Loc,
7180 Left_Opnd => Duplicate_Subexpr (Expr),
7182 Make_Attribute_Reference (Loc,
7184 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
7185 Attribute_Name => Name_First)),
7186 Reason => CE_Overflow_Check_Failed));
7188 Set_Do_Overflow_Check (N, False);
7190 end Expand_N_Op_Abs;
7192 ---------------------
7193 -- Expand_N_Op_Add --
7194 ---------------------
7196 procedure Expand_N_Op_Add (N : Node_Id) is
7197 Typ : constant Entity_Id := Etype (N);
7200 Binary_Op_Validity_Checks (N);
7202 -- Check for MINIMIZED/ELIMINATED overflow mode
7204 if Minimized_Eliminated_Overflow_Check (N) then
7205 Apply_Arithmetic_Overflow_Check (N);
7209 -- N + 0 = 0 + N = N for integer types
7211 if Is_Integer_Type (Typ) then
7212 if Compile_Time_Known_Value (Right_Opnd (N))
7213 and then Expr_Value (Right_Opnd (N)) = Uint_0
7215 Rewrite (N, Left_Opnd (N));
7218 elsif Compile_Time_Known_Value (Left_Opnd (N))
7219 and then Expr_Value (Left_Opnd (N)) = Uint_0
7221 Rewrite (N, Right_Opnd (N));
7226 -- Arithmetic overflow checks for signed integer/fixed point types
7228 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
7229 Apply_Arithmetic_Overflow_Check (N);
7233 -- Overflow checks for floating-point if -gnateF mode active
7235 Check_Float_Op_Overflow (N);
7237 Expand_Nonbinary_Modular_Op (N);
7238 end Expand_N_Op_Add;
7240 ---------------------
7241 -- Expand_N_Op_And --
7242 ---------------------
7244 procedure Expand_N_Op_And (N : Node_Id) is
7245 Typ : constant Entity_Id := Etype (N);
7248 Binary_Op_Validity_Checks (N);
7250 if Is_Array_Type (Etype (N)) then
7251 Expand_Boolean_Operator (N);
7253 elsif Is_Boolean_Type (Etype (N)) then
7254 Adjust_Condition (Left_Opnd (N));
7255 Adjust_Condition (Right_Opnd (N));
7256 Set_Etype (N, Standard_Boolean);
7257 Adjust_Result_Type (N, Typ);
7259 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7260 Expand_Intrinsic_Call (N, Entity (N));
7263 Expand_Nonbinary_Modular_Op (N);
7264 end Expand_N_Op_And;
7266 ------------------------
7267 -- Expand_N_Op_Concat --
7268 ------------------------
7270 procedure Expand_N_Op_Concat (N : Node_Id) is
7272 -- List of operands to be concatenated
7275 -- Node which is to be replaced by the result of concatenating the nodes
7276 -- in the list Opnds.
7279 -- Ensure validity of both operands
7281 Binary_Op_Validity_Checks (N);
7283 -- If we are the left operand of a concatenation higher up the tree,
7284 -- then do nothing for now, since we want to deal with a series of
7285 -- concatenations as a unit.
7287 if Nkind (Parent (N)) = N_Op_Concat
7288 and then N = Left_Opnd (Parent (N))
7293 -- We get here with a concatenation whose left operand may be a
7294 -- concatenation itself with a consistent type. We need to process
7295 -- these concatenation operands from left to right, which means
7296 -- from the deepest node in the tree to the highest node.
7299 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
7300 Cnode := Left_Opnd (Cnode);
7303 -- Now Cnode is the deepest concatenation, and its parents are the
7304 -- concatenation nodes above, so now we process bottom up, doing the
7307 -- The outer loop runs more than once if more than one concatenation
7308 -- type is involved.
7311 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
7312 Set_Parent (Opnds, N);
7314 -- The inner loop gathers concatenation operands
7316 Inner : while Cnode /= N
7317 and then Base_Type (Etype (Cnode)) =
7318 Base_Type (Etype (Parent (Cnode)))
7320 Cnode := Parent (Cnode);
7321 Append (Right_Opnd (Cnode), Opnds);
7324 -- Note: The following code is a temporary workaround for N731-034
7325 -- and N829-028 and will be kept until the general issue of internal
7326 -- symbol serialization is addressed. The workaround is kept under a
7327 -- debug switch to avoid permiating into the general case.
7329 -- Wrap the node to concatenate into an expression actions node to
7330 -- keep it nicely packaged. This is useful in the case of an assert
7331 -- pragma with a concatenation where we want to be able to delete
7332 -- the concatenation and all its expansion stuff.
7334 if Debug_Flag_Dot_H then
7336 Cnod : constant Node_Id := New_Copy_Tree (Cnode);
7337 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
7340 -- Note: use Rewrite rather than Replace here, so that for
7341 -- example Why_Not_Static can find the original concatenation
7345 Make_Expression_With_Actions (Sloc (Cnode),
7346 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
7347 Expression => Cnod));
7349 Expand_Concatenate (Cnod, Opnds);
7350 Analyze_And_Resolve (Cnode, Typ);
7356 Expand_Concatenate (Cnode, Opnds);
7359 exit Outer when Cnode = N;
7360 Cnode := Parent (Cnode);
7362 end Expand_N_Op_Concat;
7364 ------------------------
7365 -- Expand_N_Op_Divide --
7366 ------------------------
7368 procedure Expand_N_Op_Divide (N : Node_Id) is
7369 Loc : constant Source_Ptr := Sloc (N);
7370 Lopnd : constant Node_Id := Left_Opnd (N);
7371 Ropnd : constant Node_Id := Right_Opnd (N);
7372 Ltyp : constant Entity_Id := Etype (Lopnd);
7373 Rtyp : constant Entity_Id := Etype (Ropnd);
7374 Typ : Entity_Id := Etype (N);
7375 Rknow : constant Boolean := Is_Integer_Type (Typ)
7377 Compile_Time_Known_Value (Ropnd);
7381 Binary_Op_Validity_Checks (N);
7383 -- Check for MINIMIZED/ELIMINATED overflow mode
7385 if Minimized_Eliminated_Overflow_Check (N) then
7386 Apply_Arithmetic_Overflow_Check (N);
7390 -- Otherwise proceed with expansion of division
7393 Rval := Expr_Value (Ropnd);
7396 -- N / 1 = N for integer types
7398 if Rknow and then Rval = Uint_1 then
7403 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7404 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7405 -- operand is an unsigned integer, as required for this to work.
7407 if Nkind (Ropnd) = N_Op_Expon
7408 and then Is_Power_Of_2_For_Shift (Ropnd)
7410 -- We cannot do this transformation in configurable run time mode if we
7411 -- have 64-bit integers and long shifts are not available.
7413 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
7416 Make_Op_Shift_Right (Loc,
7419 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
7420 Analyze_And_Resolve (N, Typ);
7424 -- Do required fixup of universal fixed operation
7426 if Typ = Universal_Fixed then
7427 Fixup_Universal_Fixed_Operation (N);
7431 -- Divisions with fixed-point results
7433 if Is_Fixed_Point_Type (Typ) then
7435 if Is_Integer_Type (Rtyp) then
7436 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
7438 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
7441 -- Deal with divide-by-zero check if back end cannot handle them
7442 -- and the flag is set indicating that we need such a check. Note
7443 -- that we don't need to bother here with the case of mixed-mode
7444 -- (Right operand an integer type), since these will be rewritten
7445 -- with conversions to a divide with a fixed-point right operand.
7447 if Nkind (N) = N_Op_Divide
7448 and then Do_Division_Check (N)
7449 and then not Backend_Divide_Checks_On_Target
7450 and then not Is_Integer_Type (Rtyp)
7452 Set_Do_Division_Check (N, False);
7454 Make_Raise_Constraint_Error (Loc,
7457 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
7458 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
7459 Reason => CE_Divide_By_Zero));
7462 -- Other cases of division of fixed-point operands
7464 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
7465 if Is_Integer_Type (Typ) then
7466 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
7468 pragma Assert (Is_Floating_Point_Type (Typ));
7469 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
7472 -- Mixed-mode operations can appear in a non-static universal context,
7473 -- in which case the integer argument must be converted explicitly.
7475 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
7477 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
7479 Analyze_And_Resolve (Ropnd, Universal_Real);
7481 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
7483 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
7485 Analyze_And_Resolve (Lopnd, Universal_Real);
7487 -- Non-fixed point cases, do integer zero divide and overflow checks
7489 elsif Is_Integer_Type (Typ) then
7490 Apply_Divide_Checks (N);
7493 -- Overflow checks for floating-point if -gnateF mode active
7495 Check_Float_Op_Overflow (N);
7497 Expand_Nonbinary_Modular_Op (N);
7498 end Expand_N_Op_Divide;
7500 --------------------
7501 -- Expand_N_Op_Eq --
7502 --------------------
7504 procedure Expand_N_Op_Eq (N : Node_Id) is
7505 Loc : constant Source_Ptr := Sloc (N);
7506 Typ : constant Entity_Id := Etype (N);
7507 Lhs : constant Node_Id := Left_Opnd (N);
7508 Rhs : constant Node_Id := Right_Opnd (N);
7509 Bodies : constant List_Id := New_List;
7510 A_Typ : constant Entity_Id := Etype (Lhs);
7512 procedure Build_Equality_Call (Eq : Entity_Id);
7513 -- If a constructed equality exists for the type or for its parent,
7514 -- build and analyze call, adding conversions if the operation is
7517 function Is_Equality (Subp : Entity_Id;
7518 Typ : Entity_Id := Empty) return Boolean;
7519 -- Determine whether arbitrary Entity_Id denotes a function with the
7520 -- right name and profile for an equality op, specifically for the
7521 -- base type Typ if Typ is nonempty.
7523 function Find_Equality (Prims : Elist_Id) return Entity_Id;
7524 -- Find a primitive equality function within primitive operation list
7527 function User_Defined_Primitive_Equality_Op
7528 (Typ : Entity_Id) return Entity_Id;
7529 -- Find a user-defined primitive equality function for a given untagged
7530 -- record type, ignoring visibility. Return Empty if no such op found.
7532 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
7533 -- Determines whether a type has a subcomponent of an unconstrained
7534 -- Unchecked_Union subtype. Typ is a record type.
7536 -------------------------
7537 -- Build_Equality_Call --
7538 -------------------------
7540 procedure Build_Equality_Call (Eq : Entity_Id) is
7541 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
7542 L_Exp : Node_Id := Relocate_Node (Lhs);
7543 R_Exp : Node_Id := Relocate_Node (Rhs);
7546 -- Adjust operands if necessary to comparison type
7548 if Base_Type (Op_Type) /= Base_Type (A_Typ)
7549 and then not Is_Class_Wide_Type (A_Typ)
7551 L_Exp := OK_Convert_To (Op_Type, L_Exp);
7552 R_Exp := OK_Convert_To (Op_Type, R_Exp);
7555 -- If we have an Unchecked_Union, we need to add the inferred
7556 -- discriminant values as actuals in the function call. At this
7557 -- point, the expansion has determined that both operands have
7558 -- inferable discriminants.
7560 if Is_Unchecked_Union (Op_Type) then
7562 Lhs_Type : constant Node_Id := Etype (L_Exp);
7563 Rhs_Type : constant Node_Id := Etype (R_Exp);
7565 Lhs_Discr_Vals : Elist_Id;
7566 -- List of inferred discriminant values for left operand.
7568 Rhs_Discr_Vals : Elist_Id;
7569 -- List of inferred discriminant values for right operand.
7574 Lhs_Discr_Vals := New_Elmt_List;
7575 Rhs_Discr_Vals := New_Elmt_List;
7577 -- Per-object constrained selected components require special
7578 -- attention. If the enclosing scope of the component is an
7579 -- Unchecked_Union, we cannot reference its discriminants
7580 -- directly. This is why we use the extra parameters of the
7581 -- equality function of the enclosing Unchecked_Union.
7583 -- type UU_Type (Discr : Integer := 0) is
7586 -- pragma Unchecked_Union (UU_Type);
7588 -- 1. Unchecked_Union enclosing record:
7590 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7592 -- Comp : UU_Type (Discr);
7594 -- end Enclosing_UU_Type;
7595 -- pragma Unchecked_Union (Enclosing_UU_Type);
7597 -- Obj1 : Enclosing_UU_Type;
7598 -- Obj2 : Enclosing_UU_Type (1);
7600 -- [. . .] Obj1 = Obj2 [. . .]
7604 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7606 -- A and B are the formal parameters of the equality function
7607 -- of Enclosing_UU_Type. The function always has two extra
7608 -- formals to capture the inferred discriminant values for
7609 -- each discriminant of the type.
7611 -- 2. Non-Unchecked_Union enclosing record:
7614 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7617 -- Comp : UU_Type (Discr);
7619 -- end Enclosing_Non_UU_Type;
7621 -- Obj1 : Enclosing_Non_UU_Type;
7622 -- Obj2 : Enclosing_Non_UU_Type (1);
7624 -- ... Obj1 = Obj2 ...
7628 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7629 -- obj1.discr, obj2.discr)) then
7631 -- In this case we can directly reference the discriminants of
7632 -- the enclosing record.
7634 -- Process left operand of equality
7636 if Nkind (Lhs) = N_Selected_Component
7638 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
7640 -- If enclosing record is an Unchecked_Union, use formals
7641 -- corresponding to each discriminant. The name of the
7642 -- formal is that of the discriminant, with added suffix,
7643 -- see Exp_Ch3.Build_Record_Equality for details.
7645 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
7649 (Scope (Entity (Selector_Name (Lhs))));
7650 while Present (Discr) loop
7652 (Make_Identifier (Loc,
7653 Chars => New_External_Name (Chars (Discr), 'A')),
7654 To => Lhs_Discr_Vals);
7655 Next_Discriminant (Discr);
7658 -- If enclosing record is of a non-Unchecked_Union type, it
7659 -- is possible to reference its discriminants directly.
7662 Discr := First_Discriminant (Lhs_Type);
7663 while Present (Discr) loop
7665 (Make_Selected_Component (Loc,
7666 Prefix => Prefix (Lhs),
7669 (Get_Discriminant_Value (Discr,
7671 Stored_Constraint (Lhs_Type)))),
7672 To => Lhs_Discr_Vals);
7673 Next_Discriminant (Discr);
7677 -- Otherwise operand is on object with a constrained type.
7678 -- Infer the discriminant values from the constraint.
7681 Discr := First_Discriminant (Lhs_Type);
7682 while Present (Discr) loop
7685 (Get_Discriminant_Value (Discr,
7687 Stored_Constraint (Lhs_Type))),
7688 To => Lhs_Discr_Vals);
7689 Next_Discriminant (Discr);
7693 -- Similar processing for right operand of equality
7695 if Nkind (Rhs) = N_Selected_Component
7697 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7699 if Is_Unchecked_Union
7700 (Scope (Entity (Selector_Name (Rhs))))
7704 (Scope (Entity (Selector_Name (Rhs))));
7705 while Present (Discr) loop
7707 (Make_Identifier (Loc,
7708 Chars => New_External_Name (Chars (Discr), 'B')),
7709 To => Rhs_Discr_Vals);
7710 Next_Discriminant (Discr);
7714 Discr := First_Discriminant (Rhs_Type);
7715 while Present (Discr) loop
7717 (Make_Selected_Component (Loc,
7718 Prefix => Prefix (Rhs),
7720 New_Copy (Get_Discriminant_Value
7723 Stored_Constraint (Rhs_Type)))),
7724 To => Rhs_Discr_Vals);
7725 Next_Discriminant (Discr);
7730 Discr := First_Discriminant (Rhs_Type);
7731 while Present (Discr) loop
7733 (New_Copy (Get_Discriminant_Value
7736 Stored_Constraint (Rhs_Type))),
7737 To => Rhs_Discr_Vals);
7738 Next_Discriminant (Discr);
7742 -- Now merge the list of discriminant values so that values
7743 -- of corresponding discriminants are adjacent.
7751 Params := New_List (L_Exp, R_Exp);
7752 L_Elmt := First_Elmt (Lhs_Discr_Vals);
7753 R_Elmt := First_Elmt (Rhs_Discr_Vals);
7754 while Present (L_Elmt) loop
7755 Append_To (Params, Node (L_Elmt));
7756 Append_To (Params, Node (R_Elmt));
7762 Make_Function_Call (Loc,
7763 Name => New_Occurrence_Of (Eq, Loc),
7764 Parameter_Associations => Params));
7768 -- Normal case, not an unchecked union
7772 Make_Function_Call (Loc,
7773 Name => New_Occurrence_Of (Eq, Loc),
7774 Parameter_Associations => New_List (L_Exp, R_Exp)));
7777 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7778 end Build_Equality_Call;
7784 function Is_Equality (Subp : Entity_Id;
7785 Typ : Entity_Id := Empty) return Boolean is
7786 Formal_1 : Entity_Id;
7787 Formal_2 : Entity_Id;
7789 -- The equality function carries name "=", returns Boolean, and has
7790 -- exactly two formal parameters of an identical type.
7792 if Ekind (Subp) = E_Function
7793 and then Chars (Subp) = Name_Op_Eq
7794 and then Base_Type (Etype (Subp)) = Standard_Boolean
7796 Formal_1 := First_Formal (Subp);
7799 if Present (Formal_1) then
7800 Formal_2 := Next_Formal (Formal_1);
7805 and then Present (Formal_2)
7806 and then No (Next_Formal (Formal_2))
7807 and then Base_Type (Etype (Formal_1)) =
7808 Base_Type (Etype (Formal_2))
7811 or else Implementation_Base_Type (Etype (Formal_1)) = Typ);
7821 function Find_Equality (Prims : Elist_Id) return Entity_Id is
7822 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id;
7823 -- Find an equality in a possible alias chain starting from primitive
7826 ---------------------------
7827 -- Find_Aliased_Equality --
7828 ---------------------------
7830 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is
7834 -- Inspect each candidate in the alias chain, checking whether it
7835 -- denotes an equality.
7838 while Present (Candid) loop
7839 if Is_Equality (Candid) then
7843 Candid := Alias (Candid);
7847 end Find_Aliased_Equality;
7851 Eq_Prim : Entity_Id;
7852 Prim_Elmt : Elmt_Id;
7854 -- Start of processing for Find_Equality
7857 -- Assume that the tagged type lacks an equality
7861 -- Inspect the list of primitives looking for a suitable equality
7862 -- within a possible chain of aliases.
7864 Prim_Elmt := First_Elmt (Prims);
7865 while Present (Prim_Elmt) and then No (Eq_Prim) loop
7866 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt));
7868 Next_Elmt (Prim_Elmt);
7871 -- A tagged type should always have an equality
7873 pragma Assert (Present (Eq_Prim));
7878 ----------------------------------------
7879 -- User_Defined_Primitive_Equality_Op --
7880 ----------------------------------------
7882 function User_Defined_Primitive_Equality_Op
7883 (Typ : Entity_Id) return Entity_Id
7885 Enclosing_Scope : constant Node_Id := Scope (Typ);
7888 -- Prune this search by somehow not looking at decls that precede
7889 -- the declaration of the first view of Typ (which might be a partial
7892 for Private_Entities in Boolean loop
7893 if Private_Entities then
7894 if Ekind (Enclosing_Scope) /= E_Package then
7897 E := First_Private_Entity (Enclosing_Scope);
7900 E := First_Entity (Enclosing_Scope);
7903 while Present (E) loop
7904 if Is_Equality (E, Typ) then
7911 if Is_Derived_Type (Typ) then
7912 return User_Defined_Primitive_Equality_Op
7913 (Implementation_Base_Type (Etype (Typ)));
7917 end User_Defined_Primitive_Equality_Op;
7919 ------------------------------------
7920 -- Has_Unconstrained_UU_Component --
7921 ------------------------------------
7923 function Has_Unconstrained_UU_Component
7924 (Typ : Entity_Id) return Boolean
7926 Tdef : constant Node_Id :=
7927 Type_Definition (Declaration_Node (Base_Type (Typ)));
7931 function Component_Is_Unconstrained_UU
7932 (Comp : Node_Id) return Boolean;
7933 -- Determines whether the subtype of the component is an
7934 -- unconstrained Unchecked_Union.
7936 function Variant_Is_Unconstrained_UU
7937 (Variant : Node_Id) return Boolean;
7938 -- Determines whether a component of the variant has an unconstrained
7939 -- Unchecked_Union subtype.
7941 -----------------------------------
7942 -- Component_Is_Unconstrained_UU --
7943 -----------------------------------
7945 function Component_Is_Unconstrained_UU
7946 (Comp : Node_Id) return Boolean
7949 if Nkind (Comp) /= N_Component_Declaration then
7954 Sindic : constant Node_Id :=
7955 Subtype_Indication (Component_Definition (Comp));
7958 -- Unconstrained nominal type. In the case of a constraint
7959 -- present, the node kind would have been N_Subtype_Indication.
7961 if Nkind (Sindic) = N_Identifier then
7962 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7967 end Component_Is_Unconstrained_UU;
7969 ---------------------------------
7970 -- Variant_Is_Unconstrained_UU --
7971 ---------------------------------
7973 function Variant_Is_Unconstrained_UU
7974 (Variant : Node_Id) return Boolean
7976 Clist : constant Node_Id := Component_List (Variant);
7979 if Is_Empty_List (Component_Items (Clist)) then
7983 -- We only need to test one component
7986 Comp : Node_Id := First (Component_Items (Clist));
7989 while Present (Comp) loop
7990 if Component_Is_Unconstrained_UU (Comp) then
7998 -- None of the components withing the variant were of
7999 -- unconstrained Unchecked_Union type.
8002 end Variant_Is_Unconstrained_UU;
8004 -- Start of processing for Has_Unconstrained_UU_Component
8007 if Null_Present (Tdef) then
8011 Clist := Component_List (Tdef);
8012 Vpart := Variant_Part (Clist);
8014 -- Inspect available components
8016 if Present (Component_Items (Clist)) then
8018 Comp : Node_Id := First (Component_Items (Clist));
8021 while Present (Comp) loop
8023 -- One component is sufficient
8025 if Component_Is_Unconstrained_UU (Comp) then
8034 -- Inspect available components withing variants
8036 if Present (Vpart) then
8038 Variant : Node_Id := First (Variants (Vpart));
8041 while Present (Variant) loop
8043 -- One component within a variant is sufficient
8045 if Variant_Is_Unconstrained_UU (Variant) then
8054 -- Neither the available components, nor the components inside the
8055 -- variant parts were of an unconstrained Unchecked_Union subtype.
8058 end Has_Unconstrained_UU_Component;
8064 -- Start of processing for Expand_N_Op_Eq
8067 Binary_Op_Validity_Checks (N);
8069 -- Deal with private types
8073 if Ekind (Typl) = E_Private_Type then
8074 Typl := Underlying_Type (Typl);
8076 elsif Ekind (Typl) = E_Private_Subtype then
8077 Typl := Underlying_Type (Base_Type (Typl));
8080 -- It may happen in error situations that the underlying type is not
8081 -- set. The error will be detected later, here we just defend the
8088 -- Now get the implementation base type (note that plain Base_Type here
8089 -- might lead us back to the private type, which is not what we want!)
8091 Typl := Implementation_Base_Type (Typl);
8093 -- Equality between variant records results in a call to a routine
8094 -- that has conditional tests of the discriminant value(s), and hence
8095 -- violates the No_Implicit_Conditionals restriction.
8097 if Has_Variant_Part (Typl) then
8102 Check_Restriction (Msg, No_Implicit_Conditionals, N);
8106 ("\comparison of variant records tests discriminants", N);
8112 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8113 -- means we no longer have a comparison operation, we are all done.
8115 Expand_Compare_Minimize_Eliminate_Overflow (N);
8117 if Nkind (N) /= N_Op_Eq then
8121 -- Boolean types (requiring handling of non-standard case)
8123 if Is_Boolean_Type (Typl) then
8124 Adjust_Condition (Left_Opnd (N));
8125 Adjust_Condition (Right_Opnd (N));
8126 Set_Etype (N, Standard_Boolean);
8127 Adjust_Result_Type (N, Typ);
8131 elsif Is_Array_Type (Typl) then
8133 -- If we are doing full validity checking, and it is possible for the
8134 -- array elements to be invalid then expand out array comparisons to
8135 -- make sure that we check the array elements.
8137 if Validity_Check_Operands
8138 and then not Is_Known_Valid (Component_Type (Typl))
8141 Save_Force_Validity_Checks : constant Boolean :=
8142 Force_Validity_Checks;
8144 Force_Validity_Checks := True;
8146 Expand_Array_Equality
8148 Relocate_Node (Lhs),
8149 Relocate_Node (Rhs),
8152 Insert_Actions (N, Bodies);
8153 Analyze_And_Resolve (N, Standard_Boolean);
8154 Force_Validity_Checks := Save_Force_Validity_Checks;
8157 -- Packed case where both operands are known aligned
8159 elsif Is_Bit_Packed_Array (Typl)
8160 and then not Is_Possibly_Unaligned_Object (Lhs)
8161 and then not Is_Possibly_Unaligned_Object (Rhs)
8163 Expand_Packed_Eq (N);
8165 -- Where the component type is elementary we can use a block bit
8166 -- comparison (if supported on the target) exception in the case
8167 -- of floating-point (negative zero issues require element by
8168 -- element comparison), and atomic/VFA types (where we must be sure
8169 -- to load elements independently) and possibly unaligned arrays.
8171 elsif Is_Elementary_Type (Component_Type (Typl))
8172 and then not Is_Floating_Point_Type (Component_Type (Typl))
8173 and then not Is_Atomic_Or_VFA (Component_Type (Typl))
8174 and then not Is_Possibly_Unaligned_Object (Lhs)
8175 and then not Is_Possibly_Unaligned_Slice (Lhs)
8176 and then not Is_Possibly_Unaligned_Object (Rhs)
8177 and then not Is_Possibly_Unaligned_Slice (Rhs)
8178 and then Support_Composite_Compare_On_Target
8182 -- For composite and floating-point cases, expand equality loop to
8183 -- make sure of using proper comparisons for tagged types, and
8184 -- correctly handling the floating-point case.
8188 Expand_Array_Equality
8190 Relocate_Node (Lhs),
8191 Relocate_Node (Rhs),
8194 Insert_Actions (N, Bodies, Suppress => All_Checks);
8195 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8200 elsif Is_Record_Type (Typl) then
8202 -- For tagged types, use the primitive "="
8204 if Is_Tagged_Type (Typl) then
8206 -- No need to do anything else compiling under restriction
8207 -- No_Dispatching_Calls. During the semantic analysis we
8208 -- already notified such violation.
8210 if Restriction_Active (No_Dispatching_Calls) then
8214 -- If this is an untagged private type completed with a derivation
8215 -- of an untagged private type whose full view is a tagged type,
8216 -- we use the primitive operations of the private type (since it
8217 -- does not have a full view, and also because its equality
8218 -- primitive may have been overridden in its untagged full view).
8220 if Inherits_From_Tagged_Full_View (A_Typ) then
8222 (Find_Equality (Collect_Primitive_Operations (A_Typ)));
8224 -- Find the type's predefined equality or an overriding
8225 -- user-defined equality. The reason for not simply calling
8226 -- Find_Prim_Op here is that there may be a user-defined
8227 -- overloaded equality op that precedes the equality that we
8228 -- want, so we have to explicitly search (e.g., there could be
8229 -- an equality with two different parameter types).
8232 if Is_Class_Wide_Type (Typl) then
8233 Typl := Find_Specific_Type (Typl);
8237 (Find_Equality (Primitive_Operations (Typl)));
8240 -- See AI12-0101 (which only removes a legality rule) and then
8241 -- AI05-0123 (which then applies in the previously illegal case).
8242 -- AI12-0101 is a binding interpretation.
8244 elsif Ada_Version >= Ada_2012
8245 and then Present (User_Defined_Primitive_Equality_Op (Typl))
8247 Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl));
8249 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8250 -- predefined equality operator for a type which has a subcomponent
8251 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8253 elsif Has_Unconstrained_UU_Component (Typl) then
8255 Make_Raise_Program_Error (Loc,
8256 Reason => PE_Unchecked_Union_Restriction));
8258 -- Prevent Gigi from generating incorrect code by rewriting the
8259 -- equality as a standard False. (is this documented somewhere???)
8262 New_Occurrence_Of (Standard_False, Loc));
8264 elsif Is_Unchecked_Union (Typl) then
8266 -- If we can infer the discriminants of the operands, we make a
8267 -- call to the TSS equality function.
8269 if Has_Inferable_Discriminants (Lhs)
8271 Has_Inferable_Discriminants (Rhs)
8274 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8277 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8278 -- the predefined equality operator for an Unchecked_Union type
8279 -- if either of the operands lack inferable discriminants.
8282 Make_Raise_Program_Error (Loc,
8283 Reason => PE_Unchecked_Union_Restriction));
8285 -- Emit a warning on source equalities only, otherwise the
8286 -- message may appear out of place due to internal use. The
8287 -- warning is unconditional because it is required by the
8290 if Comes_From_Source (N) then
8292 ("Unchecked_Union discriminants cannot be determined??",
8295 ("\Program_Error will be raised for equality operation??",
8299 -- Prevent Gigi from generating incorrect code by rewriting
8300 -- the equality as a standard False (documented where???).
8303 New_Occurrence_Of (Standard_False, Loc));
8306 -- If a type support function is present (for complex cases), use it
8308 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
8310 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8312 -- When comparing two Bounded_Strings, use the primitive equality of
8313 -- the root Super_String type.
8315 elsif Is_Bounded_String (Typl) then
8318 (Collect_Primitive_Operations (Root_Type (Typl))));
8320 -- Otherwise expand the component by component equality. Note that
8321 -- we never use block-bit comparisons for records, because of the
8322 -- problems with gaps. The back end will often be able to recombine
8323 -- the separate comparisons that we generate here.
8326 Remove_Side_Effects (Lhs);
8327 Remove_Side_Effects (Rhs);
8329 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
8331 Insert_Actions (N, Bodies, Suppress => All_Checks);
8332 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8335 -- If unnesting, handle elementary types whose Equivalent_Types are
8336 -- records because there may be padding or undefined fields.
8338 elsif Unnest_Subprogram_Mode
8339 and then Ekind_In (Typl, E_Class_Wide_Type,
8340 E_Class_Wide_Subtype,
8341 E_Access_Subprogram_Type,
8342 E_Access_Protected_Subprogram_Type,
8343 E_Anonymous_Access_Protected_Subprogram_Type,
8344 E_Access_Subprogram_Type,
8346 and then Present (Equivalent_Type (Typl))
8347 and then Is_Record_Type (Equivalent_Type (Typl))
8349 Typl := Equivalent_Type (Typl);
8350 Remove_Side_Effects (Lhs);
8351 Remove_Side_Effects (Rhs);
8353 Expand_Record_Equality (N, Typl,
8354 Unchecked_Convert_To (Typl, Lhs),
8355 Unchecked_Convert_To (Typl, Rhs),
8358 Insert_Actions (N, Bodies, Suppress => All_Checks);
8359 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8362 -- Test if result is known at compile time
8364 Rewrite_Comparison (N);
8366 -- Special optimization of length comparison
8368 Optimize_Length_Comparison (N);
8370 -- One more special case: if we have a comparison of X'Result = expr
8371 -- in floating-point, then if not already there, change expr to be
8372 -- f'Machine (expr) to eliminate surprise from extra precision.
8374 if Is_Floating_Point_Type (Typl)
8375 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
8376 and then Attribute_Name (Original_Node (Lhs)) = Name_Result
8378 -- Stick in the Typ'Machine call if not already there
8380 if Nkind (Rhs) /= N_Attribute_Reference
8381 or else Attribute_Name (Rhs) /= Name_Machine
8384 Make_Attribute_Reference (Loc,
8385 Prefix => New_Occurrence_Of (Typl, Loc),
8386 Attribute_Name => Name_Machine,
8387 Expressions => New_List (Relocate_Node (Rhs))));
8388 Analyze_And_Resolve (Rhs, Typl);
8393 -----------------------
8394 -- Expand_N_Op_Expon --
8395 -----------------------
8397 procedure Expand_N_Op_Expon (N : Node_Id) is
8398 Loc : constant Source_Ptr := Sloc (N);
8399 Ovflo : constant Boolean := Do_Overflow_Check (N);
8400 Typ : constant Entity_Id := Etype (N);
8401 Rtyp : constant Entity_Id := Root_Type (Typ);
8405 function Wrap_MA (Exp : Node_Id) return Node_Id;
8406 -- Given an expression Exp, if the root type is Float or Long_Float,
8407 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8408 -- extra precision. This is done to ensure that X**A = X**B when A is
8409 -- a static constant and B is a variable with the same value. For any
8410 -- other type, the node Exp is returned unchanged.
8416 function Wrap_MA (Exp : Node_Id) return Node_Id is
8417 Loc : constant Source_Ptr := Sloc (Exp);
8420 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
8422 Make_Attribute_Reference (Loc,
8423 Attribute_Name => Name_Machine,
8424 Prefix => New_Occurrence_Of (Bastyp, Loc),
8425 Expressions => New_List (Relocate_Node (Exp)));
8443 -- Start of processing for Expand_N_Op_Expon
8446 Binary_Op_Validity_Checks (N);
8448 -- CodePeer wants to see the unexpanded N_Op_Expon node
8450 if CodePeer_Mode then
8454 -- Relocation of left and right operands must be done after performing
8455 -- the validity checks since the generation of validation checks may
8456 -- remove side effects.
8458 Base := Relocate_Node (Left_Opnd (N));
8459 Bastyp := Etype (Base);
8460 Exp := Relocate_Node (Right_Opnd (N));
8461 Exptyp := Etype (Exp);
8463 -- If either operand is of a private type, then we have the use of an
8464 -- intrinsic operator, and we get rid of the privateness, by using root
8465 -- types of underlying types for the actual operation. Otherwise the
8466 -- private types will cause trouble if we expand multiplications or
8467 -- shifts etc. We also do this transformation if the result type is
8468 -- different from the base type.
8470 if Is_Private_Type (Etype (Base))
8471 or else Is_Private_Type (Typ)
8472 or else Is_Private_Type (Exptyp)
8473 or else Rtyp /= Root_Type (Bastyp)
8476 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
8477 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
8480 Unchecked_Convert_To (Typ,
8482 Left_Opnd => Unchecked_Convert_To (Bt, Base),
8483 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
8484 Analyze_And_Resolve (N, Typ);
8489 -- Check for MINIMIZED/ELIMINATED overflow mode
8491 if Minimized_Eliminated_Overflow_Check (N) then
8492 Apply_Arithmetic_Overflow_Check (N);
8496 -- Test for case of known right argument where we can replace the
8497 -- exponentiation by an equivalent expression using multiplication.
8499 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8500 -- configurable run-time mode, we may not have the exponentiation
8501 -- routine available, and we don't want the legality of the program
8502 -- to depend on how clever the compiler is in knowing values.
8504 if CRT_Safe_Compile_Time_Known_Value (Exp) then
8505 Expv := Expr_Value (Exp);
8507 -- We only fold small non-negative exponents. You might think we
8508 -- could fold small negative exponents for the real case, but we
8509 -- can't because we are required to raise Constraint_Error for
8510 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8511 -- See ACVC test C4A012B, and it is not worth generating the test.
8513 -- For small negative exponents, we return the reciprocal of
8514 -- the folding of the exponentiation for the opposite (positive)
8515 -- exponent, as required by Ada RM 4.5.6(11/3).
8517 if abs Expv <= 4 then
8519 -- X ** 0 = 1 (or 1.0)
8523 -- Call Remove_Side_Effects to ensure that any side effects
8524 -- in the ignored left operand (in particular function calls
8525 -- to user defined functions) are properly executed.
8527 Remove_Side_Effects (Base);
8529 if Ekind (Typ) in Integer_Kind then
8530 Xnode := Make_Integer_Literal (Loc, Intval => 1);
8532 Xnode := Make_Real_Literal (Loc, Ureal_1);
8545 Make_Op_Multiply (Loc,
8546 Left_Opnd => Duplicate_Subexpr (Base),
8547 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8549 -- X ** 3 = X * X * X
8554 Make_Op_Multiply (Loc,
8556 Make_Op_Multiply (Loc,
8557 Left_Opnd => Duplicate_Subexpr (Base),
8558 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
8559 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8564 -- En : constant base'type := base * base;
8569 Temp := Make_Temporary (Loc, 'E', Base);
8572 Make_Expression_With_Actions (Loc,
8573 Actions => New_List (
8574 Make_Object_Declaration (Loc,
8575 Defining_Identifier => Temp,
8576 Constant_Present => True,
8577 Object_Definition => New_Occurrence_Of (Typ, Loc),
8580 Make_Op_Multiply (Loc,
8582 Duplicate_Subexpr (Base),
8584 Duplicate_Subexpr_No_Checks (Base))))),
8588 Make_Op_Multiply (Loc,
8589 Left_Opnd => New_Occurrence_Of (Temp, Loc),
8590 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
8592 -- X ** N = 1.0 / X ** (-N)
8597 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4);
8600 Make_Op_Divide (Loc,
8602 Make_Float_Literal (Loc,
8604 Significand => Uint_1,
8605 Exponent => Uint_0),
8608 Left_Opnd => Duplicate_Subexpr (Base),
8610 Make_Integer_Literal (Loc,
8615 Analyze_And_Resolve (N, Typ);
8620 -- Deal with optimizing 2 ** expression to shift where possible
8622 -- Note: we used to check that Exptyp was an unsigned type. But that is
8623 -- an unnecessary check, since if Exp is negative, we have a run-time
8624 -- error that is either caught (so we get the right result) or we have
8625 -- suppressed the check, in which case the code is erroneous anyway.
8627 if Is_Integer_Type (Rtyp)
8629 -- The base value must be "safe compile-time known", and exactly 2
8631 and then Nkind (Base) = N_Integer_Literal
8632 and then CRT_Safe_Compile_Time_Known_Value (Base)
8633 and then Expr_Value (Base) = Uint_2
8635 -- We only handle cases where the right type is a integer
8637 and then Is_Integer_Type (Root_Type (Exptyp))
8638 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
8640 -- This transformation is not applicable for a modular type with a
8641 -- nonbinary modulus because we do not handle modular reduction in
8642 -- a correct manner if we attempt this transformation in this case.
8644 and then not Non_Binary_Modulus (Typ)
8646 -- Handle the cases where our parent is a division or multiplication
8647 -- specially. In these cases we can convert to using a shift at the
8648 -- parent level if we are not doing overflow checking, since it is
8649 -- too tricky to combine the overflow check at the parent level.
8652 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply)
8655 P : constant Node_Id := Parent (N);
8656 L : constant Node_Id := Left_Opnd (P);
8657 R : constant Node_Id := Right_Opnd (P);
8660 if (Nkind (P) = N_Op_Multiply
8662 ((Is_Integer_Type (Etype (L)) and then R = N)
8664 (Is_Integer_Type (Etype (R)) and then L = N))
8665 and then not Do_Overflow_Check (P))
8668 (Nkind (P) = N_Op_Divide
8669 and then Is_Integer_Type (Etype (L))
8670 and then Is_Unsigned_Type (Etype (L))
8672 and then not Do_Overflow_Check (P))
8674 Set_Is_Power_Of_2_For_Shift (N);
8679 -- Here we just have 2 ** N on its own, so we can convert this to a
8680 -- shift node. We are prepared to deal with overflow here, and we
8681 -- also have to handle proper modular reduction for binary modular.
8690 -- Maximum shift count with no overflow
8693 -- Set True if we must test the shift count
8696 -- Node for test against TestS
8699 -- Compute maximum shift based on the underlying size. For a
8700 -- modular type this is one less than the size.
8702 if Is_Modular_Integer_Type (Typ) then
8704 -- For modular integer types, this is the size of the value
8705 -- being shifted minus one. Any larger values will cause
8706 -- modular reduction to a result of zero. Note that we do
8707 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8708 -- of 6, since 2**7 should be reduced to zero).
8710 MaxS := RM_Size (Rtyp) - 1;
8712 -- For signed integer types, we use the size of the value
8713 -- being shifted minus 2. Larger values cause overflow.
8716 MaxS := Esize (Rtyp) - 2;
8719 -- Determine range to see if it can be larger than MaxS
8722 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
8723 TestS := (not OK) or else Hi > MaxS;
8725 -- Signed integer case
8727 if Is_Signed_Integer_Type (Typ) then
8729 -- Generate overflow check if overflow is active. Note that
8730 -- we can simply ignore the possibility of overflow if the
8731 -- flag is not set (means that overflow cannot happen or
8732 -- that overflow checks are suppressed).
8734 if Ovflo and TestS then
8736 Make_Raise_Constraint_Error (Loc,
8739 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
8740 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
8741 Reason => CE_Overflow_Check_Failed));
8744 -- Now rewrite node as Shift_Left (1, right-operand)
8747 Make_Op_Shift_Left (Loc,
8748 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8749 Right_Opnd => Right_Opnd (N)));
8751 -- Modular integer case
8753 else pragma Assert (Is_Modular_Integer_Type (Typ));
8755 -- If shift count can be greater than MaxS, we need to wrap
8756 -- the shift in a test that will reduce the result value to
8757 -- zero if this shift count is exceeded.
8761 -- Note: build node for the comparison first, before we
8762 -- reuse the Right_Opnd, so that we have proper parents
8763 -- in place for the Duplicate_Subexpr call.
8767 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
8768 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
8771 Make_If_Expression (Loc,
8772 Expressions => New_List (
8774 Make_Integer_Literal (Loc, Uint_0),
8775 Make_Op_Shift_Left (Loc,
8776 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8777 Right_Opnd => Right_Opnd (N)))));
8779 -- If we know shift count cannot be greater than MaxS, then
8780 -- it is safe to just rewrite as a shift with no test.
8784 Make_Op_Shift_Left (Loc,
8785 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8786 Right_Opnd => Right_Opnd (N)));
8790 Analyze_And_Resolve (N, Typ);
8796 -- Fall through if exponentiation must be done using a runtime routine
8798 -- First deal with modular case
8800 if Is_Modular_Integer_Type (Rtyp) then
8802 -- Nonbinary modular case, we call the special exponentiation
8803 -- routine for the nonbinary case, converting the argument to
8804 -- Long_Long_Integer and passing the modulus value. Then the
8805 -- result is converted back to the base type.
8807 if Non_Binary_Modulus (Rtyp) then
8810 Make_Function_Call (Loc,
8812 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
8813 Parameter_Associations => New_List (
8814 Convert_To (RTE (RE_Unsigned), Base),
8815 Make_Integer_Literal (Loc, Modulus (Rtyp)),
8818 -- Binary modular case, in this case, we call one of two routines,
8819 -- either the unsigned integer case, or the unsigned long long
8820 -- integer case, with a final "and" operation to do the required mod.
8823 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
8824 Ent := RTE (RE_Exp_Unsigned);
8826 Ent := RTE (RE_Exp_Long_Long_Unsigned);
8833 Make_Function_Call (Loc,
8834 Name => New_Occurrence_Of (Ent, Loc),
8835 Parameter_Associations => New_List (
8836 Convert_To (Etype (First_Formal (Ent)), Base),
8839 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
8843 -- Common exit point for modular type case
8845 Analyze_And_Resolve (N, Typ);
8848 -- Signed integer cases, done using either Integer or Long_Long_Integer.
8849 -- It is not worth having routines for Short_[Short_]Integer, since for
8850 -- most machines it would not help, and it would generate more code that
8851 -- might need certification when a certified run time is required.
8853 -- In the integer cases, we have two routines, one for when overflow
8854 -- checks are required, and one when they are not required, since there
8855 -- is a real gain in omitting checks on many machines.
8857 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
8858 or else (Rtyp = Base_Type (Standard_Long_Integer)
8860 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
8861 or else Rtyp = Universal_Integer
8863 Etyp := Standard_Long_Long_Integer;
8866 Rent := RE_Exp_Long_Long_Integer;
8868 Rent := RE_Exn_Long_Long_Integer;
8871 elsif Is_Signed_Integer_Type (Rtyp) then
8872 Etyp := Standard_Integer;
8875 Rent := RE_Exp_Integer;
8877 Rent := RE_Exn_Integer;
8880 -- Floating-point cases. We do not need separate routines for the
8881 -- overflow case here, since in the case of floating-point, we generate
8882 -- infinities anyway as a rule (either that or we automatically trap
8883 -- overflow), and if there is an infinity generated and a range check
8884 -- is required, the check will fail anyway.
8886 -- Historical note: we used to convert everything to Long_Long_Float
8887 -- and call a single common routine, but this had the undesirable effect
8888 -- of giving different results for small static exponent values and the
8889 -- same dynamic values.
8892 pragma Assert (Is_Floating_Point_Type (Rtyp));
8894 if Rtyp = Standard_Float then
8895 Etyp := Standard_Float;
8896 Rent := RE_Exn_Float;
8898 elsif Rtyp = Standard_Long_Float then
8899 Etyp := Standard_Long_Float;
8900 Rent := RE_Exn_Long_Float;
8903 Etyp := Standard_Long_Long_Float;
8904 Rent := RE_Exn_Long_Long_Float;
8908 -- Common processing for integer cases and floating-point cases.
8909 -- If we are in the right type, we can call runtime routine directly
8912 and then Rtyp /= Universal_Integer
8913 and then Rtyp /= Universal_Real
8917 Make_Function_Call (Loc,
8918 Name => New_Occurrence_Of (RTE (Rent), Loc),
8919 Parameter_Associations => New_List (Base, Exp))));
8921 -- Otherwise we have to introduce conversions (conversions are also
8922 -- required in the universal cases, since the runtime routine is
8923 -- typed using one of the standard types).
8928 Make_Function_Call (Loc,
8929 Name => New_Occurrence_Of (RTE (Rent), Loc),
8930 Parameter_Associations => New_List (
8931 Convert_To (Etyp, Base),
8935 Analyze_And_Resolve (N, Typ);
8939 when RE_Not_Available =>
8941 end Expand_N_Op_Expon;
8943 --------------------
8944 -- Expand_N_Op_Ge --
8945 --------------------
8947 procedure Expand_N_Op_Ge (N : Node_Id) is
8948 Typ : constant Entity_Id := Etype (N);
8949 Op1 : constant Node_Id := Left_Opnd (N);
8950 Op2 : constant Node_Id := Right_Opnd (N);
8951 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8954 Binary_Op_Validity_Checks (N);
8956 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8957 -- means we no longer have a comparison operation, we are all done.
8959 Expand_Compare_Minimize_Eliminate_Overflow (N);
8961 if Nkind (N) /= N_Op_Ge then
8967 if Is_Array_Type (Typ1) then
8968 Expand_Array_Comparison (N);
8972 -- Deal with boolean operands
8974 if Is_Boolean_Type (Typ1) then
8975 Adjust_Condition (Op1);
8976 Adjust_Condition (Op2);
8977 Set_Etype (N, Standard_Boolean);
8978 Adjust_Result_Type (N, Typ);
8981 Rewrite_Comparison (N);
8983 Optimize_Length_Comparison (N);
8986 --------------------
8987 -- Expand_N_Op_Gt --
8988 --------------------
8990 procedure Expand_N_Op_Gt (N : Node_Id) is
8991 Typ : constant Entity_Id := Etype (N);
8992 Op1 : constant Node_Id := Left_Opnd (N);
8993 Op2 : constant Node_Id := Right_Opnd (N);
8994 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8997 Binary_Op_Validity_Checks (N);
8999 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9000 -- means we no longer have a comparison operation, we are all done.
9002 Expand_Compare_Minimize_Eliminate_Overflow (N);
9004 if Nkind (N) /= N_Op_Gt then
9008 -- Deal with array type operands
9010 if Is_Array_Type (Typ1) then
9011 Expand_Array_Comparison (N);
9015 -- Deal with boolean type operands
9017 if Is_Boolean_Type (Typ1) then
9018 Adjust_Condition (Op1);
9019 Adjust_Condition (Op2);
9020 Set_Etype (N, Standard_Boolean);
9021 Adjust_Result_Type (N, Typ);
9024 Rewrite_Comparison (N);
9026 Optimize_Length_Comparison (N);
9029 --------------------
9030 -- Expand_N_Op_Le --
9031 --------------------
9033 procedure Expand_N_Op_Le (N : Node_Id) is
9034 Typ : constant Entity_Id := Etype (N);
9035 Op1 : constant Node_Id := Left_Opnd (N);
9036 Op2 : constant Node_Id := Right_Opnd (N);
9037 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9040 Binary_Op_Validity_Checks (N);
9042 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9043 -- means we no longer have a comparison operation, we are all done.
9045 Expand_Compare_Minimize_Eliminate_Overflow (N);
9047 if Nkind (N) /= N_Op_Le then
9051 -- Deal with array type operands
9053 if Is_Array_Type (Typ1) then
9054 Expand_Array_Comparison (N);
9058 -- Deal with Boolean type operands
9060 if Is_Boolean_Type (Typ1) then
9061 Adjust_Condition (Op1);
9062 Adjust_Condition (Op2);
9063 Set_Etype (N, Standard_Boolean);
9064 Adjust_Result_Type (N, Typ);
9067 Rewrite_Comparison (N);
9069 Optimize_Length_Comparison (N);
9072 --------------------
9073 -- Expand_N_Op_Lt --
9074 --------------------
9076 procedure Expand_N_Op_Lt (N : Node_Id) is
9077 Typ : constant Entity_Id := Etype (N);
9078 Op1 : constant Node_Id := Left_Opnd (N);
9079 Op2 : constant Node_Id := Right_Opnd (N);
9080 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9083 Binary_Op_Validity_Checks (N);
9085 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9086 -- means we no longer have a comparison operation, we are all done.
9088 Expand_Compare_Minimize_Eliminate_Overflow (N);
9090 if Nkind (N) /= N_Op_Lt then
9094 -- Deal with array type operands
9096 if Is_Array_Type (Typ1) then
9097 Expand_Array_Comparison (N);
9101 -- Deal with Boolean type operands
9103 if Is_Boolean_Type (Typ1) then
9104 Adjust_Condition (Op1);
9105 Adjust_Condition (Op2);
9106 Set_Etype (N, Standard_Boolean);
9107 Adjust_Result_Type (N, Typ);
9110 Rewrite_Comparison (N);
9112 Optimize_Length_Comparison (N);
9115 -----------------------
9116 -- Expand_N_Op_Minus --
9117 -----------------------
9119 procedure Expand_N_Op_Minus (N : Node_Id) is
9120 Loc : constant Source_Ptr := Sloc (N);
9121 Typ : constant Entity_Id := Etype (N);
9124 Unary_Op_Validity_Checks (N);
9126 -- Check for MINIMIZED/ELIMINATED overflow mode
9128 if Minimized_Eliminated_Overflow_Check (N) then
9129 Apply_Arithmetic_Overflow_Check (N);
9133 if not Backend_Overflow_Checks_On_Target
9134 and then Is_Signed_Integer_Type (Etype (N))
9135 and then Do_Overflow_Check (N)
9137 -- Software overflow checking expands -expr into (0 - expr)
9140 Make_Op_Subtract (Loc,
9141 Left_Opnd => Make_Integer_Literal (Loc, 0),
9142 Right_Opnd => Right_Opnd (N)));
9144 Analyze_And_Resolve (N, Typ);
9147 Expand_Nonbinary_Modular_Op (N);
9148 end Expand_N_Op_Minus;
9150 ---------------------
9151 -- Expand_N_Op_Mod --
9152 ---------------------
9154 procedure Expand_N_Op_Mod (N : Node_Id) is
9155 Loc : constant Source_Ptr := Sloc (N);
9156 Typ : constant Entity_Id := Etype (N);
9157 DDC : constant Boolean := Do_Division_Check (N);
9170 pragma Warnings (Off, Lhi);
9173 Binary_Op_Validity_Checks (N);
9175 -- Check for MINIMIZED/ELIMINATED overflow mode
9177 if Minimized_Eliminated_Overflow_Check (N) then
9178 Apply_Arithmetic_Overflow_Check (N);
9182 if Is_Integer_Type (Etype (N)) then
9183 Apply_Divide_Checks (N);
9185 -- All done if we don't have a MOD any more, which can happen as a
9186 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9188 if Nkind (N) /= N_Op_Mod then
9193 -- Proceed with expansion of mod operator
9195 Left := Left_Opnd (N);
9196 Right := Right_Opnd (N);
9198 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
9199 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
9201 -- Convert mod to rem if operands are both known to be non-negative, or
9202 -- both known to be non-positive (these are the cases in which rem and
9203 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9204 -- likely that this will improve the quality of code, (the operation now
9205 -- corresponds to the hardware remainder), and it does not seem likely
9206 -- that it could be harmful. It also avoids some cases of the elaborate
9207 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9210 and then ((Llo >= 0 and then Rlo >= 0)
9212 (Lhi <= 0 and then Rhi <= 0))
9215 Make_Op_Rem (Sloc (N),
9216 Left_Opnd => Left_Opnd (N),
9217 Right_Opnd => Right_Opnd (N)));
9219 -- Instead of reanalyzing the node we do the analysis manually. This
9220 -- avoids anomalies when the replacement is done in an instance and
9221 -- is epsilon more efficient.
9223 Set_Entity (N, Standard_Entity (S_Op_Rem));
9225 Set_Do_Division_Check (N, DDC);
9226 Expand_N_Op_Rem (N);
9230 -- Otherwise, normal mod processing
9233 -- Apply optimization x mod 1 = 0. We don't really need that with
9234 -- gcc, but it is useful with other back ends and is certainly
9237 if Is_Integer_Type (Etype (N))
9238 and then Compile_Time_Known_Value (Right)
9239 and then Expr_Value (Right) = Uint_1
9241 -- Call Remove_Side_Effects to ensure that any side effects in
9242 -- the ignored left operand (in particular function calls to
9243 -- user defined functions) are properly executed.
9245 Remove_Side_Effects (Left);
9247 Rewrite (N, Make_Integer_Literal (Loc, 0));
9248 Analyze_And_Resolve (N, Typ);
9252 -- If we still have a mod operator and we are in Modify_Tree_For_C
9253 -- mode, and we have a signed integer type, then here is where we do
9254 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9255 -- for the special handling of the annoying case of largest negative
9256 -- number mod minus one.
9258 if Nkind (N) = N_Op_Mod
9259 and then Is_Signed_Integer_Type (Typ)
9260 and then Modify_Tree_For_C
9262 -- In the general case, we expand A mod B as
9264 -- Tnn : constant typ := A rem B;
9266 -- (if (A >= 0) = (B >= 0) then Tnn
9267 -- elsif Tnn = 0 then 0
9270 -- The comparison can be written simply as A >= 0 if we know that
9271 -- B >= 0 which is a very common case.
9273 -- An important optimization is when B is known at compile time
9274 -- to be 2**K for some constant. In this case we can simply AND
9275 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9276 -- and that works for both the positive and negative cases.
9279 P2 : constant Nat := Power_Of_Two (Right);
9284 Unchecked_Convert_To (Typ,
9287 Unchecked_Convert_To
9288 (Corresponding_Unsigned_Type (Typ), Left),
9290 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
9291 Analyze_And_Resolve (N, Typ);
9296 -- Here for the full rewrite
9299 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
9305 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9306 Right_Opnd => Make_Integer_Literal (Loc, 0));
9308 if not LOK or else Rlo < 0 then
9314 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
9315 Right_Opnd => Make_Integer_Literal (Loc, 0)));
9319 Make_Object_Declaration (Loc,
9320 Defining_Identifier => Tnn,
9321 Constant_Present => True,
9322 Object_Definition => New_Occurrence_Of (Typ, Loc),
9326 Right_Opnd => Right)));
9329 Make_If_Expression (Loc,
9330 Expressions => New_List (
9332 New_Occurrence_Of (Tnn, Loc),
9333 Make_If_Expression (Loc,
9335 Expressions => New_List (
9337 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9338 Right_Opnd => Make_Integer_Literal (Loc, 0)),
9339 Make_Integer_Literal (Loc, 0),
9341 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9343 Duplicate_Subexpr_No_Checks (Right)))))));
9345 Analyze_And_Resolve (N, Typ);
9350 -- Deal with annoying case of largest negative number mod minus one.
9351 -- Gigi may not handle this case correctly, because on some targets,
9352 -- the mod value is computed using a divide instruction which gives
9353 -- an overflow trap for this case.
9355 -- It would be a bit more efficient to figure out which targets
9356 -- this is really needed for, but in practice it is reasonable
9357 -- to do the following special check in all cases, since it means
9358 -- we get a clearer message, and also the overhead is minimal given
9359 -- that division is expensive in any case.
9361 -- In fact the check is quite easy, if the right operand is -1, then
9362 -- the mod value is always 0, and we can just ignore the left operand
9363 -- completely in this case.
9365 -- This only applies if we still have a mod operator. Skip if we
9366 -- have already rewritten this (e.g. in the case of eliminated
9367 -- overflow checks which have driven us into bignum mode).
9369 if Nkind (N) = N_Op_Mod then
9371 -- The operand type may be private (e.g. in the expansion of an
9372 -- intrinsic operation) so we must use the underlying type to get
9373 -- the bounds, and convert the literals explicitly.
9377 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
9379 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
9380 and then ((not LOK) or else (Llo = LLB))
9383 Make_If_Expression (Loc,
9384 Expressions => New_List (
9386 Left_Opnd => Duplicate_Subexpr (Right),
9388 Unchecked_Convert_To (Typ,
9389 Make_Integer_Literal (Loc, -1))),
9390 Unchecked_Convert_To (Typ,
9391 Make_Integer_Literal (Loc, Uint_0)),
9392 Relocate_Node (N))));
9394 Set_Analyzed (Next (Next (First (Expressions (N)))));
9395 Analyze_And_Resolve (N, Typ);
9399 end Expand_N_Op_Mod;
9401 --------------------------
9402 -- Expand_N_Op_Multiply --
9403 --------------------------
9405 procedure Expand_N_Op_Multiply (N : Node_Id) is
9406 Loc : constant Source_Ptr := Sloc (N);
9407 Lop : constant Node_Id := Left_Opnd (N);
9408 Rop : constant Node_Id := Right_Opnd (N);
9410 Lp2 : constant Boolean :=
9411 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
9412 Rp2 : constant Boolean :=
9413 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
9415 Ltyp : constant Entity_Id := Etype (Lop);
9416 Rtyp : constant Entity_Id := Etype (Rop);
9417 Typ : Entity_Id := Etype (N);
9420 Binary_Op_Validity_Checks (N);
9422 -- Check for MINIMIZED/ELIMINATED overflow mode
9424 if Minimized_Eliminated_Overflow_Check (N) then
9425 Apply_Arithmetic_Overflow_Check (N);
9429 -- Special optimizations for integer types
9431 if Is_Integer_Type (Typ) then
9433 -- N * 0 = 0 for integer types
9435 if Compile_Time_Known_Value (Rop)
9436 and then Expr_Value (Rop) = Uint_0
9438 -- Call Remove_Side_Effects to ensure that any side effects in
9439 -- the ignored left operand (in particular function calls to
9440 -- user defined functions) are properly executed.
9442 Remove_Side_Effects (Lop);
9444 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9445 Analyze_And_Resolve (N, Typ);
9449 -- Similar handling for 0 * N = 0
9451 if Compile_Time_Known_Value (Lop)
9452 and then Expr_Value (Lop) = Uint_0
9454 Remove_Side_Effects (Rop);
9455 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9456 Analyze_And_Resolve (N, Typ);
9460 -- N * 1 = 1 * N = N for integer types
9462 -- This optimisation is not done if we are going to
9463 -- rewrite the product 1 * 2 ** N to a shift.
9465 if Compile_Time_Known_Value (Rop)
9466 and then Expr_Value (Rop) = Uint_1
9472 elsif Compile_Time_Known_Value (Lop)
9473 and then Expr_Value (Lop) = Uint_1
9481 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9482 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9483 -- operand is an integer, as required for this to work.
9488 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9492 Left_Opnd => Make_Integer_Literal (Loc, 2),
9495 Left_Opnd => Right_Opnd (Lop),
9496 Right_Opnd => Right_Opnd (Rop))));
9497 Analyze_And_Resolve (N, Typ);
9501 -- If the result is modular, perform the reduction of the result
9504 if Is_Modular_Integer_Type (Typ)
9505 and then not Non_Binary_Modulus (Typ)
9510 Make_Op_Shift_Left (Loc,
9513 Convert_To (Standard_Natural, Right_Opnd (Rop))),
9515 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9519 Make_Op_Shift_Left (Loc,
9522 Convert_To (Standard_Natural, Right_Opnd (Rop))));
9525 Analyze_And_Resolve (N, Typ);
9529 -- Same processing for the operands the other way round
9532 if Is_Modular_Integer_Type (Typ)
9533 and then not Non_Binary_Modulus (Typ)
9538 Make_Op_Shift_Left (Loc,
9541 Convert_To (Standard_Natural, Right_Opnd (Lop))),
9543 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9547 Make_Op_Shift_Left (Loc,
9550 Convert_To (Standard_Natural, Right_Opnd (Lop))));
9553 Analyze_And_Resolve (N, Typ);
9557 -- Do required fixup of universal fixed operation
9559 if Typ = Universal_Fixed then
9560 Fixup_Universal_Fixed_Operation (N);
9564 -- Multiplications with fixed-point results
9566 if Is_Fixed_Point_Type (Typ) then
9568 -- Case of fixed * integer => fixed
9570 if Is_Integer_Type (Rtyp) then
9571 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
9573 -- Case of integer * fixed => fixed
9575 elsif Is_Integer_Type (Ltyp) then
9576 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
9578 -- Case of fixed * fixed => fixed
9581 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
9584 -- Other cases of multiplication of fixed-point operands
9586 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
9587 if Is_Integer_Type (Typ) then
9588 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
9590 pragma Assert (Is_Floating_Point_Type (Typ));
9591 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
9594 -- Mixed-mode operations can appear in a non-static universal context,
9595 -- in which case the integer argument must be converted explicitly.
9597 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
9598 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
9599 Analyze_And_Resolve (Rop, Universal_Real);
9601 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
9602 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
9603 Analyze_And_Resolve (Lop, Universal_Real);
9605 -- Non-fixed point cases, check software overflow checking required
9607 elsif Is_Signed_Integer_Type (Etype (N)) then
9608 Apply_Arithmetic_Overflow_Check (N);
9611 -- Overflow checks for floating-point if -gnateF mode active
9613 Check_Float_Op_Overflow (N);
9615 Expand_Nonbinary_Modular_Op (N);
9616 end Expand_N_Op_Multiply;
9618 --------------------
9619 -- Expand_N_Op_Ne --
9620 --------------------
9622 procedure Expand_N_Op_Ne (N : Node_Id) is
9623 Typ : constant Entity_Id := Etype (Left_Opnd (N));
9626 -- Case of elementary type with standard operator. But if unnesting,
9627 -- handle elementary types whose Equivalent_Types are records because
9628 -- there may be padding or undefined fields.
9630 if Is_Elementary_Type (Typ)
9631 and then Sloc (Entity (N)) = Standard_Location
9632 and then not (Ekind_In (Typ, E_Class_Wide_Type,
9633 E_Class_Wide_Subtype,
9634 E_Access_Subprogram_Type,
9635 E_Access_Protected_Subprogram_Type,
9636 E_Anonymous_Access_Protected_Subprogram_Type,
9637 E_Access_Subprogram_Type,
9639 and then Present (Equivalent_Type (Typ))
9640 and then Is_Record_Type (Equivalent_Type (Typ)))
9642 Binary_Op_Validity_Checks (N);
9644 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9645 -- means we no longer have a /= operation, we are all done.
9647 Expand_Compare_Minimize_Eliminate_Overflow (N);
9649 if Nkind (N) /= N_Op_Ne then
9653 -- Boolean types (requiring handling of non-standard case)
9655 if Is_Boolean_Type (Typ) then
9656 Adjust_Condition (Left_Opnd (N));
9657 Adjust_Condition (Right_Opnd (N));
9658 Set_Etype (N, Standard_Boolean);
9659 Adjust_Result_Type (N, Typ);
9662 Rewrite_Comparison (N);
9664 -- For all cases other than elementary types, we rewrite node as the
9665 -- negation of an equality operation, and reanalyze. The equality to be
9666 -- used is defined in the same scope and has the same signature. This
9667 -- signature must be set explicitly since in an instance it may not have
9668 -- the same visibility as in the generic unit. This avoids duplicating
9669 -- or factoring the complex code for record/array equality tests etc.
9671 -- This case is also used for the minimal expansion performed in
9676 Loc : constant Source_Ptr := Sloc (N);
9678 Ne : constant Entity_Id := Entity (N);
9681 Binary_Op_Validity_Checks (N);
9687 Left_Opnd => Left_Opnd (N),
9688 Right_Opnd => Right_Opnd (N)));
9690 -- The level of parentheses is useless in GNATprove mode, and
9691 -- bumping its level here leads to wrong columns being used in
9692 -- check messages, hence skip it in this mode.
9694 if not GNATprove_Mode then
9695 Set_Paren_Count (Right_Opnd (Neg), 1);
9698 if Scope (Ne) /= Standard_Standard then
9699 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
9702 -- For navigation purposes, we want to treat the inequality as an
9703 -- implicit reference to the corresponding equality. Preserve the
9704 -- Comes_From_ source flag to generate proper Xref entries.
9706 Preserve_Comes_From_Source (Neg, N);
9707 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
9709 Analyze_And_Resolve (N, Standard_Boolean);
9713 -- No need for optimization in GNATprove mode, where we would rather see
9714 -- the original source expression.
9716 if not GNATprove_Mode then
9717 Optimize_Length_Comparison (N);
9721 ---------------------
9722 -- Expand_N_Op_Not --
9723 ---------------------
9725 -- If the argument is other than a Boolean array type, there is no special
9726 -- expansion required, except for dealing with validity checks, and non-
9727 -- standard boolean representations.
9729 -- For the packed array case, we call the special routine in Exp_Pakd,
9730 -- except that if the component size is greater than one, we use the
9731 -- standard routine generating a gruesome loop (it is so peculiar to have
9732 -- packed arrays with non-standard Boolean representations anyway, so it
9733 -- does not matter that we do not handle this case efficiently).
9735 -- For the unpacked array case (and for the special packed case where we
9736 -- have non standard Booleans, as discussed above), we generate and insert
9737 -- into the tree the following function definition:
9739 -- function Nnnn (A : arr) is
9742 -- for J in a'range loop
9743 -- B (J) := not A (J);
9748 -- Here arr is the actual subtype of the parameter (and hence always
9749 -- constrained). Then we replace the not with a call to this function.
9751 procedure Expand_N_Op_Not (N : Node_Id) is
9752 Loc : constant Source_Ptr := Sloc (N);
9753 Typ : constant Entity_Id := Etype (N);
9762 Func_Name : Entity_Id;
9763 Loop_Statement : Node_Id;
9766 Unary_Op_Validity_Checks (N);
9768 -- For boolean operand, deal with non-standard booleans
9770 if Is_Boolean_Type (Typ) then
9771 Adjust_Condition (Right_Opnd (N));
9772 Set_Etype (N, Standard_Boolean);
9773 Adjust_Result_Type (N, Typ);
9777 -- Only array types need any other processing
9779 if not Is_Array_Type (Typ) then
9783 -- Case of array operand. If bit packed with a component size of 1,
9784 -- handle it in Exp_Pakd if the operand is known to be aligned.
9786 if Is_Bit_Packed_Array (Typ)
9787 and then Component_Size (Typ) = 1
9788 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
9790 Expand_Packed_Not (N);
9794 -- Case of array operand which is not bit-packed. If the context is
9795 -- a safe assignment, call in-place operation, If context is a larger
9796 -- boolean expression in the context of a safe assignment, expansion is
9797 -- done by enclosing operation.
9799 Opnd := Relocate_Node (Right_Opnd (N));
9800 Convert_To_Actual_Subtype (Opnd);
9801 Arr := Etype (Opnd);
9802 Ensure_Defined (Arr, N);
9803 Silly_Boolean_Array_Not_Test (N, Arr);
9805 if Nkind (Parent (N)) = N_Assignment_Statement then
9806 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
9807 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
9810 -- Special case the negation of a binary operation
9812 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
9813 and then Safe_In_Place_Array_Op
9814 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
9816 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
9820 elsif Nkind (Parent (N)) in N_Binary_Op
9821 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
9824 Op1 : constant Node_Id := Left_Opnd (Parent (N));
9825 Op2 : constant Node_Id := Right_Opnd (Parent (N));
9826 Lhs : constant Node_Id := Name (Parent (Parent (N)));
9829 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
9831 -- (not A) op (not B) can be reduced to a single call
9833 if N = Op1 and then Nkind (Op2) = N_Op_Not then
9836 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
9839 -- A xor (not B) can also be special-cased
9841 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
9848 A := Make_Defining_Identifier (Loc, Name_uA);
9849 B := Make_Defining_Identifier (Loc, Name_uB);
9850 J := Make_Defining_Identifier (Loc, Name_uJ);
9853 Make_Indexed_Component (Loc,
9854 Prefix => New_Occurrence_Of (A, Loc),
9855 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9858 Make_Indexed_Component (Loc,
9859 Prefix => New_Occurrence_Of (B, Loc),
9860 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9863 Make_Implicit_Loop_Statement (N,
9864 Identifier => Empty,
9867 Make_Iteration_Scheme (Loc,
9868 Loop_Parameter_Specification =>
9869 Make_Loop_Parameter_Specification (Loc,
9870 Defining_Identifier => J,
9871 Discrete_Subtype_Definition =>
9872 Make_Attribute_Reference (Loc,
9873 Prefix => Make_Identifier (Loc, Chars (A)),
9874 Attribute_Name => Name_Range))),
9876 Statements => New_List (
9877 Make_Assignment_Statement (Loc,
9879 Expression => Make_Op_Not (Loc, A_J))));
9881 Func_Name := Make_Temporary (Loc, 'N');
9882 Set_Is_Inlined (Func_Name);
9885 Make_Subprogram_Body (Loc,
9887 Make_Function_Specification (Loc,
9888 Defining_Unit_Name => Func_Name,
9889 Parameter_Specifications => New_List (
9890 Make_Parameter_Specification (Loc,
9891 Defining_Identifier => A,
9892 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9893 Result_Definition => New_Occurrence_Of (Typ, Loc)),
9895 Declarations => New_List (
9896 Make_Object_Declaration (Loc,
9897 Defining_Identifier => B,
9898 Object_Definition => New_Occurrence_Of (Arr, Loc))),
9900 Handled_Statement_Sequence =>
9901 Make_Handled_Sequence_Of_Statements (Loc,
9902 Statements => New_List (
9904 Make_Simple_Return_Statement (Loc,
9905 Expression => Make_Identifier (Loc, Chars (B)))))));
9908 Make_Function_Call (Loc,
9909 Name => New_Occurrence_Of (Func_Name, Loc),
9910 Parameter_Associations => New_List (Opnd)));
9912 Analyze_And_Resolve (N, Typ);
9913 end Expand_N_Op_Not;
9915 --------------------
9916 -- Expand_N_Op_Or --
9917 --------------------
9919 procedure Expand_N_Op_Or (N : Node_Id) is
9920 Typ : constant Entity_Id := Etype (N);
9923 Binary_Op_Validity_Checks (N);
9925 if Is_Array_Type (Etype (N)) then
9926 Expand_Boolean_Operator (N);
9928 elsif Is_Boolean_Type (Etype (N)) then
9929 Adjust_Condition (Left_Opnd (N));
9930 Adjust_Condition (Right_Opnd (N));
9931 Set_Etype (N, Standard_Boolean);
9932 Adjust_Result_Type (N, Typ);
9934 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9935 Expand_Intrinsic_Call (N, Entity (N));
9938 Expand_Nonbinary_Modular_Op (N);
9941 ----------------------
9942 -- Expand_N_Op_Plus --
9943 ----------------------
9945 procedure Expand_N_Op_Plus (N : Node_Id) is
9947 Unary_Op_Validity_Checks (N);
9949 -- Check for MINIMIZED/ELIMINATED overflow mode
9951 if Minimized_Eliminated_Overflow_Check (N) then
9952 Apply_Arithmetic_Overflow_Check (N);
9955 end Expand_N_Op_Plus;
9957 ---------------------
9958 -- Expand_N_Op_Rem --
9959 ---------------------
9961 procedure Expand_N_Op_Rem (N : Node_Id) is
9962 Loc : constant Source_Ptr := Sloc (N);
9963 Typ : constant Entity_Id := Etype (N);
9974 -- Set if corresponding operand can be negative
9976 pragma Unreferenced (Hi);
9979 Binary_Op_Validity_Checks (N);
9981 -- Check for MINIMIZED/ELIMINATED overflow mode
9983 if Minimized_Eliminated_Overflow_Check (N) then
9984 Apply_Arithmetic_Overflow_Check (N);
9988 if Is_Integer_Type (Etype (N)) then
9989 Apply_Divide_Checks (N);
9991 -- All done if we don't have a REM any more, which can happen as a
9992 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9994 if Nkind (N) /= N_Op_Rem then
9999 -- Proceed with expansion of REM
10001 Left := Left_Opnd (N);
10002 Right := Right_Opnd (N);
10004 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10005 -- but it is useful with other back ends, and is certainly harmless.
10007 if Is_Integer_Type (Etype (N))
10008 and then Compile_Time_Known_Value (Right)
10009 and then Expr_Value (Right) = Uint_1
10011 -- Call Remove_Side_Effects to ensure that any side effects in the
10012 -- ignored left operand (in particular function calls to user defined
10013 -- functions) are properly executed.
10015 Remove_Side_Effects (Left);
10017 Rewrite (N, Make_Integer_Literal (Loc, 0));
10018 Analyze_And_Resolve (N, Typ);
10022 -- Deal with annoying case of largest negative number remainder minus
10023 -- one. Gigi may not handle this case correctly, because on some
10024 -- targets, the mod value is computed using a divide instruction
10025 -- which gives an overflow trap for this case.
10027 -- It would be a bit more efficient to figure out which targets this
10028 -- is really needed for, but in practice it is reasonable to do the
10029 -- following special check in all cases, since it means we get a clearer
10030 -- message, and also the overhead is minimal given that division is
10031 -- expensive in any case.
10033 -- In fact the check is quite easy, if the right operand is -1, then
10034 -- the remainder is always 0, and we can just ignore the left operand
10035 -- completely in this case.
10037 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10038 Lneg := (not OK) or else Lo < 0;
10040 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
10041 Rneg := (not OK) or else Lo < 0;
10043 -- We won't mess with trying to find out if the left operand can really
10044 -- be the largest negative number (that's a pain in the case of private
10045 -- types and this is really marginal). We will just assume that we need
10046 -- the test if the left operand can be negative at all.
10048 if Lneg and Rneg then
10050 Make_If_Expression (Loc,
10051 Expressions => New_List (
10053 Left_Opnd => Duplicate_Subexpr (Right),
10055 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
10057 Unchecked_Convert_To (Typ,
10058 Make_Integer_Literal (Loc, Uint_0)),
10060 Relocate_Node (N))));
10062 Set_Analyzed (Next (Next (First (Expressions (N)))));
10063 Analyze_And_Resolve (N, Typ);
10065 end Expand_N_Op_Rem;
10067 -----------------------------
10068 -- Expand_N_Op_Rotate_Left --
10069 -----------------------------
10071 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
10073 Binary_Op_Validity_Checks (N);
10075 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10076 -- so we rewrite in terms of logical shifts
10078 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10080 -- where Bits is the shift count mod Esize (the mod operation here
10081 -- deals with ludicrous large shift counts, which are apparently OK).
10083 -- What about nonbinary modulus ???
10086 Loc : constant Source_Ptr := Sloc (N);
10087 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10088 Typ : constant Entity_Id := Etype (N);
10091 if Modify_Tree_For_C then
10092 Rewrite (Right_Opnd (N),
10094 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10095 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10097 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10102 Make_Op_Shift_Left (Loc,
10103 Left_Opnd => Left_Opnd (N),
10104 Right_Opnd => Right_Opnd (N)),
10107 Make_Op_Shift_Right (Loc,
10108 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10110 Make_Op_Subtract (Loc,
10111 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10113 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10115 Analyze_And_Resolve (N, Typ);
10118 end Expand_N_Op_Rotate_Left;
10120 ------------------------------
10121 -- Expand_N_Op_Rotate_Right --
10122 ------------------------------
10124 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
10126 Binary_Op_Validity_Checks (N);
10128 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10129 -- so we rewrite in terms of logical shifts
10131 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10133 -- where Bits is the shift count mod Esize (the mod operation here
10134 -- deals with ludicrous large shift counts, which are apparently OK).
10136 -- What about nonbinary modulus ???
10139 Loc : constant Source_Ptr := Sloc (N);
10140 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10141 Typ : constant Entity_Id := Etype (N);
10144 Rewrite (Right_Opnd (N),
10146 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10147 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10149 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10151 if Modify_Tree_For_C then
10155 Make_Op_Shift_Right (Loc,
10156 Left_Opnd => Left_Opnd (N),
10157 Right_Opnd => Right_Opnd (N)),
10160 Make_Op_Shift_Left (Loc,
10161 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10163 Make_Op_Subtract (Loc,
10164 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10166 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10168 Analyze_And_Resolve (N, Typ);
10171 end Expand_N_Op_Rotate_Right;
10173 ----------------------------
10174 -- Expand_N_Op_Shift_Left --
10175 ----------------------------
10177 -- Note: nothing in this routine depends on left as opposed to right shifts
10178 -- so we share the routine for expanding shift right operations.
10180 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
10182 Binary_Op_Validity_Checks (N);
10184 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10185 -- operand is not greater than the word size (since that would not
10186 -- be defined properly by the corresponding C shift operator).
10188 if Modify_Tree_For_C then
10190 Right : constant Node_Id := Right_Opnd (N);
10191 Loc : constant Source_Ptr := Sloc (Right);
10192 Typ : constant Entity_Id := Etype (N);
10193 Siz : constant Uint := Esize (Typ);
10200 if Compile_Time_Known_Value (Right) then
10201 if Expr_Value (Right) >= Siz then
10202 Rewrite (N, Make_Integer_Literal (Loc, 0));
10203 Analyze_And_Resolve (N, Typ);
10206 -- Not compile time known, find range
10209 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10211 -- Nothing to do if known to be OK range, otherwise expand
10213 if not OK or else Hi >= Siz then
10215 -- Prevent recursion on copy of shift node
10217 Orig := Relocate_Node (N);
10218 Set_Analyzed (Orig);
10220 -- Now do the rewrite
10223 Make_If_Expression (Loc,
10224 Expressions => New_List (
10226 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
10227 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
10228 Make_Integer_Literal (Loc, 0),
10230 Analyze_And_Resolve (N, Typ);
10235 end Expand_N_Op_Shift_Left;
10237 -----------------------------
10238 -- Expand_N_Op_Shift_Right --
10239 -----------------------------
10241 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
10243 -- Share shift left circuit
10245 Expand_N_Op_Shift_Left (N);
10246 end Expand_N_Op_Shift_Right;
10248 ----------------------------------------
10249 -- Expand_N_Op_Shift_Right_Arithmetic --
10250 ----------------------------------------
10252 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
10254 Binary_Op_Validity_Checks (N);
10256 -- If we are in Modify_Tree_For_C mode, there is no shift right
10257 -- arithmetic in C, so we rewrite in terms of logical shifts.
10259 -- Shift_Right (Num, Bits) or
10261 -- then not (Shift_Right (Mask, bits))
10264 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10266 -- Note: in almost all C compilers it would work to just shift a
10267 -- signed integer right, but it's undefined and we cannot rely on it.
10269 -- Note: the above works fine for shift counts greater than or equal
10270 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10271 -- generates all 1'bits.
10273 -- What about nonbinary modulus ???
10276 Loc : constant Source_Ptr := Sloc (N);
10277 Typ : constant Entity_Id := Etype (N);
10278 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
10279 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
10280 Left : constant Node_Id := Left_Opnd (N);
10281 Right : constant Node_Id := Right_Opnd (N);
10285 if Modify_Tree_For_C then
10287 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10288 -- compile time as a single constant.
10290 if Compile_Time_Known_Value (Right) then
10292 Val : constant Uint := Expr_Value (Right);
10295 if Val >= Esize (Typ) then
10296 Maskx := Make_Integer_Literal (Loc, Mask);
10300 Make_Integer_Literal (Loc,
10301 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
10309 Make_Op_Shift_Right (Loc,
10310 Left_Opnd => Make_Integer_Literal (Loc, Mask),
10311 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
10314 -- Now do the rewrite
10319 Make_Op_Shift_Right (Loc,
10321 Right_Opnd => Right),
10323 Make_If_Expression (Loc,
10324 Expressions => New_List (
10326 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
10327 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
10329 Make_Integer_Literal (Loc, 0)))));
10330 Analyze_And_Resolve (N, Typ);
10333 end Expand_N_Op_Shift_Right_Arithmetic;
10335 --------------------------
10336 -- Expand_N_Op_Subtract --
10337 --------------------------
10339 procedure Expand_N_Op_Subtract (N : Node_Id) is
10340 Typ : constant Entity_Id := Etype (N);
10343 Binary_Op_Validity_Checks (N);
10345 -- Check for MINIMIZED/ELIMINATED overflow mode
10347 if Minimized_Eliminated_Overflow_Check (N) then
10348 Apply_Arithmetic_Overflow_Check (N);
10352 -- N - 0 = N for integer types
10354 if Is_Integer_Type (Typ)
10355 and then Compile_Time_Known_Value (Right_Opnd (N))
10356 and then Expr_Value (Right_Opnd (N)) = 0
10358 Rewrite (N, Left_Opnd (N));
10362 -- Arithmetic overflow checks for signed integer/fixed point types
10364 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
10365 Apply_Arithmetic_Overflow_Check (N);
10368 -- Overflow checks for floating-point if -gnateF mode active
10370 Check_Float_Op_Overflow (N);
10372 Expand_Nonbinary_Modular_Op (N);
10373 end Expand_N_Op_Subtract;
10375 ---------------------
10376 -- Expand_N_Op_Xor --
10377 ---------------------
10379 procedure Expand_N_Op_Xor (N : Node_Id) is
10380 Typ : constant Entity_Id := Etype (N);
10383 Binary_Op_Validity_Checks (N);
10385 if Is_Array_Type (Etype (N)) then
10386 Expand_Boolean_Operator (N);
10388 elsif Is_Boolean_Type (Etype (N)) then
10389 Adjust_Condition (Left_Opnd (N));
10390 Adjust_Condition (Right_Opnd (N));
10391 Set_Etype (N, Standard_Boolean);
10392 Adjust_Result_Type (N, Typ);
10394 elsif Is_Intrinsic_Subprogram (Entity (N)) then
10395 Expand_Intrinsic_Call (N, Entity (N));
10398 Expand_Nonbinary_Modular_Op (N);
10399 end Expand_N_Op_Xor;
10401 ----------------------
10402 -- Expand_N_Or_Else --
10403 ----------------------
10405 procedure Expand_N_Or_Else (N : Node_Id)
10406 renames Expand_Short_Circuit_Operator;
10408 -----------------------------------
10409 -- Expand_N_Qualified_Expression --
10410 -----------------------------------
10412 procedure Expand_N_Qualified_Expression (N : Node_Id) is
10413 Operand : constant Node_Id := Expression (N);
10414 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
10417 -- Do validity check if validity checking operands
10419 if Validity_Checks_On and Validity_Check_Operands then
10420 Ensure_Valid (Operand);
10423 -- Apply possible constraint check
10425 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
10427 if Do_Range_Check (Operand) then
10428 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
10430 end Expand_N_Qualified_Expression;
10432 ------------------------------------
10433 -- Expand_N_Quantified_Expression --
10434 ------------------------------------
10438 -- for all X in range => Cond
10443 -- for X in range loop
10444 -- if not Cond then
10450 -- Similarly, an existentially quantified expression:
10452 -- for some X in range => Cond
10457 -- for X in range loop
10464 -- In both cases, the iteration may be over a container in which case it is
10465 -- given by an iterator specification, not a loop parameter specification.
10467 procedure Expand_N_Quantified_Expression (N : Node_Id) is
10468 Actions : constant List_Id := New_List;
10469 For_All : constant Boolean := All_Present (N);
10470 Iter_Spec : constant Node_Id := Iterator_Specification (N);
10471 Loc : constant Source_Ptr := Sloc (N);
10472 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
10480 -- Ensure that the bound variable is properly frozen. We must do
10481 -- this before expansion because the expression is about to be
10482 -- converted into a loop, and resulting freeze nodes may end up
10483 -- in the wrong place in the tree.
10485 if Present (Iter_Spec) then
10486 Var := Defining_Identifier (Iter_Spec);
10488 Var := Defining_Identifier (Loop_Spec);
10492 P : Node_Id := Parent (N);
10494 while Nkind (P) in N_Subexpr loop
10498 Freeze_Before (P, Etype (Var));
10501 -- Create the declaration of the flag which tracks the status of the
10502 -- quantified expression. Generate:
10504 -- Flag : Boolean := (True | False);
10506 Flag := Make_Temporary (Loc, 'T', N);
10508 Append_To (Actions,
10509 Make_Object_Declaration (Loc,
10510 Defining_Identifier => Flag,
10511 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
10513 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
10515 -- Construct the circuitry which tracks the status of the quantified
10516 -- expression. Generate:
10518 -- if [not] Cond then
10519 -- Flag := (False | True);
10523 Cond := Relocate_Node (Condition (N));
10526 Cond := Make_Op_Not (Loc, Cond);
10529 Stmts := New_List (
10530 Make_Implicit_If_Statement (N,
10532 Then_Statements => New_List (
10533 Make_Assignment_Statement (Loc,
10534 Name => New_Occurrence_Of (Flag, Loc),
10536 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
10537 Make_Exit_Statement (Loc))));
10539 -- Build the loop equivalent of the quantified expression
10541 if Present (Iter_Spec) then
10543 Make_Iteration_Scheme (Loc,
10544 Iterator_Specification => Iter_Spec);
10547 Make_Iteration_Scheme (Loc,
10548 Loop_Parameter_Specification => Loop_Spec);
10551 Append_To (Actions,
10552 Make_Loop_Statement (Loc,
10553 Iteration_Scheme => Scheme,
10554 Statements => Stmts,
10555 End_Label => Empty));
10557 -- Transform the quantified expression
10560 Make_Expression_With_Actions (Loc,
10561 Expression => New_Occurrence_Of (Flag, Loc),
10562 Actions => Actions));
10563 Analyze_And_Resolve (N, Standard_Boolean);
10564 end Expand_N_Quantified_Expression;
10566 ---------------------------------
10567 -- Expand_N_Selected_Component --
10568 ---------------------------------
10570 procedure Expand_N_Selected_Component (N : Node_Id) is
10571 Loc : constant Source_Ptr := Sloc (N);
10572 Par : constant Node_Id := Parent (N);
10573 P : constant Node_Id := Prefix (N);
10574 S : constant Node_Id := Selector_Name (N);
10575 Ptyp : Entity_Id := Underlying_Type (Etype (P));
10581 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
10582 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10583 -- unless the context of an assignment can provide size information.
10584 -- Don't we have a general routine that does this???
10586 function Is_Subtype_Declaration return Boolean;
10587 -- The replacement of a discriminant reference by its value is required
10588 -- if this is part of the initialization of an temporary generated by a
10589 -- change of representation. This shows up as the construction of a
10590 -- discriminant constraint for a subtype declared at the same point as
10591 -- the entity in the prefix of the selected component. We recognize this
10592 -- case when the context of the reference is:
10593 -- subtype ST is T(Obj.D);
10594 -- where the entity for Obj comes from source, and ST has the same sloc.
10596 -----------------------
10597 -- In_Left_Hand_Side --
10598 -----------------------
10600 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
10602 return (Nkind (Parent (Comp)) = N_Assignment_Statement
10603 and then Comp = Name (Parent (Comp)))
10604 or else (Present (Parent (Comp))
10605 and then Nkind (Parent (Comp)) in N_Subexpr
10606 and then In_Left_Hand_Side (Parent (Comp)));
10607 end In_Left_Hand_Side;
10609 -----------------------------
10610 -- Is_Subtype_Declaration --
10611 -----------------------------
10613 function Is_Subtype_Declaration return Boolean is
10614 Par : constant Node_Id := Parent (N);
10617 Nkind (Par) = N_Index_Or_Discriminant_Constraint
10618 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
10619 and then Comes_From_Source (Entity (Prefix (N)))
10620 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
10621 end Is_Subtype_Declaration;
10623 -- Start of processing for Expand_N_Selected_Component
10626 -- Insert explicit dereference if required
10628 if Is_Access_Type (Ptyp) then
10630 -- First set prefix type to proper access type, in case it currently
10631 -- has a private (non-access) view of this type.
10633 Set_Etype (P, Ptyp);
10635 Insert_Explicit_Dereference (P);
10636 Analyze_And_Resolve (P, Designated_Type (Ptyp));
10641 -- Deal with discriminant check required
10643 if Do_Discriminant_Check (N) then
10644 if Present (Discriminant_Checking_Func
10645 (Original_Record_Component (Entity (S))))
10647 -- Present the discriminant checking function to the backend, so
10648 -- that it can inline the call to the function.
10651 (Discriminant_Checking_Func
10652 (Original_Record_Component (Entity (S))),
10655 -- Now reset the flag and generate the call
10657 Set_Do_Discriminant_Check (N, False);
10658 Generate_Discriminant_Check (N);
10660 -- In the case of Unchecked_Union, no discriminant checking is
10661 -- actually performed.
10664 Set_Do_Discriminant_Check (N, False);
10668 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10669 -- function, then additional actuals must be passed.
10671 if Is_Build_In_Place_Function_Call (P) then
10672 Make_Build_In_Place_Call_In_Anonymous_Context (P);
10674 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10675 -- containing build-in-place function calls whose returned object covers
10676 -- interface types.
10678 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
10679 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
10682 -- Gigi cannot handle unchecked conversions that are the prefix of a
10683 -- selected component with discriminants. This must be checked during
10684 -- expansion, because during analysis the type of the selector is not
10685 -- known at the point the prefix is analyzed. If the conversion is the
10686 -- target of an assignment, then we cannot force the evaluation.
10688 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
10689 and then Has_Discriminants (Etype (N))
10690 and then not In_Left_Hand_Side (N)
10692 Force_Evaluation (Prefix (N));
10695 -- Remaining processing applies only if selector is a discriminant
10697 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
10699 -- If the selector is a discriminant of a constrained record type,
10700 -- we may be able to rewrite the expression with the actual value
10701 -- of the discriminant, a useful optimization in some cases.
10703 if Is_Record_Type (Ptyp)
10704 and then Has_Discriminants (Ptyp)
10705 and then Is_Constrained (Ptyp)
10707 -- Do this optimization for discrete types only, and not for
10708 -- access types (access discriminants get us into trouble).
10710 if not Is_Discrete_Type (Etype (N)) then
10713 -- Don't do this on the left-hand side of an assignment statement.
10714 -- Normally one would think that references like this would not
10715 -- occur, but they do in generated code, and mean that we really
10716 -- do want to assign the discriminant.
10718 elsif Nkind (Par) = N_Assignment_Statement
10719 and then Name (Par) = N
10723 -- Don't do this optimization for the prefix of an attribute or
10724 -- the name of an object renaming declaration since these are
10725 -- contexts where we do not want the value anyway.
10727 elsif (Nkind (Par) = N_Attribute_Reference
10728 and then Prefix (Par) = N)
10729 or else Is_Renamed_Object (N)
10733 -- Don't do this optimization if we are within the code for a
10734 -- discriminant check, since the whole point of such a check may
10735 -- be to verify the condition on which the code below depends.
10737 elsif Is_In_Discriminant_Check (N) then
10740 -- Green light to see if we can do the optimization. There is
10741 -- still one condition that inhibits the optimization below but
10742 -- now is the time to check the particular discriminant.
10745 -- Loop through discriminants to find the matching discriminant
10746 -- constraint to see if we can copy it.
10748 Disc := First_Discriminant (Ptyp);
10749 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
10750 Discr_Loop : while Present (Dcon) loop
10751 Dval := Node (Dcon);
10753 -- Check if this is the matching discriminant and if the
10754 -- discriminant value is simple enough to make sense to
10755 -- copy. We don't want to copy complex expressions, and
10756 -- indeed to do so can cause trouble (before we put in
10757 -- this guard, a discriminant expression containing an
10758 -- AND THEN was copied, causing problems for coverage
10759 -- analysis tools).
10761 -- However, if the reference is part of the initialization
10762 -- code generated for an object declaration, we must use
10763 -- the discriminant value from the subtype constraint,
10764 -- because the selected component may be a reference to the
10765 -- object being initialized, whose discriminant is not yet
10766 -- set. This only happens in complex cases involving changes
10767 -- or representation.
10769 if Disc = Entity (Selector_Name (N))
10770 and then (Is_Entity_Name (Dval)
10771 or else Compile_Time_Known_Value (Dval)
10772 or else Is_Subtype_Declaration)
10774 -- Here we have the matching discriminant. Check for
10775 -- the case of a discriminant of a component that is
10776 -- constrained by an outer discriminant, which cannot
10777 -- be optimized away.
10779 if Denotes_Discriminant
10780 (Dval, Check_Concurrent => True)
10784 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
10786 Denotes_Discriminant
10787 (Selector_Name (Original_Node (Dval)), True)
10791 -- Do not retrieve value if constraint is not static. It
10792 -- is generally not useful, and the constraint may be a
10793 -- rewritten outer discriminant in which case it is in
10796 elsif Is_Entity_Name (Dval)
10798 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
10799 and then Present (Expression (Parent (Entity (Dval))))
10801 Is_OK_Static_Expression
10802 (Expression (Parent (Entity (Dval))))
10806 -- In the context of a case statement, the expression may
10807 -- have the base type of the discriminant, and we need to
10808 -- preserve the constraint to avoid spurious errors on
10811 elsif Nkind (Parent (N)) = N_Case_Statement
10812 and then Etype (Dval) /= Etype (Disc)
10815 Make_Qualified_Expression (Loc,
10817 New_Occurrence_Of (Etype (Disc), Loc),
10819 New_Copy_Tree (Dval)));
10820 Analyze_And_Resolve (N, Etype (Disc));
10822 -- In case that comes out as a static expression,
10823 -- reset it (a selected component is never static).
10825 Set_Is_Static_Expression (N, False);
10828 -- Otherwise we can just copy the constraint, but the
10829 -- result is certainly not static. In some cases the
10830 -- discriminant constraint has been analyzed in the
10831 -- context of the original subtype indication, but for
10832 -- itypes the constraint might not have been analyzed
10833 -- yet, and this must be done now.
10836 Rewrite (N, New_Copy_Tree (Dval));
10837 Analyze_And_Resolve (N);
10838 Set_Is_Static_Expression (N, False);
10844 Next_Discriminant (Disc);
10845 end loop Discr_Loop;
10847 -- Note: the above loop should always find a matching
10848 -- discriminant, but if it does not, we just missed an
10849 -- optimization due to some glitch (perhaps a previous
10850 -- error), so ignore.
10855 -- The only remaining processing is in the case of a discriminant of
10856 -- a concurrent object, where we rewrite the prefix to denote the
10857 -- corresponding record type. If the type is derived and has renamed
10858 -- discriminants, use corresponding discriminant, which is the one
10859 -- that appears in the corresponding record.
10861 if not Is_Concurrent_Type (Ptyp) then
10865 Disc := Entity (Selector_Name (N));
10867 if Is_Derived_Type (Ptyp)
10868 and then Present (Corresponding_Discriminant (Disc))
10870 Disc := Corresponding_Discriminant (Disc);
10874 Make_Selected_Component (Loc,
10876 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
10877 New_Copy_Tree (P)),
10878 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
10880 Rewrite (N, New_N);
10884 -- Set Atomic_Sync_Required if necessary for atomic component
10886 if Nkind (N) = N_Selected_Component then
10888 E : constant Entity_Id := Entity (Selector_Name (N));
10892 -- If component is atomic, but type is not, setting depends on
10893 -- disable/enable state for the component.
10895 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
10896 Set := not Atomic_Synchronization_Disabled (E);
10898 -- If component is not atomic, but its type is atomic, setting
10899 -- depends on disable/enable state for the type.
10901 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10902 Set := not Atomic_Synchronization_Disabled (Etype (E));
10904 -- If both component and type are atomic, we disable if either
10905 -- component or its type have sync disabled.
10907 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10908 Set := (not Atomic_Synchronization_Disabled (E))
10910 (not Atomic_Synchronization_Disabled (Etype (E)));
10916 -- Set flag if required
10919 Activate_Atomic_Synchronization (N);
10923 end Expand_N_Selected_Component;
10925 --------------------
10926 -- Expand_N_Slice --
10927 --------------------
10929 procedure Expand_N_Slice (N : Node_Id) is
10930 Loc : constant Source_Ptr := Sloc (N);
10931 Typ : constant Entity_Id := Etype (N);
10933 function Is_Procedure_Actual (N : Node_Id) return Boolean;
10934 -- Check whether the argument is an actual for a procedure call, in
10935 -- which case the expansion of a bit-packed slice is deferred until the
10936 -- call itself is expanded. The reason this is required is that we might
10937 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10938 -- that copy out would be missed if we created a temporary here in
10939 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10940 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10941 -- is harmless to defer expansion in the IN case, since the call
10942 -- processing will still generate the appropriate copy in operation,
10943 -- which will take care of the slice.
10945 procedure Make_Temporary_For_Slice;
10946 -- Create a named variable for the value of the slice, in cases where
10947 -- the back end cannot handle it properly, e.g. when packed types or
10948 -- unaligned slices are involved.
10950 -------------------------
10951 -- Is_Procedure_Actual --
10952 -------------------------
10954 function Is_Procedure_Actual (N : Node_Id) return Boolean is
10955 Par : Node_Id := Parent (N);
10959 -- If our parent is a procedure call we can return
10961 if Nkind (Par) = N_Procedure_Call_Statement then
10964 -- If our parent is a type conversion, keep climbing the tree,
10965 -- since a type conversion can be a procedure actual. Also keep
10966 -- climbing if parameter association or a qualified expression,
10967 -- since these are additional cases that do can appear on
10968 -- procedure actuals.
10970 elsif Nkind_In (Par, N_Type_Conversion,
10971 N_Parameter_Association,
10972 N_Qualified_Expression)
10974 Par := Parent (Par);
10976 -- Any other case is not what we are looking for
10982 end Is_Procedure_Actual;
10984 ------------------------------
10985 -- Make_Temporary_For_Slice --
10986 ------------------------------
10988 procedure Make_Temporary_For_Slice is
10989 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
10994 Make_Object_Declaration (Loc,
10995 Defining_Identifier => Ent,
10996 Object_Definition => New_Occurrence_Of (Typ, Loc));
10998 Set_No_Initialization (Decl);
11000 Insert_Actions (N, New_List (
11002 Make_Assignment_Statement (Loc,
11003 Name => New_Occurrence_Of (Ent, Loc),
11004 Expression => Relocate_Node (N))));
11006 Rewrite (N, New_Occurrence_Of (Ent, Loc));
11007 Analyze_And_Resolve (N, Typ);
11008 end Make_Temporary_For_Slice;
11012 Pref : constant Node_Id := Prefix (N);
11013 Pref_Typ : Entity_Id := Etype (Pref);
11015 -- Start of processing for Expand_N_Slice
11018 -- Special handling for access types
11020 if Is_Access_Type (Pref_Typ) then
11021 Pref_Typ := Designated_Type (Pref_Typ);
11024 Make_Explicit_Dereference (Sloc (N),
11025 Prefix => Relocate_Node (Pref)));
11027 Analyze_And_Resolve (Pref, Pref_Typ);
11030 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11031 -- function, then additional actuals must be passed.
11033 if Is_Build_In_Place_Function_Call (Pref) then
11034 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
11036 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11037 -- containing build-in-place function calls whose returned object covers
11038 -- interface types.
11040 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
11041 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
11044 -- The remaining case to be handled is packed slices. We can leave
11045 -- packed slices as they are in the following situations:
11047 -- 1. Right or left side of an assignment (we can handle this
11048 -- situation correctly in the assignment statement expansion).
11050 -- 2. Prefix of indexed component (the slide is optimized away in this
11051 -- case, see the start of Expand_N_Slice.)
11053 -- 3. Object renaming declaration, since we want the name of the
11054 -- slice, not the value.
11056 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11057 -- be required, and this is handled in the expansion of call
11060 -- 5. Prefix of an address attribute (this is an error which is caught
11061 -- elsewhere, and the expansion would interfere with generating the
11062 -- error message) or of a size attribute (because 'Size may change
11063 -- when applied to the temporary instead of the slice directly).
11065 if not Is_Packed (Typ) then
11067 -- Apply transformation for actuals of a function call, where
11068 -- Expand_Actuals is not used.
11070 if Nkind (Parent (N)) = N_Function_Call
11071 and then Is_Possibly_Unaligned_Slice (N)
11073 Make_Temporary_For_Slice;
11076 elsif Nkind (Parent (N)) = N_Assignment_Statement
11077 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
11078 and then Parent (N) = Name (Parent (Parent (N))))
11082 elsif Nkind (Parent (N)) = N_Indexed_Component
11083 or else Is_Renamed_Object (N)
11084 or else Is_Procedure_Actual (N)
11088 elsif Nkind (Parent (N)) = N_Attribute_Reference
11089 and then (Attribute_Name (Parent (N)) = Name_Address
11090 or else Attribute_Name (Parent (N)) = Name_Size)
11095 Make_Temporary_For_Slice;
11097 end Expand_N_Slice;
11099 ------------------------------
11100 -- Expand_N_Type_Conversion --
11101 ------------------------------
11103 procedure Expand_N_Type_Conversion (N : Node_Id) is
11104 Loc : constant Source_Ptr := Sloc (N);
11105 Operand : constant Node_Id := Expression (N);
11106 Operand_Acc : Node_Id := Operand;
11107 Target_Type : Entity_Id := Etype (N);
11108 Operand_Type : Entity_Id := Etype (Operand);
11110 procedure Discrete_Range_Check;
11111 -- Handles generation of range check for discrete target value
11113 procedure Handle_Changed_Representation;
11114 -- This is called in the case of record and array type conversions to
11115 -- see if there is a change of representation to be handled. Change of
11116 -- representation is actually handled at the assignment statement level,
11117 -- and what this procedure does is rewrite node N conversion as an
11118 -- assignment to temporary. If there is no change of representation,
11119 -- then the conversion node is unchanged.
11121 procedure Raise_Accessibility_Error;
11122 -- Called when we know that an accessibility check will fail. Rewrites
11123 -- node N to an appropriate raise statement and outputs warning msgs.
11124 -- The Etype of the raise node is set to Target_Type. Note that in this
11125 -- case the rest of the processing should be skipped (i.e. the call to
11126 -- this procedure will be followed by "goto Done").
11128 procedure Real_Range_Check;
11129 -- Handles generation of range check for real target value
11131 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
11132 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11133 -- evaluates to True.
11135 --------------------------
11136 -- Discrete_Range_Check --
11137 --------------------------
11139 -- Case of conversions to a discrete type. We let Generate_Range_Check
11140 -- do the heavy lifting, after converting a fixed-point operand to an
11141 -- appropriate integer type.
11143 procedure Discrete_Range_Check is
11147 procedure Generate_Temporary;
11148 -- Generate a temporary to facilitate in the C backend the code
11149 -- generation of the unchecked conversion since the size of the
11150 -- source type may differ from the size of the target type.
11152 ------------------------
11153 -- Generate_Temporary --
11154 ------------------------
11156 procedure Generate_Temporary is
11158 if Esize (Etype (Expr)) < Esize (Etype (Ityp)) then
11160 Exp_Type : constant Entity_Id := Ityp;
11161 Def_Id : constant Entity_Id :=
11162 Make_Temporary (Loc, 'R', Expr);
11167 Set_Is_Internal (Def_Id);
11168 Set_Etype (Def_Id, Exp_Type);
11169 Res := New_Occurrence_Of (Def_Id, Loc);
11172 Make_Object_Declaration (Loc,
11173 Defining_Identifier => Def_Id,
11174 Object_Definition => New_Occurrence_Of
11176 Constant_Present => True,
11177 Expression => Relocate_Node (Expr));
11179 Set_Assignment_OK (E);
11180 Insert_Action (Expr, E);
11182 Set_Assignment_OK (Res, Assignment_OK (Expr));
11184 Rewrite (Expr, Res);
11185 Analyze_And_Resolve (Expr, Exp_Type);
11188 end Generate_Temporary;
11190 -- Start of processing for Discrete_Range_Check
11193 -- Nothing to do if conversion was rewritten
11195 if Nkind (N) /= N_Type_Conversion then
11199 Expr := Expression (N);
11201 -- Nothing to do if range checks suppressed
11203 if Range_Checks_Suppressed (Target_Type) then
11207 -- Nothing to do if expression is an entity on which checks have been
11210 if Is_Entity_Name (Expr)
11211 and then Range_Checks_Suppressed (Entity (Expr))
11216 -- Before we do a range check, we have to deal with treating
11217 -- a fixed-point operand as an integer. The way we do this
11218 -- is simply to do an unchecked conversion to an appropriate
11219 -- integer type large enough to hold the result.
11221 if Is_Fixed_Point_Type (Etype (Expr)) then
11222 if Esize (Base_Type (Etype (Expr))) > Esize (Standard_Integer) then
11223 Ityp := Standard_Long_Long_Integer;
11225 Ityp := Standard_Integer;
11228 -- Generate a temporary with the large type to facilitate in the C
11229 -- backend the code generation for the unchecked conversion.
11231 if Modify_Tree_For_C then
11232 Generate_Temporary;
11235 Set_Do_Range_Check (Expr, False);
11236 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11239 -- Reset overflow flag, since the range check will include
11240 -- dealing with possible overflow, and generate the check.
11242 Set_Do_Overflow_Check (N, False);
11244 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed);
11245 end Discrete_Range_Check;
11247 -----------------------------------
11248 -- Handle_Changed_Representation --
11249 -----------------------------------
11251 procedure Handle_Changed_Representation is
11259 -- Nothing else to do if no change of representation
11261 if Same_Representation (Operand_Type, Target_Type) then
11264 -- The real change of representation work is done by the assignment
11265 -- statement processing. So if this type conversion is appearing as
11266 -- the expression of an assignment statement, nothing needs to be
11267 -- done to the conversion.
11269 elsif Nkind (Parent (N)) = N_Assignment_Statement then
11272 -- Otherwise we need to generate a temporary variable, and do the
11273 -- change of representation assignment into that temporary variable.
11274 -- The conversion is then replaced by a reference to this variable.
11279 -- If type is unconstrained we have to add a constraint, copied
11280 -- from the actual value of the left-hand side.
11282 if not Is_Constrained (Target_Type) then
11283 if Has_Discriminants (Operand_Type) then
11285 -- A change of representation can only apply to untagged
11286 -- types. We need to build the constraint that applies to
11287 -- the target type, using the constraints of the operand.
11288 -- The analysis is complicated if there are both inherited
11289 -- discriminants and constrained discriminants.
11290 -- We iterate over the discriminants of the target, and
11291 -- find the discriminant of the same name:
11293 -- a) If there is a corresponding discriminant in the object
11294 -- then the value is a selected component of the operand.
11296 -- b) Otherwise the value of a constrained discriminant is
11297 -- found in the stored constraint of the operand.
11300 Stored : constant Elist_Id :=
11301 Stored_Constraint (Operand_Type);
11305 Disc_O : Entity_Id;
11306 -- Discriminant of the operand type. Its value in the
11307 -- object is captured in a selected component.
11309 Disc_S : Entity_Id;
11310 -- Stored discriminant of the operand. If present, it
11311 -- corresponds to a constrained discriminant of the
11314 Disc_T : Entity_Id;
11315 -- Discriminant of the target type
11318 Disc_T := First_Discriminant (Target_Type);
11319 Disc_O := First_Discriminant (Operand_Type);
11320 Disc_S := First_Stored_Discriminant (Operand_Type);
11322 if Present (Stored) then
11323 Elmt := First_Elmt (Stored);
11325 Elmt := No_Elmt; -- init to avoid warning
11329 while Present (Disc_T) loop
11330 if Present (Disc_O)
11331 and then Chars (Disc_T) = Chars (Disc_O)
11334 Make_Selected_Component (Loc,
11336 Duplicate_Subexpr_Move_Checks (Operand),
11338 Make_Identifier (Loc, Chars (Disc_O))));
11339 Next_Discriminant (Disc_O);
11341 elsif Present (Disc_S) then
11342 Append_To (Cons, New_Copy_Tree (Node (Elmt)));
11346 Next_Discriminant (Disc_T);
11350 elsif Is_Array_Type (Operand_Type) then
11351 N_Ix := First_Index (Target_Type);
11354 for J in 1 .. Number_Dimensions (Operand_Type) loop
11356 -- We convert the bounds explicitly. We use an unchecked
11357 -- conversion because bounds checks are done elsewhere.
11362 Unchecked_Convert_To (Etype (N_Ix),
11363 Make_Attribute_Reference (Loc,
11365 Duplicate_Subexpr_No_Checks
11366 (Operand, Name_Req => True),
11367 Attribute_Name => Name_First,
11368 Expressions => New_List (
11369 Make_Integer_Literal (Loc, J)))),
11372 Unchecked_Convert_To (Etype (N_Ix),
11373 Make_Attribute_Reference (Loc,
11375 Duplicate_Subexpr_No_Checks
11376 (Operand, Name_Req => True),
11377 Attribute_Name => Name_Last,
11378 Expressions => New_List (
11379 Make_Integer_Literal (Loc, J))))));
11386 Odef := New_Occurrence_Of (Target_Type, Loc);
11388 if Present (Cons) then
11390 Make_Subtype_Indication (Loc,
11391 Subtype_Mark => Odef,
11393 Make_Index_Or_Discriminant_Constraint (Loc,
11394 Constraints => Cons));
11397 Temp := Make_Temporary (Loc, 'C');
11399 Make_Object_Declaration (Loc,
11400 Defining_Identifier => Temp,
11401 Object_Definition => Odef);
11403 Set_No_Initialization (Decl, True);
11405 -- Insert required actions. It is essential to suppress checks
11406 -- since we have suppressed default initialization, which means
11407 -- that the variable we create may have no discriminants.
11412 Make_Assignment_Statement (Loc,
11413 Name => New_Occurrence_Of (Temp, Loc),
11414 Expression => Relocate_Node (N))),
11415 Suppress => All_Checks);
11417 Rewrite (N, New_Occurrence_Of (Temp, Loc));
11420 end Handle_Changed_Representation;
11422 -------------------------------
11423 -- Raise_Accessibility_Error --
11424 -------------------------------
11426 procedure Raise_Accessibility_Error is
11428 Error_Msg_Warn := SPARK_Mode /= On;
11430 Make_Raise_Program_Error (Sloc (N),
11431 Reason => PE_Accessibility_Check_Failed));
11432 Set_Etype (N, Target_Type);
11434 Error_Msg_N ("<<accessibility check failure", N);
11435 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
11436 end Raise_Accessibility_Error;
11438 ----------------------
11439 -- Real_Range_Check --
11440 ----------------------
11442 -- Case of conversions to floating-point or fixed-point. If range checks
11443 -- are enabled and the target type has a range constraint, we convert:
11449 -- Tnn : typ'Base := typ'Base (x);
11450 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11453 -- This is necessary when there is a conversion of integer to float or
11454 -- to fixed-point to ensure that the correct checks are made. It is not
11455 -- necessary for the float-to-float case where it is enough to just set
11456 -- the Do_Range_Check flag on the expression.
11458 procedure Real_Range_Check is
11459 Btyp : constant Entity_Id := Base_Type (Target_Type);
11460 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
11461 Hi : constant Node_Id := Type_High_Bound (Target_Type);
11472 -- Nothing to do if conversion was rewritten
11474 if Nkind (N) /= N_Type_Conversion then
11478 Expr := Expression (N);
11480 -- Clear the flag once for all
11482 Set_Do_Range_Check (Expr, False);
11484 -- Nothing to do if range checks suppressed, or target has the same
11485 -- range as the base type (or is the base type).
11487 if Range_Checks_Suppressed (Target_Type)
11488 or else (Lo = Type_Low_Bound (Btyp)
11490 Hi = Type_High_Bound (Btyp))
11495 -- Nothing to do if expression is an entity on which checks have been
11498 if Is_Entity_Name (Expr)
11499 and then Range_Checks_Suppressed (Entity (Expr))
11504 -- Nothing to do if expression was rewritten into a float-to-float
11505 -- conversion, since this kind of conversion is handled elsewhere.
11507 if Is_Floating_Point_Type (Etype (Expr))
11508 and then Is_Floating_Point_Type (Target_Type)
11513 -- Nothing to do if bounds are all static and we can tell that the
11514 -- expression is within the bounds of the target. Note that if the
11515 -- operand is of an unconstrained floating-point type, then we do
11516 -- not trust it to be in range (might be infinite)
11519 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr));
11520 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr));
11523 if (not Is_Floating_Point_Type (Etype (Expr))
11524 or else Is_Constrained (Etype (Expr)))
11525 and then Compile_Time_Known_Value (S_Lo)
11526 and then Compile_Time_Known_Value (S_Hi)
11527 and then Compile_Time_Known_Value (Hi)
11528 and then Compile_Time_Known_Value (Lo)
11531 D_Lov : constant Ureal := Expr_Value_R (Lo);
11532 D_Hiv : constant Ureal := Expr_Value_R (Hi);
11537 if Is_Real_Type (Etype (Expr)) then
11538 S_Lov := Expr_Value_R (S_Lo);
11539 S_Hiv := Expr_Value_R (S_Hi);
11541 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
11542 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
11546 and then S_Lov >= D_Lov
11547 and then S_Hiv <= D_Hiv
11555 -- Otherwise rewrite the conversion as described above
11557 Conv := Convert_To (Btyp, Expr);
11559 -- If a conversion is necessary, then copy the specific flags from
11560 -- the original one and also move the Do_Overflow_Check flag since
11561 -- this new conversion is to the base type.
11563 if Nkind (Conv) = N_Type_Conversion then
11564 Set_Conversion_OK (Conv, Conversion_OK (N));
11565 Set_Float_Truncate (Conv, Float_Truncate (N));
11566 Set_Rounded_Result (Conv, Rounded_Result (N));
11568 if Do_Overflow_Check (N) then
11569 Set_Do_Overflow_Check (Conv);
11570 Set_Do_Overflow_Check (N, False);
11574 Tnn := Make_Temporary (Loc, 'T', Conv);
11576 -- For a conversion from Float to Fixed where the bounds of the
11577 -- fixed-point type are static, we can obtain a more accurate
11578 -- fixed-point value by converting the result of the floating-
11579 -- point expression to an appropriate integer type, and then
11580 -- performing an unchecked conversion to the target fixed-point
11581 -- type. The range check can then use the corresponding integer
11582 -- value of the bounds instead of requiring further conversions.
11583 -- This preserves the identity:
11585 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11587 -- which used to fail when Fix_Val was a bound of the type and
11588 -- the 'Small was not a representable number.
11589 -- This transformation requires an integer type large enough to
11590 -- accommodate a fixed-point value. This will not be the case
11591 -- in systems where Duration is larger than Long_Integer.
11593 if Is_Ordinary_Fixed_Point_Type (Target_Type)
11594 and then Is_Floating_Point_Type (Etype (Expr))
11595 and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer)
11596 and then Nkind (Lo) = N_Real_Literal
11597 and then Nkind (Hi) = N_Real_Literal
11600 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
11601 Int_Type : Entity_Id;
11604 -- Find an integer type of the appropriate size to perform an
11605 -- unchecked conversion to the target fixed-point type.
11607 if RM_Size (Btyp) > RM_Size (Standard_Integer) then
11608 Int_Type := Standard_Long_Integer;
11610 elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then
11611 Int_Type := Standard_Integer;
11614 Int_Type := Standard_Short_Integer;
11617 -- Generate a temporary with the integer value. Required in the
11618 -- CCG compiler to ensure that run-time checks reference this
11619 -- integer expression (instead of the resulting fixed-point
11620 -- value because fixed-point values are handled by means of
11621 -- unsigned integer types).
11624 Make_Object_Declaration (Loc,
11625 Defining_Identifier => Expr_Id,
11626 Object_Definition => New_Occurrence_Of (Int_Type, Loc),
11627 Constant_Present => True,
11629 Convert_To (Int_Type, Expression (Conv))));
11631 -- Create integer objects for range checking of result.
11634 Unchecked_Convert_To
11635 (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
11638 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
11641 Unchecked_Convert_To
11642 (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
11645 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
11647 -- Rewrite conversion as an integer conversion of the
11648 -- original floating-point expression, followed by an
11649 -- unchecked conversion to the target fixed-point type.
11652 Make_Unchecked_Type_Conversion (Loc,
11653 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
11654 Expression => New_Occurrence_Of (Expr_Id, Loc));
11657 -- All other conversions
11660 Lo_Arg := New_Occurrence_Of (Tnn, Loc);
11662 Make_Attribute_Reference (Loc,
11663 Prefix => New_Occurrence_Of (Target_Type, Loc),
11664 Attribute_Name => Name_First);
11666 Hi_Arg := New_Occurrence_Of (Tnn, Loc);
11668 Make_Attribute_Reference (Loc,
11669 Prefix => New_Occurrence_Of (Target_Type, Loc),
11670 Attribute_Name => Name_Last);
11673 -- Build code for range checking. Note that checks are suppressed
11674 -- here since we don't want a recursive range check popping up.
11676 Insert_Actions (N, New_List (
11677 Make_Object_Declaration (Loc,
11678 Defining_Identifier => Tnn,
11679 Object_Definition => New_Occurrence_Of (Btyp, Loc),
11680 Constant_Present => True,
11681 Expression => Conv),
11683 Make_Raise_Constraint_Error (Loc,
11688 Left_Opnd => Lo_Arg,
11689 Right_Opnd => Lo_Val),
11693 Left_Opnd => Hi_Arg,
11694 Right_Opnd => Hi_Val)),
11695 Reason => CE_Range_Check_Failed)),
11696 Suppress => All_Checks);
11698 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
11699 end Real_Range_Check;
11701 -----------------------------
11702 -- Has_Extra_Accessibility --
11703 -----------------------------
11705 -- Returns true for a formal of an anonymous access type or for an Ada
11706 -- 2012-style stand-alone object of an anonymous access type.
11708 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
11710 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
11711 return Present (Effective_Extra_Accessibility (Id));
11715 end Has_Extra_Accessibility;
11717 -- Start of processing for Expand_N_Type_Conversion
11720 -- First remove check marks put by the semantic analysis on the type
11721 -- conversion between array types. We need these checks, and they will
11722 -- be generated by this expansion routine, but we do not depend on these
11723 -- flags being set, and since we do intend to expand the checks in the
11724 -- front end, we don't want them on the tree passed to the back end.
11726 if Is_Array_Type (Target_Type) then
11727 if Is_Constrained (Target_Type) then
11728 Set_Do_Length_Check (N, False);
11730 Set_Do_Range_Check (Operand, False);
11734 -- Nothing at all to do if conversion is to the identical type so remove
11735 -- the conversion completely, it is useless, except that it may carry
11736 -- an Assignment_OK attribute, which must be propagated to the operand.
11738 if Operand_Type = Target_Type then
11739 if Assignment_OK (N) then
11740 Set_Assignment_OK (Operand);
11743 Rewrite (N, Relocate_Node (Operand));
11747 -- Nothing to do if this is the second argument of read. This is a
11748 -- "backwards" conversion that will be handled by the specialized code
11749 -- in attribute processing.
11751 if Nkind (Parent (N)) = N_Attribute_Reference
11752 and then Attribute_Name (Parent (N)) = Name_Read
11753 and then Next (First (Expressions (Parent (N)))) = N
11758 -- Check for case of converting to a type that has an invariant
11759 -- associated with it. This requires an invariant check. We insert
11762 -- invariant_check (typ (expr))
11764 -- in the code, after removing side effects from the expression.
11765 -- This is clearer than replacing the conversion into an expression
11766 -- with actions, because the context may impose additional actions
11767 -- (tag checks, membership tests, etc.) that conflict with this
11768 -- rewriting (used previously).
11770 -- Note: the Comes_From_Source check, and then the resetting of this
11771 -- flag prevents what would otherwise be an infinite recursion.
11773 if Has_Invariants (Target_Type)
11774 and then Present (Invariant_Procedure (Target_Type))
11775 and then Comes_From_Source (N)
11777 Set_Comes_From_Source (N, False);
11778 Remove_Side_Effects (N);
11779 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
11783 -- Here if we may need to expand conversion
11785 -- If the operand of the type conversion is an arithmetic operation on
11786 -- signed integers, and the based type of the signed integer type in
11787 -- question is smaller than Standard.Integer, we promote both of the
11788 -- operands to type Integer.
11790 -- For example, if we have
11792 -- target-type (opnd1 + opnd2)
11794 -- and opnd1 and opnd2 are of type short integer, then we rewrite
11797 -- target-type (integer(opnd1) + integer(opnd2))
11799 -- We do this because we are always allowed to compute in a larger type
11800 -- if we do the right thing with the result, and in this case we are
11801 -- going to do a conversion which will do an appropriate check to make
11802 -- sure that things are in range of the target type in any case. This
11803 -- avoids some unnecessary intermediate overflows.
11805 -- We might consider a similar transformation in the case where the
11806 -- target is a real type or a 64-bit integer type, and the operand
11807 -- is an arithmetic operation using a 32-bit integer type. However,
11808 -- we do not bother with this case, because it could cause significant
11809 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
11810 -- much cheaper, but we don't want different behavior on 32-bit and
11811 -- 64-bit machines. Note that the exclusion of the 64-bit case also
11812 -- handles the configurable run-time cases where 64-bit arithmetic
11813 -- may simply be unavailable.
11815 -- Note: this circuit is partially redundant with respect to the circuit
11816 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
11817 -- the processing here. Also we still need the Checks circuit, since we
11818 -- have to be sure not to generate junk overflow checks in the first
11819 -- place, since it would be trick to remove them here.
11821 if Integer_Promotion_Possible (N) then
11823 -- All conditions met, go ahead with transformation
11831 Make_Type_Conversion (Loc,
11832 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
11833 Expression => Relocate_Node (Right_Opnd (Operand)));
11835 Opnd := New_Op_Node (Nkind (Operand), Loc);
11836 Set_Right_Opnd (Opnd, R);
11838 if Nkind (Operand) in N_Binary_Op then
11840 Make_Type_Conversion (Loc,
11841 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
11842 Expression => Relocate_Node (Left_Opnd (Operand)));
11844 Set_Left_Opnd (Opnd, L);
11848 Make_Type_Conversion (Loc,
11849 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
11850 Expression => Opnd));
11852 Analyze_And_Resolve (N, Target_Type);
11857 -- Do validity check if validity checking operands
11859 if Validity_Checks_On and Validity_Check_Operands then
11860 Ensure_Valid (Operand);
11863 -- Special case of converting from non-standard boolean type
11865 if Is_Boolean_Type (Operand_Type)
11866 and then (Nonzero_Is_True (Operand_Type))
11868 Adjust_Condition (Operand);
11869 Set_Etype (Operand, Standard_Boolean);
11870 Operand_Type := Standard_Boolean;
11873 -- Case of converting to an access type
11875 if Is_Access_Type (Target_Type) then
11876 -- In terms of accessibility rules, an anonymous access discriminant
11877 -- is not considered separate from its parent object.
11879 if Nkind (Operand) = N_Selected_Component
11880 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
11881 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
11883 Operand_Acc := Original_Node (Prefix (Operand));
11886 -- If this type conversion was internally generated by the front end
11887 -- to displace the pointer to the object to reference an interface
11888 -- type and the original node was an Unrestricted_Access attribute,
11889 -- then skip applying accessibility checks (because, according to the
11890 -- GNAT Reference Manual, this attribute is similar to 'Access except
11891 -- that all accessibility and aliased view checks are omitted).
11893 if not Comes_From_Source (N)
11894 and then Is_Interface (Designated_Type (Target_Type))
11895 and then Nkind (Original_Node (N)) = N_Attribute_Reference
11896 and then Attribute_Name (Original_Node (N)) =
11897 Name_Unrestricted_Access
11901 -- Apply an accessibility check when the conversion operand is an
11902 -- access parameter (or a renaming thereof), unless conversion was
11903 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
11904 -- or for the actual of a class-wide interface parameter. Note that
11905 -- other checks may still need to be applied below (such as tagged
11908 elsif Is_Entity_Name (Operand_Acc)
11909 and then Has_Extra_Accessibility (Entity (Operand_Acc))
11910 and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
11911 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
11912 or else Attribute_Name (Original_Node (N)) = Name_Access)
11914 if not Comes_From_Source (N)
11915 and then Nkind_In (Parent (N), N_Function_Call,
11916 N_Parameter_Association,
11917 N_Procedure_Call_Statement)
11918 and then Is_Interface (Designated_Type (Target_Type))
11919 and then Is_Class_Wide_Type (Designated_Type (Target_Type))
11924 Apply_Accessibility_Check
11925 (Operand_Acc, Target_Type, Insert_Node => Operand);
11928 -- If the level of the operand type is statically deeper than the
11929 -- level of the target type, then force Program_Error. Note that this
11930 -- can only occur for cases where the attribute is within the body of
11931 -- an instantiation, otherwise the conversion will already have been
11932 -- rejected as illegal.
11934 -- Note: warnings are issued by the analyzer for the instance cases
11936 elsif In_Instance_Body
11938 -- The case where the target type is an anonymous access type of
11939 -- a discriminant is excluded, because the level of such a type
11940 -- depends on the context and currently the level returned for such
11941 -- types is zero, resulting in warnings about check failures
11942 -- in certain legal cases involving class-wide interfaces as the
11943 -- designated type (some cases, such as return statements, are
11944 -- checked at run time, but not clear if these are handled right
11945 -- in general, see 3.10.2(12/2-12.5/3) ???).
11948 not (Ekind (Target_Type) = E_Anonymous_Access_Type
11949 and then Present (Associated_Node_For_Itype (Target_Type))
11950 and then Nkind (Associated_Node_For_Itype (Target_Type)) =
11951 N_Discriminant_Specification)
11953 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
11955 Raise_Accessibility_Error;
11958 -- When the operand is a selected access discriminant the check needs
11959 -- to be made against the level of the object denoted by the prefix
11960 -- of the selected name. Force Program_Error for this case as well
11961 -- (this accessibility violation can only happen if within the body
11962 -- of an instantiation).
11964 elsif In_Instance_Body
11965 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
11966 and then Nkind (Operand) = N_Selected_Component
11967 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
11968 and then Object_Access_Level (Operand) >
11969 Type_Access_Level (Target_Type)
11971 Raise_Accessibility_Error;
11976 -- Case of conversions of tagged types and access to tagged types
11978 -- When needed, that is to say when the expression is class-wide, Add
11979 -- runtime a tag check for (strict) downward conversion by using the
11980 -- membership test, generating:
11982 -- [constraint_error when Operand not in Target_Type'Class]
11984 -- or in the access type case
11986 -- [constraint_error
11987 -- when Operand /= null
11988 -- and then Operand.all not in
11989 -- Designated_Type (Target_Type)'Class]
11991 if (Is_Access_Type (Target_Type)
11992 and then Is_Tagged_Type (Designated_Type (Target_Type)))
11993 or else Is_Tagged_Type (Target_Type)
11995 -- Do not do any expansion in the access type case if the parent is a
11996 -- renaming, since this is an error situation which will be caught by
11997 -- Sem_Ch8, and the expansion can interfere with this error check.
11999 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
12003 -- Otherwise, proceed with processing tagged conversion
12005 Tagged_Conversion : declare
12006 Actual_Op_Typ : Entity_Id;
12007 Actual_Targ_Typ : Entity_Id;
12008 Make_Conversion : Boolean := False;
12009 Root_Op_Typ : Entity_Id;
12011 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
12012 -- Create a membership check to test whether Operand is a member
12013 -- of Targ_Typ. If the original Target_Type is an access, include
12014 -- a test for null value. The check is inserted at N.
12016 --------------------
12017 -- Make_Tag_Check --
12018 --------------------
12020 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
12025 -- [Constraint_Error
12026 -- when Operand /= null
12027 -- and then Operand.all not in Targ_Typ]
12029 if Is_Access_Type (Target_Type) then
12031 Make_And_Then (Loc,
12034 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12035 Right_Opnd => Make_Null (Loc)),
12040 Make_Explicit_Dereference (Loc,
12041 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
12042 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
12045 -- [Constraint_Error when Operand not in Targ_Typ]
12050 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12051 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
12055 Make_Raise_Constraint_Error (Loc,
12057 Reason => CE_Tag_Check_Failed),
12058 Suppress => All_Checks);
12059 end Make_Tag_Check;
12061 -- Start of processing for Tagged_Conversion
12064 -- Handle entities from the limited view
12066 if Is_Access_Type (Operand_Type) then
12068 Available_View (Designated_Type (Operand_Type));
12070 Actual_Op_Typ := Operand_Type;
12073 if Is_Access_Type (Target_Type) then
12075 Available_View (Designated_Type (Target_Type));
12077 Actual_Targ_Typ := Target_Type;
12080 Root_Op_Typ := Root_Type (Actual_Op_Typ);
12082 -- Ada 2005 (AI-251): Handle interface type conversion
12084 if Is_Interface (Actual_Op_Typ)
12086 Is_Interface (Actual_Targ_Typ)
12088 Expand_Interface_Conversion (N);
12092 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
12094 -- Create a runtime tag check for a downward class-wide type
12097 if Is_Class_Wide_Type (Actual_Op_Typ)
12098 and then Actual_Op_Typ /= Actual_Targ_Typ
12099 and then Root_Op_Typ /= Actual_Targ_Typ
12100 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
12101 Use_Full_View => True)
12103 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
12104 Make_Conversion := True;
12107 -- AI05-0073: If the result subtype of the function is defined
12108 -- by an access_definition designating a specific tagged type
12109 -- T, a check is made that the result value is null or the tag
12110 -- of the object designated by the result value identifies T.
12111 -- Constraint_Error is raised if this check fails.
12113 if Nkind (Parent (N)) = N_Simple_Return_Statement then
12116 Func_Typ : Entity_Id;
12119 -- Climb scope stack looking for the enclosing function
12121 Func := Current_Scope;
12122 while Present (Func)
12123 and then Ekind (Func) /= E_Function
12125 Func := Scope (Func);
12128 -- The function's return subtype must be defined using
12129 -- an access definition.
12131 if Nkind (Result_Definition (Parent (Func))) =
12132 N_Access_Definition
12134 Func_Typ := Directly_Designated_Type (Etype (Func));
12136 -- The return subtype denotes a specific tagged type,
12137 -- in other words, a non class-wide type.
12139 if Is_Tagged_Type (Func_Typ)
12140 and then not Is_Class_Wide_Type (Func_Typ)
12142 Make_Tag_Check (Actual_Targ_Typ);
12143 Make_Conversion := True;
12149 -- We have generated a tag check for either a class-wide type
12150 -- conversion or for AI05-0073.
12152 if Make_Conversion then
12157 Make_Unchecked_Type_Conversion (Loc,
12158 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
12159 Expression => Relocate_Node (Expression (N)));
12161 Analyze_And_Resolve (N, Target_Type);
12165 end Tagged_Conversion;
12167 -- Case of other access type conversions
12169 elsif Is_Access_Type (Target_Type) then
12170 Apply_Constraint_Check (Operand, Target_Type);
12172 -- Case of conversions from a fixed-point type
12174 -- These conversions require special expansion and processing, found in
12175 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12176 -- since from a semantic point of view, these are simple integer
12177 -- conversions, which do not need further processing.
12179 elsif Is_Fixed_Point_Type (Operand_Type)
12180 and then not Conversion_OK (N)
12182 -- We should never see universal fixed at this case, since the
12183 -- expansion of the constituent divide or multiply should have
12184 -- eliminated the explicit mention of universal fixed.
12186 pragma Assert (Operand_Type /= Universal_Fixed);
12188 -- Check for special case of the conversion to universal real that
12189 -- occurs as a result of the use of a round attribute. In this case,
12190 -- the real type for the conversion is taken from the target type of
12191 -- the Round attribute and the result must be marked as rounded.
12193 if Target_Type = Universal_Real
12194 and then Nkind (Parent (N)) = N_Attribute_Reference
12195 and then Attribute_Name (Parent (N)) = Name_Round
12197 Set_Rounded_Result (N);
12198 Set_Etype (N, Etype (Parent (N)));
12199 Target_Type := Etype (N);
12202 if Is_Fixed_Point_Type (Target_Type) then
12203 Expand_Convert_Fixed_To_Fixed (N);
12206 elsif Is_Integer_Type (Target_Type) then
12207 Expand_Convert_Fixed_To_Integer (N);
12208 Discrete_Range_Check;
12211 pragma Assert (Is_Floating_Point_Type (Target_Type));
12212 Expand_Convert_Fixed_To_Float (N);
12216 -- Case of conversions to a fixed-point type
12218 -- These conversions require special expansion and processing, found in
12219 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12220 -- since from a semantic point of view, these are simple integer
12221 -- conversions, which do not need further processing.
12223 elsif Is_Fixed_Point_Type (Target_Type)
12224 and then not Conversion_OK (N)
12226 if Is_Integer_Type (Operand_Type) then
12227 Expand_Convert_Integer_To_Fixed (N);
12230 pragma Assert (Is_Floating_Point_Type (Operand_Type));
12231 Expand_Convert_Float_To_Fixed (N);
12235 -- Case of array conversions
12237 -- Expansion of array conversions, add required length/range checks but
12238 -- only do this if there is no change of representation. For handling of
12239 -- this case, see Handle_Changed_Representation.
12241 elsif Is_Array_Type (Target_Type) then
12242 if Is_Constrained (Target_Type) then
12243 Apply_Length_Check (Operand, Target_Type);
12245 Apply_Range_Check (Operand, Target_Type);
12248 Handle_Changed_Representation;
12250 -- Case of conversions of discriminated types
12252 -- Add required discriminant checks if target is constrained. Again this
12253 -- change is skipped if we have a change of representation.
12255 elsif Has_Discriminants (Target_Type)
12256 and then Is_Constrained (Target_Type)
12258 Apply_Discriminant_Check (Operand, Target_Type);
12259 Handle_Changed_Representation;
12261 -- Case of all other record conversions. The only processing required
12262 -- is to check for a change of representation requiring the special
12263 -- assignment processing.
12265 elsif Is_Record_Type (Target_Type) then
12267 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12268 -- a derived Unchecked_Union type to an unconstrained type that is
12269 -- not Unchecked_Union if the operand lacks inferable discriminants.
12271 if Is_Derived_Type (Operand_Type)
12272 and then Is_Unchecked_Union (Base_Type (Operand_Type))
12273 and then not Is_Constrained (Target_Type)
12274 and then not Is_Unchecked_Union (Base_Type (Target_Type))
12275 and then not Has_Inferable_Discriminants (Operand)
12277 -- To prevent Gigi from generating illegal code, we generate a
12278 -- Program_Error node, but we give it the target type of the
12279 -- conversion (is this requirement documented somewhere ???)
12282 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
12283 Reason => PE_Unchecked_Union_Restriction);
12286 Set_Etype (PE, Target_Type);
12291 Handle_Changed_Representation;
12294 -- Case of conversions of enumeration types
12296 elsif Is_Enumeration_Type (Target_Type) then
12298 -- Special processing is required if there is a change of
12299 -- representation (from enumeration representation clauses).
12301 if not Same_Representation (Target_Type, Operand_Type) then
12303 -- Convert: x(y) to x'val (ytyp'val (y))
12306 Make_Attribute_Reference (Loc,
12307 Prefix => New_Occurrence_Of (Target_Type, Loc),
12308 Attribute_Name => Name_Val,
12309 Expressions => New_List (
12310 Make_Attribute_Reference (Loc,
12311 Prefix => New_Occurrence_Of (Operand_Type, Loc),
12312 Attribute_Name => Name_Pos,
12313 Expressions => New_List (Operand)))));
12315 Analyze_And_Resolve (N, Target_Type);
12319 -- At this stage, either the conversion node has been transformed into
12320 -- some other equivalent expression, or left as a conversion that can be
12321 -- handled by Gigi, in the following cases:
12323 -- Conversions with no change of representation or type
12325 -- Numeric conversions involving integer, floating- and fixed-point
12326 -- values. Fixed-point values are allowed only if Conversion_OK is
12327 -- set, i.e. if the fixed-point values are to be treated as integers.
12329 -- No other conversions should be passed to Gigi
12331 -- Check: are these rules stated in sinfo??? if so, why restate here???
12333 -- The only remaining step is to generate a range check if we still have
12334 -- a type conversion at this stage and Do_Range_Check is set. Note that
12335 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12336 -- conversions here, because the float-to-integer case is entirely dealt
12337 -- with by Apply_Float_Conversion_Check.
12339 if Nkind (N) = N_Type_Conversion
12340 and then Do_Range_Check (Expression (N))
12342 -- Float-to-float conversions
12344 if Is_Floating_Point_Type (Target_Type)
12345 and then Is_Floating_Point_Type (Etype (Expression (N)))
12347 -- Reset overflow flag, since the range check will include
12348 -- dealing with possible overflow, and generate the check.
12350 Set_Do_Overflow_Check (N, False);
12352 Generate_Range_Check
12353 (Expression (N), Target_Type, CE_Range_Check_Failed);
12355 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12356 -- conversions when Conversion_OK is set.
12358 elsif Is_Discrete_Type (Target_Type)
12359 and then (Is_Discrete_Type (Etype (Expression (N)))
12360 or else (Is_Fixed_Point_Type (Etype (Expression (N)))
12361 and then Conversion_OK (N)))
12363 -- If Address is either a source type or target type,
12364 -- suppress range check to avoid typing anomalies when
12365 -- it is a visible integer type.
12367 if Is_Descendant_Of_Address (Etype (Expression (N)))
12368 or else Is_Descendant_Of_Address (Target_Type)
12370 Set_Do_Range_Check (Expression (N), False);
12372 Discrete_Range_Check;
12375 -- Conversions to floating- or fixed-point when Conversion_OK is set
12377 elsif Is_Floating_Point_Type (Target_Type)
12378 or else (Is_Fixed_Point_Type (Target_Type)
12379 and then Conversion_OK (N))
12385 -- Here at end of processing
12388 -- Apply predicate check if required. Note that we can't just call
12389 -- Apply_Predicate_Check here, because the type looks right after
12390 -- the conversion and it would omit the check. The Comes_From_Source
12391 -- guard is necessary to prevent infinite recursions when we generate
12392 -- internal conversions for the purpose of checking predicates.
12394 if Present (Predicate_Function (Target_Type))
12395 and then not Predicates_Ignored (Target_Type)
12396 and then Target_Type /= Operand_Type
12397 and then Comes_From_Source (N)
12400 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
12403 -- Avoid infinite recursion on the subsequent expansion of
12404 -- of the copy of the original type conversion. When needed,
12405 -- a range check has already been applied to the expression.
12407 Set_Comes_From_Source (New_Expr, False);
12409 Make_Predicate_Check (Target_Type, New_Expr),
12410 Suppress => Range_Check);
12413 end Expand_N_Type_Conversion;
12415 -----------------------------------
12416 -- Expand_N_Unchecked_Expression --
12417 -----------------------------------
12419 -- Remove the unchecked expression node from the tree. Its job was simply
12420 -- to make sure that its constituent expression was handled with checks
12421 -- off, and now that is done, we can remove it from the tree, and indeed
12422 -- must, since Gigi does not expect to see these nodes.
12424 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
12425 Exp : constant Node_Id := Expression (N);
12427 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
12429 end Expand_N_Unchecked_Expression;
12431 ----------------------------------------
12432 -- Expand_N_Unchecked_Type_Conversion --
12433 ----------------------------------------
12435 -- If this cannot be handled by Gigi and we haven't already made a
12436 -- temporary for it, do it now.
12438 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
12439 Target_Type : constant Entity_Id := Etype (N);
12440 Operand : constant Node_Id := Expression (N);
12441 Operand_Type : constant Entity_Id := Etype (Operand);
12444 -- Nothing at all to do if conversion is to the identical type so remove
12445 -- the conversion completely, it is useless, except that it may carry
12446 -- an Assignment_OK indication which must be propagated to the operand.
12448 if Operand_Type = Target_Type then
12450 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12452 if Assignment_OK (N) then
12453 Set_Assignment_OK (Operand);
12456 Rewrite (N, Relocate_Node (Operand));
12460 -- If we have a conversion of a compile time known value to a target
12461 -- type and the value is in range of the target type, then we can simply
12462 -- replace the construct by an integer literal of the correct type. We
12463 -- only apply this to discrete types being converted. Possibly it may
12464 -- apply in other cases, but it is too much trouble to worry about.
12466 -- Note that we do not do this transformation if the Kill_Range_Check
12467 -- flag is set, since then the value may be outside the expected range.
12468 -- This happens in the Normalize_Scalars case.
12470 -- We also skip this if either the target or operand type is biased
12471 -- because in this case, the unchecked conversion is supposed to
12472 -- preserve the bit pattern, not the integer value.
12474 if Is_Integer_Type (Target_Type)
12475 and then not Has_Biased_Representation (Target_Type)
12476 and then Is_Discrete_Type (Operand_Type)
12477 and then not Has_Biased_Representation (Operand_Type)
12478 and then Compile_Time_Known_Value (Operand)
12479 and then not Kill_Range_Check (N)
12482 Val : constant Uint := Expr_Rep_Value (Operand);
12485 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
12487 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
12489 Val >= Expr_Value (Type_Low_Bound (Target_Type))
12491 Val <= Expr_Value (Type_High_Bound (Target_Type))
12493 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
12495 -- If Address is the target type, just set the type to avoid a
12496 -- spurious type error on the literal when Address is a visible
12499 if Is_Descendant_Of_Address (Target_Type) then
12500 Set_Etype (N, Target_Type);
12502 Analyze_And_Resolve (N, Target_Type);
12510 -- Generate an extra temporary for cases unsupported by the C backend
12512 if Modify_Tree_For_C then
12514 Source : constant Node_Id := Unqual_Conv (Expression (N));
12515 Source_Typ : Entity_Id := Get_Full_View (Etype (Source));
12518 if Is_Packed_Array (Source_Typ) then
12519 Source_Typ := Packed_Array_Impl_Type (Source_Typ);
12522 if Nkind (Source) = N_Function_Call
12523 and then (Is_Composite_Type (Etype (Source))
12524 or else Is_Composite_Type (Target_Type))
12526 Force_Evaluation (Source);
12531 -- Nothing to do if conversion is safe
12533 if Safe_Unchecked_Type_Conversion (N) then
12537 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12538 -- flag indicates ??? More comments needed here)
12540 if Assignment_OK (N) then
12543 Force_Evaluation (N);
12545 end Expand_N_Unchecked_Type_Conversion;
12547 ----------------------------
12548 -- Expand_Record_Equality --
12549 ----------------------------
12551 -- For non-variant records, Equality is expanded when needed into:
12553 -- and then Lhs.Discr1 = Rhs.Discr1
12555 -- and then Lhs.Discrn = Rhs.Discrn
12556 -- and then Lhs.Cmp1 = Rhs.Cmp1
12558 -- and then Lhs.Cmpn = Rhs.Cmpn
12560 -- The expression is folded by the back end for adjacent fields. This
12561 -- function is called for tagged record in only one occasion: for imple-
12562 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12563 -- otherwise the primitive "=" is used directly.
12565 function Expand_Record_Equality
12570 Bodies : List_Id) return Node_Id
12572 Loc : constant Source_Ptr := Sloc (Nod);
12577 First_Time : Boolean := True;
12579 function Element_To_Compare (C : Entity_Id) return Entity_Id;
12580 -- Return the next discriminant or component to compare, starting with
12581 -- C, skipping inherited components.
12583 ------------------------
12584 -- Element_To_Compare --
12585 ------------------------
12587 function Element_To_Compare (C : Entity_Id) return Entity_Id is
12593 -- Exit loop when the next element to be compared is found, or
12594 -- there is no more such element.
12596 exit when No (Comp);
12598 exit when Ekind_In (Comp, E_Discriminant, E_Component)
12601 -- Skip inherited components
12603 -- Note: for a tagged type, we always generate the "=" primitive
12604 -- for the base type (not on the first subtype), so the test for
12605 -- Comp /= Original_Record_Component (Comp) is True for
12606 -- inherited components only.
12608 (Is_Tagged_Type (Typ)
12609 and then Comp /= Original_Record_Component (Comp))
12613 or else Chars (Comp) = Name_uTag
12615 -- Skip interface elements (secondary tags???)
12617 or else Is_Interface (Etype (Comp)));
12619 Next_Entity (Comp);
12623 end Element_To_Compare;
12625 -- Start of processing for Expand_Record_Equality
12628 -- Generates the following code: (assuming that Typ has one Discr and
12629 -- component C2 is also a record)
12631 -- Lhs.Discr1 = Rhs.Discr1
12632 -- and then Lhs.C1 = Rhs.C1
12633 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12635 -- and then Lhs.Cmpn = Rhs.Cmpn
12637 Result := New_Occurrence_Of (Standard_True, Loc);
12638 C := Element_To_Compare (First_Entity (Typ));
12639 while Present (C) loop
12650 New_Lhs := New_Copy_Tree (Lhs);
12651 New_Rhs := New_Copy_Tree (Rhs);
12655 Expand_Composite_Equality (Nod, Etype (C),
12657 Make_Selected_Component (Loc,
12659 Selector_Name => New_Occurrence_Of (C, Loc)),
12661 Make_Selected_Component (Loc,
12663 Selector_Name => New_Occurrence_Of (C, Loc)),
12666 -- If some (sub)component is an unchecked_union, the whole
12667 -- operation will raise program error.
12669 if Nkind (Check) = N_Raise_Program_Error then
12671 Set_Etype (Result, Standard_Boolean);
12677 -- Generate logical "and" for CodePeer to simplify the
12678 -- generated code and analysis.
12680 elsif CodePeer_Mode then
12683 Left_Opnd => Result,
12684 Right_Opnd => Check);
12688 Make_And_Then (Loc,
12689 Left_Opnd => Result,
12690 Right_Opnd => Check);
12695 First_Time := False;
12696 C := Element_To_Compare (Next_Entity (C));
12700 end Expand_Record_Equality;
12702 ---------------------------
12703 -- Expand_Set_Membership --
12704 ---------------------------
12706 procedure Expand_Set_Membership (N : Node_Id) is
12707 Lop : constant Node_Id := Left_Opnd (N);
12711 function Make_Cond (Alt : Node_Id) return Node_Id;
12712 -- If the alternative is a subtype mark, create a simple membership
12713 -- test. Otherwise create an equality test for it.
12719 function Make_Cond (Alt : Node_Id) return Node_Id is
12721 L : constant Node_Id := New_Copy_Tree (Lop);
12722 R : constant Node_Id := Relocate_Node (Alt);
12725 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
12726 or else Nkind (Alt) = N_Range
12729 Make_In (Sloc (Alt),
12734 Make_Op_Eq (Sloc (Alt),
12742 -- Start of processing for Expand_Set_Membership
12745 Remove_Side_Effects (Lop);
12747 Alt := Last (Alternatives (N));
12748 Res := Make_Cond (Alt);
12751 while Present (Alt) loop
12753 Make_Or_Else (Sloc (Alt),
12754 Left_Opnd => Make_Cond (Alt),
12755 Right_Opnd => Res);
12760 Analyze_And_Resolve (N, Standard_Boolean);
12761 end Expand_Set_Membership;
12763 -----------------------------------
12764 -- Expand_Short_Circuit_Operator --
12765 -----------------------------------
12767 -- Deal with special expansion if actions are present for the right operand
12768 -- and deal with optimizing case of arguments being True or False. We also
12769 -- deal with the special case of non-standard boolean values.
12771 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
12772 Loc : constant Source_Ptr := Sloc (N);
12773 Typ : constant Entity_Id := Etype (N);
12774 Left : constant Node_Id := Left_Opnd (N);
12775 Right : constant Node_Id := Right_Opnd (N);
12776 LocR : constant Source_Ptr := Sloc (Right);
12779 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
12780 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
12781 -- If Left = Shortcut_Value then Right need not be evaluated
12783 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
12784 -- For Opnd a boolean expression, return a Boolean expression equivalent
12785 -- to Opnd /= Shortcut_Value.
12787 function Useful (Actions : List_Id) return Boolean;
12788 -- Return True if Actions is not empty and contains useful nodes to
12791 --------------------
12792 -- Make_Test_Expr --
12793 --------------------
12795 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
12797 if Shortcut_Value then
12798 return Make_Op_Not (Sloc (Opnd), Opnd);
12802 end Make_Test_Expr;
12808 function Useful (Actions : List_Id) return Boolean is
12811 if Present (Actions) then
12812 L := First (Actions);
12814 -- For now "useful" means not N_Variable_Reference_Marker.
12815 -- Consider stripping other nodes in the future.
12817 while Present (L) loop
12818 if Nkind (L) /= N_Variable_Reference_Marker then
12831 Op_Var : Entity_Id;
12832 -- Entity for a temporary variable holding the value of the operator,
12833 -- used for expansion in the case where actions are present.
12835 -- Start of processing for Expand_Short_Circuit_Operator
12838 -- Deal with non-standard booleans
12840 if Is_Boolean_Type (Typ) then
12841 Adjust_Condition (Left);
12842 Adjust_Condition (Right);
12843 Set_Etype (N, Standard_Boolean);
12846 -- Check for cases where left argument is known to be True or False
12848 if Compile_Time_Known_Value (Left) then
12850 -- Mark SCO for left condition as compile time known
12852 if Generate_SCO and then Comes_From_Source (Left) then
12853 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
12856 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
12857 -- Any actions associated with Right will be executed unconditionally
12858 -- and can thus be inserted into the tree unconditionally.
12860 if Expr_Value_E (Left) /= Shortcut_Ent then
12861 if Present (Actions (N)) then
12862 Insert_Actions (N, Actions (N));
12865 Rewrite (N, Right);
12867 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
12868 -- In this case we can forget the actions associated with Right,
12869 -- since they will never be executed.
12872 Kill_Dead_Code (Right);
12873 Kill_Dead_Code (Actions (N));
12874 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
12877 Adjust_Result_Type (N, Typ);
12881 -- If Actions are present for the right operand, we have to do some
12882 -- special processing. We can't just let these actions filter back into
12883 -- code preceding the short circuit (which is what would have happened
12884 -- if we had not trapped them in the short-circuit form), since they
12885 -- must only be executed if the right operand of the short circuit is
12886 -- executed and not otherwise.
12888 if Useful (Actions (N)) then
12889 Actlist := Actions (N);
12891 -- The old approach is to expand:
12893 -- left AND THEN right
12897 -- C : Boolean := False;
12905 -- and finally rewrite the operator into a reference to C. Similarly
12906 -- for left OR ELSE right, with negated values. Note that this
12907 -- rewrite causes some difficulties for coverage analysis because
12908 -- of the introduction of the new variable C, which obscures the
12909 -- structure of the test.
12911 -- We use this "old approach" if Minimize_Expression_With_Actions
12914 if Minimize_Expression_With_Actions then
12915 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
12918 Make_Object_Declaration (Loc,
12919 Defining_Identifier => Op_Var,
12920 Object_Definition =>
12921 New_Occurrence_Of (Standard_Boolean, Loc),
12923 New_Occurrence_Of (Shortcut_Ent, Loc)));
12925 Append_To (Actlist,
12926 Make_Implicit_If_Statement (Right,
12927 Condition => Make_Test_Expr (Right),
12928 Then_Statements => New_List (
12929 Make_Assignment_Statement (LocR,
12930 Name => New_Occurrence_Of (Op_Var, LocR),
12933 (Boolean_Literals (not Shortcut_Value), LocR)))));
12936 Make_Implicit_If_Statement (Left,
12937 Condition => Make_Test_Expr (Left),
12938 Then_Statements => Actlist));
12940 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
12941 Analyze_And_Resolve (N, Standard_Boolean);
12943 -- The new approach (the default) is to use an
12944 -- Expression_With_Actions node for the right operand of the
12945 -- short-circuit form. Note that this solves the traceability
12946 -- problems for coverage analysis.
12950 Make_Expression_With_Actions (LocR,
12951 Expression => Relocate_Node (Right),
12952 Actions => Actlist));
12954 Set_Actions (N, No_List);
12955 Analyze_And_Resolve (Right, Standard_Boolean);
12958 Adjust_Result_Type (N, Typ);
12962 -- No actions present, check for cases of right argument True/False
12964 if Compile_Time_Known_Value (Right) then
12966 -- Mark SCO for left condition as compile time known
12968 if Generate_SCO and then Comes_From_Source (Right) then
12969 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
12972 -- Change (Left and then True), (Left or else False) to Left. Note
12973 -- that we know there are no actions associated with the right
12974 -- operand, since we just checked for this case above.
12976 if Expr_Value_E (Right) /= Shortcut_Ent then
12979 -- Change (Left and then False), (Left or else True) to Right,
12980 -- making sure to preserve any side effects associated with the Left
12984 Remove_Side_Effects (Left);
12985 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
12989 Adjust_Result_Type (N, Typ);
12990 end Expand_Short_Circuit_Operator;
12992 ------------------------------------
12993 -- Fixup_Universal_Fixed_Operation --
12994 -------------------------------------
12996 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
12997 Conv : constant Node_Id := Parent (N);
13000 -- We must have a type conversion immediately above us
13002 pragma Assert (Nkind (Conv) = N_Type_Conversion);
13004 -- Normally the type conversion gives our target type. The exception
13005 -- occurs in the case of the Round attribute, where the conversion
13006 -- will be to universal real, and our real type comes from the Round
13007 -- attribute (as well as an indication that we must round the result)
13009 if Nkind (Parent (Conv)) = N_Attribute_Reference
13010 and then Attribute_Name (Parent (Conv)) = Name_Round
13012 Set_Etype (N, Base_Type (Etype (Parent (Conv))));
13013 Set_Rounded_Result (N);
13015 -- Normal case where type comes from conversion above us
13018 Set_Etype (N, Base_Type (Etype (Conv)));
13020 end Fixup_Universal_Fixed_Operation;
13022 ---------------------------------
13023 -- Has_Inferable_Discriminants --
13024 ---------------------------------
13026 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
13028 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
13029 -- Determines whether the left-most prefix of a selected component is a
13030 -- formal parameter in a subprogram. Assumes N is a selected component.
13032 --------------------------------
13033 -- Prefix_Is_Formal_Parameter --
13034 --------------------------------
13036 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
13037 Sel_Comp : Node_Id;
13040 -- Move to the left-most prefix by climbing up the tree
13043 while Present (Parent (Sel_Comp))
13044 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
13046 Sel_Comp := Parent (Sel_Comp);
13049 return Is_Formal (Entity (Prefix (Sel_Comp)));
13050 end Prefix_Is_Formal_Parameter;
13052 -- Start of processing for Has_Inferable_Discriminants
13055 -- For selected components, the subtype of the selector must be a
13056 -- constrained Unchecked_Union. If the component is subject to a
13057 -- per-object constraint, then the enclosing object must have inferable
13060 if Nkind (N) = N_Selected_Component then
13061 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
13063 -- A small hack. If we have a per-object constrained selected
13064 -- component of a formal parameter, return True since we do not
13065 -- know the actual parameter association yet.
13067 if Prefix_Is_Formal_Parameter (N) then
13070 -- Otherwise, check the enclosing object and the selector
13073 return Has_Inferable_Discriminants (Prefix (N))
13074 and then Has_Inferable_Discriminants (Selector_Name (N));
13077 -- The call to Has_Inferable_Discriminants will determine whether
13078 -- the selector has a constrained Unchecked_Union nominal type.
13081 return Has_Inferable_Discriminants (Selector_Name (N));
13084 -- A qualified expression has inferable discriminants if its subtype
13085 -- mark is a constrained Unchecked_Union subtype.
13087 elsif Nkind (N) = N_Qualified_Expression then
13088 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
13089 and then Is_Constrained (Etype (Subtype_Mark (N)));
13091 -- For all other names, it is sufficient to have a constrained
13092 -- Unchecked_Union nominal subtype.
13095 return Is_Unchecked_Union (Base_Type (Etype (N)))
13096 and then Is_Constrained (Etype (N));
13098 end Has_Inferable_Discriminants;
13100 -------------------------------
13101 -- Insert_Dereference_Action --
13102 -------------------------------
13104 procedure Insert_Dereference_Action (N : Node_Id) is
13105 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
13106 -- Return true if type of P is derived from Checked_Pool;
13108 -----------------------------
13109 -- Is_Checked_Storage_Pool --
13110 -----------------------------
13112 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
13121 while T /= Etype (T) loop
13122 if Is_RTE (T, RE_Checked_Pool) then
13130 end Is_Checked_Storage_Pool;
13134 Context : constant Node_Id := Parent (N);
13135 Ptr_Typ : constant Entity_Id := Etype (N);
13136 Desig_Typ : constant Entity_Id :=
13137 Available_View (Designated_Type (Ptr_Typ));
13138 Loc : constant Source_Ptr := Sloc (N);
13139 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ);
13145 Size_Bits : Node_Id;
13148 -- Start of processing for Insert_Dereference_Action
13151 pragma Assert (Nkind (Context) = N_Explicit_Dereference);
13153 -- Do not re-expand a dereference which has already been processed by
13156 if Has_Dereference_Action (Context) then
13159 -- Do not perform this type of expansion for internally-generated
13162 elsif not Comes_From_Source (Original_Node (Context)) then
13165 -- A dereference action is only applicable to objects which have been
13166 -- allocated on a checked pool.
13168 elsif not Is_Checked_Storage_Pool (Pool) then
13172 -- Extract the address of the dereferenced object. Generate:
13174 -- Addr : System.Address := <N>'Pool_Address;
13176 Addr := Make_Temporary (Loc, 'P');
13179 Make_Object_Declaration (Loc,
13180 Defining_Identifier => Addr,
13181 Object_Definition =>
13182 New_Occurrence_Of (RTE (RE_Address), Loc),
13184 Make_Attribute_Reference (Loc,
13185 Prefix => Duplicate_Subexpr_Move_Checks (N),
13186 Attribute_Name => Name_Pool_Address)));
13188 -- Calculate the size of the dereferenced object. Generate:
13190 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13193 Make_Explicit_Dereference (Loc,
13194 Prefix => Duplicate_Subexpr_Move_Checks (N));
13195 Set_Has_Dereference_Action (Deref);
13198 Make_Attribute_Reference (Loc,
13200 Attribute_Name => Name_Size);
13202 -- Special case of an unconstrained array: need to add descriptor size
13204 if Is_Array_Type (Desig_Typ)
13205 and then not Is_Constrained (First_Subtype (Desig_Typ))
13210 Make_Attribute_Reference (Loc,
13212 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc),
13213 Attribute_Name => Name_Descriptor_Size),
13214 Right_Opnd => Size_Bits);
13217 Size := Make_Temporary (Loc, 'S');
13219 Make_Object_Declaration (Loc,
13220 Defining_Identifier => Size,
13221 Object_Definition =>
13222 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13224 Make_Op_Divide (Loc,
13225 Left_Opnd => Size_Bits,
13226 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
13228 -- Calculate the alignment of the dereferenced object. Generate:
13229 -- Alig : constant Storage_Count := <N>.all'Alignment;
13232 Make_Explicit_Dereference (Loc,
13233 Prefix => Duplicate_Subexpr_Move_Checks (N));
13234 Set_Has_Dereference_Action (Deref);
13236 Alig := Make_Temporary (Loc, 'A');
13238 Make_Object_Declaration (Loc,
13239 Defining_Identifier => Alig,
13240 Object_Definition =>
13241 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13243 Make_Attribute_Reference (Loc,
13245 Attribute_Name => Name_Alignment)));
13247 -- A dereference of a controlled object requires special processing. The
13248 -- finalization machinery requests additional space from the underlying
13249 -- pool to allocate and hide two pointers. As a result, a checked pool
13250 -- may mark the wrong memory as valid. Since checked pools do not have
13251 -- knowledge of hidden pointers, we have to bring the two pointers back
13252 -- in view in order to restore the original state of the object.
13254 -- The address manipulation is not performed for access types that are
13255 -- subject to pragma No_Heap_Finalization because the two pointers do
13256 -- not exist in the first place.
13258 if No_Heap_Finalization (Ptr_Typ) then
13261 elsif Needs_Finalization (Desig_Typ) then
13263 -- Adjust the address and size of the dereferenced object. Generate:
13264 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13267 Make_Procedure_Call_Statement (Loc,
13269 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
13270 Parameter_Associations => New_List (
13271 New_Occurrence_Of (Addr, Loc),
13272 New_Occurrence_Of (Size, Loc),
13273 New_Occurrence_Of (Alig, Loc)));
13275 -- Class-wide types complicate things because we cannot determine
13276 -- statically whether the actual object is truly controlled. We must
13277 -- generate a runtime check to detect this property. Generate:
13279 -- if Needs_Finalization (<N>.all'Tag) then
13283 if Is_Class_Wide_Type (Desig_Typ) then
13285 Make_Explicit_Dereference (Loc,
13286 Prefix => Duplicate_Subexpr_Move_Checks (N));
13287 Set_Has_Dereference_Action (Deref);
13290 Make_Implicit_If_Statement (N,
13292 Make_Function_Call (Loc,
13294 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
13295 Parameter_Associations => New_List (
13296 Make_Attribute_Reference (Loc,
13298 Attribute_Name => Name_Tag))),
13299 Then_Statements => New_List (Stmt));
13302 Insert_Action (N, Stmt);
13306 -- Dereference (Pool, Addr, Size, Alig);
13309 Make_Procedure_Call_Statement (Loc,
13312 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
13313 Parameter_Associations => New_List (
13314 New_Occurrence_Of (Pool, Loc),
13315 New_Occurrence_Of (Addr, Loc),
13316 New_Occurrence_Of (Size, Loc),
13317 New_Occurrence_Of (Alig, Loc))));
13319 -- Mark the explicit dereference as processed to avoid potential
13320 -- infinite expansion.
13322 Set_Has_Dereference_Action (Context);
13325 when RE_Not_Available =>
13327 end Insert_Dereference_Action;
13329 --------------------------------
13330 -- Integer_Promotion_Possible --
13331 --------------------------------
13333 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
13334 Operand : constant Node_Id := Expression (N);
13335 Operand_Type : constant Entity_Id := Etype (Operand);
13336 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
13339 pragma Assert (Nkind (N) = N_Type_Conversion);
13343 -- We only do the transformation for source constructs. We assume
13344 -- that the expander knows what it is doing when it generates code.
13346 Comes_From_Source (N)
13348 -- If the operand type is Short_Integer or Short_Short_Integer,
13349 -- then we will promote to Integer, which is available on all
13350 -- targets, and is sufficient to ensure no intermediate overflow.
13351 -- Furthermore it is likely to be as efficient or more efficient
13352 -- than using the smaller type for the computation so we do this
13353 -- unconditionally.
13356 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
13358 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
13360 -- Test for interesting operation, which includes addition,
13361 -- division, exponentiation, multiplication, subtraction, absolute
13362 -- value and unary negation. Unary "+" is omitted since it is a
13363 -- no-op and thus can't overflow.
13365 and then Nkind_In (Operand, N_Op_Abs,
13372 end Integer_Promotion_Possible;
13374 ------------------------------
13375 -- Make_Array_Comparison_Op --
13376 ------------------------------
13378 -- This is a hand-coded expansion of the following generic function:
13381 -- type elem is (<>);
13382 -- type index is (<>);
13383 -- type a is array (index range <>) of elem;
13385 -- function Gnnn (X : a; Y: a) return boolean is
13386 -- J : index := Y'first;
13389 -- if X'length = 0 then
13392 -- elsif Y'length = 0 then
13396 -- for I in X'range loop
13397 -- if X (I) = Y (J) then
13398 -- if J = Y'last then
13401 -- J := index'succ (J);
13405 -- return X (I) > Y (J);
13409 -- return X'length > Y'length;
13413 -- Note that since we are essentially doing this expansion by hand, we
13414 -- do not need to generate an actual or formal generic part, just the
13415 -- instantiated function itself.
13417 -- Perhaps we could have the actual generic available in the run-time,
13418 -- obtained by rtsfind, and actually expand a real instantiation ???
13420 function Make_Array_Comparison_Op
13422 Nod : Node_Id) return Node_Id
13424 Loc : constant Source_Ptr := Sloc (Nod);
13426 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
13427 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
13428 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
13429 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13431 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
13433 Loop_Statement : Node_Id;
13434 Loop_Body : Node_Id;
13436 Inner_If : Node_Id;
13437 Final_Expr : Node_Id;
13438 Func_Body : Node_Id;
13439 Func_Name : Entity_Id;
13445 -- if J = Y'last then
13448 -- J := index'succ (J);
13452 Make_Implicit_If_Statement (Nod,
13455 Left_Opnd => New_Occurrence_Of (J, Loc),
13457 Make_Attribute_Reference (Loc,
13458 Prefix => New_Occurrence_Of (Y, Loc),
13459 Attribute_Name => Name_Last)),
13461 Then_Statements => New_List (
13462 Make_Exit_Statement (Loc)),
13466 Make_Assignment_Statement (Loc,
13467 Name => New_Occurrence_Of (J, Loc),
13469 Make_Attribute_Reference (Loc,
13470 Prefix => New_Occurrence_Of (Index, Loc),
13471 Attribute_Name => Name_Succ,
13472 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
13474 -- if X (I) = Y (J) then
13477 -- return X (I) > Y (J);
13481 Make_Implicit_If_Statement (Nod,
13485 Make_Indexed_Component (Loc,
13486 Prefix => New_Occurrence_Of (X, Loc),
13487 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13490 Make_Indexed_Component (Loc,
13491 Prefix => New_Occurrence_Of (Y, Loc),
13492 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
13494 Then_Statements => New_List (Inner_If),
13496 Else_Statements => New_List (
13497 Make_Simple_Return_Statement (Loc,
13501 Make_Indexed_Component (Loc,
13502 Prefix => New_Occurrence_Of (X, Loc),
13503 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13506 Make_Indexed_Component (Loc,
13507 Prefix => New_Occurrence_Of (Y, Loc),
13508 Expressions => New_List (
13509 New_Occurrence_Of (J, Loc)))))));
13511 -- for I in X'range loop
13516 Make_Implicit_Loop_Statement (Nod,
13517 Identifier => Empty,
13519 Iteration_Scheme =>
13520 Make_Iteration_Scheme (Loc,
13521 Loop_Parameter_Specification =>
13522 Make_Loop_Parameter_Specification (Loc,
13523 Defining_Identifier => I,
13524 Discrete_Subtype_Definition =>
13525 Make_Attribute_Reference (Loc,
13526 Prefix => New_Occurrence_Of (X, Loc),
13527 Attribute_Name => Name_Range))),
13529 Statements => New_List (Loop_Body));
13531 -- if X'length = 0 then
13533 -- elsif Y'length = 0 then
13536 -- for ... loop ... end loop;
13537 -- return X'length > Y'length;
13541 Make_Attribute_Reference (Loc,
13542 Prefix => New_Occurrence_Of (X, Loc),
13543 Attribute_Name => Name_Length);
13546 Make_Attribute_Reference (Loc,
13547 Prefix => New_Occurrence_Of (Y, Loc),
13548 Attribute_Name => Name_Length);
13552 Left_Opnd => Length1,
13553 Right_Opnd => Length2);
13556 Make_Implicit_If_Statement (Nod,
13560 Make_Attribute_Reference (Loc,
13561 Prefix => New_Occurrence_Of (X, Loc),
13562 Attribute_Name => Name_Length),
13564 Make_Integer_Literal (Loc, 0)),
13568 Make_Simple_Return_Statement (Loc,
13569 Expression => New_Occurrence_Of (Standard_False, Loc))),
13571 Elsif_Parts => New_List (
13572 Make_Elsif_Part (Loc,
13576 Make_Attribute_Reference (Loc,
13577 Prefix => New_Occurrence_Of (Y, Loc),
13578 Attribute_Name => Name_Length),
13580 Make_Integer_Literal (Loc, 0)),
13584 Make_Simple_Return_Statement (Loc,
13585 Expression => New_Occurrence_Of (Standard_True, Loc))))),
13587 Else_Statements => New_List (
13589 Make_Simple_Return_Statement (Loc,
13590 Expression => Final_Expr)));
13594 Formals := New_List (
13595 Make_Parameter_Specification (Loc,
13596 Defining_Identifier => X,
13597 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13599 Make_Parameter_Specification (Loc,
13600 Defining_Identifier => Y,
13601 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13603 -- function Gnnn (...) return boolean is
13604 -- J : index := Y'first;
13609 Func_Name := Make_Temporary (Loc, 'G');
13612 Make_Subprogram_Body (Loc,
13614 Make_Function_Specification (Loc,
13615 Defining_Unit_Name => Func_Name,
13616 Parameter_Specifications => Formals,
13617 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
13619 Declarations => New_List (
13620 Make_Object_Declaration (Loc,
13621 Defining_Identifier => J,
13622 Object_Definition => New_Occurrence_Of (Index, Loc),
13624 Make_Attribute_Reference (Loc,
13625 Prefix => New_Occurrence_Of (Y, Loc),
13626 Attribute_Name => Name_First))),
13628 Handled_Statement_Sequence =>
13629 Make_Handled_Sequence_Of_Statements (Loc,
13630 Statements => New_List (If_Stat)));
13633 end Make_Array_Comparison_Op;
13635 ---------------------------
13636 -- Make_Boolean_Array_Op --
13637 ---------------------------
13639 -- For logical operations on boolean arrays, expand in line the following,
13640 -- replacing 'and' with 'or' or 'xor' where needed:
13642 -- function Annn (A : typ; B: typ) return typ is
13645 -- for J in A'range loop
13646 -- C (J) := A (J) op B (J);
13651 -- Here typ is the boolean array type
13653 function Make_Boolean_Array_Op
13655 N : Node_Id) return Node_Id
13657 Loc : constant Source_Ptr := Sloc (N);
13659 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
13660 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
13661 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
13662 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13670 Func_Name : Entity_Id;
13671 Func_Body : Node_Id;
13672 Loop_Statement : Node_Id;
13676 Make_Indexed_Component (Loc,
13677 Prefix => New_Occurrence_Of (A, Loc),
13678 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13681 Make_Indexed_Component (Loc,
13682 Prefix => New_Occurrence_Of (B, Loc),
13683 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13686 Make_Indexed_Component (Loc,
13687 Prefix => New_Occurrence_Of (C, Loc),
13688 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13690 if Nkind (N) = N_Op_And then
13694 Right_Opnd => B_J);
13696 elsif Nkind (N) = N_Op_Or then
13700 Right_Opnd => B_J);
13706 Right_Opnd => B_J);
13710 Make_Implicit_Loop_Statement (N,
13711 Identifier => Empty,
13713 Iteration_Scheme =>
13714 Make_Iteration_Scheme (Loc,
13715 Loop_Parameter_Specification =>
13716 Make_Loop_Parameter_Specification (Loc,
13717 Defining_Identifier => J,
13718 Discrete_Subtype_Definition =>
13719 Make_Attribute_Reference (Loc,
13720 Prefix => New_Occurrence_Of (A, Loc),
13721 Attribute_Name => Name_Range))),
13723 Statements => New_List (
13724 Make_Assignment_Statement (Loc,
13726 Expression => Op)));
13728 Formals := New_List (
13729 Make_Parameter_Specification (Loc,
13730 Defining_Identifier => A,
13731 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13733 Make_Parameter_Specification (Loc,
13734 Defining_Identifier => B,
13735 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13737 Func_Name := Make_Temporary (Loc, 'A');
13738 Set_Is_Inlined (Func_Name);
13741 Make_Subprogram_Body (Loc,
13743 Make_Function_Specification (Loc,
13744 Defining_Unit_Name => Func_Name,
13745 Parameter_Specifications => Formals,
13746 Result_Definition => New_Occurrence_Of (Typ, Loc)),
13748 Declarations => New_List (
13749 Make_Object_Declaration (Loc,
13750 Defining_Identifier => C,
13751 Object_Definition => New_Occurrence_Of (Typ, Loc))),
13753 Handled_Statement_Sequence =>
13754 Make_Handled_Sequence_Of_Statements (Loc,
13755 Statements => New_List (
13757 Make_Simple_Return_Statement (Loc,
13758 Expression => New_Occurrence_Of (C, Loc)))));
13761 end Make_Boolean_Array_Op;
13763 -----------------------------------------
13764 -- Minimized_Eliminated_Overflow_Check --
13765 -----------------------------------------
13767 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
13770 Is_Signed_Integer_Type (Etype (N))
13771 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
13772 end Minimized_Eliminated_Overflow_Check;
13774 --------------------------------
13775 -- Optimize_Length_Comparison --
13776 --------------------------------
13778 procedure Optimize_Length_Comparison (N : Node_Id) is
13779 Loc : constant Source_Ptr := Sloc (N);
13780 Typ : constant Entity_Id := Etype (N);
13785 -- First and Last attribute reference nodes, which end up as left and
13786 -- right operands of the optimized result.
13789 -- True for comparison operand of zero
13792 -- Comparison operand, set only if Is_Zero is false
13794 Ent : Entity_Id := Empty;
13795 -- Entity whose length is being compared
13797 Index : Node_Id := Empty;
13798 -- Integer_Literal node for length attribute expression, or Empty
13799 -- if there is no such expression present.
13802 -- Type of array index to which 'Length is applied
13804 Op : Node_Kind := Nkind (N);
13805 -- Kind of comparison operator, gets flipped if operands backwards
13807 function Is_Optimizable (N : Node_Id) return Boolean;
13808 -- Tests N to see if it is an optimizable comparison value (defined as
13809 -- constant zero or one, or something else where the value is known to
13810 -- be positive and in the range of 32-bits, and where the corresponding
13811 -- Length value is also known to be 32-bits. If result is true, sets
13812 -- Is_Zero, Ityp, and Comp accordingly.
13814 function Is_Entity_Length (N : Node_Id) return Boolean;
13815 -- Tests if N is a length attribute applied to a simple entity. If so,
13816 -- returns True, and sets Ent to the entity, and Index to the integer
13817 -- literal provided as an attribute expression, or to Empty if none.
13818 -- Also returns True if the expression is a generated type conversion
13819 -- whose expression is of the desired form. This latter case arises
13820 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
13821 -- to check for being in range, which is not needed in this context.
13822 -- Returns False if neither condition holds.
13824 function Prepare_64 (N : Node_Id) return Node_Id;
13825 -- Given a discrete expression, returns a Long_Long_Integer typed
13826 -- expression representing the underlying value of the expression.
13827 -- This is done with an unchecked conversion to the result type. We
13828 -- use unchecked conversion to handle the enumeration type case.
13830 ----------------------
13831 -- Is_Entity_Length --
13832 ----------------------
13834 function Is_Entity_Length (N : Node_Id) return Boolean is
13836 if Nkind (N) = N_Attribute_Reference
13837 and then Attribute_Name (N) = Name_Length
13838 and then Is_Entity_Name (Prefix (N))
13840 Ent := Entity (Prefix (N));
13842 if Present (Expressions (N)) then
13843 Index := First (Expressions (N));
13850 elsif Nkind (N) = N_Type_Conversion
13851 and then not Comes_From_Source (N)
13853 return Is_Entity_Length (Expression (N));
13858 end Is_Entity_Length;
13860 --------------------
13861 -- Is_Optimizable --
13862 --------------------
13864 function Is_Optimizable (N : Node_Id) return Boolean is
13872 if Compile_Time_Known_Value (N) then
13873 Val := Expr_Value (N);
13875 if Val = Uint_0 then
13880 elsif Val = Uint_1 then
13887 -- Here we have to make sure of being within 32-bits
13889 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
13892 or else Lo < Uint_1
13893 or else Hi > UI_From_Int (Int'Last)
13898 -- Comparison value was within range, so now we must check the index
13899 -- value to make sure it is also within 32-bits.
13901 Indx := First_Index (Etype (Ent));
13903 if Present (Index) then
13904 for J in 2 .. UI_To_Int (Intval (Index)) loop
13909 Ityp := Etype (Indx);
13911 if Esize (Ityp) > 32 then
13918 end Is_Optimizable;
13924 function Prepare_64 (N : Node_Id) return Node_Id is
13926 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
13929 -- Start of processing for Optimize_Length_Comparison
13932 -- Nothing to do if not a comparison
13934 if Op not in N_Op_Compare then
13938 -- Nothing to do if special -gnatd.P debug flag set.
13940 if Debug_Flag_Dot_PP then
13944 -- Ent'Length op 0/1
13946 if Is_Entity_Length (Left_Opnd (N))
13947 and then Is_Optimizable (Right_Opnd (N))
13951 -- 0/1 op Ent'Length
13953 elsif Is_Entity_Length (Right_Opnd (N))
13954 and then Is_Optimizable (Left_Opnd (N))
13956 -- Flip comparison to opposite sense
13959 when N_Op_Lt => Op := N_Op_Gt;
13960 when N_Op_Le => Op := N_Op_Ge;
13961 when N_Op_Gt => Op := N_Op_Lt;
13962 when N_Op_Ge => Op := N_Op_Le;
13963 when others => null;
13966 -- Else optimization not possible
13972 -- Fall through if we will do the optimization
13974 -- Cases to handle:
13976 -- X'Length = 0 => X'First > X'Last
13977 -- X'Length = 1 => X'First = X'Last
13978 -- X'Length = n => X'First + (n - 1) = X'Last
13980 -- X'Length /= 0 => X'First <= X'Last
13981 -- X'Length /= 1 => X'First /= X'Last
13982 -- X'Length /= n => X'First + (n - 1) /= X'Last
13984 -- X'Length >= 0 => always true, warn
13985 -- X'Length >= 1 => X'First <= X'Last
13986 -- X'Length >= n => X'First + (n - 1) <= X'Last
13988 -- X'Length > 0 => X'First <= X'Last
13989 -- X'Length > 1 => X'First < X'Last
13990 -- X'Length > n => X'First + (n - 1) < X'Last
13992 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
13993 -- X'Length <= 1 => X'First >= X'Last
13994 -- X'Length <= n => X'First + (n - 1) >= X'Last
13996 -- X'Length < 0 => always false (warn)
13997 -- X'Length < 1 => X'First > X'Last
13998 -- X'Length < n => X'First + (n - 1) > X'Last
14000 -- Note: for the cases of n (not constant 0,1), we require that the
14001 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14002 -- and the same for the comparison value. Then we do the comparison
14003 -- using 64-bit arithmetic (actually long long integer), so that we
14004 -- cannot have overflow intefering with the result.
14006 -- First deal with warning cases
14015 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
14016 Analyze_And_Resolve (N, Typ);
14017 Warn_On_Known_Condition (N);
14024 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
14025 Analyze_And_Resolve (N, Typ);
14026 Warn_On_Known_Condition (N);
14030 if Constant_Condition_Warnings
14031 and then Comes_From_Source (Original_Node (N))
14033 Error_Msg_N ("could replace by ""'=""?c?", N);
14043 -- Build the First reference we will use
14046 Make_Attribute_Reference (Loc,
14047 Prefix => New_Occurrence_Of (Ent, Loc),
14048 Attribute_Name => Name_First);
14050 if Present (Index) then
14051 Set_Expressions (Left, New_List (New_Copy (Index)));
14054 -- If general value case, then do the addition of (n - 1), and
14055 -- also add the needed conversions to type Long_Long_Integer.
14057 if Present (Comp) then
14060 Left_Opnd => Prepare_64 (Left),
14062 Make_Op_Subtract (Loc,
14063 Left_Opnd => Prepare_64 (Comp),
14064 Right_Opnd => Make_Integer_Literal (Loc, 1)));
14067 -- Build the Last reference we will use
14070 Make_Attribute_Reference (Loc,
14071 Prefix => New_Occurrence_Of (Ent, Loc),
14072 Attribute_Name => Name_Last);
14074 if Present (Index) then
14075 Set_Expressions (Right, New_List (New_Copy (Index)));
14078 -- If general operand, convert Last reference to Long_Long_Integer
14080 if Present (Comp) then
14081 Right := Prepare_64 (Right);
14084 -- Check for cases to optimize
14086 -- X'Length = 0 => X'First > X'Last
14087 -- X'Length < 1 => X'First > X'Last
14088 -- X'Length < n => X'First + (n - 1) > X'Last
14090 if (Is_Zero and then Op = N_Op_Eq)
14091 or else (not Is_Zero and then Op = N_Op_Lt)
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_Eq then
14105 Right_Opnd => Right);
14107 -- X'Length /= 0 => X'First <= X'Last
14108 -- X'Length > 0 => X'First <= X'Last
14110 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
14114 Right_Opnd => Right);
14116 -- X'Length /= 1 => X'First /= X'Last
14117 -- X'Length /= n => X'First + (n - 1) /= X'Last
14119 elsif not Is_Zero and then Op = N_Op_Ne then
14123 Right_Opnd => Right);
14125 -- X'Length >= 1 => X'First <= X'Last
14126 -- X'Length >= n => X'First + (n - 1) <= X'Last
14128 elsif not Is_Zero and then Op = N_Op_Ge then
14132 Right_Opnd => Right);
14134 -- X'Length > 1 => X'First < X'Last
14135 -- X'Length > n => X'First + (n = 1) < X'Last
14137 elsif not Is_Zero and then Op = N_Op_Gt then
14141 Right_Opnd => Right);
14143 -- X'Length <= 1 => X'First >= X'Last
14144 -- X'Length <= n => X'First + (n - 1) >= X'Last
14146 elsif not Is_Zero and then Op = N_Op_Le then
14150 Right_Opnd => Right);
14152 -- Should not happen at this stage
14155 raise Program_Error;
14158 -- Rewrite and finish up
14160 Rewrite (N, Result);
14161 Analyze_And_Resolve (N, Typ);
14163 end Optimize_Length_Comparison;
14165 --------------------------------
14166 -- Process_If_Case_Statements --
14167 --------------------------------
14169 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
14173 Decl := First (Stmts);
14174 while Present (Decl) loop
14175 if Nkind (Decl) = N_Object_Declaration
14176 and then Is_Finalizable_Transient (Decl, N)
14178 Process_Transient_In_Expression (Decl, N, Stmts);
14183 end Process_If_Case_Statements;
14185 -------------------------------------
14186 -- Process_Transient_In_Expression --
14187 -------------------------------------
14189 procedure Process_Transient_In_Expression
14190 (Obj_Decl : Node_Id;
14194 Loc : constant Source_Ptr := Sloc (Obj_Decl);
14195 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
14197 Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
14198 -- The node on which to insert the hook as an action. This is usually
14199 -- the innermost enclosing non-transient construct.
14201 Fin_Call : Node_Id;
14202 Hook_Assign : Node_Id;
14203 Hook_Clear : Node_Id;
14204 Hook_Decl : Node_Id;
14205 Hook_Insert : Node_Id;
14206 Ptr_Decl : Node_Id;
14208 Fin_Context : Node_Id;
14209 -- The node after which to insert the finalization actions of the
14210 -- transient object.
14213 pragma Assert (Nkind_In (Expr, N_Case_Expression,
14214 N_Expression_With_Actions,
14217 -- When the context is a Boolean evaluation, all three nodes capture the
14218 -- result of their computation in a local temporary:
14221 -- Trans_Id : Ctrl_Typ := ...;
14222 -- Result : constant Boolean := ... Trans_Id ...;
14223 -- <finalize Trans_Id>
14226 -- As a result, the finalization of any transient objects can safely
14227 -- take place after the result capture.
14229 -- ??? could this be extended to elementary types?
14231 if Is_Boolean_Type (Etype (Expr)) then
14232 Fin_Context := Last (Stmts);
14234 -- Otherwise the immediate context may not be safe enough to carry
14235 -- out transient object finalization due to aliasing and nesting of
14236 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14237 -- enclosing non-transient construct.
14240 Fin_Context := Hook_Context;
14243 -- Mark the transient object as successfully processed to avoid double
14246 Set_Is_Finalized_Transient (Obj_Id);
14248 -- Construct all the pieces necessary to hook and finalize a transient
14251 Build_Transient_Object_Statements
14252 (Obj_Decl => Obj_Decl,
14253 Fin_Call => Fin_Call,
14254 Hook_Assign => Hook_Assign,
14255 Hook_Clear => Hook_Clear,
14256 Hook_Decl => Hook_Decl,
14257 Ptr_Decl => Ptr_Decl,
14258 Finalize_Obj => False);
14260 -- Add the access type which provides a reference to the transient
14261 -- object. Generate:
14263 -- type Ptr_Typ is access all Desig_Typ;
14265 Insert_Action (Hook_Context, Ptr_Decl);
14267 -- Add the temporary which acts as a hook to the transient object.
14270 -- Hook : Ptr_Id := null;
14272 Insert_Action (Hook_Context, Hook_Decl);
14274 -- When the transient object is initialized by an aggregate, the hook
14275 -- must capture the object after the last aggregate assignment takes
14276 -- place. Only then is the object considered initialized. Generate:
14278 -- Hook := Ptr_Typ (Obj_Id);
14280 -- Hook := Obj_Id'Unrestricted_Access;
14282 if Ekind_In (Obj_Id, E_Constant, E_Variable)
14283 and then Present (Last_Aggregate_Assignment (Obj_Id))
14285 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
14287 -- Otherwise the hook seizes the related object immediately
14290 Hook_Insert := Obj_Decl;
14293 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
14295 -- When the node is part of a return statement, there is no need to
14296 -- insert a finalization call, as the general finalization mechanism
14297 -- (see Build_Finalizer) would take care of the transient object on
14298 -- subprogram exit. Note that it would also be impossible to insert the
14299 -- finalization code after the return statement as this will render it
14302 if Nkind (Fin_Context) = N_Simple_Return_Statement then
14305 -- Finalize the hook after the context has been evaluated. Generate:
14307 -- if Hook /= null then
14308 -- [Deep_]Finalize (Hook.all);
14313 Insert_Action_After (Fin_Context,
14314 Make_Implicit_If_Statement (Obj_Decl,
14318 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
14319 Right_Opnd => Make_Null (Loc)),
14321 Then_Statements => New_List (
14325 end Process_Transient_In_Expression;
14327 ------------------------
14328 -- Rewrite_Comparison --
14329 ------------------------
14331 procedure Rewrite_Comparison (N : Node_Id) is
14332 Typ : constant Entity_Id := Etype (N);
14334 False_Result : Boolean;
14335 True_Result : Boolean;
14338 if Nkind (N) = N_Type_Conversion then
14339 Rewrite_Comparison (Expression (N));
14342 elsif Nkind (N) not in N_Op_Compare then
14346 -- Determine the potential outcome of the comparison assuming that the
14347 -- operands are valid and emit a warning when the comparison evaluates
14348 -- to True or False only in the presence of invalid values.
14350 Warn_On_Constant_Valid_Condition (N);
14352 -- Determine the potential outcome of the comparison assuming that the
14353 -- operands are not valid.
14357 Assume_Valid => False,
14358 True_Result => True_Result,
14359 False_Result => False_Result);
14361 -- The outcome is a decisive False or True, rewrite the operator
14363 if False_Result or True_Result then
14366 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
14368 Analyze_And_Resolve (N, Typ);
14369 Warn_On_Known_Condition (N);
14371 end Rewrite_Comparison;
14373 ----------------------------
14374 -- Safe_In_Place_Array_Op --
14375 ----------------------------
14377 function Safe_In_Place_Array_Op
14380 Op2 : Node_Id) return Boolean
14382 Target : Entity_Id;
14384 function Is_Safe_Operand (Op : Node_Id) return Boolean;
14385 -- Operand is safe if it cannot overlap part of the target of the
14386 -- operation. If the operand and the target are identical, the operand
14387 -- is safe. The operand can be empty in the case of negation.
14389 function Is_Unaliased (N : Node_Id) return Boolean;
14390 -- Check that N is a stand-alone entity
14396 function Is_Unaliased (N : Node_Id) return Boolean is
14400 and then No (Address_Clause (Entity (N)))
14401 and then No (Renamed_Object (Entity (N)));
14404 ---------------------
14405 -- Is_Safe_Operand --
14406 ---------------------
14408 function Is_Safe_Operand (Op : Node_Id) return Boolean is
14413 elsif Is_Entity_Name (Op) then
14414 return Is_Unaliased (Op);
14416 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
14417 return Is_Unaliased (Prefix (Op));
14419 elsif Nkind (Op) = N_Slice then
14421 Is_Unaliased (Prefix (Op))
14422 and then Entity (Prefix (Op)) /= Target;
14424 elsif Nkind (Op) = N_Op_Not then
14425 return Is_Safe_Operand (Right_Opnd (Op));
14430 end Is_Safe_Operand;
14432 -- Start of processing for Safe_In_Place_Array_Op
14435 -- Skip this processing if the component size is different from system
14436 -- storage unit (since at least for NOT this would cause problems).
14438 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
14441 -- Cannot do in place stuff if non-standard Boolean representation
14443 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
14446 elsif not Is_Unaliased (Lhs) then
14450 Target := Entity (Lhs);
14451 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
14453 end Safe_In_Place_Array_Op;
14455 -----------------------
14456 -- Tagged_Membership --
14457 -----------------------
14459 -- There are two different cases to consider depending on whether the right
14460 -- operand is a class-wide type or not. If not we just compare the actual
14461 -- tag of the left expr to the target type tag:
14463 -- Left_Expr.Tag = Right_Type'Tag;
14465 -- If it is a class-wide type we use the RT function CW_Membership which is
14466 -- usually implemented by looking in the ancestor tables contained in the
14467 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
14469 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
14470 -- function IW_Membership which is usually implemented by looking in the
14471 -- table of abstract interface types plus the ancestor table contained in
14472 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
14474 procedure Tagged_Membership
14476 SCIL_Node : out Node_Id;
14477 Result : out Node_Id)
14479 Left : constant Node_Id := Left_Opnd (N);
14480 Right : constant Node_Id := Right_Opnd (N);
14481 Loc : constant Source_Ptr := Sloc (N);
14483 Full_R_Typ : Entity_Id;
14484 Left_Type : Entity_Id;
14485 New_Node : Node_Id;
14486 Right_Type : Entity_Id;
14490 SCIL_Node := Empty;
14492 -- Handle entities from the limited view
14494 Left_Type := Available_View (Etype (Left));
14495 Right_Type := Available_View (Etype (Right));
14497 -- In the case where the type is an access type, the test is applied
14498 -- using the designated types (needed in Ada 2012 for implicit anonymous
14499 -- access conversions, for AI05-0149).
14501 if Is_Access_Type (Right_Type) then
14502 Left_Type := Designated_Type (Left_Type);
14503 Right_Type := Designated_Type (Right_Type);
14506 if Is_Class_Wide_Type (Left_Type) then
14507 Left_Type := Root_Type (Left_Type);
14510 if Is_Class_Wide_Type (Right_Type) then
14511 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
14513 Full_R_Typ := Underlying_Type (Right_Type);
14517 Make_Selected_Component (Loc,
14518 Prefix => Relocate_Node (Left),
14520 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
14522 if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
14524 -- No need to issue a run-time check if we statically know that the
14525 -- result of this membership test is always true. For example,
14526 -- considering the following declarations:
14528 -- type Iface is interface;
14529 -- type T is tagged null record;
14530 -- type DT is new T and Iface with null record;
14535 -- These membership tests are always true:
14538 -- Obj2 in T'Class;
14539 -- Obj2 in Iface'Class;
14541 -- We do not need to handle cases where the membership is illegal.
14544 -- Obj1 in DT'Class; -- Compile time error
14545 -- Obj1 in Iface'Class; -- Compile time error
14547 if not Is_Interface (Left_Type)
14548 and then not Is_Class_Wide_Type (Left_Type)
14549 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
14550 Use_Full_View => True)
14551 or else (Is_Interface (Etype (Right_Type))
14552 and then Interface_Present_In_Ancestor
14554 Iface => Etype (Right_Type))))
14556 Result := New_Occurrence_Of (Standard_True, Loc);
14560 -- Ada 2005 (AI-251): Class-wide applied to interfaces
14562 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
14564 -- Support to: "Iface_CW_Typ in Typ'Class"
14566 or else Is_Interface (Left_Type)
14568 -- Issue error if IW_Membership operation not available in a
14569 -- configurable run time setting.
14571 if not RTE_Available (RE_IW_Membership) then
14573 ("dynamic membership test on interface types", N);
14579 Make_Function_Call (Loc,
14580 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
14581 Parameter_Associations => New_List (
14582 Make_Attribute_Reference (Loc,
14584 Attribute_Name => Name_Address),
14585 New_Occurrence_Of (
14586 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
14589 -- Ada 95: Normal case
14592 Build_CW_Membership (Loc,
14593 Obj_Tag_Node => Obj_Tag,
14595 New_Occurrence_Of (
14596 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
14598 New_Node => New_Node);
14600 -- Generate the SCIL node for this class-wide membership test.
14601 -- Done here because the previous call to Build_CW_Membership
14602 -- relocates Obj_Tag.
14604 if Generate_SCIL then
14605 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
14606 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
14607 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
14610 Result := New_Node;
14613 -- Right_Type is not a class-wide type
14616 -- No need to check the tag of the object if Right_Typ is abstract
14618 if Is_Abstract_Type (Right_Type) then
14619 Result := New_Occurrence_Of (Standard_False, Loc);
14624 Left_Opnd => Obj_Tag,
14627 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
14630 end Tagged_Membership;
14632 ------------------------------
14633 -- Unary_Op_Validity_Checks --
14634 ------------------------------
14636 procedure Unary_Op_Validity_Checks (N : Node_Id) is
14638 if Validity_Checks_On and Validity_Check_Operands then
14639 Ensure_Valid (Right_Opnd (N));
14641 end Unary_Op_Validity_Checks;