1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_Ch2; use Exp_Ch2;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Disp; use Exp_Disp;
40 with Exp_Fixd; use Exp_Fixd;
41 with Exp_Intr; use Exp_Intr;
42 with Exp_Pakd; use Exp_Pakd;
43 with Exp_Tss; use Exp_Tss;
44 with Exp_Util; use Exp_Util;
45 with Freeze; use Freeze;
46 with Inline; use Inline;
47 with Namet; use Namet;
48 with Nlists; use Nlists;
49 with Nmake; use Nmake;
51 with Par_SCO; use Par_SCO;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Cat; use Sem_Cat;
58 with Sem_Ch3; use Sem_Ch3;
59 with Sem_Ch13; use Sem_Ch13;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Res; use Sem_Res;
62 with Sem_Type; use Sem_Type;
63 with Sem_Util; use Sem_Util;
64 with Sem_Warn; use Sem_Warn;
65 with Sinfo; use Sinfo;
66 with Snames; use Snames;
67 with Stand; use Stand;
68 with SCIL_LL; use SCIL_LL;
69 with Targparm; use Targparm;
70 with Tbuild; use Tbuild;
71 with Ttypes; use Ttypes;
72 with Uintp; use Uintp;
73 with Urealp; use Urealp;
74 with Validsw; use Validsw;
75 with Warnsw; use Warnsw;
77 package body Exp_Ch4 is
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 procedure Binary_Op_Validity_Checks (N : Node_Id);
84 pragma Inline (Binary_Op_Validity_Checks);
85 -- Performs validity checks for a binary operator
87 procedure Build_Boolean_Array_Proc_Call
91 -- If a boolean array assignment can be done in place, build call to
92 -- corresponding library procedure.
94 procedure Displace_Allocator_Pointer (N : Node_Id);
95 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
96 -- Expand_Allocator_Expression. Allocating class-wide interface objects
97 -- this routine displaces the pointer to the allocated object to reference
98 -- the component referencing the corresponding secondary dispatch table.
100 procedure Expand_Allocator_Expression (N : Node_Id);
101 -- Subsidiary to Expand_N_Allocator, for the case when the expression
102 -- is a qualified expression or an aggregate.
104 procedure Expand_Array_Comparison (N : Node_Id);
105 -- This routine handles expansion of the comparison operators (N_Op_Lt,
106 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
107 -- code for these operators is similar, differing only in the details of
108 -- the actual comparison call that is made. Special processing (call a
111 function Expand_Array_Equality
116 Typ : Entity_Id) return Node_Id;
117 -- Expand an array equality into a call to a function implementing this
118 -- equality, and a call to it. Loc is the location for the generated nodes.
119 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
120 -- on which to attach bodies of local functions that are created in the
121 -- process. It is the responsibility of the caller to insert those bodies
122 -- at the right place. Nod provides the Sloc value for the generated code.
123 -- Normally the types used for the generated equality routine are taken
124 -- from Lhs and Rhs. However, in some situations of generated code, the
125 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
126 -- the type to be used for the formal parameters.
128 procedure Expand_Boolean_Operator (N : Node_Id);
129 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
130 -- case of array type arguments.
132 procedure Expand_Nonbinary_Modular_Op (N : Node_Id);
133 -- When generating C code, convert nonbinary modular arithmetic operations
134 -- into code that relies on the front-end expansion of operator Mod. No
135 -- expansion is performed if N is not a nonbinary modular operand.
137 procedure Expand_Short_Circuit_Operator (N : Node_Id);
138 -- Common expansion processing for short-circuit boolean operators
140 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
141 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
142 -- where we allow comparison of "out of range" values.
144 function Expand_Composite_Equality
149 Bodies : List_Id) return Node_Id;
150 -- Local recursive function used to expand equality for nested composite
151 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
152 -- to attach bodies of local functions that are created in the process. It
153 -- is the responsibility of the caller to insert those bodies at the right
154 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
155 -- the left and right sides for the comparison, and Typ is the type of the
156 -- objects to compare.
158 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
159 -- Routine to expand concatenation of a sequence of two or more operands
160 -- (in the list Operands) and replace node Cnode with the result of the
161 -- concatenation. The operands can be of any appropriate type, and can
162 -- include both arrays and singleton elements.
164 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
165 -- N is an N_In membership test mode, with the overflow check mode set to
166 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
167 -- integer type. This is a case where top level processing is required to
168 -- handle overflow checks in subtrees.
170 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
171 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
172 -- fixed. We do not have such a type at runtime, so the purpose of this
173 -- routine is to find the real type by looking up the tree. We also
174 -- determine if the operation must be rounded.
176 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
177 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
178 -- discriminants if it has a constrained nominal type, unless the object
179 -- is a component of an enclosing Unchecked_Union object that is subject
180 -- to a per-object constraint and the enclosing object lacks inferable
183 -- An expression of an Unchecked_Union type has inferable discriminants
184 -- if it is either a name of an object with inferable discriminants or a
185 -- qualified expression whose subtype mark denotes a constrained subtype.
187 procedure Insert_Dereference_Action (N : Node_Id);
188 -- N is an expression whose type is an access. When the type of the
189 -- associated storage pool is derived from Checked_Pool, generate a
190 -- call to the 'Dereference' primitive operation.
192 function Make_Array_Comparison_Op
194 Nod : Node_Id) return Node_Id;
195 -- Comparisons between arrays are expanded in line. This function produces
196 -- the body of the implementation of (a > b), where a and b are one-
197 -- dimensional arrays of some discrete type. The original node is then
198 -- expanded into the appropriate call to this function. Nod provides the
199 -- Sloc value for the generated code.
201 function Make_Boolean_Array_Op
203 N : Node_Id) return Node_Id;
204 -- Boolean operations on boolean arrays are expanded in line. This function
205 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
206 -- b). It is used only the normal case and not the packed case. The type
207 -- involved, Typ, is the Boolean array type, and the logical operations in
208 -- the body are simple boolean operations. Note that Typ is always a
209 -- constrained type (the caller has ensured this by using
210 -- Convert_To_Actual_Subtype if necessary).
212 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
213 -- For signed arithmetic operations when the current overflow mode is
214 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
215 -- as the first thing we do. We then return. We count on the recursive
216 -- apparatus for overflow checks to call us back with an equivalent
217 -- operation that is in CHECKED mode, avoiding a recursive entry into this
218 -- routine, and that is when we will proceed with the expansion of the
219 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
220 -- these optimizations without first making this check, since there may be
221 -- operands further down the tree that are relying on the recursive calls
222 -- triggered by the top level nodes to properly process overflow checking
223 -- and remaining expansion on these nodes. Note that this call back may be
224 -- skipped if the operation is done in Bignum mode but that's fine, since
225 -- the Bignum call takes care of everything.
227 procedure Optimize_Length_Comparison (N : Node_Id);
228 -- Given an expression, if it is of the form X'Length op N (or the other
229 -- way round), where N is known at compile time to be 0 or 1, and X is a
230 -- simple entity, and op is a comparison operator, optimizes it into a
231 -- comparison of First and Last.
233 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
234 -- Inspect and process statement list Stmt of if or case expression N for
235 -- transient objects. If such objects are found, the routine generates code
236 -- to clean them up when the context of the expression is evaluated.
238 procedure Process_Transient_In_Expression
242 -- Subsidiary routine to the expansion of expression_with_actions, if and
243 -- case expressions. Generate all necessary code to finalize a transient
244 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
245 -- denotes the declaration of the transient object, which is usually the
246 -- result of a controlled function call. Expr denotes the expression with
247 -- actions, if expression, or case expression node. Stmts denotes the
248 -- statement list which contains Decl, either at the top level or within a
251 procedure Rewrite_Comparison (N : Node_Id);
252 -- If N is the node for a comparison whose outcome can be determined at
253 -- compile time, then the node N can be rewritten with True or False. If
254 -- the outcome cannot be determined at compile time, the call has no
255 -- effect. If N is a type conversion, then this processing is applied to
256 -- its expression. If N is neither comparison nor a type conversion, the
257 -- call has no effect.
259 procedure Tagged_Membership
261 SCIL_Node : out Node_Id;
262 Result : out Node_Id);
263 -- Construct the expression corresponding to the tagged membership test.
264 -- Deals with a second operand being (or not) a class-wide type.
266 function Safe_In_Place_Array_Op
269 Op2 : Node_Id) return Boolean;
270 -- In the context of an assignment, where the right-hand side is a boolean
271 -- operation on arrays, check whether operation can be performed in place.
273 procedure Unary_Op_Validity_Checks (N : Node_Id);
274 pragma Inline (Unary_Op_Validity_Checks);
275 -- Performs validity checks for a unary operator
277 -------------------------------
278 -- Binary_Op_Validity_Checks --
279 -------------------------------
281 procedure Binary_Op_Validity_Checks (N : Node_Id) is
283 if Validity_Checks_On and Validity_Check_Operands then
284 Ensure_Valid (Left_Opnd (N));
285 Ensure_Valid (Right_Opnd (N));
287 end Binary_Op_Validity_Checks;
289 ------------------------------------
290 -- Build_Boolean_Array_Proc_Call --
291 ------------------------------------
293 procedure Build_Boolean_Array_Proc_Call
298 Loc : constant Source_Ptr := Sloc (N);
299 Kind : constant Node_Kind := Nkind (Expression (N));
300 Target : constant Node_Id :=
301 Make_Attribute_Reference (Loc,
303 Attribute_Name => Name_Address);
305 Arg1 : Node_Id := Op1;
306 Arg2 : Node_Id := Op2;
308 Proc_Name : Entity_Id;
311 if Kind = N_Op_Not then
312 if Nkind (Op1) in N_Binary_Op then
314 -- Use negated version of the binary operators
316 if Nkind (Op1) = N_Op_And then
317 Proc_Name := RTE (RE_Vector_Nand);
319 elsif Nkind (Op1) = N_Op_Or then
320 Proc_Name := RTE (RE_Vector_Nor);
322 else pragma Assert (Nkind (Op1) = N_Op_Xor);
323 Proc_Name := RTE (RE_Vector_Xor);
327 Make_Procedure_Call_Statement (Loc,
328 Name => New_Occurrence_Of (Proc_Name, Loc),
330 Parameter_Associations => New_List (
332 Make_Attribute_Reference (Loc,
333 Prefix => Left_Opnd (Op1),
334 Attribute_Name => Name_Address),
336 Make_Attribute_Reference (Loc,
337 Prefix => Right_Opnd (Op1),
338 Attribute_Name => Name_Address),
340 Make_Attribute_Reference (Loc,
341 Prefix => Left_Opnd (Op1),
342 Attribute_Name => Name_Length)));
345 Proc_Name := RTE (RE_Vector_Not);
348 Make_Procedure_Call_Statement (Loc,
349 Name => New_Occurrence_Of (Proc_Name, Loc),
350 Parameter_Associations => New_List (
353 Make_Attribute_Reference (Loc,
355 Attribute_Name => Name_Address),
357 Make_Attribute_Reference (Loc,
359 Attribute_Name => Name_Length)));
363 -- We use the following equivalences:
365 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
366 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
367 -- (not X) xor (not Y) = X xor Y
368 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
370 if Nkind (Op1) = N_Op_Not then
371 Arg1 := Right_Opnd (Op1);
372 Arg2 := Right_Opnd (Op2);
374 if Kind = N_Op_And then
375 Proc_Name := RTE (RE_Vector_Nor);
376 elsif Kind = N_Op_Or then
377 Proc_Name := RTE (RE_Vector_Nand);
379 Proc_Name := RTE (RE_Vector_Xor);
383 if Kind = N_Op_And then
384 Proc_Name := RTE (RE_Vector_And);
385 elsif Kind = N_Op_Or then
386 Proc_Name := RTE (RE_Vector_Or);
387 elsif Nkind (Op2) = N_Op_Not then
388 Proc_Name := RTE (RE_Vector_Nxor);
389 Arg2 := Right_Opnd (Op2);
391 Proc_Name := RTE (RE_Vector_Xor);
396 Make_Procedure_Call_Statement (Loc,
397 Name => New_Occurrence_Of (Proc_Name, Loc),
398 Parameter_Associations => New_List (
400 Make_Attribute_Reference (Loc,
402 Attribute_Name => Name_Address),
403 Make_Attribute_Reference (Loc,
405 Attribute_Name => Name_Address),
406 Make_Attribute_Reference (Loc,
408 Attribute_Name => Name_Length)));
411 Rewrite (N, Call_Node);
415 when RE_Not_Available =>
417 end Build_Boolean_Array_Proc_Call;
419 -----------------------
421 -----------------------
423 function Build_Eq_Call
427 Rhs : Node_Id) return Node_Id
433 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
434 while Present (Prim_E) loop
435 Prim := Node (Prim_E);
437 -- Locate primitive equality with the right signature
439 if Chars (Prim) = Name_Op_Eq
440 and then Etype (First_Formal (Prim)) =
441 Etype (Next_Formal (First_Formal (Prim)))
442 and then Etype (Prim) = Standard_Boolean
444 if Is_Abstract_Subprogram (Prim) then
446 Make_Raise_Program_Error (Loc,
447 Reason => PE_Explicit_Raise);
451 Make_Function_Call (Loc,
452 Name => New_Occurrence_Of (Prim, Loc),
453 Parameter_Associations => New_List (Lhs, Rhs));
460 -- If not found, predefined operation will be used
465 --------------------------------
466 -- Displace_Allocator_Pointer --
467 --------------------------------
469 procedure Displace_Allocator_Pointer (N : Node_Id) is
470 Loc : constant Source_Ptr := Sloc (N);
471 Orig_Node : constant Node_Id := Original_Node (N);
477 -- Do nothing in case of VM targets: the virtual machine will handle
478 -- interfaces directly.
480 if not Tagged_Type_Expansion then
484 pragma Assert (Nkind (N) = N_Identifier
485 and then Nkind (Orig_Node) = N_Allocator);
487 PtrT := Etype (Orig_Node);
488 Dtyp := Available_View (Designated_Type (PtrT));
489 Etyp := Etype (Expression (Orig_Node));
491 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
493 -- If the type of the allocator expression is not an interface type
494 -- we can generate code to reference the record component containing
495 -- the pointer to the secondary dispatch table.
497 if not Is_Interface (Etyp) then
499 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
502 -- 1) Get access to the allocated object
505 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
509 -- 2) Add the conversion to displace the pointer to reference
510 -- the secondary dispatch table.
512 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
513 Analyze_And_Resolve (N, Dtyp);
515 -- 3) The 'access to the secondary dispatch table will be used
516 -- as the value returned by the allocator.
519 Make_Attribute_Reference (Loc,
520 Prefix => Relocate_Node (N),
521 Attribute_Name => Name_Access));
522 Set_Etype (N, Saved_Typ);
526 -- If the type of the allocator expression is an interface type we
527 -- generate a run-time call to displace "this" to reference the
528 -- component containing the pointer to the secondary dispatch table
529 -- or else raise Constraint_Error if the actual object does not
530 -- implement the target interface. This case corresponds to the
531 -- following example:
533 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
535 -- return new Iface_2'Class'(Obj);
540 Unchecked_Convert_To (PtrT,
541 Make_Function_Call (Loc,
542 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
543 Parameter_Associations => New_List (
544 Unchecked_Convert_To (RTE (RE_Address),
550 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
552 Analyze_And_Resolve (N, PtrT);
555 end Displace_Allocator_Pointer;
557 ---------------------------------
558 -- Expand_Allocator_Expression --
559 ---------------------------------
561 procedure Expand_Allocator_Expression (N : Node_Id) is
562 Loc : constant Source_Ptr := Sloc (N);
563 Exp : constant Node_Id := Expression (Expression (N));
564 PtrT : constant Entity_Id := Etype (N);
565 DesigT : constant Entity_Id := Designated_Type (PtrT);
567 procedure Apply_Accessibility_Check
569 Built_In_Place : Boolean := False);
570 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
571 -- type, generate an accessibility check to verify that the level of the
572 -- type of the created object is not deeper than the level of the access
573 -- type. If the type of the qualified expression is class-wide, then
574 -- always generate the check (except in the case where it is known to be
575 -- unnecessary, see comment below). Otherwise, only generate the check
576 -- if the level of the qualified expression type is statically deeper
577 -- than the access type.
579 -- Although the static accessibility will generally have been performed
580 -- as a legality check, it won't have been done in cases where the
581 -- allocator appears in generic body, so a run-time check is needed in
582 -- general. One special case is when the access type is declared in the
583 -- same scope as the class-wide allocator, in which case the check can
584 -- never fail, so it need not be generated.
586 -- As an open issue, there seem to be cases where the static level
587 -- associated with the class-wide object's underlying type is not
588 -- sufficient to perform the proper accessibility check, such as for
589 -- allocators in nested subprograms or accept statements initialized by
590 -- class-wide formals when the actual originates outside at a deeper
591 -- static level. The nested subprogram case might require passing
592 -- accessibility levels along with class-wide parameters, and the task
593 -- case seems to be an actual gap in the language rules that needs to
594 -- be fixed by the ARG. ???
596 -------------------------------
597 -- Apply_Accessibility_Check --
598 -------------------------------
600 procedure Apply_Accessibility_Check
602 Built_In_Place : Boolean := False)
604 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
612 if Ada_Version >= Ada_2005
613 and then Is_Class_Wide_Type (DesigT)
614 and then Tagged_Type_Expansion
615 and then not Scope_Suppress.Suppress (Accessibility_Check)
617 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
619 (Is_Class_Wide_Type (Etype (Exp))
620 and then Scope (PtrT) /= Current_Scope))
622 -- If the allocator was built in place, Ref is already a reference
623 -- to the access object initialized to the result of the allocator
624 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
625 -- Remove_Side_Effects for cases where the build-in-place call may
626 -- still be the prefix of the reference (to avoid generating
627 -- duplicate calls). Otherwise, it is the entity associated with
628 -- the object containing the address of the allocated object.
630 if Built_In_Place then
631 Remove_Side_Effects (Ref);
632 Obj_Ref := New_Copy_Tree (Ref);
634 Obj_Ref := New_Occurrence_Of (Ref, Loc);
637 -- For access to interface types we must generate code to displace
638 -- the pointer to the base of the object since the subsequent code
639 -- references components located in the TSD of the object (which
640 -- is associated with the primary dispatch table --see a-tags.ads)
641 -- and also generates code invoking Free, which requires also a
642 -- reference to the base of the unallocated object.
644 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
646 Unchecked_Convert_To (Etype (Obj_Ref),
647 Make_Function_Call (Loc,
649 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
650 Parameter_Associations => New_List (
651 Unchecked_Convert_To (RTE (RE_Address),
652 New_Copy_Tree (Obj_Ref)))));
655 -- Step 1: Create the object clean up code
659 -- Deallocate the object if the accessibility check fails. This
660 -- is done only on targets or profiles that support deallocation.
664 if RTE_Available (RE_Free) then
665 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
666 Set_Storage_Pool (Free_Stmt, Pool_Id);
668 Append_To (Stmts, Free_Stmt);
670 -- The target or profile cannot deallocate objects
676 -- Finalize the object if applicable. Generate:
678 -- [Deep_]Finalize (Obj_Ref.all);
680 if Needs_Finalization (DesigT)
681 and then not No_Heap_Finalization (PtrT)
686 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
689 -- Guard against a missing [Deep_]Finalize when the designated
690 -- type was not properly frozen.
692 if No (Fin_Call) then
693 Fin_Call := Make_Null_Statement (Loc);
696 -- When the target or profile supports deallocation, wrap the
697 -- finalization call in a block to ensure proper deallocation
698 -- even if finalization fails. Generate:
708 if Present (Free_Stmt) then
710 Make_Block_Statement (Loc,
711 Handled_Statement_Sequence =>
712 Make_Handled_Sequence_Of_Statements (Loc,
713 Statements => New_List (Fin_Call),
715 Exception_Handlers => New_List (
716 Make_Exception_Handler (Loc,
717 Exception_Choices => New_List (
718 Make_Others_Choice (Loc)),
719 Statements => New_List (
720 New_Copy_Tree (Free_Stmt),
721 Make_Raise_Statement (Loc))))));
724 Prepend_To (Stmts, Fin_Call);
727 -- Signal the accessibility failure through a Program_Error
730 Make_Raise_Program_Error (Loc,
731 Condition => New_Occurrence_Of (Standard_True, Loc),
732 Reason => PE_Accessibility_Check_Failed));
734 -- Step 2: Create the accessibility comparison
740 Make_Attribute_Reference (Loc,
742 Attribute_Name => Name_Tag);
744 -- For tagged types, determine the accessibility level by looking
745 -- at the type specific data of the dispatch table. Generate:
747 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
749 if Tagged_Type_Expansion then
750 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
752 -- Use a runtime call to determine the accessibility level when
753 -- compiling on virtual machine targets. Generate:
755 -- Get_Access_Level (Ref'Tag)
759 Make_Function_Call (Loc,
761 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
762 Parameter_Associations => New_List (Obj_Ref));
769 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
771 -- Due to the complexity and side effects of the check, utilize an
772 -- if statement instead of the regular Program_Error circuitry.
775 Make_Implicit_If_Statement (N,
777 Then_Statements => Stmts));
779 end Apply_Accessibility_Check;
783 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
784 Indic : constant Node_Id := Subtype_Mark (Expression (N));
785 T : constant Entity_Id := Entity (Indic);
788 Tag_Assign : Node_Id;
792 TagT : Entity_Id := Empty;
793 -- Type used as source for tag assignment
795 TagR : Node_Id := Empty;
796 -- Target reference for tag assignment
798 -- Start of processing for Expand_Allocator_Expression
801 -- Handle call to C++ constructor
803 if Is_CPP_Constructor_Call (Exp) then
804 Make_CPP_Constructor_Call_In_Allocator
806 Function_Call => Exp);
810 -- In the case of an Ada 2012 allocator whose initial value comes from a
811 -- function call, pass "the accessibility level determined by the point
812 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
813 -- Expand_Call but it couldn't be done there (because the Etype of the
814 -- allocator wasn't set then) so we generate the parameter here. See
815 -- the Boolean variable Defer in (a block within) Expand_Call.
817 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
822 if Nkind (Name (Exp)) = N_Explicit_Dereference then
823 Subp := Designated_Type (Etype (Prefix (Name (Exp))));
825 Subp := Entity (Name (Exp));
828 Subp := Ultimate_Alias (Subp);
830 if Present (Extra_Accessibility_Of_Result (Subp)) then
831 Add_Extra_Actual_To_Call
832 (Subprogram_Call => Exp,
833 Extra_Formal => Extra_Accessibility_Of_Result (Subp),
834 Extra_Actual => Dynamic_Accessibility_Level (PtrT));
839 -- Case of tagged type or type requiring finalization
841 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
843 -- Ada 2005 (AI-318-02): If the initialization expression is a call
844 -- to a build-in-place function, then access to the allocated object
845 -- must be passed to the function.
847 if Is_Build_In_Place_Function_Call (Exp) then
848 Make_Build_In_Place_Call_In_Allocator (N, Exp);
849 Apply_Accessibility_Check (N, Built_In_Place => True);
852 -- Ada 2005 (AI-318-02): Specialization of the previous case for
853 -- expressions containing a build-in-place function call whose
854 -- returned object covers interface types, and Expr has calls to
855 -- Ada.Tags.Displace to displace the pointer to the returned build-
856 -- in-place object to reference the secondary dispatch table of a
857 -- covered interface type.
859 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
860 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
861 Apply_Accessibility_Check (N, Built_In_Place => True);
865 -- Actions inserted before:
866 -- Temp : constant ptr_T := new T'(Expression);
867 -- Temp._tag = T'tag; -- when not class-wide
868 -- [Deep_]Adjust (Temp.all);
870 -- We analyze by hand the new internal allocator to avoid any
871 -- recursion and inappropriate call to Initialize.
873 -- We don't want to remove side effects when the expression must be
874 -- built in place. In the case of a build-in-place function call,
875 -- that could lead to a duplication of the call, which was already
876 -- substituted for the allocator.
878 if not Aggr_In_Place then
879 Remove_Side_Effects (Exp);
882 Temp := Make_Temporary (Loc, 'P', N);
884 -- For a class wide allocation generate the following code:
886 -- type Equiv_Record is record ... end record;
887 -- implicit subtype CW is <Class_Wide_Subytpe>;
888 -- temp : PtrT := new CW'(CW!(expr));
890 if Is_Class_Wide_Type (T) then
891 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
893 -- Ada 2005 (AI-251): If the expression is a class-wide interface
894 -- object we generate code to move up "this" to reference the
895 -- base of the object before allocating the new object.
897 -- Note that Exp'Address is recursively expanded into a call
898 -- to Base_Address (Exp.Tag)
900 if Is_Class_Wide_Type (Etype (Exp))
901 and then Is_Interface (Etype (Exp))
902 and then Tagged_Type_Expansion
906 Unchecked_Convert_To (Entity (Indic),
907 Make_Explicit_Dereference (Loc,
908 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
909 Make_Attribute_Reference (Loc,
911 Attribute_Name => Name_Address)))));
915 Unchecked_Convert_To (Entity (Indic), Exp));
918 Analyze_And_Resolve (Expression (N), Entity (Indic));
921 -- Processing for allocators returning non-interface types
923 if not Is_Interface (Directly_Designated_Type (PtrT)) then
924 if Aggr_In_Place then
926 Make_Object_Declaration (Loc,
927 Defining_Identifier => Temp,
928 Object_Definition => New_Occurrence_Of (PtrT, Loc),
932 New_Occurrence_Of (Etype (Exp), Loc)));
934 -- Copy the Comes_From_Source flag for the allocator we just
935 -- built, since logically this allocator is a replacement of
936 -- the original allocator node. This is for proper handling of
937 -- restriction No_Implicit_Heap_Allocations.
939 Set_Comes_From_Source
940 (Expression (Temp_Decl), Comes_From_Source (N));
942 Set_No_Initialization (Expression (Temp_Decl));
943 Insert_Action (N, Temp_Decl);
945 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
946 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
949 Node := Relocate_Node (N);
953 Make_Object_Declaration (Loc,
954 Defining_Identifier => Temp,
955 Constant_Present => True,
956 Object_Definition => New_Occurrence_Of (PtrT, Loc),
959 Insert_Action (N, Temp_Decl);
960 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
963 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
964 -- interface type. In this case we use the type of the qualified
965 -- expression to allocate the object.
969 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
974 Make_Full_Type_Declaration (Loc,
975 Defining_Identifier => Def_Id,
977 Make_Access_To_Object_Definition (Loc,
979 Null_Exclusion_Present => False,
981 Is_Access_Constant (Etype (N)),
982 Subtype_Indication =>
983 New_Occurrence_Of (Etype (Exp), Loc)));
985 Insert_Action (N, New_Decl);
987 -- Inherit the allocation-related attributes from the original
990 Set_Finalization_Master
991 (Def_Id, Finalization_Master (PtrT));
993 Set_Associated_Storage_Pool
994 (Def_Id, Associated_Storage_Pool (PtrT));
996 -- Declare the object using the previous type declaration
998 if Aggr_In_Place then
1000 Make_Object_Declaration (Loc,
1001 Defining_Identifier => Temp,
1002 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1004 Make_Allocator (Loc,
1005 New_Occurrence_Of (Etype (Exp), Loc)));
1007 -- Copy the Comes_From_Source flag for the allocator we just
1008 -- built, since logically this allocator is a replacement of
1009 -- the original allocator node. This is for proper handling
1010 -- of restriction No_Implicit_Heap_Allocations.
1012 Set_Comes_From_Source
1013 (Expression (Temp_Decl), Comes_From_Source (N));
1015 Set_No_Initialization (Expression (Temp_Decl));
1016 Insert_Action (N, Temp_Decl);
1018 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1019 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1022 Node := Relocate_Node (N);
1023 Set_Analyzed (Node);
1026 Make_Object_Declaration (Loc,
1027 Defining_Identifier => Temp,
1028 Constant_Present => True,
1029 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1030 Expression => Node);
1032 Insert_Action (N, Temp_Decl);
1033 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1036 -- Generate an additional object containing the address of the
1037 -- returned object. The type of this second object declaration
1038 -- is the correct type required for the common processing that
1039 -- is still performed by this subprogram. The displacement of
1040 -- this pointer to reference the component associated with the
1041 -- interface type will be done at the end of common processing.
1044 Make_Object_Declaration (Loc,
1045 Defining_Identifier => Make_Temporary (Loc, 'P'),
1046 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1048 Unchecked_Convert_To (PtrT,
1049 New_Occurrence_Of (Temp, Loc)));
1051 Insert_Action (N, New_Decl);
1053 Temp_Decl := New_Decl;
1054 Temp := Defining_Identifier (New_Decl);
1058 -- Generate the tag assignment
1060 -- Suppress the tag assignment for VM targets because VM tags are
1061 -- represented implicitly in objects.
1063 if not Tagged_Type_Expansion then
1066 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1067 -- interface objects because in this case the tag does not change.
1069 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1070 pragma Assert (Is_Class_Wide_Type
1071 (Directly_Designated_Type (Etype (N))));
1074 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1076 TagR := New_Occurrence_Of (Temp, Loc);
1078 elsif Is_Private_Type (T)
1079 and then Is_Tagged_Type (Underlying_Type (T))
1081 TagT := Underlying_Type (T);
1083 Unchecked_Convert_To (Underlying_Type (T),
1084 Make_Explicit_Dereference (Loc,
1085 Prefix => New_Occurrence_Of (Temp, Loc)));
1088 if Present (TagT) then
1090 Full_T : constant Entity_Id := Underlying_Type (TagT);
1094 Make_Assignment_Statement (Loc,
1096 Make_Selected_Component (Loc,
1100 (First_Tag_Component (Full_T), Loc)),
1103 Unchecked_Convert_To (RTE (RE_Tag),
1106 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1109 -- The previous assignment has to be done in any case
1111 Set_Assignment_OK (Name (Tag_Assign));
1112 Insert_Action (N, Tag_Assign);
1115 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1116 -- the object may be inherently limited, in which case there is no
1117 -- Adjust procedure, and the object is built in place. In Ada 95, the
1118 -- object can be limited but not inherently limited if this allocator
1119 -- came from a return statement (we're allocating the result on the
1120 -- secondary stack). In that case, the object will be moved, so we do
1121 -- want to Adjust. However, if it's a nonlimited build-in-place
1122 -- function call, Adjust is not wanted.
1124 if Needs_Finalization (DesigT)
1125 and then Needs_Finalization (T)
1126 and then not Aggr_In_Place
1127 and then not Is_Limited_View (T)
1128 and then not Alloc_For_BIP_Return (N)
1129 and then not Is_Build_In_Place_Function_Call (Expression (N))
1131 -- An unchecked conversion is needed in the classwide case because
1132 -- the designated type can be an ancestor of the subtype mark of
1138 Unchecked_Convert_To (T,
1139 Make_Explicit_Dereference (Loc,
1140 Prefix => New_Occurrence_Of (Temp, Loc))),
1143 if Present (Adj_Call) then
1144 Insert_Action (N, Adj_Call);
1148 -- Note: the accessibility check must be inserted after the call to
1149 -- [Deep_]Adjust to ensure proper completion of the assignment.
1151 Apply_Accessibility_Check (Temp);
1153 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1154 Analyze_And_Resolve (N, PtrT);
1156 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1157 -- component containing the secondary dispatch table of the interface
1160 if Is_Interface (Directly_Designated_Type (PtrT)) then
1161 Displace_Allocator_Pointer (N);
1164 -- Always force the generation of a temporary for aggregates when
1165 -- generating C code, to simplify the work in the code generator.
1168 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate)
1170 Temp := Make_Temporary (Loc, 'P', N);
1172 Make_Object_Declaration (Loc,
1173 Defining_Identifier => Temp,
1174 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1176 Make_Allocator (Loc,
1177 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1179 -- Copy the Comes_From_Source flag for the allocator we just built,
1180 -- since logically this allocator is a replacement of the original
1181 -- allocator node. This is for proper handling of restriction
1182 -- No_Implicit_Heap_Allocations.
1184 Set_Comes_From_Source
1185 (Expression (Temp_Decl), Comes_From_Source (N));
1187 Set_No_Initialization (Expression (Temp_Decl));
1188 Insert_Action (N, Temp_Decl);
1190 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1191 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1193 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1194 Analyze_And_Resolve (N, PtrT);
1196 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1197 Install_Null_Excluding_Check (Exp);
1199 elsif Is_Access_Type (DesigT)
1200 and then Nkind (Exp) = N_Allocator
1201 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1203 -- Apply constraint to designated subtype indication
1205 Apply_Constraint_Check
1206 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
1208 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1210 -- Propagate constraint_error to enclosing allocator
1212 Rewrite (Exp, New_Copy (Expression (Exp)));
1216 Build_Allocate_Deallocate_Proc (N, True);
1219 -- type A is access T1;
1220 -- X : A := new T2'(...);
1221 -- T1 and T2 can be different subtypes, and we might need to check
1222 -- both constraints. First check against the type of the qualified
1225 Apply_Constraint_Check (Exp, T, No_Sliding => True);
1227 if Do_Range_Check (Exp) then
1228 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1231 -- A check is also needed in cases where the designated subtype is
1232 -- constrained and differs from the subtype given in the qualified
1233 -- expression. Note that the check on the qualified expression does
1234 -- not allow sliding, but this check does (a relaxation from Ada 83).
1236 if Is_Constrained (DesigT)
1237 and then not Subtypes_Statically_Match (T, DesigT)
1239 Apply_Constraint_Check
1240 (Exp, DesigT, No_Sliding => False);
1242 if Do_Range_Check (Exp) then
1243 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1247 -- For an access to unconstrained packed array, GIGI needs to see an
1248 -- expression with a constrained subtype in order to compute the
1249 -- proper size for the allocator.
1251 if Is_Array_Type (T)
1252 and then not Is_Constrained (T)
1253 and then Is_Packed (T)
1256 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1257 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1260 Make_Subtype_Declaration (Loc,
1261 Defining_Identifier => ConstrT,
1262 Subtype_Indication =>
1263 Make_Subtype_From_Expr (Internal_Exp, T)));
1264 Freeze_Itype (ConstrT, Exp);
1265 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1269 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1270 -- to a build-in-place function, then access to the allocated object
1271 -- must be passed to the function.
1273 if Is_Build_In_Place_Function_Call (Exp) then
1274 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1279 when RE_Not_Available =>
1281 end Expand_Allocator_Expression;
1283 -----------------------------
1284 -- Expand_Array_Comparison --
1285 -----------------------------
1287 -- Expansion is only required in the case of array types. For the unpacked
1288 -- case, an appropriate runtime routine is called. For packed cases, and
1289 -- also in some other cases where a runtime routine cannot be called, the
1290 -- form of the expansion is:
1292 -- [body for greater_nn; boolean_expression]
1294 -- The body is built by Make_Array_Comparison_Op, and the form of the
1295 -- Boolean expression depends on the operator involved.
1297 procedure Expand_Array_Comparison (N : Node_Id) is
1298 Loc : constant Source_Ptr := Sloc (N);
1299 Op1 : Node_Id := Left_Opnd (N);
1300 Op2 : Node_Id := Right_Opnd (N);
1301 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1302 Ctyp : constant Entity_Id := Component_Type (Typ1);
1305 Func_Body : Node_Id;
1306 Func_Name : Entity_Id;
1310 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1311 -- True for byte addressable target
1313 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1314 -- Returns True if the length of the given operand is known to be less
1315 -- than 4. Returns False if this length is known to be four or greater
1316 -- or is not known at compile time.
1318 ------------------------
1319 -- Length_Less_Than_4 --
1320 ------------------------
1322 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1323 Otyp : constant Entity_Id := Etype (Opnd);
1326 if Ekind (Otyp) = E_String_Literal_Subtype then
1327 return String_Literal_Length (Otyp) < 4;
1331 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1332 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1333 Hi : constant Node_Id := Type_High_Bound (Ityp);
1338 if Compile_Time_Known_Value (Lo) then
1339 Lov := Expr_Value (Lo);
1344 if Compile_Time_Known_Value (Hi) then
1345 Hiv := Expr_Value (Hi);
1350 return Hiv < Lov + 3;
1353 end Length_Less_Than_4;
1355 -- Start of processing for Expand_Array_Comparison
1358 -- Deal first with unpacked case, where we can call a runtime routine
1359 -- except that we avoid this for targets for which are not addressable
1362 if not Is_Bit_Packed_Array (Typ1)
1363 and then Byte_Addressable
1365 -- The call we generate is:
1367 -- Compare_Array_xn[_Unaligned]
1368 -- (left'address, right'address, left'length, right'length) <op> 0
1370 -- x = U for unsigned, S for signed
1371 -- n = 8,16,32,64 for component size
1372 -- Add _Unaligned if length < 4 and component size is 8.
1373 -- <op> is the standard comparison operator
1375 if Component_Size (Typ1) = 8 then
1376 if Length_Less_Than_4 (Op1)
1378 Length_Less_Than_4 (Op2)
1380 if Is_Unsigned_Type (Ctyp) then
1381 Comp := RE_Compare_Array_U8_Unaligned;
1383 Comp := RE_Compare_Array_S8_Unaligned;
1387 if Is_Unsigned_Type (Ctyp) then
1388 Comp := RE_Compare_Array_U8;
1390 Comp := RE_Compare_Array_S8;
1394 elsif Component_Size (Typ1) = 16 then
1395 if Is_Unsigned_Type (Ctyp) then
1396 Comp := RE_Compare_Array_U16;
1398 Comp := RE_Compare_Array_S16;
1401 elsif Component_Size (Typ1) = 32 then
1402 if Is_Unsigned_Type (Ctyp) then
1403 Comp := RE_Compare_Array_U32;
1405 Comp := RE_Compare_Array_S32;
1408 else pragma Assert (Component_Size (Typ1) = 64);
1409 if Is_Unsigned_Type (Ctyp) then
1410 Comp := RE_Compare_Array_U64;
1412 Comp := RE_Compare_Array_S64;
1416 if RTE_Available (Comp) then
1418 -- Expand to a call only if the runtime function is available,
1419 -- otherwise fall back to inline code.
1421 Remove_Side_Effects (Op1, Name_Req => True);
1422 Remove_Side_Effects (Op2, Name_Req => True);
1425 Make_Function_Call (Sloc (Op1),
1426 Name => New_Occurrence_Of (RTE (Comp), Loc),
1428 Parameter_Associations => New_List (
1429 Make_Attribute_Reference (Loc,
1430 Prefix => Relocate_Node (Op1),
1431 Attribute_Name => Name_Address),
1433 Make_Attribute_Reference (Loc,
1434 Prefix => Relocate_Node (Op2),
1435 Attribute_Name => Name_Address),
1437 Make_Attribute_Reference (Loc,
1438 Prefix => Relocate_Node (Op1),
1439 Attribute_Name => Name_Length),
1441 Make_Attribute_Reference (Loc,
1442 Prefix => Relocate_Node (Op2),
1443 Attribute_Name => Name_Length))));
1446 Make_Integer_Literal (Sloc (Op2),
1449 Analyze_And_Resolve (Op1, Standard_Integer);
1450 Analyze_And_Resolve (Op2, Standard_Integer);
1455 -- Cases where we cannot make runtime call
1457 -- For (a <= b) we convert to not (a > b)
1459 if Chars (N) = Name_Op_Le then
1465 Right_Opnd => Op2)));
1466 Analyze_And_Resolve (N, Standard_Boolean);
1469 -- For < the Boolean expression is
1470 -- greater__nn (op2, op1)
1472 elsif Chars (N) = Name_Op_Lt then
1473 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1477 Op1 := Right_Opnd (N);
1478 Op2 := Left_Opnd (N);
1480 -- For (a >= b) we convert to not (a < b)
1482 elsif Chars (N) = Name_Op_Ge then
1488 Right_Opnd => Op2)));
1489 Analyze_And_Resolve (N, Standard_Boolean);
1492 -- For > the Boolean expression is
1493 -- greater__nn (op1, op2)
1496 pragma Assert (Chars (N) = Name_Op_Gt);
1497 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1500 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1502 Make_Function_Call (Loc,
1503 Name => New_Occurrence_Of (Func_Name, Loc),
1504 Parameter_Associations => New_List (Op1, Op2));
1506 Insert_Action (N, Func_Body);
1508 Analyze_And_Resolve (N, Standard_Boolean);
1509 end Expand_Array_Comparison;
1511 ---------------------------
1512 -- Expand_Array_Equality --
1513 ---------------------------
1515 -- Expand an equality function for multi-dimensional arrays. Here is an
1516 -- example of such a function for Nb_Dimension = 2
1518 -- function Enn (A : atyp; B : btyp) return boolean is
1520 -- if (A'length (1) = 0 or else A'length (2) = 0)
1522 -- (B'length (1) = 0 or else B'length (2) = 0)
1524 -- return True; -- RM 4.5.2(22)
1527 -- if A'length (1) /= B'length (1)
1529 -- A'length (2) /= B'length (2)
1531 -- return False; -- RM 4.5.2(23)
1535 -- A1 : Index_T1 := A'first (1);
1536 -- B1 : Index_T1 := B'first (1);
1540 -- A2 : Index_T2 := A'first (2);
1541 -- B2 : Index_T2 := B'first (2);
1544 -- if A (A1, A2) /= B (B1, B2) then
1548 -- exit when A2 = A'last (2);
1549 -- A2 := Index_T2'succ (A2);
1550 -- B2 := Index_T2'succ (B2);
1554 -- exit when A1 = A'last (1);
1555 -- A1 := Index_T1'succ (A1);
1556 -- B1 := Index_T1'succ (B1);
1563 -- Note on the formal types used (atyp and btyp). If either of the arrays
1564 -- is of a private type, we use the underlying type, and do an unchecked
1565 -- conversion of the actual. If either of the arrays has a bound depending
1566 -- on a discriminant, then we use the base type since otherwise we have an
1567 -- escaped discriminant in the function.
1569 -- If both arrays are constrained and have the same bounds, we can generate
1570 -- a loop with an explicit iteration scheme using a 'Range attribute over
1573 function Expand_Array_Equality
1578 Typ : Entity_Id) return Node_Id
1580 Loc : constant Source_Ptr := Sloc (Nod);
1581 Decls : constant List_Id := New_List;
1582 Index_List1 : constant List_Id := New_List;
1583 Index_List2 : constant List_Id := New_List;
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
1600 Num : Int) return Node_Id;
1601 -- This builds the attribute reference Arr'Nam (Expr)
1603 function Component_Equality (Typ : Entity_Id) return Node_Id;
1604 -- Create one statement to compare corresponding components, designated
1605 -- by a full set of indexes.
1607 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1608 -- Given one of the arguments, computes the appropriate type to be used
1609 -- for that argument in the corresponding function formal
1611 function Handle_One_Dimension
1613 Index : Node_Id) return Node_Id;
1614 -- This procedure returns the following code
1617 -- Bn : Index_T := B'First (N);
1621 -- exit when An = A'Last (N);
1622 -- An := Index_T'Succ (An)
1623 -- Bn := Index_T'Succ (Bn)
1627 -- If both indexes are constrained and identical, the procedure
1628 -- returns a simpler loop:
1630 -- for An in A'Range (N) loop
1634 -- N is the dimension for which we are generating a loop. Index is the
1635 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1636 -- xxx statement is either the loop or declare for the next dimension
1637 -- or if this is the last dimension the comparison of corresponding
1638 -- components of the arrays.
1640 -- The actual way the code works is to return the comparison of
1641 -- corresponding components for the N+1 call. That's neater.
1643 function Test_Empty_Arrays return Node_Id;
1644 -- This function constructs the test for both arrays being empty
1645 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1647 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1649 function Test_Lengths_Correspond return Node_Id;
1650 -- This function constructs the test for arrays having different lengths
1651 -- in at least one index position, in which case the resulting code is:
1653 -- A'length (1) /= B'length (1)
1655 -- A'length (2) /= B'length (2)
1666 Num : Int) return Node_Id
1670 Make_Attribute_Reference (Loc,
1671 Attribute_Name => Nam,
1672 Prefix => New_Occurrence_Of (Arr, Loc),
1673 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1676 ------------------------
1677 -- Component_Equality --
1678 ------------------------
1680 function Component_Equality (Typ : Entity_Id) return Node_Id is
1685 -- if a(i1...) /= b(j1...) then return false; end if;
1688 Make_Indexed_Component (Loc,
1689 Prefix => Make_Identifier (Loc, Chars (A)),
1690 Expressions => Index_List1);
1693 Make_Indexed_Component (Loc,
1694 Prefix => Make_Identifier (Loc, Chars (B)),
1695 Expressions => Index_List2);
1697 Test := Expand_Composite_Equality
1698 (Nod, Component_Type (Typ), L, R, Decls);
1700 -- If some (sub)component is an unchecked_union, the whole operation
1701 -- will raise program error.
1703 if Nkind (Test) = N_Raise_Program_Error then
1705 -- This node is going to be inserted at a location where a
1706 -- statement is expected: clear its Etype so analysis will set
1707 -- it to the expected Standard_Void_Type.
1709 Set_Etype (Test, Empty);
1714 Make_Implicit_If_Statement (Nod,
1715 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1716 Then_Statements => New_List (
1717 Make_Simple_Return_Statement (Loc,
1718 Expression => New_Occurrence_Of (Standard_False, Loc))));
1720 end Component_Equality;
1726 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1737 T := Underlying_Type (T);
1739 X := First_Index (T);
1740 while Present (X) loop
1741 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1743 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1756 --------------------------
1757 -- Handle_One_Dimension --
1758 ---------------------------
1760 function Handle_One_Dimension
1762 Index : Node_Id) return Node_Id
1764 Need_Separate_Indexes : constant Boolean :=
1765 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1766 -- If the index types are identical, and we are working with
1767 -- constrained types, then we can use the same index for both
1770 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1773 Index_T : Entity_Id;
1778 if N > Number_Dimensions (Ltyp) then
1779 return Component_Equality (Ltyp);
1782 -- Case where we generate a loop
1784 Index_T := Base_Type (Etype (Index));
1786 if Need_Separate_Indexes then
1787 Bn := Make_Temporary (Loc, 'B');
1792 Append (New_Occurrence_Of (An, Loc), Index_List1);
1793 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1795 Stm_List := New_List (
1796 Handle_One_Dimension (N + 1, Next_Index (Index)));
1798 if Need_Separate_Indexes then
1800 -- Generate guard for loop, followed by increments of indexes
1802 Append_To (Stm_List,
1803 Make_Exit_Statement (Loc,
1806 Left_Opnd => New_Occurrence_Of (An, Loc),
1807 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1809 Append_To (Stm_List,
1810 Make_Assignment_Statement (Loc,
1811 Name => New_Occurrence_Of (An, Loc),
1813 Make_Attribute_Reference (Loc,
1814 Prefix => New_Occurrence_Of (Index_T, Loc),
1815 Attribute_Name => Name_Succ,
1816 Expressions => New_List (
1817 New_Occurrence_Of (An, Loc)))));
1819 Append_To (Stm_List,
1820 Make_Assignment_Statement (Loc,
1821 Name => New_Occurrence_Of (Bn, Loc),
1823 Make_Attribute_Reference (Loc,
1824 Prefix => New_Occurrence_Of (Index_T, Loc),
1825 Attribute_Name => Name_Succ,
1826 Expressions => New_List (
1827 New_Occurrence_Of (Bn, Loc)))));
1830 -- If separate indexes, we need a declare block for An and Bn, and a
1831 -- loop without an iteration scheme.
1833 if Need_Separate_Indexes then
1835 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1838 Make_Block_Statement (Loc,
1839 Declarations => New_List (
1840 Make_Object_Declaration (Loc,
1841 Defining_Identifier => An,
1842 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1843 Expression => Arr_Attr (A, Name_First, N)),
1845 Make_Object_Declaration (Loc,
1846 Defining_Identifier => Bn,
1847 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1848 Expression => Arr_Attr (B, Name_First, N))),
1850 Handled_Statement_Sequence =>
1851 Make_Handled_Sequence_Of_Statements (Loc,
1852 Statements => New_List (Loop_Stm)));
1854 -- If no separate indexes, return loop statement with explicit
1855 -- iteration scheme on its own
1859 Make_Implicit_Loop_Statement (Nod,
1860 Statements => Stm_List,
1862 Make_Iteration_Scheme (Loc,
1863 Loop_Parameter_Specification =>
1864 Make_Loop_Parameter_Specification (Loc,
1865 Defining_Identifier => An,
1866 Discrete_Subtype_Definition =>
1867 Arr_Attr (A, Name_Range, N))));
1870 end Handle_One_Dimension;
1872 -----------------------
1873 -- Test_Empty_Arrays --
1874 -----------------------
1876 function Test_Empty_Arrays return Node_Id is
1886 for J in 1 .. Number_Dimensions (Ltyp) loop
1889 Left_Opnd => Arr_Attr (A, Name_Length, J),
1890 Right_Opnd => Make_Integer_Literal (Loc, 0));
1894 Left_Opnd => Arr_Attr (B, Name_Length, J),
1895 Right_Opnd => Make_Integer_Literal (Loc, 0));
1904 Left_Opnd => Relocate_Node (Alist),
1905 Right_Opnd => Atest);
1909 Left_Opnd => Relocate_Node (Blist),
1910 Right_Opnd => Btest);
1917 Right_Opnd => Blist);
1918 end Test_Empty_Arrays;
1920 -----------------------------
1921 -- Test_Lengths_Correspond --
1922 -----------------------------
1924 function Test_Lengths_Correspond return Node_Id is
1930 for J in 1 .. Number_Dimensions (Ltyp) loop
1933 Left_Opnd => Arr_Attr (A, Name_Length, J),
1934 Right_Opnd => Arr_Attr (B, Name_Length, J));
1941 Left_Opnd => Relocate_Node (Result),
1942 Right_Opnd => Rtest);
1947 end Test_Lengths_Correspond;
1949 -- Start of processing for Expand_Array_Equality
1952 Ltyp := Get_Arg_Type (Lhs);
1953 Rtyp := Get_Arg_Type (Rhs);
1955 -- For now, if the argument types are not the same, go to the base type,
1956 -- since the code assumes that the formals have the same type. This is
1957 -- fixable in future ???
1959 if Ltyp /= Rtyp then
1960 Ltyp := Base_Type (Ltyp);
1961 Rtyp := Base_Type (Rtyp);
1962 pragma Assert (Ltyp = Rtyp);
1965 -- Build list of formals for function
1967 Formals := New_List (
1968 Make_Parameter_Specification (Loc,
1969 Defining_Identifier => A,
1970 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
1972 Make_Parameter_Specification (Loc,
1973 Defining_Identifier => B,
1974 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
1976 Func_Name := Make_Temporary (Loc, 'E');
1978 -- Build statement sequence for function
1981 Make_Subprogram_Body (Loc,
1983 Make_Function_Specification (Loc,
1984 Defining_Unit_Name => Func_Name,
1985 Parameter_Specifications => Formals,
1986 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
1988 Declarations => Decls,
1990 Handled_Statement_Sequence =>
1991 Make_Handled_Sequence_Of_Statements (Loc,
1992 Statements => New_List (
1994 Make_Implicit_If_Statement (Nod,
1995 Condition => Test_Empty_Arrays,
1996 Then_Statements => New_List (
1997 Make_Simple_Return_Statement (Loc,
1999 New_Occurrence_Of (Standard_True, Loc)))),
2001 Make_Implicit_If_Statement (Nod,
2002 Condition => Test_Lengths_Correspond,
2003 Then_Statements => New_List (
2004 Make_Simple_Return_Statement (Loc,
2005 Expression => New_Occurrence_Of (Standard_False, Loc)))),
2007 Handle_One_Dimension (1, First_Index (Ltyp)),
2009 Make_Simple_Return_Statement (Loc,
2010 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2012 Set_Has_Completion (Func_Name, True);
2013 Set_Is_Inlined (Func_Name);
2015 -- If the array type is distinct from the type of the arguments, it
2016 -- is the full view of a private type. Apply an unchecked conversion
2017 -- to insure that analysis of the call succeeds.
2027 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
2029 L := OK_Convert_To (Ltyp, Lhs);
2033 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
2035 R := OK_Convert_To (Rtyp, Rhs);
2038 Actuals := New_List (L, R);
2041 Append_To (Bodies, Func_Body);
2044 Make_Function_Call (Loc,
2045 Name => New_Occurrence_Of (Func_Name, Loc),
2046 Parameter_Associations => Actuals);
2047 end Expand_Array_Equality;
2049 -----------------------------
2050 -- Expand_Boolean_Operator --
2051 -----------------------------
2053 -- Note that we first get the actual subtypes of the operands, since we
2054 -- always want to deal with types that have bounds.
2056 procedure Expand_Boolean_Operator (N : Node_Id) is
2057 Typ : constant Entity_Id := Etype (N);
2060 -- Special case of bit packed array where both operands are known to be
2061 -- properly aligned. In this case we use an efficient run time routine
2062 -- to carry out the operation (see System.Bit_Ops).
2064 if Is_Bit_Packed_Array (Typ)
2065 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2066 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2068 Expand_Packed_Boolean_Operator (N);
2072 -- For the normal non-packed case, the general expansion is to build
2073 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2074 -- and then inserting it into the tree. The original operator node is
2075 -- then rewritten as a call to this function. We also use this in the
2076 -- packed case if either operand is a possibly unaligned object.
2079 Loc : constant Source_Ptr := Sloc (N);
2080 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2081 R : Node_Id := Relocate_Node (Right_Opnd (N));
2082 Func_Body : Node_Id;
2083 Func_Name : Entity_Id;
2086 Convert_To_Actual_Subtype (L);
2087 Convert_To_Actual_Subtype (R);
2088 Ensure_Defined (Etype (L), N);
2089 Ensure_Defined (Etype (R), N);
2090 Apply_Length_Check (R, Etype (L));
2092 if Nkind (N) = N_Op_Xor then
2093 R := Duplicate_Subexpr (R);
2094 Silly_Boolean_Array_Xor_Test (N, R, Etype (L));
2097 if Nkind (Parent (N)) = N_Assignment_Statement
2098 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2100 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2102 elsif Nkind (Parent (N)) = N_Op_Not
2103 and then Nkind (N) = N_Op_And
2104 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2105 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2110 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2111 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2112 Insert_Action (N, Func_Body);
2114 -- Now rewrite the expression with a call
2117 Make_Function_Call (Loc,
2118 Name => New_Occurrence_Of (Func_Name, Loc),
2119 Parameter_Associations =>
2122 Make_Type_Conversion
2123 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
2125 Analyze_And_Resolve (N, Typ);
2128 end Expand_Boolean_Operator;
2130 ------------------------------------------------
2131 -- Expand_Compare_Minimize_Eliminate_Overflow --
2132 ------------------------------------------------
2134 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2135 Loc : constant Source_Ptr := Sloc (N);
2137 Result_Type : constant Entity_Id := Etype (N);
2138 -- Capture result type (could be a derived boolean type)
2143 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2144 -- Entity for Long_Long_Integer'Base
2146 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2147 -- Current overflow checking mode
2150 procedure Set_False;
2151 -- These procedures rewrite N with an occurrence of Standard_True or
2152 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2158 procedure Set_False is
2160 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2161 Warn_On_Known_Condition (N);
2168 procedure Set_True is
2170 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2171 Warn_On_Known_Condition (N);
2174 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2177 -- Nothing to do unless we have a comparison operator with operands
2178 -- that are signed integer types, and we are operating in either
2179 -- MINIMIZED or ELIMINATED overflow checking mode.
2181 if Nkind (N) not in N_Op_Compare
2182 or else Check not in Minimized_Or_Eliminated
2183 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2188 -- OK, this is the case we are interested in. First step is to process
2189 -- our operands using the Minimize_Eliminate circuitry which applies
2190 -- this processing to the two operand subtrees.
2192 Minimize_Eliminate_Overflows
2193 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2194 Minimize_Eliminate_Overflows
2195 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2197 -- See if the range information decides the result of the comparison.
2198 -- We can only do this if we in fact have full range information (which
2199 -- won't be the case if either operand is bignum at this stage).
2201 if Llo /= No_Uint and then Rlo /= No_Uint then
2202 case N_Op_Compare (Nkind (N)) is
2204 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2206 elsif Llo > Rhi or else Lhi < Rlo then
2213 elsif Lhi < Rlo then
2220 elsif Lhi <= Rlo then
2227 elsif Lhi <= Rlo then
2234 elsif Lhi < Rlo then
2239 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2241 elsif Llo > Rhi or else Lhi < Rlo then
2246 -- All done if we did the rewrite
2248 if Nkind (N) not in N_Op_Compare then
2253 -- Otherwise, time to do the comparison
2256 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2257 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2260 -- If the two operands have the same signed integer type we are
2261 -- all set, nothing more to do. This is the case where either
2262 -- both operands were unchanged, or we rewrote both of them to
2263 -- be Long_Long_Integer.
2265 -- Note: Entity for the comparison may be wrong, but it's not worth
2266 -- the effort to change it, since the back end does not use it.
2268 if Is_Signed_Integer_Type (Ltype)
2269 and then Base_Type (Ltype) = Base_Type (Rtype)
2273 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2275 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2277 Left : Node_Id := Left_Opnd (N);
2278 Right : Node_Id := Right_Opnd (N);
2279 -- Bignum references for left and right operands
2282 if not Is_RTE (Ltype, RE_Bignum) then
2283 Left := Convert_To_Bignum (Left);
2284 elsif not Is_RTE (Rtype, RE_Bignum) then
2285 Right := Convert_To_Bignum (Right);
2288 -- We rewrite our node with:
2291 -- Bnn : Result_Type;
2293 -- M : Mark_Id := SS_Mark;
2295 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2303 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2304 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2308 case N_Op_Compare (Nkind (N)) is
2309 when N_Op_Eq => Ent := RE_Big_EQ;
2310 when N_Op_Ge => Ent := RE_Big_GE;
2311 when N_Op_Gt => Ent := RE_Big_GT;
2312 when N_Op_Le => Ent := RE_Big_LE;
2313 when N_Op_Lt => Ent := RE_Big_LT;
2314 when N_Op_Ne => Ent := RE_Big_NE;
2317 -- Insert assignment to Bnn into the bignum block
2320 (First (Statements (Handled_Statement_Sequence (Blk))),
2321 Make_Assignment_Statement (Loc,
2322 Name => New_Occurrence_Of (Bnn, Loc),
2324 Make_Function_Call (Loc,
2326 New_Occurrence_Of (RTE (Ent), Loc),
2327 Parameter_Associations => New_List (Left, Right))));
2329 -- Now do the rewrite with expression actions
2332 Make_Expression_With_Actions (Loc,
2333 Actions => New_List (
2334 Make_Object_Declaration (Loc,
2335 Defining_Identifier => Bnn,
2336 Object_Definition =>
2337 New_Occurrence_Of (Result_Type, Loc)),
2339 Expression => New_Occurrence_Of (Bnn, Loc)));
2340 Analyze_And_Resolve (N, Result_Type);
2344 -- No bignums involved, but types are different, so we must have
2345 -- rewritten one of the operands as a Long_Long_Integer but not
2348 -- If left operand is Long_Long_Integer, convert right operand
2349 -- and we are done (with a comparison of two Long_Long_Integers).
2351 elsif Ltype = LLIB then
2352 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2353 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2356 -- If right operand is Long_Long_Integer, convert left operand
2357 -- and we are done (with a comparison of two Long_Long_Integers).
2359 -- This is the only remaining possibility
2361 else pragma Assert (Rtype = LLIB);
2362 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2363 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2367 end Expand_Compare_Minimize_Eliminate_Overflow;
2369 -------------------------------
2370 -- Expand_Composite_Equality --
2371 -------------------------------
2373 -- This function is only called for comparing internal fields of composite
2374 -- types when these fields are themselves composites. This is a special
2375 -- case because it is not possible to respect normal Ada visibility rules.
2377 function Expand_Composite_Equality
2382 Bodies : List_Id) return Node_Id
2384 Loc : constant Source_Ptr := Sloc (Nod);
2385 Full_Type : Entity_Id;
2388 -- Start of processing for Expand_Composite_Equality
2391 if Is_Private_Type (Typ) then
2392 Full_Type := Underlying_Type (Typ);
2397 -- If the private type has no completion the context may be the
2398 -- expansion of a composite equality for a composite type with some
2399 -- still incomplete components. The expression will not be analyzed
2400 -- until the enclosing type is completed, at which point this will be
2401 -- properly expanded, unless there is a bona fide completion error.
2403 if No (Full_Type) then
2404 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2407 Full_Type := Base_Type (Full_Type);
2409 -- When the base type itself is private, use the full view to expand
2410 -- the composite equality.
2412 if Is_Private_Type (Full_Type) then
2413 Full_Type := Underlying_Type (Full_Type);
2416 -- Case of array types
2418 if Is_Array_Type (Full_Type) then
2420 -- If the operand is an elementary type other than a floating-point
2421 -- type, then we can simply use the built-in block bitwise equality,
2422 -- since the predefined equality operators always apply and bitwise
2423 -- equality is fine for all these cases.
2425 if Is_Elementary_Type (Component_Type (Full_Type))
2426 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2428 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2430 -- For composite component types, and floating-point types, use the
2431 -- expansion. This deals with tagged component types (where we use
2432 -- the applicable equality routine) and floating-point (where we
2433 -- need to worry about negative zeroes), and also the case of any
2434 -- composite type recursively containing such fields.
2438 Comp_Typ : Entity_Id;
2445 -- Do the comparison in the type (or its full view) and not in
2446 -- its unconstrained base type, because the latter operation is
2447 -- more complex and would also require an unchecked conversion.
2449 if Is_Private_Type (Typ) then
2450 Comp_Typ := Underlying_Type (Typ);
2455 -- Except for the case where the bounds of the type depend on a
2456 -- discriminant, or else we would run into scoping issues.
2458 Indx := First_Index (Comp_Typ);
2459 while Present (Indx) loop
2460 Ityp := Etype (Indx);
2462 Lo := Type_Low_Bound (Ityp);
2463 Hi := Type_High_Bound (Ityp);
2465 if (Nkind (Lo) = N_Identifier
2466 and then Ekind (Entity (Lo)) = E_Discriminant)
2468 (Nkind (Hi) = N_Identifier
2469 and then Ekind (Entity (Hi)) = E_Discriminant)
2471 Comp_Typ := Full_Type;
2478 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Comp_Typ);
2482 -- Case of tagged record types
2484 elsif Is_Tagged_Type (Full_Type) then
2485 Eq_Op := Find_Primitive_Eq (Typ);
2486 pragma Assert (Present (Eq_Op));
2489 Make_Function_Call (Loc,
2490 Name => New_Occurrence_Of (Eq_Op, Loc),
2491 Parameter_Associations =>
2493 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2494 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2496 -- Case of untagged record types
2498 elsif Is_Record_Type (Full_Type) then
2499 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2501 if Present (Eq_Op) then
2502 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2504 -- Inherited equality from parent type. Convert the actuals to
2505 -- match signature of operation.
2508 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2512 Make_Function_Call (Loc,
2513 Name => New_Occurrence_Of (Eq_Op, Loc),
2514 Parameter_Associations => New_List (
2515 OK_Convert_To (T, Lhs),
2516 OK_Convert_To (T, Rhs)));
2520 -- Comparison between Unchecked_Union components
2522 if Is_Unchecked_Union (Full_Type) then
2524 Lhs_Type : Node_Id := Full_Type;
2525 Rhs_Type : Node_Id := Full_Type;
2526 Lhs_Discr_Val : Node_Id;
2527 Rhs_Discr_Val : Node_Id;
2532 if Nkind (Lhs) = N_Selected_Component then
2533 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2538 if Nkind (Rhs) = N_Selected_Component then
2539 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2542 -- Lhs of the composite equality
2544 if Is_Constrained (Lhs_Type) then
2546 -- Since the enclosing record type can never be an
2547 -- Unchecked_Union (this code is executed for records
2548 -- that do not have variants), we may reference its
2551 if Nkind (Lhs) = N_Selected_Component
2552 and then Has_Per_Object_Constraint
2553 (Entity (Selector_Name (Lhs)))
2556 Make_Selected_Component (Loc,
2557 Prefix => Prefix (Lhs),
2560 (Get_Discriminant_Value
2561 (First_Discriminant (Lhs_Type),
2563 Stored_Constraint (Lhs_Type))));
2568 (Get_Discriminant_Value
2569 (First_Discriminant (Lhs_Type),
2571 Stored_Constraint (Lhs_Type)));
2575 -- It is not possible to infer the discriminant since
2576 -- the subtype is not constrained.
2579 Make_Raise_Program_Error (Loc,
2580 Reason => PE_Unchecked_Union_Restriction);
2583 -- Rhs of the composite equality
2585 if Is_Constrained (Rhs_Type) then
2586 if Nkind (Rhs) = N_Selected_Component
2587 and then Has_Per_Object_Constraint
2588 (Entity (Selector_Name (Rhs)))
2591 Make_Selected_Component (Loc,
2592 Prefix => Prefix (Rhs),
2595 (Get_Discriminant_Value
2596 (First_Discriminant (Rhs_Type),
2598 Stored_Constraint (Rhs_Type))));
2603 (Get_Discriminant_Value
2604 (First_Discriminant (Rhs_Type),
2606 Stored_Constraint (Rhs_Type)));
2611 Make_Raise_Program_Error (Loc,
2612 Reason => PE_Unchecked_Union_Restriction);
2615 -- Call the TSS equality function with the inferred
2616 -- discriminant values.
2619 Make_Function_Call (Loc,
2620 Name => New_Occurrence_Of (Eq_Op, Loc),
2621 Parameter_Associations => New_List (
2628 -- All cases other than comparing Unchecked_Union types
2632 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2635 Make_Function_Call (Loc,
2637 New_Occurrence_Of (Eq_Op, Loc),
2638 Parameter_Associations => New_List (
2639 OK_Convert_To (T, Lhs),
2640 OK_Convert_To (T, Rhs)));
2645 -- Equality composes in Ada 2012 for untagged record types. It also
2646 -- composes for bounded strings, because they are part of the
2647 -- predefined environment. We could make it compose for bounded
2648 -- strings by making them tagged, or by making sure all subcomponents
2649 -- are set to the same value, even when not used. Instead, we have
2650 -- this special case in the compiler, because it's more efficient.
2652 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2654 -- If no TSS has been created for the type, check whether there is
2655 -- a primitive equality declared for it.
2658 Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
2661 -- Use user-defined primitive if it exists, otherwise use
2662 -- predefined equality.
2664 if Present (Op) then
2667 return Make_Op_Eq (Loc, Lhs, Rhs);
2672 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2675 -- Non-composite types (always use predefined equality)
2678 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2680 end Expand_Composite_Equality;
2682 ------------------------
2683 -- Expand_Concatenate --
2684 ------------------------
2686 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2687 Loc : constant Source_Ptr := Sloc (Cnode);
2689 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2690 -- Result type of concatenation
2692 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2693 -- Component type. Elements of this component type can appear as one
2694 -- of the operands of concatenation as well as arrays.
2696 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2699 Ityp : constant Entity_Id := Base_Type (Istyp);
2700 -- Index type. This is the base type of the index subtype, and is used
2701 -- for all computed bounds (which may be out of range of Istyp in the
2702 -- case of null ranges).
2705 -- This is the type we use to do arithmetic to compute the bounds and
2706 -- lengths of operands. The choice of this type is a little subtle and
2707 -- is discussed in a separate section at the start of the body code.
2709 Concatenation_Error : exception;
2710 -- Raised if concatenation is sure to raise a CE
2712 Result_May_Be_Null : Boolean := True;
2713 -- Reset to False if at least one operand is encountered which is known
2714 -- at compile time to be non-null. Used for handling the special case
2715 -- of setting the high bound to the last operand high bound for a null
2716 -- result, thus ensuring a proper high bound in the super-flat case.
2718 N : constant Nat := List_Length (Opnds);
2719 -- Number of concatenation operands including possibly null operands
2722 -- Number of operands excluding any known to be null, except that the
2723 -- last operand is always retained, in case it provides the bounds for
2726 Opnd : Node_Id := Empty;
2727 -- Current operand being processed in the loop through operands. After
2728 -- this loop is complete, always contains the last operand (which is not
2729 -- the same as Operands (NN), since null operands are skipped).
2731 -- Arrays describing the operands, only the first NN entries of each
2732 -- array are set (NN < N when we exclude known null operands).
2734 Is_Fixed_Length : array (1 .. N) of Boolean;
2735 -- True if length of corresponding operand known at compile time
2737 Operands : array (1 .. N) of Node_Id;
2738 -- Set to the corresponding entry in the Opnds list (but note that null
2739 -- operands are excluded, so not all entries in the list are stored).
2741 Fixed_Length : array (1 .. N) of Uint;
2742 -- Set to length of operand. Entries in this array are set only if the
2743 -- corresponding entry in Is_Fixed_Length is True.
2745 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2746 -- Set to lower bound of operand. Either an integer literal in the case
2747 -- where the bound is known at compile time, else actual lower bound.
2748 -- The operand low bound is of type Ityp.
2750 Var_Length : array (1 .. N) of Entity_Id;
2751 -- Set to an entity of type Natural that contains the length of an
2752 -- operand whose length is not known at compile time. Entries in this
2753 -- array are set only if the corresponding entry in Is_Fixed_Length
2754 -- is False. The entity is of type Artyp.
2756 Aggr_Length : array (0 .. N) of Node_Id;
2757 -- The J'th entry in an expression node that represents the total length
2758 -- of operands 1 through J. It is either an integer literal node, or a
2759 -- reference to a constant entity with the right value, so it is fine
2760 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2761 -- entry always is set to zero. The length is of type Artyp.
2763 Low_Bound : Node_Id;
2764 -- A tree node representing the low bound of the result (of type Ityp).
2765 -- This is either an integer literal node, or an identifier reference to
2766 -- a constant entity initialized to the appropriate value.
2768 Last_Opnd_Low_Bound : Node_Id := Empty;
2769 -- A tree node representing the low bound of the last operand. This
2770 -- need only be set if the result could be null. It is used for the
2771 -- special case of setting the right low bound for a null result.
2772 -- This is of type Ityp.
2774 Last_Opnd_High_Bound : Node_Id := Empty;
2775 -- A tree node representing the high bound of the last operand. This
2776 -- need only be set if the result could be null. It is used for the
2777 -- special case of setting the right high bound for a null result.
2778 -- This is of type Ityp.
2780 High_Bound : Node_Id := Empty;
2781 -- A tree node representing the high bound of the result (of type Ityp)
2784 -- Result of the concatenation (of type Ityp)
2786 Actions : constant List_Id := New_List;
2787 -- Collect actions to be inserted
2789 Known_Non_Null_Operand_Seen : Boolean;
2790 -- Set True during generation of the assignments of operands into
2791 -- result once an operand known to be non-null has been seen.
2793 function Library_Level_Target return Boolean;
2794 -- Return True if the concatenation is within the expression of the
2795 -- declaration of a library-level object.
2797 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2798 -- This function makes an N_Integer_Literal node that is returned in
2799 -- analyzed form with the type set to Artyp. Importantly this literal
2800 -- is not flagged as static, so that if we do computations with it that
2801 -- result in statically detected out of range conditions, we will not
2802 -- generate error messages but instead warning messages.
2804 function To_Artyp (X : Node_Id) return Node_Id;
2805 -- Given a node of type Ityp, returns the corresponding value of type
2806 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2807 -- For enum types, the Pos of the value is returned.
2809 function To_Ityp (X : Node_Id) return Node_Id;
2810 -- The inverse function (uses Val in the case of enumeration types)
2812 --------------------------
2813 -- Library_Level_Target --
2814 --------------------------
2816 function Library_Level_Target return Boolean is
2817 P : Node_Id := Parent (Cnode);
2820 while Present (P) loop
2821 if Nkind (P) = N_Object_Declaration then
2822 return Is_Library_Level_Entity (Defining_Identifier (P));
2824 -- Prevent the search from going too far
2826 elsif Is_Body_Or_Package_Declaration (P) then
2834 end Library_Level_Target;
2836 ------------------------
2837 -- Make_Artyp_Literal --
2838 ------------------------
2840 function Make_Artyp_Literal (Val : Nat) return Node_Id is
2841 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2843 Set_Etype (Result, Artyp);
2844 Set_Analyzed (Result, True);
2845 Set_Is_Static_Expression (Result, False);
2847 end Make_Artyp_Literal;
2853 function To_Artyp (X : Node_Id) return Node_Id is
2855 if Ityp = Base_Type (Artyp) then
2858 elsif Is_Enumeration_Type (Ityp) then
2860 Make_Attribute_Reference (Loc,
2861 Prefix => New_Occurrence_Of (Ityp, Loc),
2862 Attribute_Name => Name_Pos,
2863 Expressions => New_List (X));
2866 return Convert_To (Artyp, X);
2874 function To_Ityp (X : Node_Id) return Node_Id is
2876 if Is_Enumeration_Type (Ityp) then
2878 Make_Attribute_Reference (Loc,
2879 Prefix => New_Occurrence_Of (Ityp, Loc),
2880 Attribute_Name => Name_Val,
2881 Expressions => New_List (X));
2883 -- Case where we will do a type conversion
2886 if Ityp = Base_Type (Artyp) then
2889 return Convert_To (Ityp, X);
2894 -- Local Declarations
2896 Opnd_Typ : Entity_Id;
2903 -- Start of processing for Expand_Concatenate
2906 -- Choose an appropriate computational type
2908 -- We will be doing calculations of lengths and bounds in this routine
2909 -- and computing one from the other in some cases, e.g. getting the high
2910 -- bound by adding the length-1 to the low bound.
2912 -- We can't just use the index type, or even its base type for this
2913 -- purpose for two reasons. First it might be an enumeration type which
2914 -- is not suitable for computations of any kind, and second it may
2915 -- simply not have enough range. For example if the index type is
2916 -- -128..+127 then lengths can be up to 256, which is out of range of
2919 -- For enumeration types, we can simply use Standard_Integer, this is
2920 -- sufficient since the actual number of enumeration literals cannot
2921 -- possibly exceed the range of integer (remember we will be doing the
2922 -- arithmetic with POS values, not representation values).
2924 if Is_Enumeration_Type (Ityp) then
2925 Artyp := Standard_Integer;
2927 -- If index type is Positive, we use the standard unsigned type, to give
2928 -- more room on the top of the range, obviating the need for an overflow
2929 -- check when creating the upper bound. This is needed to avoid junk
2930 -- overflow checks in the common case of String types.
2932 -- ??? Disabled for now
2934 -- elsif Istyp = Standard_Positive then
2935 -- Artyp := Standard_Unsigned;
2937 -- For modular types, we use a 32-bit modular type for types whose size
2938 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2939 -- identity type, and for larger unsigned types we use 64-bits.
2941 elsif Is_Modular_Integer_Type (Ityp) then
2942 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
2943 Artyp := Standard_Unsigned;
2944 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
2947 Artyp := RTE (RE_Long_Long_Unsigned);
2950 -- Similar treatment for signed types
2953 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
2954 Artyp := Standard_Integer;
2955 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
2958 Artyp := Standard_Long_Long_Integer;
2962 -- Supply dummy entry at start of length array
2964 Aggr_Length (0) := Make_Artyp_Literal (0);
2966 -- Go through operands setting up the above arrays
2970 Opnd := Remove_Head (Opnds);
2971 Opnd_Typ := Etype (Opnd);
2973 -- The parent got messed up when we put the operands in a list,
2974 -- so now put back the proper parent for the saved operand, that
2975 -- is to say the concatenation node, to make sure that each operand
2976 -- is seen as a subexpression, e.g. if actions must be inserted.
2978 Set_Parent (Opnd, Cnode);
2980 -- Set will be True when we have setup one entry in the array
2984 -- Singleton element (or character literal) case
2986 if Base_Type (Opnd_Typ) = Ctyp then
2988 Operands (NN) := Opnd;
2989 Is_Fixed_Length (NN) := True;
2990 Fixed_Length (NN) := Uint_1;
2991 Result_May_Be_Null := False;
2993 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2994 -- since we know that the result cannot be null).
2996 Opnd_Low_Bound (NN) :=
2997 Make_Attribute_Reference (Loc,
2998 Prefix => New_Occurrence_Of (Istyp, Loc),
2999 Attribute_Name => Name_First);
3003 -- String literal case (can only occur for strings of course)
3005 elsif Nkind (Opnd) = N_String_Literal then
3006 Len := String_Literal_Length (Opnd_Typ);
3009 Result_May_Be_Null := False;
3012 -- Capture last operand low and high bound if result could be null
3014 if J = N and then Result_May_Be_Null then
3015 Last_Opnd_Low_Bound :=
3016 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3018 Last_Opnd_High_Bound :=
3019 Make_Op_Subtract (Loc,
3021 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
3022 Right_Opnd => Make_Integer_Literal (Loc, 1));
3025 -- Skip null string literal
3027 if J < N and then Len = 0 then
3032 Operands (NN) := Opnd;
3033 Is_Fixed_Length (NN) := True;
3035 -- Set length and bounds
3037 Fixed_Length (NN) := Len;
3039 Opnd_Low_Bound (NN) :=
3040 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3047 -- Check constrained case with known bounds
3049 if Is_Constrained (Opnd_Typ) then
3051 Index : constant Node_Id := First_Index (Opnd_Typ);
3052 Indx_Typ : constant Entity_Id := Etype (Index);
3053 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3054 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3057 -- Fixed length constrained array type with known at compile
3058 -- time bounds is last case of fixed length operand.
3060 if Compile_Time_Known_Value (Lo)
3062 Compile_Time_Known_Value (Hi)
3065 Loval : constant Uint := Expr_Value (Lo);
3066 Hival : constant Uint := Expr_Value (Hi);
3067 Len : constant Uint :=
3068 UI_Max (Hival - Loval + 1, Uint_0);
3072 Result_May_Be_Null := False;
3075 -- Capture last operand bounds if result could be null
3077 if J = N and then Result_May_Be_Null then
3078 Last_Opnd_Low_Bound :=
3080 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3082 Last_Opnd_High_Bound :=
3084 Make_Integer_Literal (Loc, Expr_Value (Hi)));
3087 -- Exclude null length case unless last operand
3089 if J < N and then Len = 0 then
3094 Operands (NN) := Opnd;
3095 Is_Fixed_Length (NN) := True;
3096 Fixed_Length (NN) := Len;
3098 Opnd_Low_Bound (NN) :=
3100 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3107 -- All cases where the length is not known at compile time, or the
3108 -- special case of an operand which is known to be null but has a
3109 -- lower bound other than 1 or is other than a string type.
3114 -- Capture operand bounds
3116 Opnd_Low_Bound (NN) :=
3117 Make_Attribute_Reference (Loc,
3119 Duplicate_Subexpr (Opnd, Name_Req => True),
3120 Attribute_Name => Name_First);
3122 -- Capture last operand bounds if result could be null
3124 if J = N and Result_May_Be_Null then
3125 Last_Opnd_Low_Bound :=
3127 Make_Attribute_Reference (Loc,
3129 Duplicate_Subexpr (Opnd, Name_Req => True),
3130 Attribute_Name => Name_First));
3132 Last_Opnd_High_Bound :=
3134 Make_Attribute_Reference (Loc,
3136 Duplicate_Subexpr (Opnd, Name_Req => True),
3137 Attribute_Name => Name_Last));
3140 -- Capture length of operand in entity
3142 Operands (NN) := Opnd;
3143 Is_Fixed_Length (NN) := False;
3145 Var_Length (NN) := Make_Temporary (Loc, 'L');
3148 Make_Object_Declaration (Loc,
3149 Defining_Identifier => Var_Length (NN),
3150 Constant_Present => True,
3151 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3153 Make_Attribute_Reference (Loc,
3155 Duplicate_Subexpr (Opnd, Name_Req => True),
3156 Attribute_Name => Name_Length)));
3160 -- Set next entry in aggregate length array
3162 -- For first entry, make either integer literal for fixed length
3163 -- or a reference to the saved length for variable length.
3166 if Is_Fixed_Length (1) then
3167 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3169 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3172 -- If entry is fixed length and only fixed lengths so far, make
3173 -- appropriate new integer literal adding new length.
3175 elsif Is_Fixed_Length (NN)
3176 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3179 Make_Integer_Literal (Loc,
3180 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3182 -- All other cases, construct an addition node for the length and
3183 -- create an entity initialized to this length.
3186 Ent := Make_Temporary (Loc, 'L');
3188 if Is_Fixed_Length (NN) then
3189 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3191 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3195 Make_Object_Declaration (Loc,
3196 Defining_Identifier => Ent,
3197 Constant_Present => True,
3198 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3201 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)),
3202 Right_Opnd => Clen)));
3204 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3211 -- If we have only skipped null operands, return the last operand
3218 -- If we have only one non-null operand, return it and we are done.
3219 -- There is one case in which this cannot be done, and that is when
3220 -- the sole operand is of the element type, in which case it must be
3221 -- converted to an array, and the easiest way of doing that is to go
3222 -- through the normal general circuit.
3224 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3225 Result := Operands (1);
3229 -- Cases where we have a real concatenation
3231 -- Next step is to find the low bound for the result array that we
3232 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3234 -- If the ultimate ancestor of the index subtype is a constrained array
3235 -- definition, then the lower bound is that of the index subtype as
3236 -- specified by (RM 4.5.3(6)).
3238 -- The right test here is to go to the root type, and then the ultimate
3239 -- ancestor is the first subtype of this root type.
3241 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3243 Make_Attribute_Reference (Loc,
3245 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3246 Attribute_Name => Name_First);
3248 -- If the first operand in the list has known length we know that
3249 -- the lower bound of the result is the lower bound of this operand.
3251 elsif Is_Fixed_Length (1) then
3252 Low_Bound := Opnd_Low_Bound (1);
3254 -- OK, we don't know the lower bound, we have to build a horrible
3255 -- if expression node of the form
3257 -- if Cond1'Length /= 0 then
3260 -- if Opnd2'Length /= 0 then
3265 -- The nesting ends either when we hit an operand whose length is known
3266 -- at compile time, or on reaching the last operand, whose low bound we
3267 -- take unconditionally whether or not it is null. It's easiest to do
3268 -- this with a recursive procedure:
3272 function Get_Known_Bound (J : Nat) return Node_Id;
3273 -- Returns the lower bound determined by operands J .. NN
3275 ---------------------
3276 -- Get_Known_Bound --
3277 ---------------------
3279 function Get_Known_Bound (J : Nat) return Node_Id is
3281 if Is_Fixed_Length (J) or else J = NN then
3282 return New_Copy_Tree (Opnd_Low_Bound (J));
3286 Make_If_Expression (Loc,
3287 Expressions => New_List (
3291 New_Occurrence_Of (Var_Length (J), Loc),
3293 Make_Integer_Literal (Loc, 0)),
3295 New_Copy_Tree (Opnd_Low_Bound (J)),
3296 Get_Known_Bound (J + 1)));
3298 end Get_Known_Bound;
3301 Ent := Make_Temporary (Loc, 'L');
3304 Make_Object_Declaration (Loc,
3305 Defining_Identifier => Ent,
3306 Constant_Present => True,
3307 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3308 Expression => Get_Known_Bound (1)));
3310 Low_Bound := New_Occurrence_Of (Ent, Loc);
3314 -- Now we can safely compute the upper bound, normally
3315 -- Low_Bound + Length - 1.
3320 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3322 Make_Op_Subtract (Loc,
3323 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3324 Right_Opnd => Make_Artyp_Literal (1))));
3326 -- Note that calculation of the high bound may cause overflow in some
3327 -- very weird cases, so in the general case we need an overflow check on
3328 -- the high bound. We can avoid this for the common case of string types
3329 -- and other types whose index is Positive, since we chose a wider range
3330 -- for the arithmetic type. If checks are suppressed we do not set the
3331 -- flag, and possibly superfluous warnings will be omitted.
3333 if Istyp /= Standard_Positive
3334 and then not Overflow_Checks_Suppressed (Istyp)
3336 Activate_Overflow_Check (High_Bound);
3339 -- Handle the exceptional case where the result is null, in which case
3340 -- case the bounds come from the last operand (so that we get the proper
3341 -- bounds if the last operand is super-flat).
3343 if Result_May_Be_Null then
3345 Make_If_Expression (Loc,
3346 Expressions => New_List (
3348 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3349 Right_Opnd => Make_Artyp_Literal (0)),
3350 Last_Opnd_Low_Bound,
3354 Make_If_Expression (Loc,
3355 Expressions => New_List (
3357 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3358 Right_Opnd => Make_Artyp_Literal (0)),
3359 Last_Opnd_High_Bound,
3363 -- Here is where we insert the saved up actions
3365 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3367 -- Now we construct an array object with appropriate bounds. We mark
3368 -- the target as internal to prevent useless initialization when
3369 -- Initialize_Scalars is enabled. Also since this is the actual result
3370 -- entity, we make sure we have debug information for the result.
3372 Ent := Make_Temporary (Loc, 'S');
3373 Set_Is_Internal (Ent);
3374 Set_Debug_Info_Needed (Ent);
3376 -- If the bound is statically known to be out of range, we do not want
3377 -- to abort, we want a warning and a runtime constraint error. Note that
3378 -- we have arranged that the result will not be treated as a static
3379 -- constant, so we won't get an illegality during this insertion.
3381 Insert_Action (Cnode,
3382 Make_Object_Declaration (Loc,
3383 Defining_Identifier => Ent,
3384 Object_Definition =>
3385 Make_Subtype_Indication (Loc,
3386 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3388 Make_Index_Or_Discriminant_Constraint (Loc,
3389 Constraints => New_List (
3391 Low_Bound => Low_Bound,
3392 High_Bound => High_Bound))))),
3393 Suppress => All_Checks);
3395 -- If the result of the concatenation appears as the initializing
3396 -- expression of an object declaration, we can just rename the
3397 -- result, rather than copying it.
3399 Set_OK_To_Rename (Ent);
3401 -- Catch the static out of range case now
3403 if Raises_Constraint_Error (High_Bound) then
3404 raise Concatenation_Error;
3407 -- Now we will generate the assignments to do the actual concatenation
3409 -- There is one case in which we will not do this, namely when all the
3410 -- following conditions are met:
3412 -- The result type is Standard.String
3414 -- There are nine or fewer retained (non-null) operands
3416 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3417 -- and the debug flag gnatd.c is not set.
3419 -- The corresponding System.Concat_n.Str_Concat_n routine is
3420 -- available in the run time.
3422 -- If all these conditions are met then we generate a call to the
3423 -- relevant concatenation routine. The purpose of this is to avoid
3424 -- undesirable code bloat at -O0.
3426 -- If the concatenation is within the declaration of a library-level
3427 -- object, we call the built-in concatenation routines to prevent code
3428 -- bloat, regardless of the optimization level. This is space efficient
3429 -- and prevents linking problems when units are compiled with different
3430 -- optimization levels.
3432 if Atyp = Standard_String
3433 and then NN in 2 .. 9
3434 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3435 and then not Debug_Flag_Dot_C)
3436 or else Library_Level_Target)
3439 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3450 if RTE_Available (RR (NN)) then
3452 Opnds : constant List_Id :=
3453 New_List (New_Occurrence_Of (Ent, Loc));
3456 for J in 1 .. NN loop
3457 if Is_List_Member (Operands (J)) then
3458 Remove (Operands (J));
3461 if Base_Type (Etype (Operands (J))) = Ctyp then
3463 Make_Aggregate (Loc,
3464 Component_Associations => New_List (
3465 Make_Component_Association (Loc,
3466 Choices => New_List (
3467 Make_Integer_Literal (Loc, 1)),
3468 Expression => Operands (J)))));
3471 Append_To (Opnds, Operands (J));
3475 Insert_Action (Cnode,
3476 Make_Procedure_Call_Statement (Loc,
3477 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3478 Parameter_Associations => Opnds));
3480 Result := New_Occurrence_Of (Ent, Loc);
3487 -- Not special case so generate the assignments
3489 Known_Non_Null_Operand_Seen := False;
3491 for J in 1 .. NN loop
3493 Lo : constant Node_Id :=
3495 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3496 Right_Opnd => Aggr_Length (J - 1));
3498 Hi : constant Node_Id :=
3500 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3502 Make_Op_Subtract (Loc,
3503 Left_Opnd => Aggr_Length (J),
3504 Right_Opnd => Make_Artyp_Literal (1)));
3507 -- Singleton case, simple assignment
3509 if Base_Type (Etype (Operands (J))) = Ctyp then
3510 Known_Non_Null_Operand_Seen := True;
3511 Insert_Action (Cnode,
3512 Make_Assignment_Statement (Loc,
3514 Make_Indexed_Component (Loc,
3515 Prefix => New_Occurrence_Of (Ent, Loc),
3516 Expressions => New_List (To_Ityp (Lo))),
3517 Expression => Operands (J)),
3518 Suppress => All_Checks);
3520 -- Array case, slice assignment, skipped when argument is fixed
3521 -- length and known to be null.
3523 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3526 Make_Assignment_Statement (Loc,
3530 New_Occurrence_Of (Ent, Loc),
3533 Low_Bound => To_Ityp (Lo),
3534 High_Bound => To_Ityp (Hi))),
3535 Expression => Operands (J));
3537 if Is_Fixed_Length (J) then
3538 Known_Non_Null_Operand_Seen := True;
3540 elsif not Known_Non_Null_Operand_Seen then
3542 -- Here if operand length is not statically known and no
3543 -- operand known to be non-null has been processed yet.
3544 -- If operand length is 0, we do not need to perform the
3545 -- assignment, and we must avoid the evaluation of the
3546 -- high bound of the slice, since it may underflow if the
3547 -- low bound is Ityp'First.
3550 Make_Implicit_If_Statement (Cnode,
3554 New_Occurrence_Of (Var_Length (J), Loc),
3555 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3556 Then_Statements => New_List (Assign));
3559 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3565 -- Finally we build the result, which is a reference to the array object
3567 Result := New_Occurrence_Of (Ent, Loc);
3570 Rewrite (Cnode, Result);
3571 Analyze_And_Resolve (Cnode, Atyp);
3574 when Concatenation_Error =>
3576 -- Kill warning generated for the declaration of the static out of
3577 -- range high bound, and instead generate a Constraint_Error with
3578 -- an appropriate specific message.
3580 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3581 Apply_Compile_Time_Constraint_Error
3583 Msg => "concatenation result upper bound out of range??",
3584 Reason => CE_Range_Check_Failed);
3585 end Expand_Concatenate;
3587 ---------------------------------------------------
3588 -- Expand_Membership_Minimize_Eliminate_Overflow --
3589 ---------------------------------------------------
3591 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3592 pragma Assert (Nkind (N) = N_In);
3593 -- Despite the name, this routine applies only to N_In, not to
3594 -- N_Not_In. The latter is always rewritten as not (X in Y).
3596 Result_Type : constant Entity_Id := Etype (N);
3597 -- Capture result type, may be a derived boolean type
3599 Loc : constant Source_Ptr := Sloc (N);
3600 Lop : constant Node_Id := Left_Opnd (N);
3601 Rop : constant Node_Id := Right_Opnd (N);
3603 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3604 -- is thus tempting to capture these values, but due to the rewrites
3605 -- that occur as a result of overflow checking, these values change
3606 -- as we go along, and it is safe just to always use Etype explicitly.
3608 Restype : constant Entity_Id := Etype (N);
3612 -- Bounds in Minimize calls, not used currently
3614 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3615 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3618 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3620 -- If right operand is a subtype name, and the subtype name has no
3621 -- predicate, then we can just replace the right operand with an
3622 -- explicit range T'First .. T'Last, and use the explicit range code.
3624 if Nkind (Rop) /= N_Range
3625 and then No (Predicate_Function (Etype (Rop)))
3628 Rtyp : constant Entity_Id := Etype (Rop);
3633 Make_Attribute_Reference (Loc,
3634 Attribute_Name => Name_First,
3635 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3637 Make_Attribute_Reference (Loc,
3638 Attribute_Name => Name_Last,
3639 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3640 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3644 -- Here for the explicit range case. Note that the bounds of the range
3645 -- have not been processed for minimized or eliminated checks.
3647 if Nkind (Rop) = N_Range then
3648 Minimize_Eliminate_Overflows
3649 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3650 Minimize_Eliminate_Overflows
3651 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3653 -- We have A in B .. C, treated as A >= B and then A <= C
3657 if Is_RTE (Etype (Lop), RE_Bignum)
3658 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3659 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3662 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3663 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3664 L : constant Entity_Id :=
3665 Make_Defining_Identifier (Loc, Name_uL);
3666 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3667 Lbound : constant Node_Id :=
3668 Convert_To_Bignum (Low_Bound (Rop));
3669 Hbound : constant Node_Id :=
3670 Convert_To_Bignum (High_Bound (Rop));
3672 -- Now we rewrite the membership test node to look like
3675 -- Bnn : Result_Type;
3677 -- M : Mark_Id := SS_Mark;
3678 -- L : Bignum := Lopnd;
3680 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3688 -- Insert declaration of L into declarations of bignum block
3691 (Last (Declarations (Blk)),
3692 Make_Object_Declaration (Loc,
3693 Defining_Identifier => L,
3694 Object_Definition =>
3695 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3696 Expression => Lopnd));
3698 -- Insert assignment to Bnn into expressions of bignum block
3701 (First (Statements (Handled_Statement_Sequence (Blk))),
3702 Make_Assignment_Statement (Loc,
3703 Name => New_Occurrence_Of (Bnn, Loc),
3707 Make_Function_Call (Loc,
3709 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3710 Parameter_Associations => New_List (
3711 New_Occurrence_Of (L, Loc),
3715 Make_Function_Call (Loc,
3717 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3718 Parameter_Associations => New_List (
3719 New_Occurrence_Of (L, Loc),
3722 -- Now rewrite the node
3725 Make_Expression_With_Actions (Loc,
3726 Actions => New_List (
3727 Make_Object_Declaration (Loc,
3728 Defining_Identifier => Bnn,
3729 Object_Definition =>
3730 New_Occurrence_Of (Result_Type, Loc)),
3732 Expression => New_Occurrence_Of (Bnn, Loc)));
3733 Analyze_And_Resolve (N, Result_Type);
3737 -- Here if no bignums around
3740 -- Case where types are all the same
3742 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3744 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3748 -- If types are not all the same, it means that we have rewritten
3749 -- at least one of them to be of type Long_Long_Integer, and we
3750 -- will convert the other operands to Long_Long_Integer.
3753 Convert_To_And_Rewrite (LLIB, Lop);
3754 Set_Analyzed (Lop, False);
3755 Analyze_And_Resolve (Lop, LLIB);
3757 -- For the right operand, avoid unnecessary recursion into
3758 -- this routine, we know that overflow is not possible.
3760 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3761 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3762 Set_Analyzed (Rop, False);
3763 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3766 -- Now the three operands are of the same signed integer type,
3767 -- so we can use the normal expansion routine for membership,
3768 -- setting the flag to prevent recursion into this procedure.
3770 Set_No_Minimize_Eliminate (N);
3774 -- Right operand is a subtype name and the subtype has a predicate. We
3775 -- have to make sure the predicate is checked, and for that we need to
3776 -- use the standard N_In circuitry with appropriate types.
3779 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3781 -- If types are "right", just call Expand_N_In preventing recursion
3783 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3784 Set_No_Minimize_Eliminate (N);
3789 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3791 -- For X in T, we want to rewrite our node as
3794 -- Bnn : Result_Type;
3797 -- M : Mark_Id := SS_Mark;
3798 -- Lnn : Long_Long_Integer'Base
3804 -- if not Bignum_In_LLI_Range (Nnn) then
3807 -- Lnn := From_Bignum (Nnn);
3809 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3810 -- and then T'Base (Lnn) in T;
3819 -- A bit gruesome, but there doesn't seem to be a simpler way
3822 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3823 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3824 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3825 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3826 T : constant Entity_Id := Etype (Rop);
3827 TB : constant Entity_Id := Base_Type (T);
3831 -- Mark the last membership operation to prevent recursion
3835 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3836 Right_Opnd => New_Occurrence_Of (T, Loc));
3837 Set_No_Minimize_Eliminate (Nin);
3839 -- Now decorate the block
3842 (Last (Declarations (Blk)),
3843 Make_Object_Declaration (Loc,
3844 Defining_Identifier => Lnn,
3845 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
3848 (Last (Declarations (Blk)),
3849 Make_Object_Declaration (Loc,
3850 Defining_Identifier => Nnn,
3851 Object_Definition =>
3852 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3855 (First (Statements (Handled_Statement_Sequence (Blk))),
3857 Make_Assignment_Statement (Loc,
3858 Name => New_Occurrence_Of (Nnn, Loc),
3859 Expression => Relocate_Node (Lop)),
3861 Make_Implicit_If_Statement (N,
3865 Make_Function_Call (Loc,
3868 (RTE (RE_Bignum_In_LLI_Range), Loc),
3869 Parameter_Associations => New_List (
3870 New_Occurrence_Of (Nnn, Loc)))),
3872 Then_Statements => New_List (
3873 Make_Assignment_Statement (Loc,
3874 Name => New_Occurrence_Of (Bnn, Loc),
3876 New_Occurrence_Of (Standard_False, Loc))),
3878 Else_Statements => New_List (
3879 Make_Assignment_Statement (Loc,
3880 Name => New_Occurrence_Of (Lnn, Loc),
3882 Make_Function_Call (Loc,
3884 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3885 Parameter_Associations => New_List (
3886 New_Occurrence_Of (Nnn, Loc)))),
3888 Make_Assignment_Statement (Loc,
3889 Name => New_Occurrence_Of (Bnn, Loc),
3894 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3899 Make_Attribute_Reference (Loc,
3900 Attribute_Name => Name_First,
3902 New_Occurrence_Of (TB, Loc))),
3906 Make_Attribute_Reference (Loc,
3907 Attribute_Name => Name_Last,
3909 New_Occurrence_Of (TB, Loc))))),
3911 Right_Opnd => Nin))))));
3913 -- Now we can do the rewrite
3916 Make_Expression_With_Actions (Loc,
3917 Actions => New_List (
3918 Make_Object_Declaration (Loc,
3919 Defining_Identifier => Bnn,
3920 Object_Definition =>
3921 New_Occurrence_Of (Result_Type, Loc)),
3923 Expression => New_Occurrence_Of (Bnn, Loc)));
3924 Analyze_And_Resolve (N, Result_Type);
3928 -- Not bignum case, but types don't match (this means we rewrote the
3929 -- left operand to be Long_Long_Integer).
3932 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
3934 -- We rewrite the membership test as (where T is the type with
3935 -- the predicate, i.e. the type of the right operand)
3937 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3938 -- and then T'Base (Lop) in T
3941 T : constant Entity_Id := Etype (Rop);
3942 TB : constant Entity_Id := Base_Type (T);
3946 -- The last membership test is marked to prevent recursion
3950 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
3951 Right_Opnd => New_Occurrence_Of (T, Loc));
3952 Set_No_Minimize_Eliminate (Nin);
3954 -- Now do the rewrite
3965 Make_Attribute_Reference (Loc,
3966 Attribute_Name => Name_First,
3968 New_Occurrence_Of (TB, Loc))),
3971 Make_Attribute_Reference (Loc,
3972 Attribute_Name => Name_Last,
3974 New_Occurrence_Of (TB, Loc))))),
3975 Right_Opnd => Nin));
3976 Set_Analyzed (N, False);
3977 Analyze_And_Resolve (N, Restype);
3981 end Expand_Membership_Minimize_Eliminate_Overflow;
3983 ---------------------------------
3984 -- Expand_Nonbinary_Modular_Op --
3985 ---------------------------------
3987 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is
3988 Loc : constant Source_Ptr := Sloc (N);
3989 Typ : constant Entity_Id := Etype (N);
3991 procedure Expand_Modular_Addition;
3992 -- Expand the modular addition, handling the special case of adding a
3995 procedure Expand_Modular_Op;
3996 -- Compute the general rule: (lhs OP rhs) mod Modulus
3998 procedure Expand_Modular_Subtraction;
3999 -- Expand the modular addition, handling the special case of subtracting
4002 -----------------------------
4003 -- Expand_Modular_Addition --
4004 -----------------------------
4006 procedure Expand_Modular_Addition is
4008 -- If this is not the addition of a constant then compute it using
4009 -- the general rule: (lhs + rhs) mod Modulus
4011 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4014 -- If this is an addition of a constant, convert it to a subtraction
4015 -- plus a conditional expression since we can compute it faster than
4016 -- computing the modulus.
4018 -- modMinusRhs = Modulus - rhs
4019 -- if lhs < modMinusRhs then lhs + rhs
4020 -- else lhs - modMinusRhs
4024 Mod_Minus_Right : constant Uint :=
4025 Modulus (Typ) - Intval (Right_Opnd (N));
4027 Exprs : constant List_Id := New_List;
4028 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4029 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4030 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4033 -- To prevent spurious visibility issues, convert all
4034 -- operands to Standard.Unsigned.
4036 Set_Left_Opnd (Cond_Expr,
4037 Unchecked_Convert_To (Standard_Unsigned,
4038 New_Copy_Tree (Left_Opnd (N))));
4039 Set_Right_Opnd (Cond_Expr,
4040 Make_Integer_Literal (Loc, Mod_Minus_Right));
4041 Append_To (Exprs, Cond_Expr);
4043 Set_Left_Opnd (Then_Expr,
4044 Unchecked_Convert_To (Standard_Unsigned,
4045 New_Copy_Tree (Left_Opnd (N))));
4046 Set_Right_Opnd (Then_Expr,
4047 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4048 Append_To (Exprs, Then_Expr);
4050 Set_Left_Opnd (Else_Expr,
4051 Unchecked_Convert_To (Standard_Unsigned,
4052 New_Copy_Tree (Left_Opnd (N))));
4053 Set_Right_Opnd (Else_Expr,
4054 Make_Integer_Literal (Loc, Mod_Minus_Right));
4055 Append_To (Exprs, Else_Expr);
4058 Unchecked_Convert_To (Typ,
4059 Make_If_Expression (Loc, Expressions => Exprs)));
4062 end Expand_Modular_Addition;
4064 -----------------------
4065 -- Expand_Modular_Op --
4066 -----------------------
4068 procedure Expand_Modular_Op is
4069 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc);
4070 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc);
4072 Target_Type : Entity_Id;
4075 -- Convert nonbinary modular type operands into integer values. Thus
4076 -- we avoid never-ending loops expanding them, and we also ensure
4077 -- the back end never receives nonbinary modular type expressions.
4079 if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then
4080 Set_Left_Opnd (Op_Expr,
4081 Unchecked_Convert_To (Standard_Unsigned,
4082 New_Copy_Tree (Left_Opnd (N))));
4083 Set_Right_Opnd (Op_Expr,
4084 Unchecked_Convert_To (Standard_Unsigned,
4085 New_Copy_Tree (Right_Opnd (N))));
4086 Set_Left_Opnd (Mod_Expr,
4087 Unchecked_Convert_To (Standard_Integer, Op_Expr));
4090 -- If the modulus of the type is larger than Integer'Last use a
4091 -- larger type for the operands, to prevent spurious constraint
4092 -- errors on large legal literals of the type.
4094 if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
4095 Target_Type := Standard_Long_Integer;
4097 Target_Type := Standard_Integer;
4100 Set_Left_Opnd (Op_Expr,
4101 Unchecked_Convert_To (Target_Type,
4102 New_Copy_Tree (Left_Opnd (N))));
4103 Set_Right_Opnd (Op_Expr,
4104 Unchecked_Convert_To (Target_Type,
4105 New_Copy_Tree (Right_Opnd (N))));
4107 -- Link this node to the tree to analyze it
4109 -- If the parent node is an expression with actions we link it to
4110 -- N since otherwise Force_Evaluation cannot identify if this node
4111 -- comes from the Expression and rejects generating the temporary.
4113 if Nkind (Parent (N)) = N_Expression_With_Actions then
4114 Set_Parent (Op_Expr, N);
4119 Set_Parent (Op_Expr, Parent (N));
4124 -- Force generating a temporary because in the expansion of this
4125 -- expression we may generate code that performs this computation
4128 Force_Evaluation (Op_Expr, Mode => Strict);
4130 Set_Left_Opnd (Mod_Expr, Op_Expr);
4133 Set_Right_Opnd (Mod_Expr,
4134 Make_Integer_Literal (Loc, Modulus (Typ)));
4137 Unchecked_Convert_To (Typ, Mod_Expr));
4138 end Expand_Modular_Op;
4140 --------------------------------
4141 -- Expand_Modular_Subtraction --
4142 --------------------------------
4144 procedure Expand_Modular_Subtraction is
4146 -- If this is not the addition of a constant then compute it using
4147 -- the general rule: (lhs + rhs) mod Modulus
4149 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4152 -- If this is an addition of a constant, convert it to a subtraction
4153 -- plus a conditional expression since we can compute it faster than
4154 -- computing the modulus.
4156 -- modMinusRhs = Modulus - rhs
4157 -- if lhs < rhs then lhs + modMinusRhs
4162 Mod_Minus_Right : constant Uint :=
4163 Modulus (Typ) - Intval (Right_Opnd (N));
4165 Exprs : constant List_Id := New_List;
4166 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4167 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4168 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4171 Set_Left_Opnd (Cond_Expr,
4172 Unchecked_Convert_To (Standard_Unsigned,
4173 New_Copy_Tree (Left_Opnd (N))));
4174 Set_Right_Opnd (Cond_Expr,
4175 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4176 Append_To (Exprs, Cond_Expr);
4178 Set_Left_Opnd (Then_Expr,
4179 Unchecked_Convert_To (Standard_Unsigned,
4180 New_Copy_Tree (Left_Opnd (N))));
4181 Set_Right_Opnd (Then_Expr,
4182 Make_Integer_Literal (Loc, Mod_Minus_Right));
4183 Append_To (Exprs, Then_Expr);
4185 Set_Left_Opnd (Else_Expr,
4186 Unchecked_Convert_To (Standard_Unsigned,
4187 New_Copy_Tree (Left_Opnd (N))));
4188 Set_Right_Opnd (Else_Expr,
4189 Unchecked_Convert_To (Standard_Unsigned,
4190 New_Copy_Tree (Right_Opnd (N))));
4191 Append_To (Exprs, Else_Expr);
4194 Unchecked_Convert_To (Typ,
4195 Make_If_Expression (Loc, Expressions => Exprs)));
4198 end Expand_Modular_Subtraction;
4200 -- Start of processing for Expand_Nonbinary_Modular_Op
4203 -- No action needed if front-end expansion is not required or if we
4204 -- have a binary modular operand.
4206 if not Expand_Nonbinary_Modular_Ops
4207 or else not Non_Binary_Modulus (Typ)
4214 Expand_Modular_Addition;
4216 when N_Op_Subtract =>
4217 Expand_Modular_Subtraction;
4221 -- Expand -expr into (0 - expr)
4224 Make_Op_Subtract (Loc,
4225 Left_Opnd => Make_Integer_Literal (Loc, 0),
4226 Right_Opnd => Right_Opnd (N)));
4227 Analyze_And_Resolve (N, Typ);
4233 Analyze_And_Resolve (N, Typ);
4234 end Expand_Nonbinary_Modular_Op;
4236 ------------------------
4237 -- Expand_N_Allocator --
4238 ------------------------
4240 procedure Expand_N_Allocator (N : Node_Id) is
4241 Etyp : constant Entity_Id := Etype (Expression (N));
4242 Loc : constant Source_Ptr := Sloc (N);
4243 PtrT : constant Entity_Id := Etype (N);
4245 procedure Rewrite_Coextension (N : Node_Id);
4246 -- Static coextensions have the same lifetime as the entity they
4247 -- constrain. Such occurrences can be rewritten as aliased objects
4248 -- and their unrestricted access used instead of the coextension.
4250 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4251 -- Given a constrained array type E, returns a node representing the
4252 -- code to compute a close approximation of the size in storage elements
4253 -- for the given type; for indexes that are modular types we compute
4254 -- 'Last - First (instead of 'Length) because for large arrays computing
4255 -- 'Last -'First + 1 causes overflow. This is done without using the
4256 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4259 -------------------------
4260 -- Rewrite_Coextension --
4261 -------------------------
4263 procedure Rewrite_Coextension (N : Node_Id) is
4264 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4265 Temp_Decl : Node_Id;
4269 -- Cnn : aliased Etyp;
4272 Make_Object_Declaration (Loc,
4273 Defining_Identifier => Temp_Id,
4274 Aliased_Present => True,
4275 Object_Definition => New_Occurrence_Of (Etyp, Loc));
4277 if Nkind (Expression (N)) = N_Qualified_Expression then
4278 Set_Expression (Temp_Decl, Expression (Expression (N)));
4281 Insert_Action (N, Temp_Decl);
4283 Make_Attribute_Reference (Loc,
4284 Prefix => New_Occurrence_Of (Temp_Id, Loc),
4285 Attribute_Name => Name_Unrestricted_Access));
4287 Analyze_And_Resolve (N, PtrT);
4288 end Rewrite_Coextension;
4290 ------------------------------
4291 -- Size_In_Storage_Elements --
4292 ------------------------------
4294 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4296 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4297 -- However, the reason for the existence of this function is
4298 -- to construct a test for sizes too large, which means near the
4299 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4300 -- is that we get overflows when sizes are greater than 2**31.
4302 -- So what we end up doing for array types is to use the expression:
4304 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4306 -- which avoids this problem. All this is a bit bogus, but it does
4307 -- mean we catch common cases of trying to allocate arrays that
4308 -- are too large, and which in the absence of a check results in
4309 -- undetected chaos ???
4311 -- Note in particular that this is a pessimistic estimate in the
4312 -- case of packed array types, where an array element might occupy
4313 -- just a fraction of a storage element???
4316 Idx : Node_Id := First_Index (E);
4319 pragma Warnings (Off, Res);
4322 for J in 1 .. Number_Dimensions (E) loop
4324 if not Is_Modular_Integer_Type (Etype (Idx)) then
4326 Make_Attribute_Reference (Loc,
4327 Prefix => New_Occurrence_Of (E, Loc),
4328 Attribute_Name => Name_Length,
4329 Expressions => New_List
4330 (Make_Integer_Literal (Loc, J)));
4332 -- For indexes that are modular types we cannot generate code
4333 -- to compute 'Length since for large arrays 'Last -'First + 1
4334 -- causes overflow; therefore we compute 'Last - 'First (which
4335 -- is not the exact number of components but it is valid for
4336 -- the purpose of this runtime check on 32-bit targets)
4340 Len_Minus_1_Expr : Node_Id;
4346 Make_Attribute_Reference (Loc,
4347 Prefix => New_Occurrence_Of (E, Loc),
4348 Attribute_Name => Name_Last,
4350 New_List (Make_Integer_Literal (Loc, J))),
4351 Make_Attribute_Reference (Loc,
4352 Prefix => New_Occurrence_Of (E, Loc),
4353 Attribute_Name => Name_First,
4355 New_List (Make_Integer_Literal (Loc, J))));
4358 Convert_To (Standard_Unsigned,
4359 Make_Op_Subtract (Loc,
4360 Make_Attribute_Reference (Loc,
4361 Prefix => New_Occurrence_Of (E, Loc),
4362 Attribute_Name => Name_Last,
4365 (Make_Integer_Literal (Loc, J))),
4366 Make_Attribute_Reference (Loc,
4367 Prefix => New_Occurrence_Of (E, Loc),
4368 Attribute_Name => Name_First,
4371 (Make_Integer_Literal (Loc, J)))));
4373 -- Handle superflat arrays, i.e. arrays with such bounds
4374 -- as 4 .. 2, to insure that the result is correct.
4377 -- (if X'Last > X'First then X'Last - X'First else 0)
4380 Make_If_Expression (Loc,
4381 Expressions => New_List (
4384 Make_Integer_Literal (Loc, Uint_0)));
4393 Make_Op_Multiply (Loc,
4402 Make_Op_Multiply (Loc,
4405 Make_Attribute_Reference (Loc,
4406 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4407 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4409 end Size_In_Storage_Elements;
4413 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4417 Rel_Typ : Entity_Id;
4420 -- Start of processing for Expand_N_Allocator
4423 -- Warn on the presence of an allocator of an anonymous access type when
4424 -- enabled except when its an object declaration at library level.
4426 if Warn_On_Anonymous_Allocators
4427 and then Ekind (PtrT) = E_Anonymous_Access_Type
4428 and then not (Is_Library_Level_Entity (PtrT)
4429 and then Nkind (Associated_Node_For_Itype (PtrT)) =
4430 N_Object_Declaration)
4432 Error_Msg_N ("?use of an anonymous access type allocator", N);
4435 -- RM E.2.3(22). We enforce that the expected type of an allocator
4436 -- shall not be a remote access-to-class-wide-limited-private type
4438 -- Why is this being done at expansion time, seems clearly wrong ???
4440 Validate_Remote_Access_To_Class_Wide_Type (N);
4442 -- Processing for anonymous access-to-controlled types. These access
4443 -- types receive a special finalization master which appears in the
4444 -- declarations of the enclosing semantic unit. This expansion is done
4445 -- now to ensure that any additional types generated by this routine or
4446 -- Expand_Allocator_Expression inherit the proper type attributes.
4448 if (Ekind (PtrT) = E_Anonymous_Access_Type
4449 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4450 and then Needs_Finalization (Dtyp)
4452 -- Detect the allocation of an anonymous controlled object where the
4453 -- type of the context is named. For example:
4455 -- procedure Proc (Ptr : Named_Access_Typ);
4456 -- Proc (new Designated_Typ);
4458 -- Regardless of the anonymous-to-named access type conversion, the
4459 -- lifetime of the object must be associated with the named access
4460 -- type. Use the finalization-related attributes of this type.
4462 if Nkind_In (Parent (N), N_Type_Conversion,
4463 N_Unchecked_Type_Conversion)
4464 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4466 E_General_Access_Type)
4468 Rel_Typ := Etype (Parent (N));
4473 -- Anonymous access-to-controlled types allocate on the global pool.
4474 -- Note that this is a "root type only" attribute.
4476 if No (Associated_Storage_Pool (PtrT)) then
4477 if Present (Rel_Typ) then
4478 Set_Associated_Storage_Pool
4479 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4481 Set_Associated_Storage_Pool
4482 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4486 -- The finalization master must be inserted and analyzed as part of
4487 -- the current semantic unit. Note that the master is updated when
4488 -- analysis changes current units. Note that this is a "root type
4491 if Present (Rel_Typ) then
4492 Set_Finalization_Master
4493 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4495 Build_Anonymous_Master (Root_Type (PtrT));
4499 -- Set the storage pool and find the appropriate version of Allocate to
4500 -- call. Do not overwrite the storage pool if it is already set, which
4501 -- can happen for build-in-place function returns (see
4502 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4504 if No (Storage_Pool (N)) then
4505 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4507 if Present (Pool) then
4508 Set_Storage_Pool (N, Pool);
4510 if Is_RTE (Pool, RE_SS_Pool) then
4511 Check_Restriction (No_Secondary_Stack, N);
4512 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4514 -- In the case of an allocator for a simple storage pool, locate
4515 -- and save a reference to the pool type's Allocate routine.
4517 elsif Present (Get_Rep_Pragma
4518 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4521 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4522 Alloc_Op : Entity_Id;
4524 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4525 while Present (Alloc_Op) loop
4526 if Scope (Alloc_Op) = Scope (Pool_Type)
4527 and then Present (First_Formal (Alloc_Op))
4528 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4530 Set_Procedure_To_Call (N, Alloc_Op);
4533 Alloc_Op := Homonym (Alloc_Op);
4538 elsif Is_Class_Wide_Type (Etype (Pool)) then
4539 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4542 Set_Procedure_To_Call (N,
4543 Find_Prim_Op (Etype (Pool), Name_Allocate));
4548 -- Under certain circumstances we can replace an allocator by an access
4549 -- to statically allocated storage. The conditions, as noted in AARM
4550 -- 3.10 (10c) are as follows:
4552 -- Size and initial value is known at compile time
4553 -- Access type is access-to-constant
4555 -- The allocator is not part of a constraint on a record component,
4556 -- because in that case the inserted actions are delayed until the
4557 -- record declaration is fully analyzed, which is too late for the
4558 -- analysis of the rewritten allocator.
4560 if Is_Access_Constant (PtrT)
4561 and then Nkind (Expression (N)) = N_Qualified_Expression
4562 and then Compile_Time_Known_Value (Expression (Expression (N)))
4563 and then Size_Known_At_Compile_Time
4564 (Etype (Expression (Expression (N))))
4565 and then not Is_Record_Type (Current_Scope)
4567 -- Here we can do the optimization. For the allocator
4571 -- We insert an object declaration
4573 -- Tnn : aliased x := y;
4575 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4576 -- marked as requiring static allocation.
4578 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4579 Desig := Subtype_Mark (Expression (N));
4581 -- If context is constrained, use constrained subtype directly,
4582 -- so that the constant is not labelled as having a nominally
4583 -- unconstrained subtype.
4585 if Entity (Desig) = Base_Type (Dtyp) then
4586 Desig := New_Occurrence_Of (Dtyp, Loc);
4590 Make_Object_Declaration (Loc,
4591 Defining_Identifier => Temp,
4592 Aliased_Present => True,
4593 Constant_Present => Is_Access_Constant (PtrT),
4594 Object_Definition => Desig,
4595 Expression => Expression (Expression (N))));
4598 Make_Attribute_Reference (Loc,
4599 Prefix => New_Occurrence_Of (Temp, Loc),
4600 Attribute_Name => Name_Unrestricted_Access));
4602 Analyze_And_Resolve (N, PtrT);
4604 -- We set the variable as statically allocated, since we don't want
4605 -- it going on the stack of the current procedure.
4607 Set_Is_Statically_Allocated (Temp);
4611 -- Same if the allocator is an access discriminant for a local object:
4612 -- instead of an allocator we create a local value and constrain the
4613 -- enclosing object with the corresponding access attribute.
4615 if Is_Static_Coextension (N) then
4616 Rewrite_Coextension (N);
4620 -- Check for size too large, we do this because the back end misses
4621 -- proper checks here and can generate rubbish allocation calls when
4622 -- we are near the limit. We only do this for the 32-bit address case
4623 -- since that is from a practical point of view where we see a problem.
4625 if System_Address_Size = 32
4626 and then not Storage_Checks_Suppressed (PtrT)
4627 and then not Storage_Checks_Suppressed (Dtyp)
4628 and then not Storage_Checks_Suppressed (Etyp)
4630 -- The check we want to generate should look like
4632 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4633 -- raise Storage_Error;
4636 -- where 3.5 gigabytes is a constant large enough to accommodate any
4637 -- reasonable request for. But we can't do it this way because at
4638 -- least at the moment we don't compute this attribute right, and
4639 -- can silently give wrong results when the result gets large. Since
4640 -- this is all about large results, that's bad, so instead we only
4641 -- apply the check for constrained arrays, and manually compute the
4642 -- value of the attribute ???
4644 -- The check on No_Initialization is used here to prevent generating
4645 -- this runtime check twice when the allocator is locally replaced by
4646 -- the expander by another one.
4648 if Is_Array_Type (Etyp) and then not No_Initialization (N) then
4651 Ins_Nod : Node_Id := N;
4652 Siz_Typ : Entity_Id := Etyp;
4656 -- For unconstrained array types initialized with a qualified
4657 -- expression we use its type to perform this check
4659 if not Is_Constrained (Etyp)
4660 and then not No_Initialization (N)
4661 and then Nkind (Expression (N)) = N_Qualified_Expression
4663 Expr := Expression (Expression (N));
4664 Siz_Typ := Etype (Expression (Expression (N)));
4666 -- If the qualified expression has been moved to an internal
4667 -- temporary (to remove side effects) then we must insert
4668 -- the runtime check before its declaration to ensure that
4669 -- the check is performed before the execution of the code
4670 -- computing the qualified expression.
4672 if Nkind (Expr) = N_Identifier
4673 and then Is_Internal_Name (Chars (Expr))
4675 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
4677 Ins_Nod := Parent (Entity (Expr));
4683 if Is_Constrained (Siz_Typ)
4684 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype
4686 -- For CCG targets the largest array may have up to 2**31-1
4687 -- components (i.e. 2 Gigabytes if each array component is
4688 -- 1-byte). This insures that fat pointer fields do not
4689 -- overflow, since they are 32-bit integer types, and also
4690 -- insures that 'Length can be computed at run time.
4692 if Modify_Tree_For_C then
4695 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4696 Right_Opnd => Make_Integer_Literal (Loc,
4697 Uint_2 ** 31 - Uint_1));
4699 -- For native targets the largest object is 3.5 gigabytes
4704 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4705 Right_Opnd => Make_Integer_Literal (Loc,
4706 Uint_7 * (Uint_2 ** 29)));
4709 Insert_Action (Ins_Nod,
4710 Make_Raise_Storage_Error (Loc,
4712 Reason => SE_Object_Too_Large));
4714 if Entity (Cond) = Standard_True then
4716 ("object too large: Storage_Error will be raised at "
4724 -- If no storage pool has been specified, or the storage pool
4725 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4726 -- No_Standard_Allocators_After_Elaboration is present, then generate
4727 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4729 if Nkind (N) = N_Allocator
4730 and then (No (Storage_Pool (N))
4731 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
4732 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4735 Make_Procedure_Call_Statement (Loc,
4737 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4740 -- Handle case of qualified expression (other than optimization above)
4741 -- First apply constraint checks, because the bounds or discriminants
4742 -- in the aggregate might not match the subtype mark in the allocator.
4744 if Nkind (Expression (N)) = N_Qualified_Expression then
4746 Exp : constant Node_Id := Expression (Expression (N));
4747 Typ : constant Entity_Id := Etype (Expression (N));
4750 Apply_Constraint_Check (Exp, Typ);
4751 Apply_Predicate_Check (Exp, Typ);
4754 Expand_Allocator_Expression (N);
4758 -- If the allocator is for a type which requires initialization, and
4759 -- there is no initial value (i.e. operand is a subtype indication
4760 -- rather than a qualified expression), then we must generate a call to
4761 -- the initialization routine using an expressions action node:
4763 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4765 -- Here ptr_T is the pointer type for the allocator, and T is the
4766 -- subtype of the allocator. A special case arises if the designated
4767 -- type of the access type is a task or contains tasks. In this case
4768 -- the call to Init (Temp.all ...) is replaced by code that ensures
4769 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4770 -- for details). In addition, if the type T is a task type, then the
4771 -- first argument to Init must be converted to the task record type.
4774 T : constant Entity_Id := Etype (Expression (N));
4780 Init_Arg1 : Node_Id;
4781 Init_Call : Node_Id;
4782 Temp_Decl : Node_Id;
4783 Temp_Type : Entity_Id;
4786 if No_Initialization (N) then
4788 -- Even though this might be a simple allocation, create a custom
4789 -- Allocate if the context requires it.
4791 if Present (Finalization_Master (PtrT)) then
4792 Build_Allocate_Deallocate_Proc
4794 Is_Allocate => True);
4797 -- Optimize the default allocation of an array object when pragma
4798 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4799 -- in-place initialization aggregate which may be convert into a fast
4800 -- memset by the backend.
4802 elsif Init_Or_Norm_Scalars
4803 and then Is_Array_Type (T)
4805 -- The array must lack atomic components because they are treated
4806 -- as non-static, and as a result the backend will not initialize
4807 -- the memory in one go.
4809 and then not Has_Atomic_Components (T)
4811 -- The array must not be packed because the invalid values in
4812 -- System.Scalar_Values are multiples of Storage_Unit.
4814 and then not Is_Packed (T)
4816 -- The array must have static non-empty ranges, otherwise the
4817 -- backend cannot initialize the memory in one go.
4819 and then Has_Static_Non_Empty_Array_Bounds (T)
4821 -- The optimization is only relevant for arrays of scalar types
4823 and then Is_Scalar_Type (Component_Type (T))
4825 -- Similar to regular array initialization using a type init proc,
4826 -- predicate checks are not performed because the initialization
4827 -- values are intentionally invalid, and may violate the predicate.
4829 and then not Has_Predicates (Component_Type (T))
4831 -- The component type must have a single initialization value
4833 and then Needs_Simple_Initialization
4834 (Typ => Component_Type (T),
4835 Consider_IS => True)
4838 Temp := Make_Temporary (Loc, 'P');
4841 -- Temp : Ptr_Typ := new ...;
4846 Make_Object_Declaration (Loc,
4847 Defining_Identifier => Temp,
4848 Object_Definition => New_Occurrence_Of (PtrT, Loc),
4849 Expression => Relocate_Node (N)),
4850 Suppress => All_Checks);
4853 -- Temp.all := (others => ...);
4858 Make_Assignment_Statement (Loc,
4860 Make_Explicit_Dereference (Loc,
4861 Prefix => New_Occurrence_Of (Temp, Loc)),
4866 Size => Esize (Component_Type (T)))),
4867 Suppress => All_Checks);
4869 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4870 Analyze_And_Resolve (N, PtrT);
4872 -- Case of no initialization procedure present
4874 elsif not Has_Non_Null_Base_Init_Proc (T) then
4876 -- Case of simple initialization required
4878 if Needs_Simple_Initialization (T) then
4879 Check_Restriction (No_Default_Initialization, N);
4880 Rewrite (Expression (N),
4881 Make_Qualified_Expression (Loc,
4882 Subtype_Mark => New_Occurrence_Of (T, Loc),
4883 Expression => Get_Simple_Init_Val (T, N)));
4885 Analyze_And_Resolve (Expression (Expression (N)), T);
4886 Analyze_And_Resolve (Expression (N), T);
4887 Set_Paren_Count (Expression (Expression (N)), 1);
4888 Expand_N_Allocator (N);
4890 -- No initialization required
4893 Build_Allocate_Deallocate_Proc
4895 Is_Allocate => True);
4898 -- Case of initialization procedure present, must be called
4900 -- NOTE: There is a *huge* amount of code duplication here from
4901 -- Build_Initialization_Call. We should probably refactor???
4904 Check_Restriction (No_Default_Initialization, N);
4906 if not Restriction_Active (No_Default_Initialization) then
4907 Init := Base_Init_Proc (T);
4909 Temp := Make_Temporary (Loc, 'P');
4911 -- Construct argument list for the initialization routine call
4914 Make_Explicit_Dereference (Loc,
4916 New_Occurrence_Of (Temp, Loc));
4918 Set_Assignment_OK (Init_Arg1);
4921 -- The initialization procedure expects a specific type. if the
4922 -- context is access to class wide, indicate that the object
4923 -- being allocated has the right specific type.
4925 if Is_Class_Wide_Type (Dtyp) then
4926 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4929 -- If designated type is a concurrent type or if it is private
4930 -- type whose definition is a concurrent type, the first
4931 -- argument in the Init routine has to be unchecked conversion
4932 -- to the corresponding record type. If the designated type is
4933 -- a derived type, also convert the argument to its root type.
4935 if Is_Concurrent_Type (T) then
4937 Unchecked_Convert_To (
4938 Corresponding_Record_Type (T), Init_Arg1);
4940 elsif Is_Private_Type (T)
4941 and then Present (Full_View (T))
4942 and then Is_Concurrent_Type (Full_View (T))
4945 Unchecked_Convert_To
4946 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
4948 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
4950 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
4953 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
4954 Set_Etype (Init_Arg1, Ftyp);
4958 Args := New_List (Init_Arg1);
4960 -- For the task case, pass the Master_Id of the access type as
4961 -- the value of the _Master parameter, and _Chain as the value
4962 -- of the _Chain parameter (_Chain will be defined as part of
4963 -- the generated code for the allocator).
4965 -- In Ada 2005, the context may be a function that returns an
4966 -- anonymous access type. In that case the Master_Id has been
4967 -- created when expanding the function declaration.
4969 if Has_Task (T) then
4970 if No (Master_Id (Base_Type (PtrT))) then
4972 -- The designated type was an incomplete type, and the
4973 -- access type did not get expanded. Salvage it now.
4975 if not Restriction_Active (No_Task_Hierarchy) then
4976 if Present (Parent (Base_Type (PtrT))) then
4977 Expand_N_Full_Type_Declaration
4978 (Parent (Base_Type (PtrT)));
4980 -- The only other possibility is an itype. For this
4981 -- case, the master must exist in the context. This is
4982 -- the case when the allocator initializes an access
4983 -- component in an init-proc.
4986 pragma Assert (Is_Itype (PtrT));
4987 Build_Master_Renaming (PtrT, N);
4992 -- If the context of the allocator is a declaration or an
4993 -- assignment, we can generate a meaningful image for it,
4994 -- even though subsequent assignments might remove the
4995 -- connection between task and entity. We build this image
4996 -- when the left-hand side is a simple variable, a simple
4997 -- indexed assignment or a simple selected component.
4999 if Nkind (Parent (N)) = N_Assignment_Statement then
5001 Nam : constant Node_Id := Name (Parent (N));
5004 if Is_Entity_Name (Nam) then
5006 Build_Task_Image_Decls
5009 (Entity (Nam), Sloc (Nam)), T);
5011 elsif Nkind_In (Nam, N_Indexed_Component,
5012 N_Selected_Component)
5013 and then Is_Entity_Name (Prefix (Nam))
5016 Build_Task_Image_Decls
5017 (Loc, Nam, Etype (Prefix (Nam)));
5019 Decls := Build_Task_Image_Decls (Loc, T, T);
5023 elsif Nkind (Parent (N)) = N_Object_Declaration then
5025 Build_Task_Image_Decls
5026 (Loc, Defining_Identifier (Parent (N)), T);
5029 Decls := Build_Task_Image_Decls (Loc, T, T);
5032 if Restriction_Active (No_Task_Hierarchy) then
5034 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
5038 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
5041 Append_To (Args, Make_Identifier (Loc, Name_uChain));
5043 Decl := Last (Decls);
5045 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
5047 -- Has_Task is false, Decls not used
5053 -- Add discriminants if discriminated type
5056 Dis : Boolean := False;
5057 Typ : Entity_Id := Empty;
5060 if Has_Discriminants (T) then
5064 -- Type may be a private type with no visible discriminants
5065 -- in which case check full view if in scope, or the
5066 -- underlying_full_view if dealing with a type whose full
5067 -- view may be derived from a private type whose own full
5068 -- view has discriminants.
5070 elsif Is_Private_Type (T) then
5071 if Present (Full_View (T))
5072 and then Has_Discriminants (Full_View (T))
5075 Typ := Full_View (T);
5077 elsif Present (Underlying_Full_View (T))
5078 and then Has_Discriminants (Underlying_Full_View (T))
5081 Typ := Underlying_Full_View (T);
5087 -- If the allocated object will be constrained by the
5088 -- default values for discriminants, then build a subtype
5089 -- with those defaults, and change the allocated subtype
5090 -- to that. Note that this happens in fewer cases in Ada
5093 if not Is_Constrained (Typ)
5094 and then Present (Discriminant_Default_Value
5095 (First_Discriminant (Typ)))
5096 and then (Ada_Version < Ada_2005
5098 Object_Type_Has_Constrained_Partial_View
5099 (Typ, Current_Scope))
5101 Typ := Build_Default_Subtype (Typ, N);
5102 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
5105 Discr := First_Elmt (Discriminant_Constraint (Typ));
5106 while Present (Discr) loop
5107 Nod := Node (Discr);
5108 Append (New_Copy_Tree (Node (Discr)), Args);
5110 -- AI-416: when the discriminant constraint is an
5111 -- anonymous access type make sure an accessibility
5112 -- check is inserted if necessary (3.10.2(22.q/2))
5114 if Ada_Version >= Ada_2005
5116 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
5118 Apply_Accessibility_Check
5119 (Nod, Typ, Insert_Node => Nod);
5127 -- We set the allocator as analyzed so that when we analyze
5128 -- the if expression node, we do not get an unwanted recursive
5129 -- expansion of the allocator expression.
5131 Set_Analyzed (N, True);
5132 Nod := Relocate_Node (N);
5134 -- Here is the transformation:
5135 -- input: new Ctrl_Typ
5136 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5137 -- Ctrl_TypIP (Temp.all, ...);
5138 -- [Deep_]Initialize (Temp.all);
5140 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5141 -- is the subtype of the allocator.
5144 Make_Object_Declaration (Loc,
5145 Defining_Identifier => Temp,
5146 Constant_Present => True,
5147 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
5150 Set_Assignment_OK (Temp_Decl);
5151 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
5153 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
5155 -- If the designated type is a task type or contains tasks,
5156 -- create block to activate created tasks, and insert
5157 -- declaration for Task_Image variable ahead of call.
5159 if Has_Task (T) then
5161 L : constant List_Id := New_List;
5164 Build_Task_Allocate_Block (L, Nod, Args);
5166 Insert_List_Before (First (Declarations (Blk)), Decls);
5167 Insert_Actions (N, L);
5172 Make_Procedure_Call_Statement (Loc,
5173 Name => New_Occurrence_Of (Init, Loc),
5174 Parameter_Associations => Args));
5177 if Needs_Finalization (T) then
5180 -- [Deep_]Initialize (Init_Arg1);
5184 (Obj_Ref => New_Copy_Tree (Init_Arg1),
5187 -- Guard against a missing [Deep_]Initialize when the
5188 -- designated type was not properly frozen.
5190 if Present (Init_Call) then
5191 Insert_Action (N, Init_Call);
5195 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5196 Analyze_And_Resolve (N, PtrT);
5201 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5202 -- object that has been rewritten as a reference, we displace "this"
5203 -- to reference properly its secondary dispatch table.
5205 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
5206 Displace_Allocator_Pointer (N);
5210 when RE_Not_Available =>
5212 end Expand_N_Allocator;
5214 -----------------------
5215 -- Expand_N_And_Then --
5216 -----------------------
5218 procedure Expand_N_And_Then (N : Node_Id)
5219 renames Expand_Short_Circuit_Operator;
5221 ------------------------------
5222 -- Expand_N_Case_Expression --
5223 ------------------------------
5225 procedure Expand_N_Case_Expression (N : Node_Id) is
5226 function Is_Copy_Type (Typ : Entity_Id) return Boolean;
5227 -- Return True if we can copy objects of this type when expanding a case
5234 function Is_Copy_Type (Typ : Entity_Id) return Boolean is
5236 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5237 -- large objects, as long as they are constrained and not limited.
5240 Is_Elementary_Type (Underlying_Type (Typ))
5242 (Minimize_Expression_With_Actions
5243 and then Is_Constrained (Underlying_Type (Typ))
5244 and then not Is_Limited_Type (Underlying_Type (Typ)));
5249 Loc : constant Source_Ptr := Sloc (N);
5250 Par : constant Node_Id := Parent (N);
5251 Typ : constant Entity_Id := Etype (N);
5255 Case_Stmt : Node_Id;
5259 Target_Typ : Entity_Id;
5261 In_Predicate : Boolean := False;
5262 -- Flag set when the case expression appears within a predicate
5264 Optimize_Return_Stmt : Boolean := False;
5265 -- Flag set when the case expression can be optimized in the context of
5266 -- a simple return statement.
5268 -- Start of processing for Expand_N_Case_Expression
5271 -- Check for MINIMIZED/ELIMINATED overflow mode
5273 if Minimized_Eliminated_Overflow_Check (N) then
5274 Apply_Arithmetic_Overflow_Check (N);
5278 -- If the case expression is a predicate specification, and the type
5279 -- to which it applies has a static predicate aspect, do not expand,
5280 -- because it will be converted to the proper predicate form later.
5282 if Ekind_In (Current_Scope, E_Function, E_Procedure)
5283 and then Is_Predicate_Function (Current_Scope)
5285 In_Predicate := True;
5287 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
5293 -- When the type of the case expression is elementary, expand
5295 -- (case X is when A => AX, when B => BX ...)
5310 -- In all other cases expand into
5313 -- type Ptr_Typ is access all Typ;
5314 -- Target : Ptr_Typ;
5317 -- Target := AX'Unrestricted_Access;
5319 -- Target := BX'Unrestricted_Access;
5322 -- in Target.all end;
5324 -- This approach avoids extra copies of potentially large objects. It
5325 -- also allows handling of values of limited or unconstrained types.
5326 -- Note that we do the copy also for constrained, nonlimited types
5327 -- when minimizing expressions with actions (e.g. when generating C
5328 -- code) since it allows us to do the optimization below in more cases.
5330 -- Small optimization: when the case expression appears in the context
5331 -- of a simple return statement, expand into
5342 Make_Case_Statement (Loc,
5343 Expression => Expression (N),
5344 Alternatives => New_List);
5346 -- Preserve the original context for which the case statement is being
5347 -- generated. This is needed by the finalization machinery to prevent
5348 -- the premature finalization of controlled objects found within the
5351 Set_From_Conditional_Expression (Case_Stmt);
5356 if Is_Copy_Type (Typ) then
5359 -- ??? Do not perform the optimization when the return statement is
5360 -- within a predicate function, as this causes spurious errors. Could
5361 -- this be a possible mismatch in handling this case somewhere else
5362 -- in semantic analysis?
5364 Optimize_Return_Stmt :=
5365 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
5367 -- Otherwise create an access type to handle the general case using
5368 -- 'Unrestricted_Access.
5371 -- type Ptr_Typ is access all Typ;
5374 if Generate_C_Code then
5376 -- We cannot ensure that correct C code will be generated if any
5377 -- temporary is created down the line (to e.g. handle checks or
5378 -- capture values) since we might end up with dangling references
5379 -- to local variables, so better be safe and reject the construct.
5382 ("case expression too complex, use case statement instead", N);
5385 Target_Typ := Make_Temporary (Loc, 'P');
5388 Make_Full_Type_Declaration (Loc,
5389 Defining_Identifier => Target_Typ,
5391 Make_Access_To_Object_Definition (Loc,
5392 All_Present => True,
5393 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5396 -- Create the declaration of the target which captures the value of the
5400 -- Target : [Ptr_]Typ;
5402 if not Optimize_Return_Stmt then
5403 Target := Make_Temporary (Loc, 'T');
5406 Make_Object_Declaration (Loc,
5407 Defining_Identifier => Target,
5408 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
5409 Set_No_Initialization (Decl);
5411 Append_To (Acts, Decl);
5414 -- Process the alternatives
5416 Alt := First (Alternatives (N));
5417 while Present (Alt) loop
5419 Alt_Expr : Node_Id := Expression (Alt);
5420 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
5425 -- Take the unrestricted access of the expression value for non-
5426 -- scalar types. This approach avoids big copies and covers the
5427 -- limited and unconstrained cases.
5430 -- AX'Unrestricted_Access
5432 if not Is_Copy_Type (Typ) then
5434 Make_Attribute_Reference (Alt_Loc,
5435 Prefix => Relocate_Node (Alt_Expr),
5436 Attribute_Name => Name_Unrestricted_Access);
5440 -- return AX['Unrestricted_Access];
5442 if Optimize_Return_Stmt then
5444 Make_Simple_Return_Statement (Alt_Loc,
5445 Expression => Alt_Expr));
5448 -- Target := AX['Unrestricted_Access];
5451 LHS := New_Occurrence_Of (Target, Loc);
5452 Set_Assignment_OK (LHS);
5455 Make_Assignment_Statement (Alt_Loc,
5457 Expression => Alt_Expr));
5460 -- Propagate declarations inserted in the node by Insert_Actions
5461 -- (for example, temporaries generated to remove side effects).
5462 -- These actions must remain attached to the alternative, given
5463 -- that they are generated by the corresponding expression.
5465 if Present (Actions (Alt)) then
5466 Prepend_List (Actions (Alt), Stmts);
5469 -- Finalize any transient objects on exit from the alternative.
5470 -- This is done only in the return optimization case because
5471 -- otherwise the case expression is converted into an expression
5472 -- with actions which already contains this form of processing.
5474 if Optimize_Return_Stmt then
5475 Process_If_Case_Statements (N, Stmts);
5479 (Alternatives (Case_Stmt),
5480 Make_Case_Statement_Alternative (Sloc (Alt),
5481 Discrete_Choices => Discrete_Choices (Alt),
5482 Statements => Stmts));
5488 -- Rewrite the parent return statement as a case statement
5490 if Optimize_Return_Stmt then
5491 Rewrite (Par, Case_Stmt);
5494 -- Otherwise convert the case expression into an expression with actions
5497 Append_To (Acts, Case_Stmt);
5499 if Is_Copy_Type (Typ) then
5500 Expr := New_Occurrence_Of (Target, Loc);
5504 Make_Explicit_Dereference (Loc,
5505 Prefix => New_Occurrence_Of (Target, Loc));
5511 -- in Target[.all] end;
5514 Make_Expression_With_Actions (Loc,
5518 Analyze_And_Resolve (N, Typ);
5520 end Expand_N_Case_Expression;
5522 -----------------------------------
5523 -- Expand_N_Explicit_Dereference --
5524 -----------------------------------
5526 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5528 -- Insert explicit dereference call for the checked storage pool case
5530 Insert_Dereference_Action (Prefix (N));
5532 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5533 -- we set the atomic sync flag.
5535 if Is_Atomic (Etype (N))
5536 and then not Atomic_Synchronization_Disabled (Etype (N))
5538 Activate_Atomic_Synchronization (N);
5540 end Expand_N_Explicit_Dereference;
5542 --------------------------------------
5543 -- Expand_N_Expression_With_Actions --
5544 --------------------------------------
5546 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5547 Acts : constant List_Id := Actions (N);
5549 procedure Force_Boolean_Evaluation (Expr : Node_Id);
5550 -- Force the evaluation of Boolean expression Expr
5552 function Process_Action (Act : Node_Id) return Traverse_Result;
5553 -- Inspect and process a single action of an expression_with_actions for
5554 -- transient objects. If such objects are found, the routine generates
5555 -- code to clean them up when the context of the expression is evaluated
5558 ------------------------------
5559 -- Force_Boolean_Evaluation --
5560 ------------------------------
5562 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
5563 Loc : constant Source_Ptr := Sloc (N);
5564 Flag_Decl : Node_Id;
5565 Flag_Id : Entity_Id;
5568 -- Relocate the expression to the actions list by capturing its value
5569 -- in a Boolean flag. Generate:
5570 -- Flag : constant Boolean := Expr;
5572 Flag_Id := Make_Temporary (Loc, 'F');
5575 Make_Object_Declaration (Loc,
5576 Defining_Identifier => Flag_Id,
5577 Constant_Present => True,
5578 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5579 Expression => Relocate_Node (Expr));
5581 Append (Flag_Decl, Acts);
5582 Analyze (Flag_Decl);
5584 -- Replace the expression with a reference to the flag
5586 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
5587 Analyze (Expression (N));
5588 end Force_Boolean_Evaluation;
5590 --------------------
5591 -- Process_Action --
5592 --------------------
5594 function Process_Action (Act : Node_Id) return Traverse_Result is
5596 if Nkind (Act) = N_Object_Declaration
5597 and then Is_Finalizable_Transient (Act, N)
5599 Process_Transient_In_Expression (Act, N, Acts);
5602 -- Avoid processing temporary function results multiple times when
5603 -- dealing with nested expression_with_actions.
5605 elsif Nkind (Act) = N_Expression_With_Actions then
5608 -- Do not process temporary function results in loops. This is done
5609 -- by Expand_N_Loop_Statement and Build_Finalizer.
5611 elsif Nkind (Act) = N_Loop_Statement then
5618 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5624 -- Start of processing for Expand_N_Expression_With_Actions
5627 -- Do not evaluate the expression when it denotes an entity because the
5628 -- expression_with_actions node will be replaced by the reference.
5630 if Is_Entity_Name (Expression (N)) then
5633 -- Do not evaluate the expression when there are no actions because the
5634 -- expression_with_actions node will be replaced by the expression.
5636 elsif No (Acts) or else Is_Empty_List (Acts) then
5639 -- Force the evaluation of the expression by capturing its value in a
5640 -- temporary. This ensures that aliases of transient objects do not leak
5641 -- to the expression of the expression_with_actions node:
5644 -- Trans_Id : Ctrl_Typ := ...;
5645 -- Alias : ... := Trans_Id;
5646 -- in ... Alias ... end;
5648 -- In the example above, Trans_Id cannot be finalized at the end of the
5649 -- actions list because this may affect the alias and the final value of
5650 -- the expression_with_actions. Forcing the evaluation encapsulates the
5651 -- reference to the Alias within the actions list:
5654 -- Trans_Id : Ctrl_Typ := ...;
5655 -- Alias : ... := Trans_Id;
5656 -- Val : constant Boolean := ... Alias ...;
5657 -- <finalize Trans_Id>
5660 -- Once this transformation is performed, it is safe to finalize the
5661 -- transient object at the end of the actions list.
5663 -- Note that Force_Evaluation does not remove side effects in operators
5664 -- because it assumes that all operands are evaluated and side effect
5665 -- free. This is not the case when an operand depends implicitly on the
5666 -- transient object through the use of access types.
5668 elsif Is_Boolean_Type (Etype (Expression (N))) then
5669 Force_Boolean_Evaluation (Expression (N));
5671 -- The expression of an expression_with_actions node may not necessarily
5672 -- be Boolean when the node appears in an if expression. In this case do
5673 -- the usual forced evaluation to encapsulate potential aliasing.
5676 Force_Evaluation (Expression (N));
5679 -- Process all transient objects found within the actions of the EWA
5682 Act := First (Acts);
5683 while Present (Act) loop
5684 Process_Single_Action (Act);
5688 -- Deal with case where there are no actions. In this case we simply
5689 -- rewrite the node with its expression since we don't need the actions
5690 -- and the specification of this node does not allow a null action list.
5692 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5693 -- the expanded tree and relying on being able to retrieve the original
5694 -- tree in cases like this. This raises a whole lot of issues of whether
5695 -- we have problems elsewhere, which will be addressed in the future???
5697 if Is_Empty_List (Acts) then
5698 Rewrite (N, Relocate_Node (Expression (N)));
5700 end Expand_N_Expression_With_Actions;
5702 ----------------------------
5703 -- Expand_N_If_Expression --
5704 ----------------------------
5706 -- Deal with limited types and condition actions
5708 procedure Expand_N_If_Expression (N : Node_Id) is
5709 Cond : constant Node_Id := First (Expressions (N));
5710 Loc : constant Source_Ptr := Sloc (N);
5711 Thenx : constant Node_Id := Next (Cond);
5712 Elsex : constant Node_Id := Next (Thenx);
5713 Typ : constant Entity_Id := Etype (N);
5722 -- Check for MINIMIZED/ELIMINATED overflow mode
5724 if Minimized_Eliminated_Overflow_Check (N) then
5725 Apply_Arithmetic_Overflow_Check (N);
5729 -- Fold at compile time if condition known. We have already folded
5730 -- static if expressions, but it is possible to fold any case in which
5731 -- the condition is known at compile time, even though the result is
5734 -- Note that we don't do the fold of such cases in Sem_Elab because
5735 -- it can cause infinite loops with the expander adding a conditional
5736 -- expression, and Sem_Elab circuitry removing it repeatedly.
5738 if Compile_Time_Known_Value (Cond) then
5740 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5741 -- Fold at compile time. Assumes condition known. Return True if
5742 -- folding occurred, meaning we're done.
5744 ----------------------
5745 -- Fold_Known_Value --
5746 ----------------------
5748 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5750 if Is_True (Expr_Value (Cond)) then
5752 Actions := Then_Actions (N);
5755 Actions := Else_Actions (N);
5760 if Present (Actions) then
5762 -- To minimize the use of Expression_With_Actions, just skip
5763 -- the optimization as it is not critical for correctness.
5765 if Minimize_Expression_With_Actions then
5770 Make_Expression_With_Actions (Loc,
5771 Expression => Relocate_Node (Expr),
5772 Actions => Actions));
5773 Analyze_And_Resolve (N, Typ);
5776 Rewrite (N, Relocate_Node (Expr));
5779 -- Note that the result is never static (legitimate cases of
5780 -- static if expressions were folded in Sem_Eval).
5782 Set_Is_Static_Expression (N, False);
5784 end Fold_Known_Value;
5787 if Fold_Known_Value (Cond) then
5793 -- If the type is limited, and the back end does not handle limited
5794 -- types, then we expand as follows to avoid the possibility of
5795 -- improper copying.
5797 -- type Ptr is access all Typ;
5801 -- Cnn := then-expr'Unrestricted_Access;
5804 -- Cnn := else-expr'Unrestricted_Access;
5807 -- and replace the if expression by a reference to Cnn.all.
5809 -- This special case can be skipped if the back end handles limited
5810 -- types properly and ensures that no incorrect copies are made.
5812 if Is_By_Reference_Type (Typ)
5813 and then not Back_End_Handles_Limited_Types
5815 -- When the "then" or "else" expressions involve controlled function
5816 -- calls, generated temporaries are chained on the corresponding list
5817 -- of actions. These temporaries need to be finalized after the if
5818 -- expression is evaluated.
5820 Process_If_Case_Statements (N, Then_Actions (N));
5821 Process_If_Case_Statements (N, Else_Actions (N));
5824 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
5825 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
5829 -- type Ann is access all Typ;
5832 Make_Full_Type_Declaration (Loc,
5833 Defining_Identifier => Ptr_Typ,
5835 Make_Access_To_Object_Definition (Loc,
5836 All_Present => True,
5837 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5843 Make_Object_Declaration (Loc,
5844 Defining_Identifier => Cnn,
5845 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
5849 -- Cnn := <Thenx>'Unrestricted_Access;
5851 -- Cnn := <Elsex>'Unrestricted_Access;
5855 Make_Implicit_If_Statement (N,
5856 Condition => Relocate_Node (Cond),
5857 Then_Statements => New_List (
5858 Make_Assignment_Statement (Sloc (Thenx),
5859 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5861 Make_Attribute_Reference (Loc,
5862 Prefix => Relocate_Node (Thenx),
5863 Attribute_Name => Name_Unrestricted_Access))),
5865 Else_Statements => New_List (
5866 Make_Assignment_Statement (Sloc (Elsex),
5867 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5869 Make_Attribute_Reference (Loc,
5870 Prefix => Relocate_Node (Elsex),
5871 Attribute_Name => Name_Unrestricted_Access))));
5873 -- Preserve the original context for which the if statement is
5874 -- being generated. This is needed by the finalization machinery
5875 -- to prevent the premature finalization of controlled objects
5876 -- found within the if statement.
5878 Set_From_Conditional_Expression (New_If);
5881 Make_Explicit_Dereference (Loc,
5882 Prefix => New_Occurrence_Of (Cnn, Loc));
5885 -- If the result is an unconstrained array and the if expression is in a
5886 -- context other than the initializing expression of the declaration of
5887 -- an object, then we pull out the if expression as follows:
5889 -- Cnn : constant typ := if-expression
5891 -- and then replace the if expression with an occurrence of Cnn. This
5892 -- avoids the need in the back end to create on-the-fly variable length
5893 -- temporaries (which it cannot do!)
5895 -- Note that the test for being in an object declaration avoids doing an
5896 -- unnecessary expansion, and also avoids infinite recursion.
5898 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
5899 and then (Nkind (Parent (N)) /= N_Object_Declaration
5900 or else Expression (Parent (N)) /= N)
5903 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5907 Make_Object_Declaration (Loc,
5908 Defining_Identifier => Cnn,
5909 Constant_Present => True,
5910 Object_Definition => New_Occurrence_Of (Typ, Loc),
5911 Expression => Relocate_Node (N),
5912 Has_Init_Expression => True));
5914 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
5918 -- For other types, we only need to expand if there are other actions
5919 -- associated with either branch.
5921 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5923 -- We now wrap the actions into the appropriate expression
5925 if Minimize_Expression_With_Actions
5926 and then (Is_Elementary_Type (Underlying_Type (Typ))
5927 or else Is_Constrained (Underlying_Type (Typ)))
5929 -- If we can't use N_Expression_With_Actions nodes, then we insert
5930 -- the following sequence of actions (using Insert_Actions):
5935 -- Cnn := then-expr;
5941 -- and replace the if expression by a reference to Cnn
5944 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5948 Make_Object_Declaration (Loc,
5949 Defining_Identifier => Cnn,
5950 Object_Definition => New_Occurrence_Of (Typ, Loc));
5953 Make_Implicit_If_Statement (N,
5954 Condition => Relocate_Node (Cond),
5956 Then_Statements => New_List (
5957 Make_Assignment_Statement (Sloc (Thenx),
5958 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5959 Expression => Relocate_Node (Thenx))),
5961 Else_Statements => New_List (
5962 Make_Assignment_Statement (Sloc (Elsex),
5963 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5964 Expression => Relocate_Node (Elsex))));
5966 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
5967 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
5969 New_N := New_Occurrence_Of (Cnn, Loc);
5972 -- Regular path using Expression_With_Actions
5975 if Present (Then_Actions (N)) then
5977 Make_Expression_With_Actions (Sloc (Thenx),
5978 Actions => Then_Actions (N),
5979 Expression => Relocate_Node (Thenx)));
5981 Set_Then_Actions (N, No_List);
5982 Analyze_And_Resolve (Thenx, Typ);
5985 if Present (Else_Actions (N)) then
5987 Make_Expression_With_Actions (Sloc (Elsex),
5988 Actions => Else_Actions (N),
5989 Expression => Relocate_Node (Elsex)));
5991 Set_Else_Actions (N, No_List);
5992 Analyze_And_Resolve (Elsex, Typ);
5998 -- If no actions then no expansion needed, gigi will handle it using the
5999 -- same approach as a C conditional expression.
6005 -- Fall through here for either the limited expansion, or the case of
6006 -- inserting actions for nonlimited types. In both these cases, we must
6007 -- move the SLOC of the parent If statement to the newly created one and
6008 -- change it to the SLOC of the expression which, after expansion, will
6009 -- correspond to what is being evaluated.
6011 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
6012 Set_Sloc (New_If, Sloc (Parent (N)));
6013 Set_Sloc (Parent (N), Loc);
6016 -- Make sure Then_Actions and Else_Actions are appropriately moved
6017 -- to the new if statement.
6019 if Present (Then_Actions (N)) then
6021 (First (Then_Statements (New_If)), Then_Actions (N));
6024 if Present (Else_Actions (N)) then
6026 (First (Else_Statements (New_If)), Else_Actions (N));
6029 Insert_Action (N, Decl);
6030 Insert_Action (N, New_If);
6032 Analyze_And_Resolve (N, Typ);
6033 end Expand_N_If_Expression;
6039 procedure Expand_N_In (N : Node_Id) is
6040 Loc : constant Source_Ptr := Sloc (N);
6041 Restyp : constant Entity_Id := Etype (N);
6042 Lop : constant Node_Id := Left_Opnd (N);
6043 Rop : constant Node_Id := Right_Opnd (N);
6044 Static : constant Boolean := Is_OK_Static_Expression (N);
6046 procedure Substitute_Valid_Check;
6047 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6048 -- test for the left operand being in range of its subtype.
6050 ----------------------------
6051 -- Substitute_Valid_Check --
6052 ----------------------------
6054 procedure Substitute_Valid_Check is
6055 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
6056 -- Determine whether arbitrary node Nod denotes a source object that
6057 -- may safely act as prefix of attribute 'Valid.
6059 ----------------------------
6060 -- Is_OK_Object_Reference --
6061 ----------------------------
6063 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
6067 -- Inspect the original operand
6069 Obj_Ref := Original_Node (Nod);
6071 -- The object reference must be a source construct, otherwise the
6072 -- codefix suggestion may refer to nonexistent code from a user
6075 if Comes_From_Source (Obj_Ref) then
6077 -- Recover the actual object reference. There may be more cases
6081 if Nkind_In (Obj_Ref, N_Type_Conversion,
6082 N_Unchecked_Type_Conversion)
6084 Obj_Ref := Expression (Obj_Ref);
6090 return Is_Object_Reference (Obj_Ref);
6094 end Is_OK_Object_Reference;
6096 -- Start of processing for Substitute_Valid_Check
6100 Make_Attribute_Reference (Loc,
6101 Prefix => Relocate_Node (Lop),
6102 Attribute_Name => Name_Valid));
6104 Analyze_And_Resolve (N, Restyp);
6106 -- Emit a warning when the left-hand operand of the membership test
6107 -- is a source object, otherwise the use of attribute 'Valid would be
6108 -- illegal. The warning is not given when overflow checking is either
6109 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6110 -- eliminated above.
6112 if Is_OK_Object_Reference (Lop)
6113 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
6116 ("??explicit membership test may be optimized away", N);
6117 Error_Msg_N -- CODEFIX
6118 ("\??use ''Valid attribute instead", N);
6120 end Substitute_Valid_Check;
6127 -- Start of processing for Expand_N_In
6130 -- If set membership case, expand with separate procedure
6132 if Present (Alternatives (N)) then
6133 Expand_Set_Membership (N);
6137 -- Not set membership, proceed with expansion
6139 Ltyp := Etype (Left_Opnd (N));
6140 Rtyp := Etype (Right_Opnd (N));
6142 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6143 -- type, then expand with a separate procedure. Note the use of the
6144 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6146 if Overflow_Check_Mode in Minimized_Or_Eliminated
6147 and then Is_Signed_Integer_Type (Ltyp)
6148 and then not No_Minimize_Eliminate (N)
6150 Expand_Membership_Minimize_Eliminate_Overflow (N);
6154 -- Check case of explicit test for an expression in range of its
6155 -- subtype. This is suspicious usage and we replace it with a 'Valid
6156 -- test and give a warning for scalar types.
6158 if Is_Scalar_Type (Ltyp)
6160 -- Only relevant for source comparisons
6162 and then Comes_From_Source (N)
6164 -- In floating-point this is a standard way to check for finite values
6165 -- and using 'Valid would typically be a pessimization.
6167 and then not Is_Floating_Point_Type (Ltyp)
6169 -- Don't give the message unless right operand is a type entity and
6170 -- the type of the left operand matches this type. Note that this
6171 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6172 -- checks have changed the type of the left operand.
6174 and then Nkind (Rop) in N_Has_Entity
6175 and then Ltyp = Entity (Rop)
6177 -- Skip this for predicated types, where such expressions are a
6178 -- reasonable way of testing if something meets the predicate.
6180 and then not Present (Predicate_Function (Ltyp))
6182 Substitute_Valid_Check;
6186 -- Do validity check on operands
6188 if Validity_Checks_On and Validity_Check_Operands then
6189 Ensure_Valid (Left_Opnd (N));
6190 Validity_Check_Range (Right_Opnd (N));
6193 -- Case of explicit range
6195 if Nkind (Rop) = N_Range then
6197 Lo : constant Node_Id := Low_Bound (Rop);
6198 Hi : constant Node_Id := High_Bound (Rop);
6200 Lo_Orig : constant Node_Id := Original_Node (Lo);
6201 Hi_Orig : constant Node_Id := Original_Node (Hi);
6203 Lcheck : Compare_Result;
6204 Ucheck : Compare_Result;
6206 Warn1 : constant Boolean :=
6207 Constant_Condition_Warnings
6208 and then Comes_From_Source (N)
6209 and then not In_Instance;
6210 -- This must be true for any of the optimization warnings, we
6211 -- clearly want to give them only for source with the flag on. We
6212 -- also skip these warnings in an instance since it may be the
6213 -- case that different instantiations have different ranges.
6215 Warn2 : constant Boolean :=
6217 and then Nkind (Original_Node (Rop)) = N_Range
6218 and then Is_Integer_Type (Etype (Lo));
6219 -- For the case where only one bound warning is elided, we also
6220 -- insist on an explicit range and an integer type. The reason is
6221 -- that the use of enumeration ranges including an end point is
6222 -- common, as is the use of a subtype name, one of whose bounds is
6223 -- the same as the type of the expression.
6226 -- If test is explicit x'First .. x'Last, replace by valid check
6228 -- Could use some individual comments for this complex test ???
6230 if Is_Scalar_Type (Ltyp)
6232 -- And left operand is X'First where X matches left operand
6233 -- type (this eliminates cases of type mismatch, including
6234 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6235 -- type of the left operand.
6237 and then Nkind (Lo_Orig) = N_Attribute_Reference
6238 and then Attribute_Name (Lo_Orig) = Name_First
6239 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
6240 and then Entity (Prefix (Lo_Orig)) = Ltyp
6242 -- Same tests for right operand
6244 and then Nkind (Hi_Orig) = N_Attribute_Reference
6245 and then Attribute_Name (Hi_Orig) = Name_Last
6246 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
6247 and then Entity (Prefix (Hi_Orig)) = Ltyp
6249 -- Relevant only for source cases
6251 and then Comes_From_Source (N)
6253 Substitute_Valid_Check;
6257 -- If bounds of type are known at compile time, and the end points
6258 -- are known at compile time and identical, this is another case
6259 -- for substituting a valid test. We only do this for discrete
6260 -- types, since it won't arise in practice for float types.
6262 if Comes_From_Source (N)
6263 and then Is_Discrete_Type (Ltyp)
6264 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
6265 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
6266 and then Compile_Time_Known_Value (Lo)
6267 and then Compile_Time_Known_Value (Hi)
6268 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
6269 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
6271 -- Kill warnings in instances, since they may be cases where we
6272 -- have a test in the generic that makes sense with some types
6273 -- and not with other types.
6275 -- Similarly, do not rewrite membership as a validity check if
6276 -- within the predicate function for the type.
6278 -- Finally, if the original bounds are type conversions, even
6279 -- if they have been folded into constants, there are different
6280 -- types involved and 'Valid is not appropriate.
6284 or else (Ekind (Current_Scope) = E_Function
6285 and then Is_Predicate_Function (Current_Scope))
6289 elsif Nkind (Lo_Orig) = N_Type_Conversion
6290 or else Nkind (Hi_Orig) = N_Type_Conversion
6295 Substitute_Valid_Check;
6300 -- If we have an explicit range, do a bit of optimization based on
6301 -- range analysis (we may be able to kill one or both checks).
6303 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
6304 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
6306 -- If either check is known to fail, replace result by False since
6307 -- the other check does not matter. Preserve the static flag for
6308 -- legality checks, because we are constant-folding beyond RM 4.9.
6310 if Lcheck = LT or else Ucheck = GT then
6312 Error_Msg_N ("?c?range test optimized away", N);
6313 Error_Msg_N ("\?c?value is known to be out of range", N);
6316 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6317 Analyze_And_Resolve (N, Restyp);
6318 Set_Is_Static_Expression (N, Static);
6321 -- If both checks are known to succeed, replace result by True,
6322 -- since we know we are in range.
6324 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6326 Error_Msg_N ("?c?range test optimized away", N);
6327 Error_Msg_N ("\?c?value is known to be in range", N);
6330 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6331 Analyze_And_Resolve (N, Restyp);
6332 Set_Is_Static_Expression (N, Static);
6335 -- If lower bound check succeeds and upper bound check is not
6336 -- known to succeed or fail, then replace the range check with
6337 -- a comparison against the upper bound.
6339 elsif Lcheck in Compare_GE then
6340 if Warn2 and then not In_Instance then
6341 Error_Msg_N ("??lower bound test optimized away", Lo);
6342 Error_Msg_N ("\??value is known to be in range", Lo);
6348 Right_Opnd => High_Bound (Rop)));
6349 Analyze_And_Resolve (N, Restyp);
6352 -- If upper bound check succeeds and lower bound check is not
6353 -- known to succeed or fail, then replace the range check with
6354 -- a comparison against the lower bound.
6356 elsif Ucheck in Compare_LE then
6357 if Warn2 and then not In_Instance then
6358 Error_Msg_N ("??upper bound test optimized away", Hi);
6359 Error_Msg_N ("\??value is known to be in range", Hi);
6365 Right_Opnd => Low_Bound (Rop)));
6366 Analyze_And_Resolve (N, Restyp);
6370 -- We couldn't optimize away the range check, but there is one
6371 -- more issue. If we are checking constant conditionals, then we
6372 -- see if we can determine the outcome assuming everything is
6373 -- valid, and if so give an appropriate warning.
6375 if Warn1 and then not Assume_No_Invalid_Values then
6376 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
6377 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
6379 -- Result is out of range for valid value
6381 if Lcheck = LT or else Ucheck = GT then
6383 ("?c?value can only be in range if it is invalid", N);
6385 -- Result is in range for valid value
6387 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6389 ("?c?value can only be out of range if it is invalid", N);
6391 -- Lower bound check succeeds if value is valid
6393 elsif Warn2 and then Lcheck in Compare_GE then
6395 ("?c?lower bound check only fails if it is invalid", Lo);
6397 -- Upper bound check succeeds if value is valid
6399 elsif Warn2 and then Ucheck in Compare_LE then
6401 ("?c?upper bound check only fails for invalid values", Hi);
6406 -- For all other cases of an explicit range, nothing to be done
6410 -- Here right operand is a subtype mark
6414 Typ : Entity_Id := Etype (Rop);
6415 Is_Acc : constant Boolean := Is_Access_Type (Typ);
6416 Cond : Node_Id := Empty;
6418 Obj : Node_Id := Lop;
6419 SCIL_Node : Node_Id;
6422 Remove_Side_Effects (Obj);
6424 -- For tagged type, do tagged membership operation
6426 if Is_Tagged_Type (Typ) then
6428 -- No expansion will be performed for VM targets, as the VM
6429 -- back ends will handle the membership tests directly.
6431 if Tagged_Type_Expansion then
6432 Tagged_Membership (N, SCIL_Node, New_N);
6434 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks);
6436 -- Update decoration of relocated node referenced by the
6439 if Generate_SCIL and then Present (SCIL_Node) then
6440 Set_SCIL_Node (N, SCIL_Node);
6446 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6447 -- This reason we do this is that the bounds may have the wrong
6448 -- type if they come from the original type definition. Also this
6449 -- way we get all the processing above for an explicit range.
6451 -- Don't do this for predicated types, since in this case we
6452 -- want to check the predicate.
6454 elsif Is_Scalar_Type (Typ) then
6455 if No (Predicate_Function (Typ)) then
6459 Make_Attribute_Reference (Loc,
6460 Attribute_Name => Name_First,
6461 Prefix => New_Occurrence_Of (Typ, Loc)),
6464 Make_Attribute_Reference (Loc,
6465 Attribute_Name => Name_Last,
6466 Prefix => New_Occurrence_Of (Typ, Loc))));
6467 Analyze_And_Resolve (N, Restyp);
6472 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6473 -- a membership test if the subtype mark denotes a constrained
6474 -- Unchecked_Union subtype and the expression lacks inferable
6477 elsif Is_Unchecked_Union (Base_Type (Typ))
6478 and then Is_Constrained (Typ)
6479 and then not Has_Inferable_Discriminants (Lop)
6482 Make_Raise_Program_Error (Loc,
6483 Reason => PE_Unchecked_Union_Restriction));
6485 -- Prevent Gigi from generating incorrect code by rewriting the
6486 -- test as False. What is this undocumented thing about ???
6488 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6492 -- Here we have a non-scalar type
6495 Typ := Designated_Type (Typ);
6498 if not Is_Constrained (Typ) then
6499 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6500 Analyze_And_Resolve (N, Restyp);
6502 -- For the constrained array case, we have to check the subscripts
6503 -- for an exact match if the lengths are non-zero (the lengths
6504 -- must match in any case).
6506 elsif Is_Array_Type (Typ) then
6507 Check_Subscripts : declare
6508 function Build_Attribute_Reference
6511 Dim : Nat) return Node_Id;
6512 -- Build attribute reference E'Nam (Dim)
6514 -------------------------------
6515 -- Build_Attribute_Reference --
6516 -------------------------------
6518 function Build_Attribute_Reference
6521 Dim : Nat) return Node_Id
6525 Make_Attribute_Reference (Loc,
6527 Attribute_Name => Nam,
6528 Expressions => New_List (
6529 Make_Integer_Literal (Loc, Dim)));
6530 end Build_Attribute_Reference;
6532 -- Start of processing for Check_Subscripts
6535 for J in 1 .. Number_Dimensions (Typ) loop
6536 Evolve_And_Then (Cond,
6539 Build_Attribute_Reference
6540 (Duplicate_Subexpr_No_Checks (Obj),
6543 Build_Attribute_Reference
6544 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
6546 Evolve_And_Then (Cond,
6549 Build_Attribute_Reference
6550 (Duplicate_Subexpr_No_Checks (Obj),
6553 Build_Attribute_Reference
6554 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
6563 Right_Opnd => Make_Null (Loc)),
6564 Right_Opnd => Cond);
6568 Analyze_And_Resolve (N, Restyp);
6569 end Check_Subscripts;
6571 -- These are the cases where constraint checks may be required,
6572 -- e.g. records with possible discriminants
6575 -- Expand the test into a series of discriminant comparisons.
6576 -- The expression that is built is the negation of the one that
6577 -- is used for checking discriminant constraints.
6579 Obj := Relocate_Node (Left_Opnd (N));
6581 if Has_Discriminants (Typ) then
6582 Cond := Make_Op_Not (Loc,
6583 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
6586 Cond := Make_Or_Else (Loc,
6590 Right_Opnd => Make_Null (Loc)),
6591 Right_Opnd => Cond);
6595 Cond := New_Occurrence_Of (Standard_True, Loc);
6599 Analyze_And_Resolve (N, Restyp);
6602 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6603 -- expression of an anonymous access type. This can involve an
6604 -- accessibility test and a tagged type membership test in the
6605 -- case of tagged designated types.
6607 if Ada_Version >= Ada_2012
6609 and then Ekind (Ltyp) = E_Anonymous_Access_Type
6612 Expr_Entity : Entity_Id := Empty;
6614 Param_Level : Node_Id;
6615 Type_Level : Node_Id;
6618 if Is_Entity_Name (Lop) then
6619 Expr_Entity := Param_Entity (Lop);
6621 if not Present (Expr_Entity) then
6622 Expr_Entity := Entity (Lop);
6626 -- If a conversion of the anonymous access value to the
6627 -- tested type would be illegal, then the result is False.
6629 if not Valid_Conversion
6630 (Lop, Rtyp, Lop, Report_Errs => False)
6632 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6633 Analyze_And_Resolve (N, Restyp);
6635 -- Apply an accessibility check if the access object has an
6636 -- associated access level and when the level of the type is
6637 -- less deep than the level of the access parameter. This
6638 -- only occur for access parameters and stand-alone objects
6639 -- of an anonymous access type.
6642 if Present (Expr_Entity)
6645 (Effective_Extra_Accessibility (Expr_Entity))
6646 and then UI_Gt (Object_Access_Level (Lop),
6647 Type_Access_Level (Rtyp))
6651 (Effective_Extra_Accessibility (Expr_Entity), Loc);
6654 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6656 -- Return True only if the accessibility level of the
6657 -- expression entity is not deeper than the level of
6658 -- the tested access type.
6662 Left_Opnd => Relocate_Node (N),
6663 Right_Opnd => Make_Op_Le (Loc,
6664 Left_Opnd => Param_Level,
6665 Right_Opnd => Type_Level)));
6667 Analyze_And_Resolve (N);
6670 -- If the designated type is tagged, do tagged membership
6673 -- *** NOTE: we have to check not null before doing the
6674 -- tagged membership test (but maybe that can be done
6675 -- inside Tagged_Membership?).
6677 if Is_Tagged_Type (Typ) then
6680 Left_Opnd => Relocate_Node (N),
6684 Right_Opnd => Make_Null (Loc))));
6686 -- No expansion will be performed for VM targets, as
6687 -- the VM back ends will handle the membership tests
6690 if Tagged_Type_Expansion then
6692 -- Note that we have to pass Original_Node, because
6693 -- the membership test might already have been
6694 -- rewritten by earlier parts of membership test.
6697 (Original_Node (N), SCIL_Node, New_N);
6699 -- Update decoration of relocated node referenced
6700 -- by the SCIL node.
6702 if Generate_SCIL and then Present (SCIL_Node) then
6703 Set_SCIL_Node (New_N, SCIL_Node);
6708 Left_Opnd => Relocate_Node (N),
6709 Right_Opnd => New_N));
6711 Analyze_And_Resolve (N, Restyp);
6720 -- At this point, we have done the processing required for the basic
6721 -- membership test, but not yet dealt with the predicate.
6725 -- If a predicate is present, then we do the predicate test, but we
6726 -- most certainly want to omit this if we are within the predicate
6727 -- function itself, since otherwise we have an infinite recursion.
6728 -- The check should also not be emitted when testing against a range
6729 -- (the check is only done when the right operand is a subtype; see
6730 -- RM12-4.5.2 (28.1/3-30/3)).
6732 Predicate_Check : declare
6733 function In_Range_Check return Boolean;
6734 -- Within an expanded range check that may raise Constraint_Error do
6735 -- not generate a predicate check as well. It is redundant because
6736 -- the context will add an explicit predicate check, and it will
6737 -- raise the wrong exception if it fails.
6739 --------------------
6740 -- In_Range_Check --
6741 --------------------
6743 function In_Range_Check return Boolean is
6747 while Present (P) loop
6748 if Nkind (P) = N_Raise_Constraint_Error then
6751 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
6752 or else Nkind (P) = N_Procedure_Call_Statement
6753 or else Nkind (P) in N_Declaration
6766 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6769 -- Start of processing for Predicate_Check
6773 and then Current_Scope /= PFunc
6774 and then Nkind (Rop) /= N_Range
6776 if not In_Range_Check then
6777 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
6779 R_Op := New_Occurrence_Of (Standard_True, Loc);
6784 Left_Opnd => Relocate_Node (N),
6785 Right_Opnd => R_Op));
6787 -- Analyze new expression, mark left operand as analyzed to
6788 -- avoid infinite recursion adding predicate calls. Similarly,
6789 -- suppress further range checks on the call.
6791 Set_Analyzed (Left_Opnd (N));
6792 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6794 -- All done, skip attempt at compile time determination of result
6798 end Predicate_Check;
6801 --------------------------------
6802 -- Expand_N_Indexed_Component --
6803 --------------------------------
6805 procedure Expand_N_Indexed_Component (N : Node_Id) is
6806 Loc : constant Source_Ptr := Sloc (N);
6807 Typ : constant Entity_Id := Etype (N);
6808 P : constant Node_Id := Prefix (N);
6809 T : constant Entity_Id := Etype (P);
6813 -- A special optimization, if we have an indexed component that is
6814 -- selecting from a slice, then we can eliminate the slice, since, for
6815 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6816 -- the range check required by the slice. The range check for the slice
6817 -- itself has already been generated. The range check for the
6818 -- subscripting operation is ensured by converting the subject to
6819 -- the subtype of the slice.
6821 -- This optimization not only generates better code, avoiding slice
6822 -- messing especially in the packed case, but more importantly bypasses
6823 -- some problems in handling this peculiar case, for example, the issue
6824 -- of dealing specially with object renamings.
6826 if Nkind (P) = N_Slice
6828 -- This optimization is disabled for CodePeer because it can transform
6829 -- an index-check constraint_error into a range-check constraint_error
6830 -- and CodePeer cares about that distinction.
6832 and then not CodePeer_Mode
6835 Make_Indexed_Component (Loc,
6836 Prefix => Prefix (P),
6837 Expressions => New_List (
6839 (Etype (First_Index (Etype (P))),
6840 First (Expressions (N))))));
6841 Analyze_And_Resolve (N, Typ);
6845 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6846 -- function, then additional actuals must be passed.
6848 if Is_Build_In_Place_Function_Call (P) then
6849 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6851 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
6852 -- containing build-in-place function calls whose returned object covers
6855 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
6856 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
6859 -- If the prefix is an access type, then we unconditionally rewrite if
6860 -- as an explicit dereference. This simplifies processing for several
6861 -- cases, including packed array cases and certain cases in which checks
6862 -- must be generated. We used to try to do this only when it was
6863 -- necessary, but it cleans up the code to do it all the time.
6865 if Is_Access_Type (T) then
6866 Insert_Explicit_Dereference (P);
6867 Analyze_And_Resolve (P, Designated_Type (T));
6868 Atp := Designated_Type (T);
6873 -- Generate index and validity checks
6875 Generate_Index_Checks (N);
6877 if Validity_Checks_On and then Validity_Check_Subscripts then
6878 Apply_Subscript_Validity_Checks (N);
6881 -- If selecting from an array with atomic components, and atomic sync
6882 -- is not suppressed for this array type, set atomic sync flag.
6884 if (Has_Atomic_Components (Atp)
6885 and then not Atomic_Synchronization_Disabled (Atp))
6886 or else (Is_Atomic (Typ)
6887 and then not Atomic_Synchronization_Disabled (Typ))
6888 or else (Is_Entity_Name (P)
6889 and then Has_Atomic_Components (Entity (P))
6890 and then not Atomic_Synchronization_Disabled (Entity (P)))
6892 Activate_Atomic_Synchronization (N);
6895 -- All done if the prefix is not a packed array implemented specially
6897 if not (Is_Packed (Etype (Prefix (N)))
6898 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
6903 -- For packed arrays that are not bit-packed (i.e. the case of an array
6904 -- with one or more index types with a non-contiguous enumeration type),
6905 -- we can always use the normal packed element get circuit.
6907 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6908 Expand_Packed_Element_Reference (N);
6912 -- For a reference to a component of a bit packed array, we convert it
6913 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6914 -- want to do this for simple references, and not for:
6916 -- Left side of assignment, or prefix of left side of assignment, or
6917 -- prefix of the prefix, to handle packed arrays of packed arrays,
6918 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6920 -- Renaming objects in renaming associations
6921 -- This case is handled when a use of the renamed variable occurs
6923 -- Actual parameters for a subprogram call
6924 -- This case is handled in Exp_Ch6.Expand_Actuals
6926 -- The second expression in a 'Read attribute reference
6928 -- The prefix of an address or bit or size attribute reference
6930 -- The following circuit detects these exceptions. Note that we need to
6931 -- deal with implicit dereferences when climbing up the parent chain,
6932 -- with the additional difficulty that the type of parents may have yet
6933 -- to be resolved since prefixes are usually resolved first.
6936 Child : Node_Id := N;
6937 Parnt : Node_Id := Parent (N);
6941 if Nkind (Parnt) = N_Unchecked_Expression then
6944 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then
6947 elsif Nkind (Parnt) in N_Subprogram_Call
6948 or else (Nkind (Parnt) = N_Parameter_Association
6949 and then Nkind (Parent (Parnt)) in N_Subprogram_Call)
6953 elsif Nkind (Parnt) = N_Attribute_Reference
6954 and then Nam_In (Attribute_Name (Parnt), Name_Address,
6957 and then Prefix (Parnt) = Child
6961 elsif Nkind (Parnt) = N_Assignment_Statement
6962 and then Name (Parnt) = Child
6966 -- If the expression is an index of an indexed component, it must
6967 -- be expanded regardless of context.
6969 elsif Nkind (Parnt) = N_Indexed_Component
6970 and then Child /= Prefix (Parnt)
6972 Expand_Packed_Element_Reference (N);
6975 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
6976 and then Name (Parent (Parnt)) = Parnt
6980 elsif Nkind (Parnt) = N_Attribute_Reference
6981 and then Attribute_Name (Parnt) = Name_Read
6982 and then Next (First (Expressions (Parnt))) = Child
6986 elsif Nkind (Parnt) = N_Indexed_Component
6987 and then Prefix (Parnt) = Child
6991 elsif Nkind (Parnt) = N_Selected_Component
6992 and then Prefix (Parnt) = Child
6993 and then not (Present (Etype (Selector_Name (Parnt)))
6995 Is_Access_Type (Etype (Selector_Name (Parnt))))
6999 -- If the parent is a dereference, either implicit or explicit,
7000 -- then the packed reference needs to be expanded.
7003 Expand_Packed_Element_Reference (N);
7007 -- Keep looking up tree for unchecked expression, or if we are the
7008 -- prefix of a possible assignment left side.
7011 Parnt := Parent (Child);
7014 end Expand_N_Indexed_Component;
7016 ---------------------
7017 -- Expand_N_Not_In --
7018 ---------------------
7020 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7021 -- can be done. This avoids needing to duplicate this expansion code.
7023 procedure Expand_N_Not_In (N : Node_Id) is
7024 Loc : constant Source_Ptr := Sloc (N);
7025 Typ : constant Entity_Id := Etype (N);
7026 Cfs : constant Boolean := Comes_From_Source (N);
7033 Left_Opnd => Left_Opnd (N),
7034 Right_Opnd => Right_Opnd (N))));
7036 -- If this is a set membership, preserve list of alternatives
7038 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
7040 -- We want this to appear as coming from source if original does (see
7041 -- transformations in Expand_N_In).
7043 Set_Comes_From_Source (N, Cfs);
7044 Set_Comes_From_Source (Right_Opnd (N), Cfs);
7046 -- Now analyze transformed node
7048 Analyze_And_Resolve (N, Typ);
7049 end Expand_N_Not_In;
7055 -- The only replacement required is for the case of a null of a type that
7056 -- is an access to protected subprogram, or a subtype thereof. We represent
7057 -- such access values as a record, and so we must replace the occurrence of
7058 -- null by the equivalent record (with a null address and a null pointer in
7059 -- it), so that the back end creates the proper value.
7061 procedure Expand_N_Null (N : Node_Id) is
7062 Loc : constant Source_Ptr := Sloc (N);
7063 Typ : constant Entity_Id := Base_Type (Etype (N));
7067 if Is_Access_Protected_Subprogram_Type (Typ) then
7069 Make_Aggregate (Loc,
7070 Expressions => New_List (
7071 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
7075 Analyze_And_Resolve (N, Equivalent_Type (Typ));
7077 -- For subsequent semantic analysis, the node must retain its type.
7078 -- Gigi in any case replaces this type by the corresponding record
7079 -- type before processing the node.
7085 when RE_Not_Available =>
7089 ---------------------
7090 -- Expand_N_Op_Abs --
7091 ---------------------
7093 procedure Expand_N_Op_Abs (N : Node_Id) is
7094 Loc : constant Source_Ptr := Sloc (N);
7095 Expr : constant Node_Id := Right_Opnd (N);
7098 Unary_Op_Validity_Checks (N);
7100 -- Check for MINIMIZED/ELIMINATED overflow mode
7102 if Minimized_Eliminated_Overflow_Check (N) then
7103 Apply_Arithmetic_Overflow_Check (N);
7107 -- Deal with software overflow checking
7109 if Is_Signed_Integer_Type (Etype (N))
7110 and then Do_Overflow_Check (N)
7112 -- The only case to worry about is when the argument is equal to the
7113 -- largest negative number, so what we do is to insert the check:
7115 -- [constraint_error when Expr = typ'Base'First]
7117 -- with the usual Duplicate_Subexpr use coding for expr
7120 Make_Raise_Constraint_Error (Loc,
7123 Left_Opnd => Duplicate_Subexpr (Expr),
7125 Make_Attribute_Reference (Loc,
7127 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
7128 Attribute_Name => Name_First)),
7129 Reason => CE_Overflow_Check_Failed));
7131 Set_Do_Overflow_Check (N, False);
7133 end Expand_N_Op_Abs;
7135 ---------------------
7136 -- Expand_N_Op_Add --
7137 ---------------------
7139 procedure Expand_N_Op_Add (N : Node_Id) is
7140 Typ : constant Entity_Id := Etype (N);
7143 Binary_Op_Validity_Checks (N);
7145 -- Check for MINIMIZED/ELIMINATED overflow mode
7147 if Minimized_Eliminated_Overflow_Check (N) then
7148 Apply_Arithmetic_Overflow_Check (N);
7152 -- N + 0 = 0 + N = N for integer types
7154 if Is_Integer_Type (Typ) then
7155 if Compile_Time_Known_Value (Right_Opnd (N))
7156 and then Expr_Value (Right_Opnd (N)) = Uint_0
7158 Rewrite (N, Left_Opnd (N));
7161 elsif Compile_Time_Known_Value (Left_Opnd (N))
7162 and then Expr_Value (Left_Opnd (N)) = Uint_0
7164 Rewrite (N, Right_Opnd (N));
7169 -- Arithmetic overflow checks for signed integer/fixed point types
7171 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
7172 Apply_Arithmetic_Overflow_Check (N);
7176 -- Overflow checks for floating-point if -gnateF mode active
7178 Check_Float_Op_Overflow (N);
7180 Expand_Nonbinary_Modular_Op (N);
7181 end Expand_N_Op_Add;
7183 ---------------------
7184 -- Expand_N_Op_And --
7185 ---------------------
7187 procedure Expand_N_Op_And (N : Node_Id) is
7188 Typ : constant Entity_Id := Etype (N);
7191 Binary_Op_Validity_Checks (N);
7193 if Is_Array_Type (Etype (N)) then
7194 Expand_Boolean_Operator (N);
7196 elsif Is_Boolean_Type (Etype (N)) then
7197 Adjust_Condition (Left_Opnd (N));
7198 Adjust_Condition (Right_Opnd (N));
7199 Set_Etype (N, Standard_Boolean);
7200 Adjust_Result_Type (N, Typ);
7202 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7203 Expand_Intrinsic_Call (N, Entity (N));
7206 Expand_Nonbinary_Modular_Op (N);
7207 end Expand_N_Op_And;
7209 ------------------------
7210 -- Expand_N_Op_Concat --
7211 ------------------------
7213 procedure Expand_N_Op_Concat (N : Node_Id) is
7215 -- List of operands to be concatenated
7218 -- Node which is to be replaced by the result of concatenating the nodes
7219 -- in the list Opnds.
7222 -- Ensure validity of both operands
7224 Binary_Op_Validity_Checks (N);
7226 -- If we are the left operand of a concatenation higher up the tree,
7227 -- then do nothing for now, since we want to deal with a series of
7228 -- concatenations as a unit.
7230 if Nkind (Parent (N)) = N_Op_Concat
7231 and then N = Left_Opnd (Parent (N))
7236 -- We get here with a concatenation whose left operand may be a
7237 -- concatenation itself with a consistent type. We need to process
7238 -- these concatenation operands from left to right, which means
7239 -- from the deepest node in the tree to the highest node.
7242 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
7243 Cnode := Left_Opnd (Cnode);
7246 -- Now Cnode is the deepest concatenation, and its parents are the
7247 -- concatenation nodes above, so now we process bottom up, doing the
7250 -- The outer loop runs more than once if more than one concatenation
7251 -- type is involved.
7254 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
7255 Set_Parent (Opnds, N);
7257 -- The inner loop gathers concatenation operands
7259 Inner : while Cnode /= N
7260 and then Base_Type (Etype (Cnode)) =
7261 Base_Type (Etype (Parent (Cnode)))
7263 Cnode := Parent (Cnode);
7264 Append (Right_Opnd (Cnode), Opnds);
7267 -- Note: The following code is a temporary workaround for N731-034
7268 -- and N829-028 and will be kept until the general issue of internal
7269 -- symbol serialization is addressed. The workaround is kept under a
7270 -- debug switch to avoid permiating into the general case.
7272 -- Wrap the node to concatenate into an expression actions node to
7273 -- keep it nicely packaged. This is useful in the case of an assert
7274 -- pragma with a concatenation where we want to be able to delete
7275 -- the concatenation and all its expansion stuff.
7277 if Debug_Flag_Dot_H then
7279 Cnod : constant Node_Id := New_Copy_Tree (Cnode);
7280 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
7283 -- Note: use Rewrite rather than Replace here, so that for
7284 -- example Why_Not_Static can find the original concatenation
7288 Make_Expression_With_Actions (Sloc (Cnode),
7289 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
7290 Expression => Cnod));
7292 Expand_Concatenate (Cnod, Opnds);
7293 Analyze_And_Resolve (Cnode, Typ);
7299 Expand_Concatenate (Cnode, Opnds);
7302 exit Outer when Cnode = N;
7303 Cnode := Parent (Cnode);
7305 end Expand_N_Op_Concat;
7307 ------------------------
7308 -- Expand_N_Op_Divide --
7309 ------------------------
7311 procedure Expand_N_Op_Divide (N : Node_Id) is
7312 Loc : constant Source_Ptr := Sloc (N);
7313 Lopnd : constant Node_Id := Left_Opnd (N);
7314 Ropnd : constant Node_Id := Right_Opnd (N);
7315 Ltyp : constant Entity_Id := Etype (Lopnd);
7316 Rtyp : constant Entity_Id := Etype (Ropnd);
7317 Typ : Entity_Id := Etype (N);
7318 Rknow : constant Boolean := Is_Integer_Type (Typ)
7320 Compile_Time_Known_Value (Ropnd);
7324 Binary_Op_Validity_Checks (N);
7326 -- Check for MINIMIZED/ELIMINATED overflow mode
7328 if Minimized_Eliminated_Overflow_Check (N) then
7329 Apply_Arithmetic_Overflow_Check (N);
7333 -- Otherwise proceed with expansion of division
7336 Rval := Expr_Value (Ropnd);
7339 -- N / 1 = N for integer types
7341 if Rknow and then Rval = Uint_1 then
7346 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7347 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7348 -- operand is an unsigned integer, as required for this to work.
7350 if Nkind (Ropnd) = N_Op_Expon
7351 and then Is_Power_Of_2_For_Shift (Ropnd)
7353 -- We cannot do this transformation in configurable run time mode if we
7354 -- have 64-bit integers and long shifts are not available.
7356 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
7359 Make_Op_Shift_Right (Loc,
7362 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
7363 Analyze_And_Resolve (N, Typ);
7367 -- Do required fixup of universal fixed operation
7369 if Typ = Universal_Fixed then
7370 Fixup_Universal_Fixed_Operation (N);
7374 -- Divisions with fixed-point results
7376 if Is_Fixed_Point_Type (Typ) then
7378 -- No special processing if Treat_Fixed_As_Integer is set, since
7379 -- from a semantic point of view such operations are simply integer
7380 -- operations and will be treated that way.
7382 if not Treat_Fixed_As_Integer (N) then
7383 if Is_Integer_Type (Rtyp) then
7384 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
7386 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
7390 -- Deal with divide-by-zero check if back end cannot handle them
7391 -- and the flag is set indicating that we need such a check. Note
7392 -- that we don't need to bother here with the case of mixed-mode
7393 -- (Right operand an integer type), since these will be rewritten
7394 -- with conversions to a divide with a fixed-point right operand.
7396 if Nkind (N) = N_Op_Divide
7397 and then Do_Division_Check (N)
7398 and then not Backend_Divide_Checks_On_Target
7399 and then not Is_Integer_Type (Rtyp)
7401 Set_Do_Division_Check (N, False);
7403 Make_Raise_Constraint_Error (Loc,
7406 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
7407 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
7408 Reason => CE_Divide_By_Zero));
7411 -- Other cases of division of fixed-point operands. Again we exclude the
7412 -- case where Treat_Fixed_As_Integer is set.
7414 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
7415 and then not Treat_Fixed_As_Integer (N)
7417 if Is_Integer_Type (Typ) then
7418 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
7420 pragma Assert (Is_Floating_Point_Type (Typ));
7421 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
7424 -- Mixed-mode operations can appear in a non-static universal context,
7425 -- in which case the integer argument must be converted explicitly.
7427 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
7429 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
7431 Analyze_And_Resolve (Ropnd, Universal_Real);
7433 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
7435 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
7437 Analyze_And_Resolve (Lopnd, Universal_Real);
7439 -- Non-fixed point cases, do integer zero divide and overflow checks
7441 elsif Is_Integer_Type (Typ) then
7442 Apply_Divide_Checks (N);
7445 -- Overflow checks for floating-point if -gnateF mode active
7447 Check_Float_Op_Overflow (N);
7449 Expand_Nonbinary_Modular_Op (N);
7450 end Expand_N_Op_Divide;
7452 --------------------
7453 -- Expand_N_Op_Eq --
7454 --------------------
7456 procedure Expand_N_Op_Eq (N : Node_Id) is
7457 Loc : constant Source_Ptr := Sloc (N);
7458 Typ : constant Entity_Id := Etype (N);
7459 Lhs : constant Node_Id := Left_Opnd (N);
7460 Rhs : constant Node_Id := Right_Opnd (N);
7461 Bodies : constant List_Id := New_List;
7462 A_Typ : constant Entity_Id := Etype (Lhs);
7464 procedure Build_Equality_Call (Eq : Entity_Id);
7465 -- If a constructed equality exists for the type or for its parent,
7466 -- build and analyze call, adding conversions if the operation is
7469 function Find_Equality (Prims : Elist_Id) return Entity_Id;
7470 -- Find a primitive equality function within primitive operation list
7473 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
7474 -- Determines whether a type has a subcomponent of an unconstrained
7475 -- Unchecked_Union subtype. Typ is a record type.
7477 -------------------------
7478 -- Build_Equality_Call --
7479 -------------------------
7481 procedure Build_Equality_Call (Eq : Entity_Id) is
7482 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
7483 L_Exp : Node_Id := Relocate_Node (Lhs);
7484 R_Exp : Node_Id := Relocate_Node (Rhs);
7487 -- Adjust operands if necessary to comparison type
7489 if Base_Type (Op_Type) /= Base_Type (A_Typ)
7490 and then not Is_Class_Wide_Type (A_Typ)
7492 L_Exp := OK_Convert_To (Op_Type, L_Exp);
7493 R_Exp := OK_Convert_To (Op_Type, R_Exp);
7496 -- If we have an Unchecked_Union, we need to add the inferred
7497 -- discriminant values as actuals in the function call. At this
7498 -- point, the expansion has determined that both operands have
7499 -- inferable discriminants.
7501 if Is_Unchecked_Union (Op_Type) then
7503 Lhs_Type : constant Node_Id := Etype (L_Exp);
7504 Rhs_Type : constant Node_Id := Etype (R_Exp);
7506 Lhs_Discr_Vals : Elist_Id;
7507 -- List of inferred discriminant values for left operand.
7509 Rhs_Discr_Vals : Elist_Id;
7510 -- List of inferred discriminant values for right operand.
7515 Lhs_Discr_Vals := New_Elmt_List;
7516 Rhs_Discr_Vals := New_Elmt_List;
7518 -- Per-object constrained selected components require special
7519 -- attention. If the enclosing scope of the component is an
7520 -- Unchecked_Union, we cannot reference its discriminants
7521 -- directly. This is why we use the extra parameters of the
7522 -- equality function of the enclosing Unchecked_Union.
7524 -- type UU_Type (Discr : Integer := 0) is
7527 -- pragma Unchecked_Union (UU_Type);
7529 -- 1. Unchecked_Union enclosing record:
7531 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7533 -- Comp : UU_Type (Discr);
7535 -- end Enclosing_UU_Type;
7536 -- pragma Unchecked_Union (Enclosing_UU_Type);
7538 -- Obj1 : Enclosing_UU_Type;
7539 -- Obj2 : Enclosing_UU_Type (1);
7541 -- [. . .] Obj1 = Obj2 [. . .]
7545 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7547 -- A and B are the formal parameters of the equality function
7548 -- of Enclosing_UU_Type. The function always has two extra
7549 -- formals to capture the inferred discriminant values for
7550 -- each discriminant of the type.
7552 -- 2. Non-Unchecked_Union enclosing record:
7555 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7558 -- Comp : UU_Type (Discr);
7560 -- end Enclosing_Non_UU_Type;
7562 -- Obj1 : Enclosing_Non_UU_Type;
7563 -- Obj2 : Enclosing_Non_UU_Type (1);
7565 -- ... Obj1 = Obj2 ...
7569 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7570 -- obj1.discr, obj2.discr)) then
7572 -- In this case we can directly reference the discriminants of
7573 -- the enclosing record.
7575 -- Process left operand of equality
7577 if Nkind (Lhs) = N_Selected_Component
7579 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
7581 -- If enclosing record is an Unchecked_Union, use formals
7582 -- corresponding to each discriminant. The name of the
7583 -- formal is that of the discriminant, with added suffix,
7584 -- see Exp_Ch3.Build_Record_Equality for details.
7586 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
7590 (Scope (Entity (Selector_Name (Lhs))));
7591 while Present (Discr) loop
7593 (Make_Identifier (Loc,
7594 Chars => New_External_Name (Chars (Discr), 'A')),
7595 To => Lhs_Discr_Vals);
7596 Next_Discriminant (Discr);
7599 -- If enclosing record is of a non-Unchecked_Union type, it
7600 -- is possible to reference its discriminants directly.
7603 Discr := First_Discriminant (Lhs_Type);
7604 while Present (Discr) loop
7606 (Make_Selected_Component (Loc,
7607 Prefix => Prefix (Lhs),
7610 (Get_Discriminant_Value (Discr,
7612 Stored_Constraint (Lhs_Type)))),
7613 To => Lhs_Discr_Vals);
7614 Next_Discriminant (Discr);
7618 -- Otherwise operand is on object with a constrained type.
7619 -- Infer the discriminant values from the constraint.
7622 Discr := First_Discriminant (Lhs_Type);
7623 while Present (Discr) loop
7626 (Get_Discriminant_Value (Discr,
7628 Stored_Constraint (Lhs_Type))),
7629 To => Lhs_Discr_Vals);
7630 Next_Discriminant (Discr);
7634 -- Similar processing for right operand of equality
7636 if Nkind (Rhs) = N_Selected_Component
7638 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7640 if Is_Unchecked_Union
7641 (Scope (Entity (Selector_Name (Rhs))))
7645 (Scope (Entity (Selector_Name (Rhs))));
7646 while Present (Discr) loop
7648 (Make_Identifier (Loc,
7649 Chars => New_External_Name (Chars (Discr), 'B')),
7650 To => Rhs_Discr_Vals);
7651 Next_Discriminant (Discr);
7655 Discr := First_Discriminant (Rhs_Type);
7656 while Present (Discr) loop
7658 (Make_Selected_Component (Loc,
7659 Prefix => Prefix (Rhs),
7661 New_Copy (Get_Discriminant_Value
7664 Stored_Constraint (Rhs_Type)))),
7665 To => Rhs_Discr_Vals);
7666 Next_Discriminant (Discr);
7671 Discr := First_Discriminant (Rhs_Type);
7672 while Present (Discr) loop
7674 (New_Copy (Get_Discriminant_Value
7677 Stored_Constraint (Rhs_Type))),
7678 To => Rhs_Discr_Vals);
7679 Next_Discriminant (Discr);
7683 -- Now merge the list of discriminant values so that values
7684 -- of corresponding discriminants are adjacent.
7692 Params := New_List (L_Exp, R_Exp);
7693 L_Elmt := First_Elmt (Lhs_Discr_Vals);
7694 R_Elmt := First_Elmt (Rhs_Discr_Vals);
7695 while Present (L_Elmt) loop
7696 Append_To (Params, Node (L_Elmt));
7697 Append_To (Params, Node (R_Elmt));
7703 Make_Function_Call (Loc,
7704 Name => New_Occurrence_Of (Eq, Loc),
7705 Parameter_Associations => Params));
7709 -- Normal case, not an unchecked union
7713 Make_Function_Call (Loc,
7714 Name => New_Occurrence_Of (Eq, Loc),
7715 Parameter_Associations => New_List (L_Exp, R_Exp)));
7718 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7719 end Build_Equality_Call;
7725 function Find_Equality (Prims : Elist_Id) return Entity_Id is
7726 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id;
7727 -- Find an equality in a possible alias chain starting from primitive
7730 function Is_Equality (Id : Entity_Id) return Boolean;
7731 -- Determine whether arbitrary entity Id denotes an equality
7733 ---------------------------
7734 -- Find_Aliased_Equality --
7735 ---------------------------
7737 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is
7741 -- Inspect each candidate in the alias chain, checking whether it
7742 -- denotes an equality.
7745 while Present (Candid) loop
7746 if Is_Equality (Candid) then
7750 Candid := Alias (Candid);
7754 end Find_Aliased_Equality;
7760 function Is_Equality (Id : Entity_Id) return Boolean is
7761 Formal_1 : Entity_Id;
7762 Formal_2 : Entity_Id;
7765 -- The equality function carries name "=", returns Boolean, and
7766 -- has exactly two formal parameters of an identical type.
7768 if Ekind (Id) = E_Function
7769 and then Chars (Id) = Name_Op_Eq
7770 and then Base_Type (Etype (Id)) = Standard_Boolean
7772 Formal_1 := First_Formal (Id);
7775 if Present (Formal_1) then
7776 Formal_2 := Next_Formal (Formal_1);
7781 and then Present (Formal_2)
7782 and then Etype (Formal_1) = Etype (Formal_2)
7783 and then No (Next_Formal (Formal_2));
7791 Eq_Prim : Entity_Id;
7792 Prim_Elmt : Elmt_Id;
7794 -- Start of processing for Find_Equality
7797 -- Assume that the tagged type lacks an equality
7801 -- Inspect the list of primitives looking for a suitable equality
7802 -- within a possible chain of aliases.
7804 Prim_Elmt := First_Elmt (Prims);
7805 while Present (Prim_Elmt) and then No (Eq_Prim) loop
7806 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt));
7808 Next_Elmt (Prim_Elmt);
7811 -- A tagged type should always have an equality
7813 pragma Assert (Present (Eq_Prim));
7818 ------------------------------------
7819 -- Has_Unconstrained_UU_Component --
7820 ------------------------------------
7822 function Has_Unconstrained_UU_Component
7823 (Typ : Entity_Id) return Boolean
7825 Tdef : constant Node_Id :=
7826 Type_Definition (Declaration_Node (Base_Type (Typ)));
7830 function Component_Is_Unconstrained_UU
7831 (Comp : Node_Id) return Boolean;
7832 -- Determines whether the subtype of the component is an
7833 -- unconstrained Unchecked_Union.
7835 function Variant_Is_Unconstrained_UU
7836 (Variant : Node_Id) return Boolean;
7837 -- Determines whether a component of the variant has an unconstrained
7838 -- Unchecked_Union subtype.
7840 -----------------------------------
7841 -- Component_Is_Unconstrained_UU --
7842 -----------------------------------
7844 function Component_Is_Unconstrained_UU
7845 (Comp : Node_Id) return Boolean
7848 if Nkind (Comp) /= N_Component_Declaration then
7853 Sindic : constant Node_Id :=
7854 Subtype_Indication (Component_Definition (Comp));
7857 -- Unconstrained nominal type. In the case of a constraint
7858 -- present, the node kind would have been N_Subtype_Indication.
7860 if Nkind (Sindic) = N_Identifier then
7861 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7866 end Component_Is_Unconstrained_UU;
7868 ---------------------------------
7869 -- Variant_Is_Unconstrained_UU --
7870 ---------------------------------
7872 function Variant_Is_Unconstrained_UU
7873 (Variant : Node_Id) return Boolean
7875 Clist : constant Node_Id := Component_List (Variant);
7878 if Is_Empty_List (Component_Items (Clist)) then
7882 -- We only need to test one component
7885 Comp : Node_Id := First (Component_Items (Clist));
7888 while Present (Comp) loop
7889 if Component_Is_Unconstrained_UU (Comp) then
7897 -- None of the components withing the variant were of
7898 -- unconstrained Unchecked_Union type.
7901 end Variant_Is_Unconstrained_UU;
7903 -- Start of processing for Has_Unconstrained_UU_Component
7906 if Null_Present (Tdef) then
7910 Clist := Component_List (Tdef);
7911 Vpart := Variant_Part (Clist);
7913 -- Inspect available components
7915 if Present (Component_Items (Clist)) then
7917 Comp : Node_Id := First (Component_Items (Clist));
7920 while Present (Comp) loop
7922 -- One component is sufficient
7924 if Component_Is_Unconstrained_UU (Comp) then
7933 -- Inspect available components withing variants
7935 if Present (Vpart) then
7937 Variant : Node_Id := First (Variants (Vpart));
7940 while Present (Variant) loop
7942 -- One component within a variant is sufficient
7944 if Variant_Is_Unconstrained_UU (Variant) then
7953 -- Neither the available components, nor the components inside the
7954 -- variant parts were of an unconstrained Unchecked_Union subtype.
7957 end Has_Unconstrained_UU_Component;
7963 -- Start of processing for Expand_N_Op_Eq
7966 Binary_Op_Validity_Checks (N);
7968 -- Deal with private types
7972 if Ekind (Typl) = E_Private_Type then
7973 Typl := Underlying_Type (Typl);
7975 elsif Ekind (Typl) = E_Private_Subtype then
7976 Typl := Underlying_Type (Base_Type (Typl));
7979 -- It may happen in error situations that the underlying type is not
7980 -- set. The error will be detected later, here we just defend the
7987 -- Now get the implementation base type (note that plain Base_Type here
7988 -- might lead us back to the private type, which is not what we want!)
7990 Typl := Implementation_Base_Type (Typl);
7992 -- Equality between variant records results in a call to a routine
7993 -- that has conditional tests of the discriminant value(s), and hence
7994 -- violates the No_Implicit_Conditionals restriction.
7996 if Has_Variant_Part (Typl) then
8001 Check_Restriction (Msg, No_Implicit_Conditionals, N);
8005 ("\comparison of variant records tests discriminants", N);
8011 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8012 -- means we no longer have a comparison operation, we are all done.
8014 Expand_Compare_Minimize_Eliminate_Overflow (N);
8016 if Nkind (N) /= N_Op_Eq then
8020 -- Boolean types (requiring handling of non-standard case)
8022 if Is_Boolean_Type (Typl) then
8023 Adjust_Condition (Left_Opnd (N));
8024 Adjust_Condition (Right_Opnd (N));
8025 Set_Etype (N, Standard_Boolean);
8026 Adjust_Result_Type (N, Typ);
8030 elsif Is_Array_Type (Typl) then
8032 -- If we are doing full validity checking, and it is possible for the
8033 -- array elements to be invalid then expand out array comparisons to
8034 -- make sure that we check the array elements.
8036 if Validity_Check_Operands
8037 and then not Is_Known_Valid (Component_Type (Typl))
8040 Save_Force_Validity_Checks : constant Boolean :=
8041 Force_Validity_Checks;
8043 Force_Validity_Checks := True;
8045 Expand_Array_Equality
8047 Relocate_Node (Lhs),
8048 Relocate_Node (Rhs),
8051 Insert_Actions (N, Bodies);
8052 Analyze_And_Resolve (N, Standard_Boolean);
8053 Force_Validity_Checks := Save_Force_Validity_Checks;
8056 -- Packed case where both operands are known aligned
8058 elsif Is_Bit_Packed_Array (Typl)
8059 and then not Is_Possibly_Unaligned_Object (Lhs)
8060 and then not Is_Possibly_Unaligned_Object (Rhs)
8062 Expand_Packed_Eq (N);
8064 -- Where the component type is elementary we can use a block bit
8065 -- comparison (if supported on the target) exception in the case
8066 -- of floating-point (negative zero issues require element by
8067 -- element comparison), and atomic/VFA types (where we must be sure
8068 -- to load elements independently) and possibly unaligned arrays.
8070 elsif Is_Elementary_Type (Component_Type (Typl))
8071 and then not Is_Floating_Point_Type (Component_Type (Typl))
8072 and then not Is_Atomic_Or_VFA (Component_Type (Typl))
8073 and then not Is_Possibly_Unaligned_Object (Lhs)
8074 and then not Is_Possibly_Unaligned_Slice (Lhs)
8075 and then not Is_Possibly_Unaligned_Object (Rhs)
8076 and then not Is_Possibly_Unaligned_Slice (Rhs)
8077 and then Support_Composite_Compare_On_Target
8081 -- For composite and floating-point cases, expand equality loop to
8082 -- make sure of using proper comparisons for tagged types, and
8083 -- correctly handling the floating-point case.
8087 Expand_Array_Equality
8089 Relocate_Node (Lhs),
8090 Relocate_Node (Rhs),
8093 Insert_Actions (N, Bodies, Suppress => All_Checks);
8094 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8099 elsif Is_Record_Type (Typl) then
8101 -- For tagged types, use the primitive "="
8103 if Is_Tagged_Type (Typl) then
8105 -- No need to do anything else compiling under restriction
8106 -- No_Dispatching_Calls. During the semantic analysis we
8107 -- already notified such violation.
8109 if Restriction_Active (No_Dispatching_Calls) then
8113 -- If this is an untagged private type completed with a derivation
8114 -- of an untagged private type whose full view is a tagged type,
8115 -- we use the primitive operations of the private type (since it
8116 -- does not have a full view, and also because its equality
8117 -- primitive may have been overridden in its untagged full view).
8119 if Inherits_From_Tagged_Full_View (A_Typ) then
8121 (Find_Equality (Collect_Primitive_Operations (A_Typ)));
8123 -- Find the type's predefined equality or an overriding
8124 -- user-defined equality. The reason for not simply calling
8125 -- Find_Prim_Op here is that there may be a user-defined
8126 -- overloaded equality op that precedes the equality that we
8127 -- want, so we have to explicitly search (e.g., there could be
8128 -- an equality with two different parameter types).
8131 if Is_Class_Wide_Type (Typl) then
8132 Typl := Find_Specific_Type (Typl);
8136 (Find_Equality (Primitive_Operations (Typl)));
8139 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8140 -- predefined equality operator for a type which has a subcomponent
8141 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8143 elsif Has_Unconstrained_UU_Component (Typl) then
8145 Make_Raise_Program_Error (Loc,
8146 Reason => PE_Unchecked_Union_Restriction));
8148 -- Prevent Gigi from generating incorrect code by rewriting the
8149 -- equality as a standard False. (is this documented somewhere???)
8152 New_Occurrence_Of (Standard_False, Loc));
8154 elsif Is_Unchecked_Union (Typl) then
8156 -- If we can infer the discriminants of the operands, we make a
8157 -- call to the TSS equality function.
8159 if Has_Inferable_Discriminants (Lhs)
8161 Has_Inferable_Discriminants (Rhs)
8164 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8167 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8168 -- the predefined equality operator for an Unchecked_Union type
8169 -- if either of the operands lack inferable discriminants.
8172 Make_Raise_Program_Error (Loc,
8173 Reason => PE_Unchecked_Union_Restriction));
8175 -- Emit a warning on source equalities only, otherwise the
8176 -- message may appear out of place due to internal use. The
8177 -- warning is unconditional because it is required by the
8180 if Comes_From_Source (N) then
8182 ("Unchecked_Union discriminants cannot be determined??",
8185 ("\Program_Error will be raised for equality operation??",
8189 -- Prevent Gigi from generating incorrect code by rewriting
8190 -- the equality as a standard False (documented where???).
8193 New_Occurrence_Of (Standard_False, Loc));
8196 -- If a type support function is present (for complex cases), use it
8198 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
8200 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8202 -- When comparing two Bounded_Strings, use the primitive equality of
8203 -- the root Super_String type.
8205 elsif Is_Bounded_String (Typl) then
8208 (Collect_Primitive_Operations (Root_Type (Typl))));
8210 -- Otherwise expand the component by component equality. Note that
8211 -- we never use block-bit comparisons for records, because of the
8212 -- problems with gaps. The back end will often be able to recombine
8213 -- the separate comparisons that we generate here.
8216 Remove_Side_Effects (Lhs);
8217 Remove_Side_Effects (Rhs);
8219 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
8221 Insert_Actions (N, Bodies, Suppress => All_Checks);
8222 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8226 -- Test if result is known at compile time
8228 Rewrite_Comparison (N);
8230 -- Special optimization of length comparison
8232 Optimize_Length_Comparison (N);
8234 -- One more special case: if we have a comparison of X'Result = expr
8235 -- in floating-point, then if not already there, change expr to be
8236 -- f'Machine (expr) to eliminate surprise from extra precision.
8238 if Is_Floating_Point_Type (Typl)
8239 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
8240 and then Attribute_Name (Original_Node (Lhs)) = Name_Result
8242 -- Stick in the Typ'Machine call if not already there
8244 if Nkind (Rhs) /= N_Attribute_Reference
8245 or else Attribute_Name (Rhs) /= Name_Machine
8248 Make_Attribute_Reference (Loc,
8249 Prefix => New_Occurrence_Of (Typl, Loc),
8250 Attribute_Name => Name_Machine,
8251 Expressions => New_List (Relocate_Node (Rhs))));
8252 Analyze_And_Resolve (Rhs, Typl);
8257 -----------------------
8258 -- Expand_N_Op_Expon --
8259 -----------------------
8261 procedure Expand_N_Op_Expon (N : Node_Id) is
8262 Loc : constant Source_Ptr := Sloc (N);
8263 Ovflo : constant Boolean := Do_Overflow_Check (N);
8264 Typ : constant Entity_Id := Etype (N);
8265 Rtyp : constant Entity_Id := Root_Type (Typ);
8269 function Wrap_MA (Exp : Node_Id) return Node_Id;
8270 -- Given an expression Exp, if the root type is Float or Long_Float,
8271 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8272 -- extra precision. This is done to ensure that X**A = X**B when A is
8273 -- a static constant and B is a variable with the same value. For any
8274 -- other type, the node Exp is returned unchanged.
8280 function Wrap_MA (Exp : Node_Id) return Node_Id is
8281 Loc : constant Source_Ptr := Sloc (Exp);
8284 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
8286 Make_Attribute_Reference (Loc,
8287 Attribute_Name => Name_Machine,
8288 Prefix => New_Occurrence_Of (Bastyp, Loc),
8289 Expressions => New_List (Relocate_Node (Exp)));
8307 -- Start of processing for Expand_N_Op_Expon
8310 Binary_Op_Validity_Checks (N);
8312 -- CodePeer wants to see the unexpanded N_Op_Expon node
8314 if CodePeer_Mode then
8318 -- Relocation of left and right operands must be done after performing
8319 -- the validity checks since the generation of validation checks may
8320 -- remove side effects.
8322 Base := Relocate_Node (Left_Opnd (N));
8323 Bastyp := Etype (Base);
8324 Exp := Relocate_Node (Right_Opnd (N));
8325 Exptyp := Etype (Exp);
8327 -- If either operand is of a private type, then we have the use of an
8328 -- intrinsic operator, and we get rid of the privateness, by using root
8329 -- types of underlying types for the actual operation. Otherwise the
8330 -- private types will cause trouble if we expand multiplications or
8331 -- shifts etc. We also do this transformation if the result type is
8332 -- different from the base type.
8334 if Is_Private_Type (Etype (Base))
8335 or else Is_Private_Type (Typ)
8336 or else Is_Private_Type (Exptyp)
8337 or else Rtyp /= Root_Type (Bastyp)
8340 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
8341 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
8344 Unchecked_Convert_To (Typ,
8346 Left_Opnd => Unchecked_Convert_To (Bt, Base),
8347 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
8348 Analyze_And_Resolve (N, Typ);
8353 -- Check for MINIMIZED/ELIMINATED overflow mode
8355 if Minimized_Eliminated_Overflow_Check (N) then
8356 Apply_Arithmetic_Overflow_Check (N);
8360 -- Test for case of known right argument where we can replace the
8361 -- exponentiation by an equivalent expression using multiplication.
8363 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8364 -- configurable run-time mode, we may not have the exponentiation
8365 -- routine available, and we don't want the legality of the program
8366 -- to depend on how clever the compiler is in knowing values.
8368 if CRT_Safe_Compile_Time_Known_Value (Exp) then
8369 Expv := Expr_Value (Exp);
8371 -- We only fold small non-negative exponents. You might think we
8372 -- could fold small negative exponents for the real case, but we
8373 -- can't because we are required to raise Constraint_Error for
8374 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8375 -- See ACVC test C4A012B, and it is not worth generating the test.
8377 -- For small negative exponents, we return the reciprocal of
8378 -- the folding of the exponentiation for the opposite (positive)
8379 -- exponent, as required by Ada RM 4.5.6(11/3).
8381 if abs Expv <= 4 then
8383 -- X ** 0 = 1 (or 1.0)
8387 -- Call Remove_Side_Effects to ensure that any side effects
8388 -- in the ignored left operand (in particular function calls
8389 -- to user defined functions) are properly executed.
8391 Remove_Side_Effects (Base);
8393 if Ekind (Typ) in Integer_Kind then
8394 Xnode := Make_Integer_Literal (Loc, Intval => 1);
8396 Xnode := Make_Real_Literal (Loc, Ureal_1);
8409 Make_Op_Multiply (Loc,
8410 Left_Opnd => Duplicate_Subexpr (Base),
8411 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8413 -- X ** 3 = X * X * X
8418 Make_Op_Multiply (Loc,
8420 Make_Op_Multiply (Loc,
8421 Left_Opnd => Duplicate_Subexpr (Base),
8422 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
8423 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8428 -- En : constant base'type := base * base;
8433 Temp := Make_Temporary (Loc, 'E', Base);
8436 Make_Expression_With_Actions (Loc,
8437 Actions => New_List (
8438 Make_Object_Declaration (Loc,
8439 Defining_Identifier => Temp,
8440 Constant_Present => True,
8441 Object_Definition => New_Occurrence_Of (Typ, Loc),
8444 Make_Op_Multiply (Loc,
8446 Duplicate_Subexpr (Base),
8448 Duplicate_Subexpr_No_Checks (Base))))),
8452 Make_Op_Multiply (Loc,
8453 Left_Opnd => New_Occurrence_Of (Temp, Loc),
8454 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
8456 -- X ** N = 1.0 / X ** (-N)
8461 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4);
8464 Make_Op_Divide (Loc,
8466 Make_Float_Literal (Loc,
8468 Significand => Uint_1,
8469 Exponent => Uint_0),
8472 Left_Opnd => Duplicate_Subexpr (Base),
8474 Make_Integer_Literal (Loc,
8479 Analyze_And_Resolve (N, Typ);
8484 -- Deal with optimizing 2 ** expression to shift where possible
8486 -- Note: we used to check that Exptyp was an unsigned type. But that is
8487 -- an unnecessary check, since if Exp is negative, we have a run-time
8488 -- error that is either caught (so we get the right result) or we have
8489 -- suppressed the check, in which case the code is erroneous anyway.
8491 if Is_Integer_Type (Rtyp)
8493 -- The base value must be "safe compile-time known", and exactly 2
8495 and then Nkind (Base) = N_Integer_Literal
8496 and then CRT_Safe_Compile_Time_Known_Value (Base)
8497 and then Expr_Value (Base) = Uint_2
8499 -- We only handle cases where the right type is a integer
8501 and then Is_Integer_Type (Root_Type (Exptyp))
8502 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
8504 -- This transformation is not applicable for a modular type with a
8505 -- nonbinary modulus because we do not handle modular reduction in
8506 -- a correct manner if we attempt this transformation in this case.
8508 and then not Non_Binary_Modulus (Typ)
8510 -- Handle the cases where our parent is a division or multiplication
8511 -- specially. In these cases we can convert to using a shift at the
8512 -- parent level if we are not doing overflow checking, since it is
8513 -- too tricky to combine the overflow check at the parent level.
8516 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply)
8519 P : constant Node_Id := Parent (N);
8520 L : constant Node_Id := Left_Opnd (P);
8521 R : constant Node_Id := Right_Opnd (P);
8524 if (Nkind (P) = N_Op_Multiply
8526 ((Is_Integer_Type (Etype (L)) and then R = N)
8528 (Is_Integer_Type (Etype (R)) and then L = N))
8529 and then not Do_Overflow_Check (P))
8532 (Nkind (P) = N_Op_Divide
8533 and then Is_Integer_Type (Etype (L))
8534 and then Is_Unsigned_Type (Etype (L))
8536 and then not Do_Overflow_Check (P))
8538 Set_Is_Power_Of_2_For_Shift (N);
8543 -- Here we just have 2 ** N on its own, so we can convert this to a
8544 -- shift node. We are prepared to deal with overflow here, and we
8545 -- also have to handle proper modular reduction for binary modular.
8554 -- Maximum shift count with no overflow
8557 -- Set True if we must test the shift count
8560 -- Node for test against TestS
8563 -- Compute maximum shift based on the underlying size. For a
8564 -- modular type this is one less than the size.
8566 if Is_Modular_Integer_Type (Typ) then
8568 -- For modular integer types, this is the size of the value
8569 -- being shifted minus one. Any larger values will cause
8570 -- modular reduction to a result of zero. Note that we do
8571 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8572 -- of 6, since 2**7 should be reduced to zero).
8574 MaxS := RM_Size (Rtyp) - 1;
8576 -- For signed integer types, we use the size of the value
8577 -- being shifted minus 2. Larger values cause overflow.
8580 MaxS := Esize (Rtyp) - 2;
8583 -- Determine range to see if it can be larger than MaxS
8586 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
8587 TestS := (not OK) or else Hi > MaxS;
8589 -- Signed integer case
8591 if Is_Signed_Integer_Type (Typ) then
8593 -- Generate overflow check if overflow is active. Note that
8594 -- we can simply ignore the possibility of overflow if the
8595 -- flag is not set (means that overflow cannot happen or
8596 -- that overflow checks are suppressed).
8598 if Ovflo and TestS then
8600 Make_Raise_Constraint_Error (Loc,
8603 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
8604 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
8605 Reason => CE_Overflow_Check_Failed));
8608 -- Now rewrite node as Shift_Left (1, right-operand)
8611 Make_Op_Shift_Left (Loc,
8612 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8613 Right_Opnd => Right_Opnd (N)));
8615 -- Modular integer case
8617 else pragma Assert (Is_Modular_Integer_Type (Typ));
8619 -- If shift count can be greater than MaxS, we need to wrap
8620 -- the shift in a test that will reduce the result value to
8621 -- zero if this shift count is exceeded.
8625 -- Note: build node for the comparison first, before we
8626 -- reuse the Right_Opnd, so that we have proper parents
8627 -- in place for the Duplicate_Subexpr call.
8631 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
8632 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
8635 Make_If_Expression (Loc,
8636 Expressions => New_List (
8638 Make_Integer_Literal (Loc, Uint_0),
8639 Make_Op_Shift_Left (Loc,
8640 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8641 Right_Opnd => Right_Opnd (N)))));
8643 -- If we know shift count cannot be greater than MaxS, then
8644 -- it is safe to just rewrite as a shift with no test.
8648 Make_Op_Shift_Left (Loc,
8649 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8650 Right_Opnd => Right_Opnd (N)));
8654 Analyze_And_Resolve (N, Typ);
8660 -- Fall through if exponentiation must be done using a runtime routine
8662 -- First deal with modular case
8664 if Is_Modular_Integer_Type (Rtyp) then
8666 -- Nonbinary modular case, we call the special exponentiation
8667 -- routine for the nonbinary case, converting the argument to
8668 -- Long_Long_Integer and passing the modulus value. Then the
8669 -- result is converted back to the base type.
8671 if Non_Binary_Modulus (Rtyp) then
8674 Make_Function_Call (Loc,
8676 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
8677 Parameter_Associations => New_List (
8678 Convert_To (RTE (RE_Unsigned), Base),
8679 Make_Integer_Literal (Loc, Modulus (Rtyp)),
8682 -- Binary modular case, in this case, we call one of two routines,
8683 -- either the unsigned integer case, or the unsigned long long
8684 -- integer case, with a final "and" operation to do the required mod.
8687 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
8688 Ent := RTE (RE_Exp_Unsigned);
8690 Ent := RTE (RE_Exp_Long_Long_Unsigned);
8697 Make_Function_Call (Loc,
8698 Name => New_Occurrence_Of (Ent, Loc),
8699 Parameter_Associations => New_List (
8700 Convert_To (Etype (First_Formal (Ent)), Base),
8703 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
8707 -- Common exit point for modular type case
8709 Analyze_And_Resolve (N, Typ);
8712 -- Signed integer cases, done using either Integer or Long_Long_Integer.
8713 -- It is not worth having routines for Short_[Short_]Integer, since for
8714 -- most machines it would not help, and it would generate more code that
8715 -- might need certification when a certified run time is required.
8717 -- In the integer cases, we have two routines, one for when overflow
8718 -- checks are required, and one when they are not required, since there
8719 -- is a real gain in omitting checks on many machines.
8721 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
8722 or else (Rtyp = Base_Type (Standard_Long_Integer)
8724 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
8725 or else Rtyp = Universal_Integer
8727 Etyp := Standard_Long_Long_Integer;
8730 Rent := RE_Exp_Long_Long_Integer;
8732 Rent := RE_Exn_Long_Long_Integer;
8735 elsif Is_Signed_Integer_Type (Rtyp) then
8736 Etyp := Standard_Integer;
8739 Rent := RE_Exp_Integer;
8741 Rent := RE_Exn_Integer;
8744 -- Floating-point cases. We do not need separate routines for the
8745 -- overflow case here, since in the case of floating-point, we generate
8746 -- infinities anyway as a rule (either that or we automatically trap
8747 -- overflow), and if there is an infinity generated and a range check
8748 -- is required, the check will fail anyway.
8750 -- Historical note: we used to convert everything to Long_Long_Float
8751 -- and call a single common routine, but this had the undesirable effect
8752 -- of giving different results for small static exponent values and the
8753 -- same dynamic values.
8756 pragma Assert (Is_Floating_Point_Type (Rtyp));
8758 if Rtyp = Standard_Float then
8759 Etyp := Standard_Float;
8760 Rent := RE_Exn_Float;
8762 elsif Rtyp = Standard_Long_Float then
8763 Etyp := Standard_Long_Float;
8764 Rent := RE_Exn_Long_Float;
8767 Etyp := Standard_Long_Long_Float;
8768 Rent := RE_Exn_Long_Long_Float;
8772 -- Common processing for integer cases and floating-point cases.
8773 -- If we are in the right type, we can call runtime routine directly
8776 and then Rtyp /= Universal_Integer
8777 and then Rtyp /= Universal_Real
8781 Make_Function_Call (Loc,
8782 Name => New_Occurrence_Of (RTE (Rent), Loc),
8783 Parameter_Associations => New_List (Base, Exp))));
8785 -- Otherwise we have to introduce conversions (conversions are also
8786 -- required in the universal cases, since the runtime routine is
8787 -- typed using one of the standard types).
8792 Make_Function_Call (Loc,
8793 Name => New_Occurrence_Of (RTE (Rent), Loc),
8794 Parameter_Associations => New_List (
8795 Convert_To (Etyp, Base),
8799 Analyze_And_Resolve (N, Typ);
8803 when RE_Not_Available =>
8805 end Expand_N_Op_Expon;
8807 --------------------
8808 -- Expand_N_Op_Ge --
8809 --------------------
8811 procedure Expand_N_Op_Ge (N : Node_Id) is
8812 Typ : constant Entity_Id := Etype (N);
8813 Op1 : constant Node_Id := Left_Opnd (N);
8814 Op2 : constant Node_Id := Right_Opnd (N);
8815 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8818 Binary_Op_Validity_Checks (N);
8820 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8821 -- means we no longer have a comparison operation, we are all done.
8823 Expand_Compare_Minimize_Eliminate_Overflow (N);
8825 if Nkind (N) /= N_Op_Ge then
8831 if Is_Array_Type (Typ1) then
8832 Expand_Array_Comparison (N);
8836 -- Deal with boolean operands
8838 if Is_Boolean_Type (Typ1) then
8839 Adjust_Condition (Op1);
8840 Adjust_Condition (Op2);
8841 Set_Etype (N, Standard_Boolean);
8842 Adjust_Result_Type (N, Typ);
8845 Rewrite_Comparison (N);
8847 Optimize_Length_Comparison (N);
8850 --------------------
8851 -- Expand_N_Op_Gt --
8852 --------------------
8854 procedure Expand_N_Op_Gt (N : Node_Id) is
8855 Typ : constant Entity_Id := Etype (N);
8856 Op1 : constant Node_Id := Left_Opnd (N);
8857 Op2 : constant Node_Id := Right_Opnd (N);
8858 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8861 Binary_Op_Validity_Checks (N);
8863 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8864 -- means we no longer have a comparison operation, we are all done.
8866 Expand_Compare_Minimize_Eliminate_Overflow (N);
8868 if Nkind (N) /= N_Op_Gt then
8872 -- Deal with array type operands
8874 if Is_Array_Type (Typ1) then
8875 Expand_Array_Comparison (N);
8879 -- Deal with boolean type operands
8881 if Is_Boolean_Type (Typ1) then
8882 Adjust_Condition (Op1);
8883 Adjust_Condition (Op2);
8884 Set_Etype (N, Standard_Boolean);
8885 Adjust_Result_Type (N, Typ);
8888 Rewrite_Comparison (N);
8890 Optimize_Length_Comparison (N);
8893 --------------------
8894 -- Expand_N_Op_Le --
8895 --------------------
8897 procedure Expand_N_Op_Le (N : Node_Id) is
8898 Typ : constant Entity_Id := Etype (N);
8899 Op1 : constant Node_Id := Left_Opnd (N);
8900 Op2 : constant Node_Id := Right_Opnd (N);
8901 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8904 Binary_Op_Validity_Checks (N);
8906 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8907 -- means we no longer have a comparison operation, we are all done.
8909 Expand_Compare_Minimize_Eliminate_Overflow (N);
8911 if Nkind (N) /= N_Op_Le then
8915 -- Deal with array type operands
8917 if Is_Array_Type (Typ1) then
8918 Expand_Array_Comparison (N);
8922 -- Deal with Boolean type operands
8924 if Is_Boolean_Type (Typ1) then
8925 Adjust_Condition (Op1);
8926 Adjust_Condition (Op2);
8927 Set_Etype (N, Standard_Boolean);
8928 Adjust_Result_Type (N, Typ);
8931 Rewrite_Comparison (N);
8933 Optimize_Length_Comparison (N);
8936 --------------------
8937 -- Expand_N_Op_Lt --
8938 --------------------
8940 procedure Expand_N_Op_Lt (N : Node_Id) is
8941 Typ : constant Entity_Id := Etype (N);
8942 Op1 : constant Node_Id := Left_Opnd (N);
8943 Op2 : constant Node_Id := Right_Opnd (N);
8944 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8947 Binary_Op_Validity_Checks (N);
8949 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8950 -- means we no longer have a comparison operation, we are all done.
8952 Expand_Compare_Minimize_Eliminate_Overflow (N);
8954 if Nkind (N) /= N_Op_Lt then
8958 -- Deal with array type operands
8960 if Is_Array_Type (Typ1) then
8961 Expand_Array_Comparison (N);
8965 -- Deal with Boolean type operands
8967 if Is_Boolean_Type (Typ1) then
8968 Adjust_Condition (Op1);
8969 Adjust_Condition (Op2);
8970 Set_Etype (N, Standard_Boolean);
8971 Adjust_Result_Type (N, Typ);
8974 Rewrite_Comparison (N);
8976 Optimize_Length_Comparison (N);
8979 -----------------------
8980 -- Expand_N_Op_Minus --
8981 -----------------------
8983 procedure Expand_N_Op_Minus (N : Node_Id) is
8984 Loc : constant Source_Ptr := Sloc (N);
8985 Typ : constant Entity_Id := Etype (N);
8988 Unary_Op_Validity_Checks (N);
8990 -- Check for MINIMIZED/ELIMINATED overflow mode
8992 if Minimized_Eliminated_Overflow_Check (N) then
8993 Apply_Arithmetic_Overflow_Check (N);
8997 if not Backend_Overflow_Checks_On_Target
8998 and then Is_Signed_Integer_Type (Etype (N))
8999 and then Do_Overflow_Check (N)
9001 -- Software overflow checking expands -expr into (0 - expr)
9004 Make_Op_Subtract (Loc,
9005 Left_Opnd => Make_Integer_Literal (Loc, 0),
9006 Right_Opnd => Right_Opnd (N)));
9008 Analyze_And_Resolve (N, Typ);
9011 Expand_Nonbinary_Modular_Op (N);
9012 end Expand_N_Op_Minus;
9014 ---------------------
9015 -- Expand_N_Op_Mod --
9016 ---------------------
9018 procedure Expand_N_Op_Mod (N : Node_Id) is
9019 Loc : constant Source_Ptr := Sloc (N);
9020 Typ : constant Entity_Id := Etype (N);
9021 DDC : constant Boolean := Do_Division_Check (N);
9034 pragma Warnings (Off, Lhi);
9037 Binary_Op_Validity_Checks (N);
9039 -- Check for MINIMIZED/ELIMINATED overflow mode
9041 if Minimized_Eliminated_Overflow_Check (N) then
9042 Apply_Arithmetic_Overflow_Check (N);
9046 if Is_Integer_Type (Etype (N)) then
9047 Apply_Divide_Checks (N);
9049 -- All done if we don't have a MOD any more, which can happen as a
9050 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9052 if Nkind (N) /= N_Op_Mod then
9057 -- Proceed with expansion of mod operator
9059 Left := Left_Opnd (N);
9060 Right := Right_Opnd (N);
9062 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
9063 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
9065 -- Convert mod to rem if operands are both known to be non-negative, or
9066 -- both known to be non-positive (these are the cases in which rem and
9067 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9068 -- likely that this will improve the quality of code, (the operation now
9069 -- corresponds to the hardware remainder), and it does not seem likely
9070 -- that it could be harmful. It also avoids some cases of the elaborate
9071 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9074 and then ((Llo >= 0 and then Rlo >= 0)
9076 (Lhi <= 0 and then Rhi <= 0))
9079 Make_Op_Rem (Sloc (N),
9080 Left_Opnd => Left_Opnd (N),
9081 Right_Opnd => Right_Opnd (N)));
9083 -- Instead of reanalyzing the node we do the analysis manually. This
9084 -- avoids anomalies when the replacement is done in an instance and
9085 -- is epsilon more efficient.
9087 Set_Entity (N, Standard_Entity (S_Op_Rem));
9089 Set_Do_Division_Check (N, DDC);
9090 Expand_N_Op_Rem (N);
9094 -- Otherwise, normal mod processing
9097 -- Apply optimization x mod 1 = 0. We don't really need that with
9098 -- gcc, but it is useful with other back ends and is certainly
9101 if Is_Integer_Type (Etype (N))
9102 and then Compile_Time_Known_Value (Right)
9103 and then Expr_Value (Right) = Uint_1
9105 -- Call Remove_Side_Effects to ensure that any side effects in
9106 -- the ignored left operand (in particular function calls to
9107 -- user defined functions) are properly executed.
9109 Remove_Side_Effects (Left);
9111 Rewrite (N, Make_Integer_Literal (Loc, 0));
9112 Analyze_And_Resolve (N, Typ);
9116 -- If we still have a mod operator and we are in Modify_Tree_For_C
9117 -- mode, and we have a signed integer type, then here is where we do
9118 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9119 -- for the special handling of the annoying case of largest negative
9120 -- number mod minus one.
9122 if Nkind (N) = N_Op_Mod
9123 and then Is_Signed_Integer_Type (Typ)
9124 and then Modify_Tree_For_C
9126 -- In the general case, we expand A mod B as
9128 -- Tnn : constant typ := A rem B;
9130 -- (if (A >= 0) = (B >= 0) then Tnn
9131 -- elsif Tnn = 0 then 0
9134 -- The comparison can be written simply as A >= 0 if we know that
9135 -- B >= 0 which is a very common case.
9137 -- An important optimization is when B is known at compile time
9138 -- to be 2**K for some constant. In this case we can simply AND
9139 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9140 -- and that works for both the positive and negative cases.
9143 P2 : constant Nat := Power_Of_Two (Right);
9148 Unchecked_Convert_To (Typ,
9151 Unchecked_Convert_To
9152 (Corresponding_Unsigned_Type (Typ), Left),
9154 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
9155 Analyze_And_Resolve (N, Typ);
9160 -- Here for the full rewrite
9163 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
9169 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9170 Right_Opnd => Make_Integer_Literal (Loc, 0));
9172 if not LOK or else Rlo < 0 then
9178 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
9179 Right_Opnd => Make_Integer_Literal (Loc, 0)));
9183 Make_Object_Declaration (Loc,
9184 Defining_Identifier => Tnn,
9185 Constant_Present => True,
9186 Object_Definition => New_Occurrence_Of (Typ, Loc),
9190 Right_Opnd => Right)));
9193 Make_If_Expression (Loc,
9194 Expressions => New_List (
9196 New_Occurrence_Of (Tnn, Loc),
9197 Make_If_Expression (Loc,
9199 Expressions => New_List (
9201 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9202 Right_Opnd => Make_Integer_Literal (Loc, 0)),
9203 Make_Integer_Literal (Loc, 0),
9205 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9207 Duplicate_Subexpr_No_Checks (Right)))))));
9209 Analyze_And_Resolve (N, Typ);
9214 -- Deal with annoying case of largest negative number mod minus one.
9215 -- Gigi may not handle this case correctly, because on some targets,
9216 -- the mod value is computed using a divide instruction which gives
9217 -- an overflow trap for this case.
9219 -- It would be a bit more efficient to figure out which targets
9220 -- this is really needed for, but in practice it is reasonable
9221 -- to do the following special check in all cases, since it means
9222 -- we get a clearer message, and also the overhead is minimal given
9223 -- that division is expensive in any case.
9225 -- In fact the check is quite easy, if the right operand is -1, then
9226 -- the mod value is always 0, and we can just ignore the left operand
9227 -- completely in this case.
9229 -- This only applies if we still have a mod operator. Skip if we
9230 -- have already rewritten this (e.g. in the case of eliminated
9231 -- overflow checks which have driven us into bignum mode).
9233 if Nkind (N) = N_Op_Mod then
9235 -- The operand type may be private (e.g. in the expansion of an
9236 -- intrinsic operation) so we must use the underlying type to get
9237 -- the bounds, and convert the literals explicitly.
9241 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
9243 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
9244 and then ((not LOK) or else (Llo = LLB))
9247 Make_If_Expression (Loc,
9248 Expressions => New_List (
9250 Left_Opnd => Duplicate_Subexpr (Right),
9252 Unchecked_Convert_To (Typ,
9253 Make_Integer_Literal (Loc, -1))),
9254 Unchecked_Convert_To (Typ,
9255 Make_Integer_Literal (Loc, Uint_0)),
9256 Relocate_Node (N))));
9258 Set_Analyzed (Next (Next (First (Expressions (N)))));
9259 Analyze_And_Resolve (N, Typ);
9263 end Expand_N_Op_Mod;
9265 --------------------------
9266 -- Expand_N_Op_Multiply --
9267 --------------------------
9269 procedure Expand_N_Op_Multiply (N : Node_Id) is
9270 Loc : constant Source_Ptr := Sloc (N);
9271 Lop : constant Node_Id := Left_Opnd (N);
9272 Rop : constant Node_Id := Right_Opnd (N);
9274 Lp2 : constant Boolean :=
9275 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
9276 Rp2 : constant Boolean :=
9277 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
9279 Ltyp : constant Entity_Id := Etype (Lop);
9280 Rtyp : constant Entity_Id := Etype (Rop);
9281 Typ : Entity_Id := Etype (N);
9284 Binary_Op_Validity_Checks (N);
9286 -- Check for MINIMIZED/ELIMINATED overflow mode
9288 if Minimized_Eliminated_Overflow_Check (N) then
9289 Apply_Arithmetic_Overflow_Check (N);
9293 -- Special optimizations for integer types
9295 if Is_Integer_Type (Typ) then
9297 -- N * 0 = 0 for integer types
9299 if Compile_Time_Known_Value (Rop)
9300 and then Expr_Value (Rop) = Uint_0
9302 -- Call Remove_Side_Effects to ensure that any side effects in
9303 -- the ignored left operand (in particular function calls to
9304 -- user defined functions) are properly executed.
9306 Remove_Side_Effects (Lop);
9308 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9309 Analyze_And_Resolve (N, Typ);
9313 -- Similar handling for 0 * N = 0
9315 if Compile_Time_Known_Value (Lop)
9316 and then Expr_Value (Lop) = Uint_0
9318 Remove_Side_Effects (Rop);
9319 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9320 Analyze_And_Resolve (N, Typ);
9324 -- N * 1 = 1 * N = N for integer types
9326 -- This optimisation is not done if we are going to
9327 -- rewrite the product 1 * 2 ** N to a shift.
9329 if Compile_Time_Known_Value (Rop)
9330 and then Expr_Value (Rop) = Uint_1
9336 elsif Compile_Time_Known_Value (Lop)
9337 and then Expr_Value (Lop) = Uint_1
9345 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9346 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9347 -- operand is an integer, as required for this to work.
9352 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9356 Left_Opnd => Make_Integer_Literal (Loc, 2),
9359 Left_Opnd => Right_Opnd (Lop),
9360 Right_Opnd => Right_Opnd (Rop))));
9361 Analyze_And_Resolve (N, Typ);
9365 -- If the result is modular, perform the reduction of the result
9368 if Is_Modular_Integer_Type (Typ)
9369 and then not Non_Binary_Modulus (Typ)
9374 Make_Op_Shift_Left (Loc,
9377 Convert_To (Standard_Natural, Right_Opnd (Rop))),
9379 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9383 Make_Op_Shift_Left (Loc,
9386 Convert_To (Standard_Natural, Right_Opnd (Rop))));
9389 Analyze_And_Resolve (N, Typ);
9393 -- Same processing for the operands the other way round
9396 if Is_Modular_Integer_Type (Typ)
9397 and then not Non_Binary_Modulus (Typ)
9402 Make_Op_Shift_Left (Loc,
9405 Convert_To (Standard_Natural, Right_Opnd (Lop))),
9407 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9411 Make_Op_Shift_Left (Loc,
9414 Convert_To (Standard_Natural, Right_Opnd (Lop))));
9417 Analyze_And_Resolve (N, Typ);
9421 -- Do required fixup of universal fixed operation
9423 if Typ = Universal_Fixed then
9424 Fixup_Universal_Fixed_Operation (N);
9428 -- Multiplications with fixed-point results
9430 if Is_Fixed_Point_Type (Typ) then
9432 -- No special processing if Treat_Fixed_As_Integer is set, since from
9433 -- a semantic point of view such operations are simply integer
9434 -- operations and will be treated that way.
9436 if not Treat_Fixed_As_Integer (N) then
9438 -- Case of fixed * integer => fixed
9440 if Is_Integer_Type (Rtyp) then
9441 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
9443 -- Case of integer * fixed => fixed
9445 elsif Is_Integer_Type (Ltyp) then
9446 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
9448 -- Case of fixed * fixed => fixed
9451 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
9455 -- Other cases of multiplication of fixed-point operands. Again we
9456 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
9458 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
9459 and then not Treat_Fixed_As_Integer (N)
9461 if Is_Integer_Type (Typ) then
9462 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
9464 pragma Assert (Is_Floating_Point_Type (Typ));
9465 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
9468 -- Mixed-mode operations can appear in a non-static universal context,
9469 -- in which case the integer argument must be converted explicitly.
9471 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
9472 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
9473 Analyze_And_Resolve (Rop, Universal_Real);
9475 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
9476 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
9477 Analyze_And_Resolve (Lop, Universal_Real);
9479 -- Non-fixed point cases, check software overflow checking required
9481 elsif Is_Signed_Integer_Type (Etype (N)) then
9482 Apply_Arithmetic_Overflow_Check (N);
9485 -- Overflow checks for floating-point if -gnateF mode active
9487 Check_Float_Op_Overflow (N);
9489 Expand_Nonbinary_Modular_Op (N);
9490 end Expand_N_Op_Multiply;
9492 --------------------
9493 -- Expand_N_Op_Ne --
9494 --------------------
9496 procedure Expand_N_Op_Ne (N : Node_Id) is
9497 Typ : constant Entity_Id := Etype (Left_Opnd (N));
9500 -- Case of elementary type with standard operator
9502 if Is_Elementary_Type (Typ)
9503 and then Sloc (Entity (N)) = Standard_Location
9505 Binary_Op_Validity_Checks (N);
9507 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9508 -- means we no longer have a /= operation, we are all done.
9510 Expand_Compare_Minimize_Eliminate_Overflow (N);
9512 if Nkind (N) /= N_Op_Ne then
9516 -- Boolean types (requiring handling of non-standard case)
9518 if Is_Boolean_Type (Typ) then
9519 Adjust_Condition (Left_Opnd (N));
9520 Adjust_Condition (Right_Opnd (N));
9521 Set_Etype (N, Standard_Boolean);
9522 Adjust_Result_Type (N, Typ);
9525 Rewrite_Comparison (N);
9527 -- For all cases other than elementary types, we rewrite node as the
9528 -- negation of an equality operation, and reanalyze. The equality to be
9529 -- used is defined in the same scope and has the same signature. This
9530 -- signature must be set explicitly since in an instance it may not have
9531 -- the same visibility as in the generic unit. This avoids duplicating
9532 -- or factoring the complex code for record/array equality tests etc.
9534 -- This case is also used for the minimal expansion performed in
9539 Loc : constant Source_Ptr := Sloc (N);
9541 Ne : constant Entity_Id := Entity (N);
9544 Binary_Op_Validity_Checks (N);
9550 Left_Opnd => Left_Opnd (N),
9551 Right_Opnd => Right_Opnd (N)));
9553 -- The level of parentheses is useless in GNATprove mode, and
9554 -- bumping its level here leads to wrong columns being used in
9555 -- check messages, hence skip it in this mode.
9557 if not GNATprove_Mode then
9558 Set_Paren_Count (Right_Opnd (Neg), 1);
9561 if Scope (Ne) /= Standard_Standard then
9562 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
9565 -- For navigation purposes, we want to treat the inequality as an
9566 -- implicit reference to the corresponding equality. Preserve the
9567 -- Comes_From_ source flag to generate proper Xref entries.
9569 Preserve_Comes_From_Source (Neg, N);
9570 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
9572 Analyze_And_Resolve (N, Standard_Boolean);
9576 -- No need for optimization in GNATprove mode, where we would rather see
9577 -- the original source expression.
9579 if not GNATprove_Mode then
9580 Optimize_Length_Comparison (N);
9584 ---------------------
9585 -- Expand_N_Op_Not --
9586 ---------------------
9588 -- If the argument is other than a Boolean array type, there is no special
9589 -- expansion required, except for dealing with validity checks, and non-
9590 -- standard boolean representations.
9592 -- For the packed array case, we call the special routine in Exp_Pakd,
9593 -- except that if the component size is greater than one, we use the
9594 -- standard routine generating a gruesome loop (it is so peculiar to have
9595 -- packed arrays with non-standard Boolean representations anyway, so it
9596 -- does not matter that we do not handle this case efficiently).
9598 -- For the unpacked array case (and for the special packed case where we
9599 -- have non standard Booleans, as discussed above), we generate and insert
9600 -- into the tree the following function definition:
9602 -- function Nnnn (A : arr) is
9605 -- for J in a'range loop
9606 -- B (J) := not A (J);
9611 -- Here arr is the actual subtype of the parameter (and hence always
9612 -- constrained). Then we replace the not with a call to this function.
9614 procedure Expand_N_Op_Not (N : Node_Id) is
9615 Loc : constant Source_Ptr := Sloc (N);
9616 Typ : constant Entity_Id := Etype (N);
9625 Func_Name : Entity_Id;
9626 Loop_Statement : Node_Id;
9629 Unary_Op_Validity_Checks (N);
9631 -- For boolean operand, deal with non-standard booleans
9633 if Is_Boolean_Type (Typ) then
9634 Adjust_Condition (Right_Opnd (N));
9635 Set_Etype (N, Standard_Boolean);
9636 Adjust_Result_Type (N, Typ);
9640 -- Only array types need any other processing
9642 if not Is_Array_Type (Typ) then
9646 -- Case of array operand. If bit packed with a component size of 1,
9647 -- handle it in Exp_Pakd if the operand is known to be aligned.
9649 if Is_Bit_Packed_Array (Typ)
9650 and then Component_Size (Typ) = 1
9651 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
9653 Expand_Packed_Not (N);
9657 -- Case of array operand which is not bit-packed. If the context is
9658 -- a safe assignment, call in-place operation, If context is a larger
9659 -- boolean expression in the context of a safe assignment, expansion is
9660 -- done by enclosing operation.
9662 Opnd := Relocate_Node (Right_Opnd (N));
9663 Convert_To_Actual_Subtype (Opnd);
9664 Arr := Etype (Opnd);
9665 Ensure_Defined (Arr, N);
9666 Silly_Boolean_Array_Not_Test (N, Arr);
9668 if Nkind (Parent (N)) = N_Assignment_Statement then
9669 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
9670 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
9673 -- Special case the negation of a binary operation
9675 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
9676 and then Safe_In_Place_Array_Op
9677 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
9679 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
9683 elsif Nkind (Parent (N)) in N_Binary_Op
9684 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
9687 Op1 : constant Node_Id := Left_Opnd (Parent (N));
9688 Op2 : constant Node_Id := Right_Opnd (Parent (N));
9689 Lhs : constant Node_Id := Name (Parent (Parent (N)));
9692 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
9694 -- (not A) op (not B) can be reduced to a single call
9696 if N = Op1 and then Nkind (Op2) = N_Op_Not then
9699 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
9702 -- A xor (not B) can also be special-cased
9704 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
9711 A := Make_Defining_Identifier (Loc, Name_uA);
9712 B := Make_Defining_Identifier (Loc, Name_uB);
9713 J := Make_Defining_Identifier (Loc, Name_uJ);
9716 Make_Indexed_Component (Loc,
9717 Prefix => New_Occurrence_Of (A, Loc),
9718 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9721 Make_Indexed_Component (Loc,
9722 Prefix => New_Occurrence_Of (B, Loc),
9723 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9726 Make_Implicit_Loop_Statement (N,
9727 Identifier => Empty,
9730 Make_Iteration_Scheme (Loc,
9731 Loop_Parameter_Specification =>
9732 Make_Loop_Parameter_Specification (Loc,
9733 Defining_Identifier => J,
9734 Discrete_Subtype_Definition =>
9735 Make_Attribute_Reference (Loc,
9736 Prefix => Make_Identifier (Loc, Chars (A)),
9737 Attribute_Name => Name_Range))),
9739 Statements => New_List (
9740 Make_Assignment_Statement (Loc,
9742 Expression => Make_Op_Not (Loc, A_J))));
9744 Func_Name := Make_Temporary (Loc, 'N');
9745 Set_Is_Inlined (Func_Name);
9748 Make_Subprogram_Body (Loc,
9750 Make_Function_Specification (Loc,
9751 Defining_Unit_Name => Func_Name,
9752 Parameter_Specifications => New_List (
9753 Make_Parameter_Specification (Loc,
9754 Defining_Identifier => A,
9755 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9756 Result_Definition => New_Occurrence_Of (Typ, Loc)),
9758 Declarations => New_List (
9759 Make_Object_Declaration (Loc,
9760 Defining_Identifier => B,
9761 Object_Definition => New_Occurrence_Of (Arr, Loc))),
9763 Handled_Statement_Sequence =>
9764 Make_Handled_Sequence_Of_Statements (Loc,
9765 Statements => New_List (
9767 Make_Simple_Return_Statement (Loc,
9768 Expression => Make_Identifier (Loc, Chars (B)))))));
9771 Make_Function_Call (Loc,
9772 Name => New_Occurrence_Of (Func_Name, Loc),
9773 Parameter_Associations => New_List (Opnd)));
9775 Analyze_And_Resolve (N, Typ);
9776 end Expand_N_Op_Not;
9778 --------------------
9779 -- Expand_N_Op_Or --
9780 --------------------
9782 procedure Expand_N_Op_Or (N : Node_Id) is
9783 Typ : constant Entity_Id := Etype (N);
9786 Binary_Op_Validity_Checks (N);
9788 if Is_Array_Type (Etype (N)) then
9789 Expand_Boolean_Operator (N);
9791 elsif Is_Boolean_Type (Etype (N)) then
9792 Adjust_Condition (Left_Opnd (N));
9793 Adjust_Condition (Right_Opnd (N));
9794 Set_Etype (N, Standard_Boolean);
9795 Adjust_Result_Type (N, Typ);
9797 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9798 Expand_Intrinsic_Call (N, Entity (N));
9801 Expand_Nonbinary_Modular_Op (N);
9804 ----------------------
9805 -- Expand_N_Op_Plus --
9806 ----------------------
9808 procedure Expand_N_Op_Plus (N : Node_Id) is
9810 Unary_Op_Validity_Checks (N);
9812 -- Check for MINIMIZED/ELIMINATED overflow mode
9814 if Minimized_Eliminated_Overflow_Check (N) then
9815 Apply_Arithmetic_Overflow_Check (N);
9818 end Expand_N_Op_Plus;
9820 ---------------------
9821 -- Expand_N_Op_Rem --
9822 ---------------------
9824 procedure Expand_N_Op_Rem (N : Node_Id) is
9825 Loc : constant Source_Ptr := Sloc (N);
9826 Typ : constant Entity_Id := Etype (N);
9837 -- Set if corresponding operand can be negative
9839 pragma Unreferenced (Hi);
9842 Binary_Op_Validity_Checks (N);
9844 -- Check for MINIMIZED/ELIMINATED overflow mode
9846 if Minimized_Eliminated_Overflow_Check (N) then
9847 Apply_Arithmetic_Overflow_Check (N);
9851 if Is_Integer_Type (Etype (N)) then
9852 Apply_Divide_Checks (N);
9854 -- All done if we don't have a REM any more, which can happen as a
9855 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9857 if Nkind (N) /= N_Op_Rem then
9862 -- Proceed with expansion of REM
9864 Left := Left_Opnd (N);
9865 Right := Right_Opnd (N);
9867 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9868 -- but it is useful with other back ends, and is certainly harmless.
9870 if Is_Integer_Type (Etype (N))
9871 and then Compile_Time_Known_Value (Right)
9872 and then Expr_Value (Right) = Uint_1
9874 -- Call Remove_Side_Effects to ensure that any side effects in the
9875 -- ignored left operand (in particular function calls to user defined
9876 -- functions) are properly executed.
9878 Remove_Side_Effects (Left);
9880 Rewrite (N, Make_Integer_Literal (Loc, 0));
9881 Analyze_And_Resolve (N, Typ);
9885 -- Deal with annoying case of largest negative number remainder minus
9886 -- one. Gigi may not handle this case correctly, because on some
9887 -- targets, the mod value is computed using a divide instruction
9888 -- which gives an overflow trap for this case.
9890 -- It would be a bit more efficient to figure out which targets this
9891 -- is really needed for, but in practice it is reasonable to do the
9892 -- following special check in all cases, since it means we get a clearer
9893 -- message, and also the overhead is minimal given that division is
9894 -- expensive in any case.
9896 -- In fact the check is quite easy, if the right operand is -1, then
9897 -- the remainder is always 0, and we can just ignore the left operand
9898 -- completely in this case.
9900 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9901 Lneg := (not OK) or else Lo < 0;
9903 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
9904 Rneg := (not OK) or else Lo < 0;
9906 -- We won't mess with trying to find out if the left operand can really
9907 -- be the largest negative number (that's a pain in the case of private
9908 -- types and this is really marginal). We will just assume that we need
9909 -- the test if the left operand can be negative at all.
9911 if Lneg and Rneg then
9913 Make_If_Expression (Loc,
9914 Expressions => New_List (
9916 Left_Opnd => Duplicate_Subexpr (Right),
9918 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
9920 Unchecked_Convert_To (Typ,
9921 Make_Integer_Literal (Loc, Uint_0)),
9923 Relocate_Node (N))));
9925 Set_Analyzed (Next (Next (First (Expressions (N)))));
9926 Analyze_And_Resolve (N, Typ);
9928 end Expand_N_Op_Rem;
9930 -----------------------------
9931 -- Expand_N_Op_Rotate_Left --
9932 -----------------------------
9934 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
9936 Binary_Op_Validity_Checks (N);
9938 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9939 -- so we rewrite in terms of logical shifts
9941 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9943 -- where Bits is the shift count mod Esize (the mod operation here
9944 -- deals with ludicrous large shift counts, which are apparently OK).
9946 -- What about nonbinary modulus ???
9949 Loc : constant Source_Ptr := Sloc (N);
9950 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
9951 Typ : constant Entity_Id := Etype (N);
9954 if Modify_Tree_For_C then
9955 Rewrite (Right_Opnd (N),
9957 Left_Opnd => Relocate_Node (Right_Opnd (N)),
9958 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
9960 Analyze_And_Resolve (Right_Opnd (N), Rtp);
9965 Make_Op_Shift_Left (Loc,
9966 Left_Opnd => Left_Opnd (N),
9967 Right_Opnd => Right_Opnd (N)),
9970 Make_Op_Shift_Right (Loc,
9971 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9973 Make_Op_Subtract (Loc,
9974 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9976 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9978 Analyze_And_Resolve (N, Typ);
9981 end Expand_N_Op_Rotate_Left;
9983 ------------------------------
9984 -- Expand_N_Op_Rotate_Right --
9985 ------------------------------
9987 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
9989 Binary_Op_Validity_Checks (N);
9991 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9992 -- so we rewrite in terms of logical shifts
9994 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9996 -- where Bits is the shift count mod Esize (the mod operation here
9997 -- deals with ludicrous large shift counts, which are apparently OK).
9999 -- What about nonbinary modulus ???
10002 Loc : constant Source_Ptr := Sloc (N);
10003 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10004 Typ : constant Entity_Id := Etype (N);
10007 Rewrite (Right_Opnd (N),
10009 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10010 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10012 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10014 if Modify_Tree_For_C then
10018 Make_Op_Shift_Right (Loc,
10019 Left_Opnd => Left_Opnd (N),
10020 Right_Opnd => Right_Opnd (N)),
10023 Make_Op_Shift_Left (Loc,
10024 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10026 Make_Op_Subtract (Loc,
10027 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10029 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10031 Analyze_And_Resolve (N, Typ);
10034 end Expand_N_Op_Rotate_Right;
10036 ----------------------------
10037 -- Expand_N_Op_Shift_Left --
10038 ----------------------------
10040 -- Note: nothing in this routine depends on left as opposed to right shifts
10041 -- so we share the routine for expanding shift right operations.
10043 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
10045 Binary_Op_Validity_Checks (N);
10047 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10048 -- operand is not greater than the word size (since that would not
10049 -- be defined properly by the corresponding C shift operator).
10051 if Modify_Tree_For_C then
10053 Right : constant Node_Id := Right_Opnd (N);
10054 Loc : constant Source_Ptr := Sloc (Right);
10055 Typ : constant Entity_Id := Etype (N);
10056 Siz : constant Uint := Esize (Typ);
10063 if Compile_Time_Known_Value (Right) then
10064 if Expr_Value (Right) >= Siz then
10065 Rewrite (N, Make_Integer_Literal (Loc, 0));
10066 Analyze_And_Resolve (N, Typ);
10069 -- Not compile time known, find range
10072 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10074 -- Nothing to do if known to be OK range, otherwise expand
10076 if not OK or else Hi >= Siz then
10078 -- Prevent recursion on copy of shift node
10080 Orig := Relocate_Node (N);
10081 Set_Analyzed (Orig);
10083 -- Now do the rewrite
10086 Make_If_Expression (Loc,
10087 Expressions => New_List (
10089 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
10090 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
10091 Make_Integer_Literal (Loc, 0),
10093 Analyze_And_Resolve (N, Typ);
10098 end Expand_N_Op_Shift_Left;
10100 -----------------------------
10101 -- Expand_N_Op_Shift_Right --
10102 -----------------------------
10104 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
10106 -- Share shift left circuit
10108 Expand_N_Op_Shift_Left (N);
10109 end Expand_N_Op_Shift_Right;
10111 ----------------------------------------
10112 -- Expand_N_Op_Shift_Right_Arithmetic --
10113 ----------------------------------------
10115 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
10117 Binary_Op_Validity_Checks (N);
10119 -- If we are in Modify_Tree_For_C mode, there is no shift right
10120 -- arithmetic in C, so we rewrite in terms of logical shifts.
10122 -- Shift_Right (Num, Bits) or
10124 -- then not (Shift_Right (Mask, bits))
10127 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10129 -- Note: in almost all C compilers it would work to just shift a
10130 -- signed integer right, but it's undefined and we cannot rely on it.
10132 -- Note: the above works fine for shift counts greater than or equal
10133 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10134 -- generates all 1'bits.
10136 -- What about nonbinary modulus ???
10139 Loc : constant Source_Ptr := Sloc (N);
10140 Typ : constant Entity_Id := Etype (N);
10141 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
10142 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
10143 Left : constant Node_Id := Left_Opnd (N);
10144 Right : constant Node_Id := Right_Opnd (N);
10148 if Modify_Tree_For_C then
10150 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10151 -- compile time as a single constant.
10153 if Compile_Time_Known_Value (Right) then
10155 Val : constant Uint := Expr_Value (Right);
10158 if Val >= Esize (Typ) then
10159 Maskx := Make_Integer_Literal (Loc, Mask);
10163 Make_Integer_Literal (Loc,
10164 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
10172 Make_Op_Shift_Right (Loc,
10173 Left_Opnd => Make_Integer_Literal (Loc, Mask),
10174 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
10177 -- Now do the rewrite
10182 Make_Op_Shift_Right (Loc,
10184 Right_Opnd => Right),
10186 Make_If_Expression (Loc,
10187 Expressions => New_List (
10189 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
10190 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
10192 Make_Integer_Literal (Loc, 0)))));
10193 Analyze_And_Resolve (N, Typ);
10196 end Expand_N_Op_Shift_Right_Arithmetic;
10198 --------------------------
10199 -- Expand_N_Op_Subtract --
10200 --------------------------
10202 procedure Expand_N_Op_Subtract (N : Node_Id) is
10203 Typ : constant Entity_Id := Etype (N);
10206 Binary_Op_Validity_Checks (N);
10208 -- Check for MINIMIZED/ELIMINATED overflow mode
10210 if Minimized_Eliminated_Overflow_Check (N) then
10211 Apply_Arithmetic_Overflow_Check (N);
10215 -- N - 0 = N for integer types
10217 if Is_Integer_Type (Typ)
10218 and then Compile_Time_Known_Value (Right_Opnd (N))
10219 and then Expr_Value (Right_Opnd (N)) = 0
10221 Rewrite (N, Left_Opnd (N));
10225 -- Arithmetic overflow checks for signed integer/fixed point types
10227 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
10228 Apply_Arithmetic_Overflow_Check (N);
10231 -- Overflow checks for floating-point if -gnateF mode active
10233 Check_Float_Op_Overflow (N);
10235 Expand_Nonbinary_Modular_Op (N);
10236 end Expand_N_Op_Subtract;
10238 ---------------------
10239 -- Expand_N_Op_Xor --
10240 ---------------------
10242 procedure Expand_N_Op_Xor (N : Node_Id) is
10243 Typ : constant Entity_Id := Etype (N);
10246 Binary_Op_Validity_Checks (N);
10248 if Is_Array_Type (Etype (N)) then
10249 Expand_Boolean_Operator (N);
10251 elsif Is_Boolean_Type (Etype (N)) then
10252 Adjust_Condition (Left_Opnd (N));
10253 Adjust_Condition (Right_Opnd (N));
10254 Set_Etype (N, Standard_Boolean);
10255 Adjust_Result_Type (N, Typ);
10257 elsif Is_Intrinsic_Subprogram (Entity (N)) then
10258 Expand_Intrinsic_Call (N, Entity (N));
10261 Expand_Nonbinary_Modular_Op (N);
10262 end Expand_N_Op_Xor;
10264 ----------------------
10265 -- Expand_N_Or_Else --
10266 ----------------------
10268 procedure Expand_N_Or_Else (N : Node_Id)
10269 renames Expand_Short_Circuit_Operator;
10271 -----------------------------------
10272 -- Expand_N_Qualified_Expression --
10273 -----------------------------------
10275 procedure Expand_N_Qualified_Expression (N : Node_Id) is
10276 Operand : constant Node_Id := Expression (N);
10277 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
10280 -- Do validity check if validity checking operands
10282 if Validity_Checks_On and Validity_Check_Operands then
10283 Ensure_Valid (Operand);
10286 -- Apply possible constraint check
10288 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
10290 if Do_Range_Check (Operand) then
10291 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
10293 end Expand_N_Qualified_Expression;
10295 ------------------------------------
10296 -- Expand_N_Quantified_Expression --
10297 ------------------------------------
10301 -- for all X in range => Cond
10306 -- for X in range loop
10307 -- if not Cond then
10313 -- Similarly, an existentially quantified expression:
10315 -- for some X in range => Cond
10320 -- for X in range loop
10327 -- In both cases, the iteration may be over a container in which case it is
10328 -- given by an iterator specification, not a loop parameter specification.
10330 procedure Expand_N_Quantified_Expression (N : Node_Id) is
10331 Actions : constant List_Id := New_List;
10332 For_All : constant Boolean := All_Present (N);
10333 Iter_Spec : constant Node_Id := Iterator_Specification (N);
10334 Loc : constant Source_Ptr := Sloc (N);
10335 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
10343 -- Ensure that the bound variable is properly frozen. We must do
10344 -- this before expansion because the expression is about to be
10345 -- converted into a loop, and resulting freeze nodes may end up
10346 -- in the wrong place in the tree.
10348 if Present (Iter_Spec) then
10349 Var := Defining_Identifier (Iter_Spec);
10351 Var := Defining_Identifier (Loop_Spec);
10355 P : Node_Id := Parent (N);
10357 while Nkind (P) in N_Subexpr loop
10361 Freeze_Before (P, Etype (Var));
10364 -- Create the declaration of the flag which tracks the status of the
10365 -- quantified expression. Generate:
10367 -- Flag : Boolean := (True | False);
10369 Flag := Make_Temporary (Loc, 'T', N);
10371 Append_To (Actions,
10372 Make_Object_Declaration (Loc,
10373 Defining_Identifier => Flag,
10374 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
10376 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
10378 -- Construct the circuitry which tracks the status of the quantified
10379 -- expression. Generate:
10381 -- if [not] Cond then
10382 -- Flag := (False | True);
10386 Cond := Relocate_Node (Condition (N));
10389 Cond := Make_Op_Not (Loc, Cond);
10392 Stmts := New_List (
10393 Make_Implicit_If_Statement (N,
10395 Then_Statements => New_List (
10396 Make_Assignment_Statement (Loc,
10397 Name => New_Occurrence_Of (Flag, Loc),
10399 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
10400 Make_Exit_Statement (Loc))));
10402 -- Build the loop equivalent of the quantified expression
10404 if Present (Iter_Spec) then
10406 Make_Iteration_Scheme (Loc,
10407 Iterator_Specification => Iter_Spec);
10410 Make_Iteration_Scheme (Loc,
10411 Loop_Parameter_Specification => Loop_Spec);
10414 Append_To (Actions,
10415 Make_Loop_Statement (Loc,
10416 Iteration_Scheme => Scheme,
10417 Statements => Stmts,
10418 End_Label => Empty));
10420 -- Transform the quantified expression
10423 Make_Expression_With_Actions (Loc,
10424 Expression => New_Occurrence_Of (Flag, Loc),
10425 Actions => Actions));
10426 Analyze_And_Resolve (N, Standard_Boolean);
10427 end Expand_N_Quantified_Expression;
10429 ---------------------------------
10430 -- Expand_N_Selected_Component --
10431 ---------------------------------
10433 procedure Expand_N_Selected_Component (N : Node_Id) is
10434 Loc : constant Source_Ptr := Sloc (N);
10435 Par : constant Node_Id := Parent (N);
10436 P : constant Node_Id := Prefix (N);
10437 S : constant Node_Id := Selector_Name (N);
10438 Ptyp : Entity_Id := Underlying_Type (Etype (P));
10444 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
10445 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10446 -- unless the context of an assignment can provide size information.
10447 -- Don't we have a general routine that does this???
10449 function Is_Subtype_Declaration return Boolean;
10450 -- The replacement of a discriminant reference by its value is required
10451 -- if this is part of the initialization of an temporary generated by a
10452 -- change of representation. This shows up as the construction of a
10453 -- discriminant constraint for a subtype declared at the same point as
10454 -- the entity in the prefix of the selected component. We recognize this
10455 -- case when the context of the reference is:
10456 -- subtype ST is T(Obj.D);
10457 -- where the entity for Obj comes from source, and ST has the same sloc.
10459 -----------------------
10460 -- In_Left_Hand_Side --
10461 -----------------------
10463 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
10465 return (Nkind (Parent (Comp)) = N_Assignment_Statement
10466 and then Comp = Name (Parent (Comp)))
10467 or else (Present (Parent (Comp))
10468 and then Nkind (Parent (Comp)) in N_Subexpr
10469 and then In_Left_Hand_Side (Parent (Comp)));
10470 end In_Left_Hand_Side;
10472 -----------------------------
10473 -- Is_Subtype_Declaration --
10474 -----------------------------
10476 function Is_Subtype_Declaration return Boolean is
10477 Par : constant Node_Id := Parent (N);
10480 Nkind (Par) = N_Index_Or_Discriminant_Constraint
10481 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
10482 and then Comes_From_Source (Entity (Prefix (N)))
10483 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
10484 end Is_Subtype_Declaration;
10486 -- Start of processing for Expand_N_Selected_Component
10489 -- Insert explicit dereference if required
10491 if Is_Access_Type (Ptyp) then
10493 -- First set prefix type to proper access type, in case it currently
10494 -- has a private (non-access) view of this type.
10496 Set_Etype (P, Ptyp);
10498 Insert_Explicit_Dereference (P);
10499 Analyze_And_Resolve (P, Designated_Type (Ptyp));
10504 -- Deal with discriminant check required
10506 if Do_Discriminant_Check (N) then
10507 if Present (Discriminant_Checking_Func
10508 (Original_Record_Component (Entity (S))))
10510 -- Present the discriminant checking function to the backend, so
10511 -- that it can inline the call to the function.
10514 (Discriminant_Checking_Func
10515 (Original_Record_Component (Entity (S))),
10518 -- Now reset the flag and generate the call
10520 Set_Do_Discriminant_Check (N, False);
10521 Generate_Discriminant_Check (N);
10523 -- In the case of Unchecked_Union, no discriminant checking is
10524 -- actually performed.
10527 Set_Do_Discriminant_Check (N, False);
10531 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10532 -- function, then additional actuals must be passed.
10534 if Is_Build_In_Place_Function_Call (P) then
10535 Make_Build_In_Place_Call_In_Anonymous_Context (P);
10537 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10538 -- containing build-in-place function calls whose returned object covers
10539 -- interface types.
10541 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
10542 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
10545 -- Gigi cannot handle unchecked conversions that are the prefix of a
10546 -- selected component with discriminants. This must be checked during
10547 -- expansion, because during analysis the type of the selector is not
10548 -- known at the point the prefix is analyzed. If the conversion is the
10549 -- target of an assignment, then we cannot force the evaluation.
10551 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
10552 and then Has_Discriminants (Etype (N))
10553 and then not In_Left_Hand_Side (N)
10555 Force_Evaluation (Prefix (N));
10558 -- Remaining processing applies only if selector is a discriminant
10560 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
10562 -- If the selector is a discriminant of a constrained record type,
10563 -- we may be able to rewrite the expression with the actual value
10564 -- of the discriminant, a useful optimization in some cases.
10566 if Is_Record_Type (Ptyp)
10567 and then Has_Discriminants (Ptyp)
10568 and then Is_Constrained (Ptyp)
10570 -- Do this optimization for discrete types only, and not for
10571 -- access types (access discriminants get us into trouble).
10573 if not Is_Discrete_Type (Etype (N)) then
10576 -- Don't do this on the left-hand side of an assignment statement.
10577 -- Normally one would think that references like this would not
10578 -- occur, but they do in generated code, and mean that we really
10579 -- do want to assign the discriminant.
10581 elsif Nkind (Par) = N_Assignment_Statement
10582 and then Name (Par) = N
10586 -- Don't do this optimization for the prefix of an attribute or
10587 -- the name of an object renaming declaration since these are
10588 -- contexts where we do not want the value anyway.
10590 elsif (Nkind (Par) = N_Attribute_Reference
10591 and then Prefix (Par) = N)
10592 or else Is_Renamed_Object (N)
10596 -- Don't do this optimization if we are within the code for a
10597 -- discriminant check, since the whole point of such a check may
10598 -- be to verify the condition on which the code below depends.
10600 elsif Is_In_Discriminant_Check (N) then
10603 -- Green light to see if we can do the optimization. There is
10604 -- still one condition that inhibits the optimization below but
10605 -- now is the time to check the particular discriminant.
10608 -- Loop through discriminants to find the matching discriminant
10609 -- constraint to see if we can copy it.
10611 Disc := First_Discriminant (Ptyp);
10612 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
10613 Discr_Loop : while Present (Dcon) loop
10614 Dval := Node (Dcon);
10616 -- Check if this is the matching discriminant and if the
10617 -- discriminant value is simple enough to make sense to
10618 -- copy. We don't want to copy complex expressions, and
10619 -- indeed to do so can cause trouble (before we put in
10620 -- this guard, a discriminant expression containing an
10621 -- AND THEN was copied, causing problems for coverage
10622 -- analysis tools).
10624 -- However, if the reference is part of the initialization
10625 -- code generated for an object declaration, we must use
10626 -- the discriminant value from the subtype constraint,
10627 -- because the selected component may be a reference to the
10628 -- object being initialized, whose discriminant is not yet
10629 -- set. This only happens in complex cases involving changes
10630 -- or representation.
10632 if Disc = Entity (Selector_Name (N))
10633 and then (Is_Entity_Name (Dval)
10634 or else Compile_Time_Known_Value (Dval)
10635 or else Is_Subtype_Declaration)
10637 -- Here we have the matching discriminant. Check for
10638 -- the case of a discriminant of a component that is
10639 -- constrained by an outer discriminant, which cannot
10640 -- be optimized away.
10642 if Denotes_Discriminant
10643 (Dval, Check_Concurrent => True)
10647 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
10649 Denotes_Discriminant
10650 (Selector_Name (Original_Node (Dval)), True)
10654 -- Do not retrieve value if constraint is not static. It
10655 -- is generally not useful, and the constraint may be a
10656 -- rewritten outer discriminant in which case it is in
10659 elsif Is_Entity_Name (Dval)
10661 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
10662 and then Present (Expression (Parent (Entity (Dval))))
10664 Is_OK_Static_Expression
10665 (Expression (Parent (Entity (Dval))))
10669 -- In the context of a case statement, the expression may
10670 -- have the base type of the discriminant, and we need to
10671 -- preserve the constraint to avoid spurious errors on
10674 elsif Nkind (Parent (N)) = N_Case_Statement
10675 and then Etype (Dval) /= Etype (Disc)
10678 Make_Qualified_Expression (Loc,
10680 New_Occurrence_Of (Etype (Disc), Loc),
10682 New_Copy_Tree (Dval)));
10683 Analyze_And_Resolve (N, Etype (Disc));
10685 -- In case that comes out as a static expression,
10686 -- reset it (a selected component is never static).
10688 Set_Is_Static_Expression (N, False);
10691 -- Otherwise we can just copy the constraint, but the
10692 -- result is certainly not static. In some cases the
10693 -- discriminant constraint has been analyzed in the
10694 -- context of the original subtype indication, but for
10695 -- itypes the constraint might not have been analyzed
10696 -- yet, and this must be done now.
10699 Rewrite (N, New_Copy_Tree (Dval));
10700 Analyze_And_Resolve (N);
10701 Set_Is_Static_Expression (N, False);
10707 Next_Discriminant (Disc);
10708 end loop Discr_Loop;
10710 -- Note: the above loop should always find a matching
10711 -- discriminant, but if it does not, we just missed an
10712 -- optimization due to some glitch (perhaps a previous
10713 -- error), so ignore.
10718 -- The only remaining processing is in the case of a discriminant of
10719 -- a concurrent object, where we rewrite the prefix to denote the
10720 -- corresponding record type. If the type is derived and has renamed
10721 -- discriminants, use corresponding discriminant, which is the one
10722 -- that appears in the corresponding record.
10724 if not Is_Concurrent_Type (Ptyp) then
10728 Disc := Entity (Selector_Name (N));
10730 if Is_Derived_Type (Ptyp)
10731 and then Present (Corresponding_Discriminant (Disc))
10733 Disc := Corresponding_Discriminant (Disc);
10737 Make_Selected_Component (Loc,
10739 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
10740 New_Copy_Tree (P)),
10741 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
10743 Rewrite (N, New_N);
10747 -- Set Atomic_Sync_Required if necessary for atomic component
10749 if Nkind (N) = N_Selected_Component then
10751 E : constant Entity_Id := Entity (Selector_Name (N));
10755 -- If component is atomic, but type is not, setting depends on
10756 -- disable/enable state for the component.
10758 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
10759 Set := not Atomic_Synchronization_Disabled (E);
10761 -- If component is not atomic, but its type is atomic, setting
10762 -- depends on disable/enable state for the type.
10764 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10765 Set := not Atomic_Synchronization_Disabled (Etype (E));
10767 -- If both component and type are atomic, we disable if either
10768 -- component or its type have sync disabled.
10770 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10771 Set := (not Atomic_Synchronization_Disabled (E))
10773 (not Atomic_Synchronization_Disabled (Etype (E)));
10779 -- Set flag if required
10782 Activate_Atomic_Synchronization (N);
10786 end Expand_N_Selected_Component;
10788 --------------------
10789 -- Expand_N_Slice --
10790 --------------------
10792 procedure Expand_N_Slice (N : Node_Id) is
10793 Loc : constant Source_Ptr := Sloc (N);
10794 Typ : constant Entity_Id := Etype (N);
10796 function Is_Procedure_Actual (N : Node_Id) return Boolean;
10797 -- Check whether the argument is an actual for a procedure call, in
10798 -- which case the expansion of a bit-packed slice is deferred until the
10799 -- call itself is expanded. The reason this is required is that we might
10800 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10801 -- that copy out would be missed if we created a temporary here in
10802 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10803 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10804 -- is harmless to defer expansion in the IN case, since the call
10805 -- processing will still generate the appropriate copy in operation,
10806 -- which will take care of the slice.
10808 procedure Make_Temporary_For_Slice;
10809 -- Create a named variable for the value of the slice, in cases where
10810 -- the back end cannot handle it properly, e.g. when packed types or
10811 -- unaligned slices are involved.
10813 -------------------------
10814 -- Is_Procedure_Actual --
10815 -------------------------
10817 function Is_Procedure_Actual (N : Node_Id) return Boolean is
10818 Par : Node_Id := Parent (N);
10822 -- If our parent is a procedure call we can return
10824 if Nkind (Par) = N_Procedure_Call_Statement then
10827 -- If our parent is a type conversion, keep climbing the tree,
10828 -- since a type conversion can be a procedure actual. Also keep
10829 -- climbing if parameter association or a qualified expression,
10830 -- since these are additional cases that do can appear on
10831 -- procedure actuals.
10833 elsif Nkind_In (Par, N_Type_Conversion,
10834 N_Parameter_Association,
10835 N_Qualified_Expression)
10837 Par := Parent (Par);
10839 -- Any other case is not what we are looking for
10845 end Is_Procedure_Actual;
10847 ------------------------------
10848 -- Make_Temporary_For_Slice --
10849 ------------------------------
10851 procedure Make_Temporary_For_Slice is
10852 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
10857 Make_Object_Declaration (Loc,
10858 Defining_Identifier => Ent,
10859 Object_Definition => New_Occurrence_Of (Typ, Loc));
10861 Set_No_Initialization (Decl);
10863 Insert_Actions (N, New_List (
10865 Make_Assignment_Statement (Loc,
10866 Name => New_Occurrence_Of (Ent, Loc),
10867 Expression => Relocate_Node (N))));
10869 Rewrite (N, New_Occurrence_Of (Ent, Loc));
10870 Analyze_And_Resolve (N, Typ);
10871 end Make_Temporary_For_Slice;
10875 Pref : constant Node_Id := Prefix (N);
10876 Pref_Typ : Entity_Id := Etype (Pref);
10878 -- Start of processing for Expand_N_Slice
10881 -- Special handling for access types
10883 if Is_Access_Type (Pref_Typ) then
10884 Pref_Typ := Designated_Type (Pref_Typ);
10887 Make_Explicit_Dereference (Sloc (N),
10888 Prefix => Relocate_Node (Pref)));
10890 Analyze_And_Resolve (Pref, Pref_Typ);
10893 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10894 -- function, then additional actuals must be passed.
10896 if Is_Build_In_Place_Function_Call (Pref) then
10897 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
10899 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10900 -- containing build-in-place function calls whose returned object covers
10901 -- interface types.
10903 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
10904 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
10907 -- The remaining case to be handled is packed slices. We can leave
10908 -- packed slices as they are in the following situations:
10910 -- 1. Right or left side of an assignment (we can handle this
10911 -- situation correctly in the assignment statement expansion).
10913 -- 2. Prefix of indexed component (the slide is optimized away in this
10914 -- case, see the start of Expand_N_Slice.)
10916 -- 3. Object renaming declaration, since we want the name of the
10917 -- slice, not the value.
10919 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10920 -- be required, and this is handled in the expansion of call
10923 -- 5. Prefix of an address attribute (this is an error which is caught
10924 -- elsewhere, and the expansion would interfere with generating the
10927 if not Is_Packed (Typ) then
10929 -- Apply transformation for actuals of a function call, where
10930 -- Expand_Actuals is not used.
10932 if Nkind (Parent (N)) = N_Function_Call
10933 and then Is_Possibly_Unaligned_Slice (N)
10935 Make_Temporary_For_Slice;
10938 elsif Nkind (Parent (N)) = N_Assignment_Statement
10939 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
10940 and then Parent (N) = Name (Parent (Parent (N))))
10944 elsif Nkind (Parent (N)) = N_Indexed_Component
10945 or else Is_Renamed_Object (N)
10946 or else Is_Procedure_Actual (N)
10950 elsif Nkind (Parent (N)) = N_Attribute_Reference
10951 and then Attribute_Name (Parent (N)) = Name_Address
10956 Make_Temporary_For_Slice;
10958 end Expand_N_Slice;
10960 ------------------------------
10961 -- Expand_N_Type_Conversion --
10962 ------------------------------
10964 procedure Expand_N_Type_Conversion (N : Node_Id) is
10965 Loc : constant Source_Ptr := Sloc (N);
10966 Operand : constant Node_Id := Expression (N);
10967 Target_Type : Entity_Id := Etype (N);
10968 Operand_Type : Entity_Id := Etype (Operand);
10970 procedure Discrete_Range_Check;
10971 -- Handles generation of range check for discrete target value
10973 procedure Handle_Changed_Representation;
10974 -- This is called in the case of record and array type conversions to
10975 -- see if there is a change of representation to be handled. Change of
10976 -- representation is actually handled at the assignment statement level,
10977 -- and what this procedure does is rewrite node N conversion as an
10978 -- assignment to temporary. If there is no change of representation,
10979 -- then the conversion node is unchanged.
10981 procedure Raise_Accessibility_Error;
10982 -- Called when we know that an accessibility check will fail. Rewrites
10983 -- node N to an appropriate raise statement and outputs warning msgs.
10984 -- The Etype of the raise node is set to Target_Type. Note that in this
10985 -- case the rest of the processing should be skipped (i.e. the call to
10986 -- this procedure will be followed by "goto Done").
10988 procedure Real_Range_Check;
10989 -- Handles generation of range check for real target value
10991 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
10992 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10993 -- evaluates to True.
10995 --------------------------
10996 -- Discrete_Range_Check --
10997 --------------------------
10999 -- Case of conversions to a discrete type. We let Generate_Range_Check
11000 -- do the heavy lifting, after converting a fixed-point operand to an
11001 -- appropriate integer type.
11003 procedure Discrete_Range_Check is
11008 -- Nothing to do if conversion was rewritten
11010 if Nkind (N) /= N_Type_Conversion then
11014 Expr := Expression (N);
11016 -- Nothing to do if range checks suppressed
11018 if Range_Checks_Suppressed (Target_Type) then
11022 -- Nothing to do if expression is an entity on which checks have been
11025 if Is_Entity_Name (Expr)
11026 and then Range_Checks_Suppressed (Entity (Expr))
11031 -- Before we do a range check, we have to deal with treating
11032 -- a fixed-point operand as an integer. The way we do this
11033 -- is simply to do an unchecked conversion to an appropriate
11034 -- integer type large enough to hold the result.
11036 if Is_Fixed_Point_Type (Etype (Expr)) then
11037 if Esize (Base_Type (Etype (Expr))) > Esize (Standard_Integer) then
11038 Ityp := Standard_Long_Long_Integer;
11040 Ityp := Standard_Integer;
11043 Set_Do_Range_Check (Expr, False);
11044 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11047 -- Reset overflow flag, since the range check will include
11048 -- dealing with possible overflow, and generate the check.
11050 Set_Do_Overflow_Check (N, False);
11052 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed);
11053 end Discrete_Range_Check;
11055 -----------------------------------
11056 -- Handle_Changed_Representation --
11057 -----------------------------------
11059 procedure Handle_Changed_Representation is
11067 -- Nothing else to do if no change of representation
11069 if Same_Representation (Operand_Type, Target_Type) then
11072 -- The real change of representation work is done by the assignment
11073 -- statement processing. So if this type conversion is appearing as
11074 -- the expression of an assignment statement, nothing needs to be
11075 -- done to the conversion.
11077 elsif Nkind (Parent (N)) = N_Assignment_Statement then
11080 -- Otherwise we need to generate a temporary variable, and do the
11081 -- change of representation assignment into that temporary variable.
11082 -- The conversion is then replaced by a reference to this variable.
11087 -- If type is unconstrained we have to add a constraint, copied
11088 -- from the actual value of the left-hand side.
11090 if not Is_Constrained (Target_Type) then
11091 if Has_Discriminants (Operand_Type) then
11093 -- A change of representation can only apply to untagged
11094 -- types. We need to build the constraint that applies to
11095 -- the target type, using the constraints of the operand.
11096 -- The analysis is complicated if there are both inherited
11097 -- discriminants and constrained discriminants.
11098 -- We iterate over the discriminants of the target, and
11099 -- find the discriminant of the same name:
11101 -- a) If there is a corresponding discriminant in the object
11102 -- then the value is a selected component of the operand.
11104 -- b) Otherwise the value of a constrained discriminant is
11105 -- found in the stored constraint of the operand.
11108 Stored : constant Elist_Id :=
11109 Stored_Constraint (Operand_Type);
11113 Disc_O : Entity_Id;
11114 -- Discriminant of the operand type. Its value in the
11115 -- object is captured in a selected component.
11117 Disc_S : Entity_Id;
11118 -- Stored discriminant of the operand. If present, it
11119 -- corresponds to a constrained discriminant of the
11122 Disc_T : Entity_Id;
11123 -- Discriminant of the target type
11126 Disc_T := First_Discriminant (Target_Type);
11127 Disc_O := First_Discriminant (Operand_Type);
11128 Disc_S := First_Stored_Discriminant (Operand_Type);
11130 if Present (Stored) then
11131 Elmt := First_Elmt (Stored);
11133 Elmt := No_Elmt; -- init to avoid warning
11137 while Present (Disc_T) loop
11138 if Present (Disc_O)
11139 and then Chars (Disc_T) = Chars (Disc_O)
11142 Make_Selected_Component (Loc,
11144 Duplicate_Subexpr_Move_Checks (Operand),
11146 Make_Identifier (Loc, Chars (Disc_O))));
11147 Next_Discriminant (Disc_O);
11149 elsif Present (Disc_S) then
11150 Append_To (Cons, New_Copy_Tree (Node (Elmt)));
11154 Next_Discriminant (Disc_T);
11158 elsif Is_Array_Type (Operand_Type) then
11159 N_Ix := First_Index (Target_Type);
11162 for J in 1 .. Number_Dimensions (Operand_Type) loop
11164 -- We convert the bounds explicitly. We use an unchecked
11165 -- conversion because bounds checks are done elsewhere.
11170 Unchecked_Convert_To (Etype (N_Ix),
11171 Make_Attribute_Reference (Loc,
11173 Duplicate_Subexpr_No_Checks
11174 (Operand, Name_Req => True),
11175 Attribute_Name => Name_First,
11176 Expressions => New_List (
11177 Make_Integer_Literal (Loc, J)))),
11180 Unchecked_Convert_To (Etype (N_Ix),
11181 Make_Attribute_Reference (Loc,
11183 Duplicate_Subexpr_No_Checks
11184 (Operand, Name_Req => True),
11185 Attribute_Name => Name_Last,
11186 Expressions => New_List (
11187 Make_Integer_Literal (Loc, J))))));
11194 Odef := New_Occurrence_Of (Target_Type, Loc);
11196 if Present (Cons) then
11198 Make_Subtype_Indication (Loc,
11199 Subtype_Mark => Odef,
11201 Make_Index_Or_Discriminant_Constraint (Loc,
11202 Constraints => Cons));
11205 Temp := Make_Temporary (Loc, 'C');
11207 Make_Object_Declaration (Loc,
11208 Defining_Identifier => Temp,
11209 Object_Definition => Odef);
11211 Set_No_Initialization (Decl, True);
11213 -- Insert required actions. It is essential to suppress checks
11214 -- since we have suppressed default initialization, which means
11215 -- that the variable we create may have no discriminants.
11220 Make_Assignment_Statement (Loc,
11221 Name => New_Occurrence_Of (Temp, Loc),
11222 Expression => Relocate_Node (N))),
11223 Suppress => All_Checks);
11225 Rewrite (N, New_Occurrence_Of (Temp, Loc));
11228 end Handle_Changed_Representation;
11230 -------------------------------
11231 -- Raise_Accessibility_Error --
11232 -------------------------------
11234 procedure Raise_Accessibility_Error is
11236 Error_Msg_Warn := SPARK_Mode /= On;
11238 Make_Raise_Program_Error (Sloc (N),
11239 Reason => PE_Accessibility_Check_Failed));
11240 Set_Etype (N, Target_Type);
11242 Error_Msg_N ("<<accessibility check failure", N);
11243 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
11244 end Raise_Accessibility_Error;
11246 ----------------------
11247 -- Real_Range_Check --
11248 ----------------------
11250 -- Case of conversions to floating-point or fixed-point. If range checks
11251 -- are enabled and the target type has a range constraint, we convert:
11257 -- Tnn : typ'Base := typ'Base (x);
11258 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11261 -- This is necessary when there is a conversion of integer to float or
11262 -- to fixed-point to ensure that the correct checks are made. It is not
11263 -- necessary for the float-to-float case where it is enough to just set
11264 -- the Do_Range_Check flag on the expression.
11266 procedure Real_Range_Check is
11267 Btyp : constant Entity_Id := Base_Type (Target_Type);
11268 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
11269 Hi : constant Node_Id := Type_High_Bound (Target_Type);
11280 -- Nothing to do if conversion was rewritten
11282 if Nkind (N) /= N_Type_Conversion then
11286 Expr := Expression (N);
11288 -- Clear the flag once for all
11290 Set_Do_Range_Check (Expr, False);
11292 -- Nothing to do if range checks suppressed, or target has the same
11293 -- range as the base type (or is the base type).
11295 if Range_Checks_Suppressed (Target_Type)
11296 or else (Lo = Type_Low_Bound (Btyp)
11298 Hi = Type_High_Bound (Btyp))
11303 -- Nothing to do if expression is an entity on which checks have been
11306 if Is_Entity_Name (Expr)
11307 and then Range_Checks_Suppressed (Entity (Expr))
11312 -- Nothing to do if expression was rewritten into a float-to-float
11313 -- conversion, since this kind of conversions is handled elsewhere.
11315 if Is_Floating_Point_Type (Etype (Expr))
11316 and then Is_Floating_Point_Type (Target_Type)
11321 -- Nothing to do if bounds are all static and we can tell that the
11322 -- expression is within the bounds of the target. Note that if the
11323 -- operand is of an unconstrained floating-point type, then we do
11324 -- not trust it to be in range (might be infinite)
11327 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr));
11328 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr));
11331 if (not Is_Floating_Point_Type (Etype (Expr))
11332 or else Is_Constrained (Etype (Expr)))
11333 and then Compile_Time_Known_Value (S_Lo)
11334 and then Compile_Time_Known_Value (S_Hi)
11335 and then Compile_Time_Known_Value (Hi)
11336 and then Compile_Time_Known_Value (Lo)
11339 D_Lov : constant Ureal := Expr_Value_R (Lo);
11340 D_Hiv : constant Ureal := Expr_Value_R (Hi);
11345 if Is_Real_Type (Etype (Expr)) then
11346 S_Lov := Expr_Value_R (S_Lo);
11347 S_Hiv := Expr_Value_R (S_Hi);
11349 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
11350 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
11354 and then S_Lov >= D_Lov
11355 and then S_Hiv <= D_Hiv
11363 -- Otherwise rewrite the conversion as described above
11365 Conv := Convert_To (Btyp, Expr);
11367 -- If a conversion is necessary, then copy the specific flags from
11368 -- the original one and also move the Do_Overflow_Check flag since
11369 -- this new conversion is to the base type.
11371 if Nkind (Conv) = N_Type_Conversion then
11372 Set_Conversion_OK (Conv, Conversion_OK (N));
11373 Set_Float_Truncate (Conv, Float_Truncate (N));
11374 Set_Rounded_Result (Conv, Rounded_Result (N));
11376 if Do_Overflow_Check (N) then
11377 Set_Do_Overflow_Check (Conv);
11378 Set_Do_Overflow_Check (N, False);
11382 Tnn := Make_Temporary (Loc, 'T', Conv);
11384 -- For a conversion from Float to Fixed where the bounds of the
11385 -- fixed-point type are static, we can obtain a more accurate
11386 -- fixed-point value by converting the result of the floating-
11387 -- point expression to an appropriate integer type, and then
11388 -- performing an unchecked conversion to the target fixed-point
11389 -- type. The range check can then use the corresponding integer
11390 -- value of the bounds instead of requiring further conversions.
11391 -- This preserves the identity:
11393 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11395 -- which used to fail when Fix_Val was a bound of the type and
11396 -- the 'Small was not a representable number.
11397 -- This transformation requires an integer type large enough to
11398 -- accommodate a fixed-point value. This will not be the case
11399 -- in systems where Duration is larger than Long_Integer.
11401 if Is_Ordinary_Fixed_Point_Type (Target_Type)
11402 and then Is_Floating_Point_Type (Etype (Expr))
11403 and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer)
11404 and then Nkind (Lo) = N_Real_Literal
11405 and then Nkind (Hi) = N_Real_Literal
11408 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
11409 Int_Type : Entity_Id;
11412 -- Find an integer type of the appropriate size to perform an
11413 -- unchecked conversion to the target fixed-point type.
11415 if RM_Size (Btyp) > RM_Size (Standard_Integer) then
11416 Int_Type := Standard_Long_Integer;
11418 elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then
11419 Int_Type := Standard_Integer;
11422 Int_Type := Standard_Short_Integer;
11425 -- Generate a temporary with the integer value. Required in the
11426 -- CCG compiler to ensure that run-time checks reference this
11427 -- integer expression (instead of the resulting fixed-point
11428 -- value because fixed-point values are handled by means of
11429 -- unsigned integer types).
11432 Make_Object_Declaration (Loc,
11433 Defining_Identifier => Expr_Id,
11434 Object_Definition => New_Occurrence_Of (Int_Type, Loc),
11435 Constant_Present => True,
11437 Convert_To (Int_Type, Expression (Conv))));
11439 -- Create integer objects for range checking of result.
11442 Unchecked_Convert_To
11443 (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
11446 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
11449 Unchecked_Convert_To
11450 (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
11453 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
11455 -- Rewrite conversion as an integer conversion of the
11456 -- original floating-point expression, followed by an
11457 -- unchecked conversion to the target fixed-point type.
11460 Make_Unchecked_Type_Conversion (Loc,
11461 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
11462 Expression => New_Occurrence_Of (Expr_Id, Loc));
11465 -- All other conversions
11468 Lo_Arg := New_Occurrence_Of (Tnn, Loc);
11470 Make_Attribute_Reference (Loc,
11471 Prefix => New_Occurrence_Of (Target_Type, Loc),
11472 Attribute_Name => Name_First);
11474 Hi_Arg := New_Occurrence_Of (Tnn, Loc);
11476 Make_Attribute_Reference (Loc,
11477 Prefix => New_Occurrence_Of (Target_Type, Loc),
11478 Attribute_Name => Name_Last);
11481 -- Build code for range checking. Note that checks are suppressed
11482 -- here since we don't want a recursive range check popping up.
11484 Insert_Actions (N, New_List (
11485 Make_Object_Declaration (Loc,
11486 Defining_Identifier => Tnn,
11487 Object_Definition => New_Occurrence_Of (Btyp, Loc),
11488 Constant_Present => True,
11489 Expression => Conv),
11491 Make_Raise_Constraint_Error (Loc,
11496 Left_Opnd => Lo_Arg,
11497 Right_Opnd => Lo_Val),
11501 Left_Opnd => Hi_Arg,
11502 Right_Opnd => Hi_Val)),
11503 Reason => CE_Range_Check_Failed)),
11504 Suppress => All_Checks);
11506 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
11507 end Real_Range_Check;
11509 -----------------------------
11510 -- Has_Extra_Accessibility --
11511 -----------------------------
11513 -- Returns true for a formal of an anonymous access type or for an Ada
11514 -- 2012-style stand-alone object of an anonymous access type.
11516 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
11518 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
11519 return Present (Effective_Extra_Accessibility (Id));
11523 end Has_Extra_Accessibility;
11525 -- Start of processing for Expand_N_Type_Conversion
11528 -- First remove check marks put by the semantic analysis on the type
11529 -- conversion between array types. We need these checks, and they will
11530 -- be generated by this expansion routine, but we do not depend on these
11531 -- flags being set, and since we do intend to expand the checks in the
11532 -- front end, we don't want them on the tree passed to the back end.
11534 if Is_Array_Type (Target_Type) then
11535 if Is_Constrained (Target_Type) then
11536 Set_Do_Length_Check (N, False);
11538 Set_Do_Range_Check (Operand, False);
11542 -- Nothing at all to do if conversion is to the identical type so remove
11543 -- the conversion completely, it is useless, except that it may carry
11544 -- an Assignment_OK attribute, which must be propagated to the operand.
11546 if Operand_Type = Target_Type then
11547 if Assignment_OK (N) then
11548 Set_Assignment_OK (Operand);
11551 Rewrite (N, Relocate_Node (Operand));
11555 -- Nothing to do if this is the second argument of read. This is a
11556 -- "backwards" conversion that will be handled by the specialized code
11557 -- in attribute processing.
11559 if Nkind (Parent (N)) = N_Attribute_Reference
11560 and then Attribute_Name (Parent (N)) = Name_Read
11561 and then Next (First (Expressions (Parent (N)))) = N
11566 -- Check for case of converting to a type that has an invariant
11567 -- associated with it. This requires an invariant check. We insert
11570 -- invariant_check (typ (expr))
11572 -- in the code, after removing side effects from the expression.
11573 -- This is clearer than replacing the conversion into an expression
11574 -- with actions, because the context may impose additional actions
11575 -- (tag checks, membership tests, etc.) that conflict with this
11576 -- rewriting (used previously).
11578 -- Note: the Comes_From_Source check, and then the resetting of this
11579 -- flag prevents what would otherwise be an infinite recursion.
11581 if Has_Invariants (Target_Type)
11582 and then Present (Invariant_Procedure (Target_Type))
11583 and then Comes_From_Source (N)
11585 Set_Comes_From_Source (N, False);
11586 Remove_Side_Effects (N);
11587 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
11591 -- Here if we may need to expand conversion
11593 -- If the operand of the type conversion is an arithmetic operation on
11594 -- signed integers, and the based type of the signed integer type in
11595 -- question is smaller than Standard.Integer, we promote both of the
11596 -- operands to type Integer.
11598 -- For example, if we have
11600 -- target-type (opnd1 + opnd2)
11602 -- and opnd1 and opnd2 are of type short integer, then we rewrite
11605 -- target-type (integer(opnd1) + integer(opnd2))
11607 -- We do this because we are always allowed to compute in a larger type
11608 -- if we do the right thing with the result, and in this case we are
11609 -- going to do a conversion which will do an appropriate check to make
11610 -- sure that things are in range of the target type in any case. This
11611 -- avoids some unnecessary intermediate overflows.
11613 -- We might consider a similar transformation in the case where the
11614 -- target is a real type or a 64-bit integer type, and the operand
11615 -- is an arithmetic operation using a 32-bit integer type. However,
11616 -- we do not bother with this case, because it could cause significant
11617 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
11618 -- much cheaper, but we don't want different behavior on 32-bit and
11619 -- 64-bit machines. Note that the exclusion of the 64-bit case also
11620 -- handles the configurable run-time cases where 64-bit arithmetic
11621 -- may simply be unavailable.
11623 -- Note: this circuit is partially redundant with respect to the circuit
11624 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
11625 -- the processing here. Also we still need the Checks circuit, since we
11626 -- have to be sure not to generate junk overflow checks in the first
11627 -- place, since it would be trick to remove them here.
11629 if Integer_Promotion_Possible (N) then
11631 -- All conditions met, go ahead with transformation
11639 Make_Type_Conversion (Loc,
11640 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
11641 Expression => Relocate_Node (Right_Opnd (Operand)));
11643 Opnd := New_Op_Node (Nkind (Operand), Loc);
11644 Set_Right_Opnd (Opnd, R);
11646 if Nkind (Operand) in N_Binary_Op then
11648 Make_Type_Conversion (Loc,
11649 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
11650 Expression => Relocate_Node (Left_Opnd (Operand)));
11652 Set_Left_Opnd (Opnd, L);
11656 Make_Type_Conversion (Loc,
11657 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
11658 Expression => Opnd));
11660 Analyze_And_Resolve (N, Target_Type);
11665 -- Do validity check if validity checking operands
11667 if Validity_Checks_On and Validity_Check_Operands then
11668 Ensure_Valid (Operand);
11671 -- Special case of converting from non-standard boolean type
11673 if Is_Boolean_Type (Operand_Type)
11674 and then (Nonzero_Is_True (Operand_Type))
11676 Adjust_Condition (Operand);
11677 Set_Etype (Operand, Standard_Boolean);
11678 Operand_Type := Standard_Boolean;
11681 -- Case of converting to an access type
11683 if Is_Access_Type (Target_Type) then
11685 -- If this type conversion was internally generated by the front end
11686 -- to displace the pointer to the object to reference an interface
11687 -- type and the original node was an Unrestricted_Access attribute,
11688 -- then skip applying accessibility checks (because, according to the
11689 -- GNAT Reference Manual, this attribute is similar to 'Access except
11690 -- that all accessibility and aliased view checks are omitted).
11692 if not Comes_From_Source (N)
11693 and then Is_Interface (Designated_Type (Target_Type))
11694 and then Nkind (Original_Node (N)) = N_Attribute_Reference
11695 and then Attribute_Name (Original_Node (N)) =
11696 Name_Unrestricted_Access
11700 -- Apply an accessibility check when the conversion operand is an
11701 -- access parameter (or a renaming thereof), unless conversion was
11702 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
11703 -- or for the actual of a class-wide interface parameter. Note that
11704 -- other checks may still need to be applied below (such as tagged
11707 elsif Is_Entity_Name (Operand)
11708 and then Has_Extra_Accessibility (Entity (Operand))
11709 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
11710 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
11711 or else Attribute_Name (Original_Node (N)) = Name_Access)
11713 if not Comes_From_Source (N)
11714 and then Nkind_In (Parent (N), N_Function_Call,
11715 N_Parameter_Association,
11716 N_Procedure_Call_Statement)
11717 and then Is_Interface (Designated_Type (Target_Type))
11718 and then Is_Class_Wide_Type (Designated_Type (Target_Type))
11723 Apply_Accessibility_Check
11724 (Operand, Target_Type, Insert_Node => Operand);
11727 -- If the level of the operand type is statically deeper than the
11728 -- level of the target type, then force Program_Error. Note that this
11729 -- can only occur for cases where the attribute is within the body of
11730 -- an instantiation, otherwise the conversion will already have been
11731 -- rejected as illegal.
11733 -- Note: warnings are issued by the analyzer for the instance cases
11735 elsif In_Instance_Body
11737 -- The case where the target type is an anonymous access type of
11738 -- a discriminant is excluded, because the level of such a type
11739 -- depends on the context and currently the level returned for such
11740 -- types is zero, resulting in warnings about about check failures
11741 -- in certain legal cases involving class-wide interfaces as the
11742 -- designated type (some cases, such as return statements, are
11743 -- checked at run time, but not clear if these are handled right
11744 -- in general, see 3.10.2(12/2-12.5/3) ???).
11747 not (Ekind (Target_Type) = E_Anonymous_Access_Type
11748 and then Present (Associated_Node_For_Itype (Target_Type))
11749 and then Nkind (Associated_Node_For_Itype (Target_Type)) =
11750 N_Discriminant_Specification)
11752 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
11754 Raise_Accessibility_Error;
11757 -- When the operand is a selected access discriminant the check needs
11758 -- to be made against the level of the object denoted by the prefix
11759 -- of the selected name. Force Program_Error for this case as well
11760 -- (this accessibility violation can only happen if within the body
11761 -- of an instantiation).
11763 elsif In_Instance_Body
11764 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
11765 and then Nkind (Operand) = N_Selected_Component
11766 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
11767 and then Object_Access_Level (Operand) >
11768 Type_Access_Level (Target_Type)
11770 Raise_Accessibility_Error;
11775 -- Case of conversions of tagged types and access to tagged types
11777 -- When needed, that is to say when the expression is class-wide, Add
11778 -- runtime a tag check for (strict) downward conversion by using the
11779 -- membership test, generating:
11781 -- [constraint_error when Operand not in Target_Type'Class]
11783 -- or in the access type case
11785 -- [constraint_error
11786 -- when Operand /= null
11787 -- and then Operand.all not in
11788 -- Designated_Type (Target_Type)'Class]
11790 if (Is_Access_Type (Target_Type)
11791 and then Is_Tagged_Type (Designated_Type (Target_Type)))
11792 or else Is_Tagged_Type (Target_Type)
11794 -- Do not do any expansion in the access type case if the parent is a
11795 -- renaming, since this is an error situation which will be caught by
11796 -- Sem_Ch8, and the expansion can interfere with this error check.
11798 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
11802 -- Otherwise, proceed with processing tagged conversion
11804 Tagged_Conversion : declare
11805 Actual_Op_Typ : Entity_Id;
11806 Actual_Targ_Typ : Entity_Id;
11807 Make_Conversion : Boolean := False;
11808 Root_Op_Typ : Entity_Id;
11810 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
11811 -- Create a membership check to test whether Operand is a member
11812 -- of Targ_Typ. If the original Target_Type is an access, include
11813 -- a test for null value. The check is inserted at N.
11815 --------------------
11816 -- Make_Tag_Check --
11817 --------------------
11819 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
11824 -- [Constraint_Error
11825 -- when Operand /= null
11826 -- and then Operand.all not in Targ_Typ]
11828 if Is_Access_Type (Target_Type) then
11830 Make_And_Then (Loc,
11833 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
11834 Right_Opnd => Make_Null (Loc)),
11839 Make_Explicit_Dereference (Loc,
11840 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
11841 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
11844 -- [Constraint_Error when Operand not in Targ_Typ]
11849 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
11850 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
11854 Make_Raise_Constraint_Error (Loc,
11856 Reason => CE_Tag_Check_Failed),
11857 Suppress => All_Checks);
11858 end Make_Tag_Check;
11860 -- Start of processing for Tagged_Conversion
11863 -- Handle entities from the limited view
11865 if Is_Access_Type (Operand_Type) then
11867 Available_View (Designated_Type (Operand_Type));
11869 Actual_Op_Typ := Operand_Type;
11872 if Is_Access_Type (Target_Type) then
11874 Available_View (Designated_Type (Target_Type));
11876 Actual_Targ_Typ := Target_Type;
11879 Root_Op_Typ := Root_Type (Actual_Op_Typ);
11881 -- Ada 2005 (AI-251): Handle interface type conversion
11883 if Is_Interface (Actual_Op_Typ)
11885 Is_Interface (Actual_Targ_Typ)
11887 Expand_Interface_Conversion (N);
11891 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
11893 -- Create a runtime tag check for a downward class-wide type
11896 if Is_Class_Wide_Type (Actual_Op_Typ)
11897 and then Actual_Op_Typ /= Actual_Targ_Typ
11898 and then Root_Op_Typ /= Actual_Targ_Typ
11899 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
11900 Use_Full_View => True)
11902 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
11903 Make_Conversion := True;
11906 -- AI05-0073: If the result subtype of the function is defined
11907 -- by an access_definition designating a specific tagged type
11908 -- T, a check is made that the result value is null or the tag
11909 -- of the object designated by the result value identifies T.
11910 -- Constraint_Error is raised if this check fails.
11912 if Nkind (Parent (N)) = N_Simple_Return_Statement then
11915 Func_Typ : Entity_Id;
11918 -- Climb scope stack looking for the enclosing function
11920 Func := Current_Scope;
11921 while Present (Func)
11922 and then Ekind (Func) /= E_Function
11924 Func := Scope (Func);
11927 -- The function's return subtype must be defined using
11928 -- an access definition.
11930 if Nkind (Result_Definition (Parent (Func))) =
11931 N_Access_Definition
11933 Func_Typ := Directly_Designated_Type (Etype (Func));
11935 -- The return subtype denotes a specific tagged type,
11936 -- in other words, a non class-wide type.
11938 if Is_Tagged_Type (Func_Typ)
11939 and then not Is_Class_Wide_Type (Func_Typ)
11941 Make_Tag_Check (Actual_Targ_Typ);
11942 Make_Conversion := True;
11948 -- We have generated a tag check for either a class-wide type
11949 -- conversion or for AI05-0073.
11951 if Make_Conversion then
11956 Make_Unchecked_Type_Conversion (Loc,
11957 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
11958 Expression => Relocate_Node (Expression (N)));
11960 Analyze_And_Resolve (N, Target_Type);
11964 end Tagged_Conversion;
11966 -- Case of other access type conversions
11968 elsif Is_Access_Type (Target_Type) then
11969 Apply_Constraint_Check (Operand, Target_Type);
11971 -- Case of conversions from a fixed-point type
11973 -- These conversions require special expansion and processing, found in
11974 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
11975 -- since from a semantic point of view, these are simple integer
11976 -- conversions, which do not need further processing.
11978 elsif Is_Fixed_Point_Type (Operand_Type)
11979 and then not Conversion_OK (N)
11981 -- We should never see universal fixed at this case, since the
11982 -- expansion of the constituent divide or multiply should have
11983 -- eliminated the explicit mention of universal fixed.
11985 pragma Assert (Operand_Type /= Universal_Fixed);
11987 -- Check for special case of the conversion to universal real that
11988 -- occurs as a result of the use of a round attribute. In this case,
11989 -- the real type for the conversion is taken from the target type of
11990 -- the Round attribute and the result must be marked as rounded.
11992 if Target_Type = Universal_Real
11993 and then Nkind (Parent (N)) = N_Attribute_Reference
11994 and then Attribute_Name (Parent (N)) = Name_Round
11996 Set_Rounded_Result (N);
11997 Set_Etype (N, Etype (Parent (N)));
11998 Target_Type := Etype (N);
12001 if Is_Fixed_Point_Type (Target_Type) then
12002 Expand_Convert_Fixed_To_Fixed (N);
12005 elsif Is_Integer_Type (Target_Type) then
12006 Expand_Convert_Fixed_To_Integer (N);
12007 Discrete_Range_Check;
12010 pragma Assert (Is_Floating_Point_Type (Target_Type));
12011 Expand_Convert_Fixed_To_Float (N);
12015 -- Case of conversions to a fixed-point type
12017 -- These conversions require special expansion and processing, found in
12018 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12019 -- since from a semantic point of view, these are simple integer
12020 -- conversions, which do not need further processing.
12022 elsif Is_Fixed_Point_Type (Target_Type)
12023 and then not Conversion_OK (N)
12025 if Is_Integer_Type (Operand_Type) then
12026 Expand_Convert_Integer_To_Fixed (N);
12029 pragma Assert (Is_Floating_Point_Type (Operand_Type));
12030 Expand_Convert_Float_To_Fixed (N);
12034 -- Case of array conversions
12036 -- Expansion of array conversions, add required length/range checks but
12037 -- only do this if there is no change of representation. For handling of
12038 -- this case, see Handle_Changed_Representation.
12040 elsif Is_Array_Type (Target_Type) then
12041 if Is_Constrained (Target_Type) then
12042 Apply_Length_Check (Operand, Target_Type);
12044 Apply_Range_Check (Operand, Target_Type);
12047 Handle_Changed_Representation;
12049 -- Case of conversions of discriminated types
12051 -- Add required discriminant checks if target is constrained. Again this
12052 -- change is skipped if we have a change of representation.
12054 elsif Has_Discriminants (Target_Type)
12055 and then Is_Constrained (Target_Type)
12057 Apply_Discriminant_Check (Operand, Target_Type);
12058 Handle_Changed_Representation;
12060 -- Case of all other record conversions. The only processing required
12061 -- is to check for a change of representation requiring the special
12062 -- assignment processing.
12064 elsif Is_Record_Type (Target_Type) then
12066 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12067 -- a derived Unchecked_Union type to an unconstrained type that is
12068 -- not Unchecked_Union if the operand lacks inferable discriminants.
12070 if Is_Derived_Type (Operand_Type)
12071 and then Is_Unchecked_Union (Base_Type (Operand_Type))
12072 and then not Is_Constrained (Target_Type)
12073 and then not Is_Unchecked_Union (Base_Type (Target_Type))
12074 and then not Has_Inferable_Discriminants (Operand)
12076 -- To prevent Gigi from generating illegal code, we generate a
12077 -- Program_Error node, but we give it the target type of the
12078 -- conversion (is this requirement documented somewhere ???)
12081 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
12082 Reason => PE_Unchecked_Union_Restriction);
12085 Set_Etype (PE, Target_Type);
12090 Handle_Changed_Representation;
12093 -- Case of conversions of enumeration types
12095 elsif Is_Enumeration_Type (Target_Type) then
12097 -- Special processing is required if there is a change of
12098 -- representation (from enumeration representation clauses).
12100 if not Same_Representation (Target_Type, Operand_Type) then
12102 -- Convert: x(y) to x'val (ytyp'val (y))
12105 Make_Attribute_Reference (Loc,
12106 Prefix => New_Occurrence_Of (Target_Type, Loc),
12107 Attribute_Name => Name_Val,
12108 Expressions => New_List (
12109 Make_Attribute_Reference (Loc,
12110 Prefix => New_Occurrence_Of (Operand_Type, Loc),
12111 Attribute_Name => Name_Pos,
12112 Expressions => New_List (Operand)))));
12114 Analyze_And_Resolve (N, Target_Type);
12118 -- At this stage, either the conversion node has been transformed into
12119 -- some other equivalent expression, or left as a conversion that can be
12120 -- handled by Gigi, in the following cases:
12122 -- Conversions with no change of representation or type
12124 -- Numeric conversions involving integer, floating- and fixed-point
12125 -- values. Fixed-point values are allowed only if Conversion_OK is
12126 -- set, i.e. if the fixed-point values are to be treated as integers.
12128 -- No other conversions should be passed to Gigi
12130 -- Check: are these rules stated in sinfo??? if so, why restate here???
12132 -- The only remaining step is to generate a range check if we still have
12133 -- a type conversion at this stage and Do_Range_Check is set. Note that
12134 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12135 -- conversions here, because the float-to-integer case is entirely dealt
12136 -- with by Apply_Float_Conversion_Check.
12138 if Nkind (N) = N_Type_Conversion
12139 and then Do_Range_Check (Expression (N))
12141 -- Float-to-float conversions
12143 if Is_Floating_Point_Type (Target_Type)
12144 and then Is_Floating_Point_Type (Etype (Expression (N)))
12146 -- Reset overflow flag, since the range check will include
12147 -- dealing with possible overflow, and generate the check.
12149 Set_Do_Overflow_Check (N, False);
12151 Generate_Range_Check
12152 (Expression (N), Target_Type, CE_Range_Check_Failed);
12154 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12155 -- conversions when Conversion_OK is set.
12157 elsif Is_Discrete_Type (Target_Type)
12158 and then (Is_Discrete_Type (Etype (Expression (N)))
12159 or else (Is_Fixed_Point_Type (Etype (Expression (N)))
12160 and then Conversion_OK (N)))
12162 -- If Address is either a source type or target type,
12163 -- suppress range check to avoid typing anomalies when
12164 -- it is a visible integer type.
12166 if Is_Descendant_Of_Address (Etype (Expression (N)))
12167 or else Is_Descendant_Of_Address (Target_Type)
12169 Set_Do_Range_Check (Expression (N), False);
12171 Discrete_Range_Check;
12174 -- Conversions to floating- or fixed-point when Conversion_OK is set
12176 elsif Is_Floating_Point_Type (Target_Type)
12177 or else (Is_Fixed_Point_Type (Target_Type)
12178 and then Conversion_OK (N))
12184 -- Here at end of processing
12187 -- Apply predicate check if required. Note that we can't just call
12188 -- Apply_Predicate_Check here, because the type looks right after
12189 -- the conversion and it would omit the check. The Comes_From_Source
12190 -- guard is necessary to prevent infinite recursions when we generate
12191 -- internal conversions for the purpose of checking predicates.
12193 if Present (Predicate_Function (Target_Type))
12194 and then not Predicates_Ignored (Target_Type)
12195 and then Target_Type /= Operand_Type
12196 and then Comes_From_Source (N)
12199 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
12202 -- Avoid infinite recursion on the subsequent expansion of
12203 -- of the copy of the original type conversion. When needed,
12204 -- a range check has already been applied to the expression.
12206 Set_Comes_From_Source (New_Expr, False);
12208 Make_Predicate_Check (Target_Type, New_Expr),
12209 Suppress => Range_Check);
12212 end Expand_N_Type_Conversion;
12214 -----------------------------------
12215 -- Expand_N_Unchecked_Expression --
12216 -----------------------------------
12218 -- Remove the unchecked expression node from the tree. Its job was simply
12219 -- to make sure that its constituent expression was handled with checks
12220 -- off, and now that that is done, we can remove it from the tree, and
12221 -- indeed must, since Gigi does not expect to see these nodes.
12223 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
12224 Exp : constant Node_Id := Expression (N);
12226 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
12228 end Expand_N_Unchecked_Expression;
12230 ----------------------------------------
12231 -- Expand_N_Unchecked_Type_Conversion --
12232 ----------------------------------------
12234 -- If this cannot be handled by Gigi and we haven't already made a
12235 -- temporary for it, do it now.
12237 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
12238 Target_Type : constant Entity_Id := Etype (N);
12239 Operand : constant Node_Id := Expression (N);
12240 Operand_Type : constant Entity_Id := Etype (Operand);
12243 -- Nothing at all to do if conversion is to the identical type so remove
12244 -- the conversion completely, it is useless, except that it may carry
12245 -- an Assignment_OK indication which must be propagated to the operand.
12247 if Operand_Type = Target_Type then
12249 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12251 if Assignment_OK (N) then
12252 Set_Assignment_OK (Operand);
12255 Rewrite (N, Relocate_Node (Operand));
12259 -- If we have a conversion of a compile time known value to a target
12260 -- type and the value is in range of the target type, then we can simply
12261 -- replace the construct by an integer literal of the correct type. We
12262 -- only apply this to integer types being converted. Possibly it may
12263 -- apply in other cases, but it is too much trouble to worry about.
12265 -- Note that we do not do this transformation if the Kill_Range_Check
12266 -- flag is set, since then the value may be outside the expected range.
12267 -- This happens in the Normalize_Scalars case.
12269 -- We also skip this if either the target or operand type is biased
12270 -- because in this case, the unchecked conversion is supposed to
12271 -- preserve the bit pattern, not the integer value.
12273 if Is_Integer_Type (Target_Type)
12274 and then not Has_Biased_Representation (Target_Type)
12275 and then Is_Integer_Type (Operand_Type)
12276 and then not Has_Biased_Representation (Operand_Type)
12277 and then Compile_Time_Known_Value (Operand)
12278 and then not Kill_Range_Check (N)
12281 Val : constant Uint := Expr_Value (Operand);
12284 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
12286 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
12288 Val >= Expr_Value (Type_Low_Bound (Target_Type))
12290 Val <= Expr_Value (Type_High_Bound (Target_Type))
12292 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
12294 -- If Address is the target type, just set the type to avoid a
12295 -- spurious type error on the literal when Address is a visible
12298 if Is_Descendant_Of_Address (Target_Type) then
12299 Set_Etype (N, Target_Type);
12301 Analyze_And_Resolve (N, Target_Type);
12309 -- Nothing to do if conversion is safe
12311 if Safe_Unchecked_Type_Conversion (N) then
12315 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12316 -- flag indicates ??? More comments needed here)
12318 if Assignment_OK (N) then
12321 Force_Evaluation (N);
12323 end Expand_N_Unchecked_Type_Conversion;
12325 ----------------------------
12326 -- Expand_Record_Equality --
12327 ----------------------------
12329 -- For non-variant records, Equality is expanded when needed into:
12331 -- and then Lhs.Discr1 = Rhs.Discr1
12333 -- and then Lhs.Discrn = Rhs.Discrn
12334 -- and then Lhs.Cmp1 = Rhs.Cmp1
12336 -- and then Lhs.Cmpn = Rhs.Cmpn
12338 -- The expression is folded by the back end for adjacent fields. This
12339 -- function is called for tagged record in only one occasion: for imple-
12340 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12341 -- otherwise the primitive "=" is used directly.
12343 function Expand_Record_Equality
12348 Bodies : List_Id) return Node_Id
12350 Loc : constant Source_Ptr := Sloc (Nod);
12355 First_Time : Boolean := True;
12357 function Element_To_Compare (C : Entity_Id) return Entity_Id;
12358 -- Return the next discriminant or component to compare, starting with
12359 -- C, skipping inherited components.
12361 ------------------------
12362 -- Element_To_Compare --
12363 ------------------------
12365 function Element_To_Compare (C : Entity_Id) return Entity_Id is
12371 -- Exit loop when the next element to be compared is found, or
12372 -- there is no more such element.
12374 exit when No (Comp);
12376 exit when Ekind_In (Comp, E_Discriminant, E_Component)
12379 -- Skip inherited components
12381 -- Note: for a tagged type, we always generate the "=" primitive
12382 -- for the base type (not on the first subtype), so the test for
12383 -- Comp /= Original_Record_Component (Comp) is True for
12384 -- inherited components only.
12386 (Is_Tagged_Type (Typ)
12387 and then Comp /= Original_Record_Component (Comp))
12391 or else Chars (Comp) = Name_uTag
12393 -- Skip interface elements (secondary tags???)
12395 or else Is_Interface (Etype (Comp)));
12397 Next_Entity (Comp);
12401 end Element_To_Compare;
12403 -- Start of processing for Expand_Record_Equality
12406 -- Generates the following code: (assuming that Typ has one Discr and
12407 -- component C2 is also a record)
12409 -- Lhs.Discr1 = Rhs.Discr1
12410 -- and then Lhs.C1 = Rhs.C1
12411 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12413 -- and then Lhs.Cmpn = Rhs.Cmpn
12415 Result := New_Occurrence_Of (Standard_True, Loc);
12416 C := Element_To_Compare (First_Entity (Typ));
12417 while Present (C) loop
12428 New_Lhs := New_Copy_Tree (Lhs);
12429 New_Rhs := New_Copy_Tree (Rhs);
12433 Expand_Composite_Equality (Nod, Etype (C),
12435 Make_Selected_Component (Loc,
12437 Selector_Name => New_Occurrence_Of (C, Loc)),
12439 Make_Selected_Component (Loc,
12441 Selector_Name => New_Occurrence_Of (C, Loc)),
12444 -- If some (sub)component is an unchecked_union, the whole
12445 -- operation will raise program error.
12447 if Nkind (Check) = N_Raise_Program_Error then
12449 Set_Etype (Result, Standard_Boolean);
12455 -- Generate logical "and" for CodePeer to simplify the
12456 -- generated code and analysis.
12458 elsif CodePeer_Mode then
12461 Left_Opnd => Result,
12462 Right_Opnd => Check);
12466 Make_And_Then (Loc,
12467 Left_Opnd => Result,
12468 Right_Opnd => Check);
12473 First_Time := False;
12474 C := Element_To_Compare (Next_Entity (C));
12478 end Expand_Record_Equality;
12480 ---------------------------
12481 -- Expand_Set_Membership --
12482 ---------------------------
12484 procedure Expand_Set_Membership (N : Node_Id) is
12485 Lop : constant Node_Id := Left_Opnd (N);
12489 function Make_Cond (Alt : Node_Id) return Node_Id;
12490 -- If the alternative is a subtype mark, create a simple membership
12491 -- test. Otherwise create an equality test for it.
12497 function Make_Cond (Alt : Node_Id) return Node_Id is
12499 L : constant Node_Id := New_Copy_Tree (Lop);
12500 R : constant Node_Id := Relocate_Node (Alt);
12503 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
12504 or else Nkind (Alt) = N_Range
12507 Make_In (Sloc (Alt),
12512 Make_Op_Eq (Sloc (Alt),
12520 -- Start of processing for Expand_Set_Membership
12523 Remove_Side_Effects (Lop);
12525 Alt := Last (Alternatives (N));
12526 Res := Make_Cond (Alt);
12529 while Present (Alt) loop
12531 Make_Or_Else (Sloc (Alt),
12532 Left_Opnd => Make_Cond (Alt),
12533 Right_Opnd => Res);
12538 Analyze_And_Resolve (N, Standard_Boolean);
12539 end Expand_Set_Membership;
12541 -----------------------------------
12542 -- Expand_Short_Circuit_Operator --
12543 -----------------------------------
12545 -- Deal with special expansion if actions are present for the right operand
12546 -- and deal with optimizing case of arguments being True or False. We also
12547 -- deal with the special case of non-standard boolean values.
12549 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
12550 Loc : constant Source_Ptr := Sloc (N);
12551 Typ : constant Entity_Id := Etype (N);
12552 Left : constant Node_Id := Left_Opnd (N);
12553 Right : constant Node_Id := Right_Opnd (N);
12554 LocR : constant Source_Ptr := Sloc (Right);
12557 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
12558 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
12559 -- If Left = Shortcut_Value then Right need not be evaluated
12561 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
12562 -- For Opnd a boolean expression, return a Boolean expression equivalent
12563 -- to Opnd /= Shortcut_Value.
12565 function Useful (Actions : List_Id) return Boolean;
12566 -- Return True if Actions is not empty and contains useful nodes to
12569 --------------------
12570 -- Make_Test_Expr --
12571 --------------------
12573 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
12575 if Shortcut_Value then
12576 return Make_Op_Not (Sloc (Opnd), Opnd);
12580 end Make_Test_Expr;
12586 function Useful (Actions : List_Id) return Boolean is
12589 if Present (Actions) then
12590 L := First (Actions);
12592 -- For now "useful" means not N_Variable_Reference_Marker.
12593 -- Consider stripping other nodes in the future.
12595 while Present (L) loop
12596 if Nkind (L) /= N_Variable_Reference_Marker then
12609 Op_Var : Entity_Id;
12610 -- Entity for a temporary variable holding the value of the operator,
12611 -- used for expansion in the case where actions are present.
12613 -- Start of processing for Expand_Short_Circuit_Operator
12616 -- Deal with non-standard booleans
12618 if Is_Boolean_Type (Typ) then
12619 Adjust_Condition (Left);
12620 Adjust_Condition (Right);
12621 Set_Etype (N, Standard_Boolean);
12624 -- Check for cases where left argument is known to be True or False
12626 if Compile_Time_Known_Value (Left) then
12628 -- Mark SCO for left condition as compile time known
12630 if Generate_SCO and then Comes_From_Source (Left) then
12631 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
12634 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
12635 -- Any actions associated with Right will be executed unconditionally
12636 -- and can thus be inserted into the tree unconditionally.
12638 if Expr_Value_E (Left) /= Shortcut_Ent then
12639 if Present (Actions (N)) then
12640 Insert_Actions (N, Actions (N));
12643 Rewrite (N, Right);
12645 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
12646 -- In this case we can forget the actions associated with Right,
12647 -- since they will never be executed.
12650 Kill_Dead_Code (Right);
12651 Kill_Dead_Code (Actions (N));
12652 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
12655 Adjust_Result_Type (N, Typ);
12659 -- If Actions are present for the right operand, we have to do some
12660 -- special processing. We can't just let these actions filter back into
12661 -- code preceding the short circuit (which is what would have happened
12662 -- if we had not trapped them in the short-circuit form), since they
12663 -- must only be executed if the right operand of the short circuit is
12664 -- executed and not otherwise.
12666 if Useful (Actions (N)) then
12667 Actlist := Actions (N);
12669 -- The old approach is to expand:
12671 -- left AND THEN right
12675 -- C : Boolean := False;
12683 -- and finally rewrite the operator into a reference to C. Similarly
12684 -- for left OR ELSE right, with negated values. Note that this
12685 -- rewrite causes some difficulties for coverage analysis because
12686 -- of the introduction of the new variable C, which obscures the
12687 -- structure of the test.
12689 -- We use this "old approach" if Minimize_Expression_With_Actions
12692 if Minimize_Expression_With_Actions then
12693 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
12696 Make_Object_Declaration (Loc,
12697 Defining_Identifier => Op_Var,
12698 Object_Definition =>
12699 New_Occurrence_Of (Standard_Boolean, Loc),
12701 New_Occurrence_Of (Shortcut_Ent, Loc)));
12703 Append_To (Actlist,
12704 Make_Implicit_If_Statement (Right,
12705 Condition => Make_Test_Expr (Right),
12706 Then_Statements => New_List (
12707 Make_Assignment_Statement (LocR,
12708 Name => New_Occurrence_Of (Op_Var, LocR),
12711 (Boolean_Literals (not Shortcut_Value), LocR)))));
12714 Make_Implicit_If_Statement (Left,
12715 Condition => Make_Test_Expr (Left),
12716 Then_Statements => Actlist));
12718 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
12719 Analyze_And_Resolve (N, Standard_Boolean);
12721 -- The new approach (the default) is to use an
12722 -- Expression_With_Actions node for the right operand of the
12723 -- short-circuit form. Note that this solves the traceability
12724 -- problems for coverage analysis.
12728 Make_Expression_With_Actions (LocR,
12729 Expression => Relocate_Node (Right),
12730 Actions => Actlist));
12732 Set_Actions (N, No_List);
12733 Analyze_And_Resolve (Right, Standard_Boolean);
12736 Adjust_Result_Type (N, Typ);
12740 -- No actions present, check for cases of right argument True/False
12742 if Compile_Time_Known_Value (Right) then
12744 -- Mark SCO for left condition as compile time known
12746 if Generate_SCO and then Comes_From_Source (Right) then
12747 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
12750 -- Change (Left and then True), (Left or else False) to Left. Note
12751 -- that we know there are no actions associated with the right
12752 -- operand, since we just checked for this case above.
12754 if Expr_Value_E (Right) /= Shortcut_Ent then
12757 -- Change (Left and then False), (Left or else True) to Right,
12758 -- making sure to preserve any side effects associated with the Left
12762 Remove_Side_Effects (Left);
12763 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
12767 Adjust_Result_Type (N, Typ);
12768 end Expand_Short_Circuit_Operator;
12770 ------------------------------------
12771 -- Fixup_Universal_Fixed_Operation --
12772 -------------------------------------
12774 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
12775 Conv : constant Node_Id := Parent (N);
12778 -- We must have a type conversion immediately above us
12780 pragma Assert (Nkind (Conv) = N_Type_Conversion);
12782 -- Normally the type conversion gives our target type. The exception
12783 -- occurs in the case of the Round attribute, where the conversion
12784 -- will be to universal real, and our real type comes from the Round
12785 -- attribute (as well as an indication that we must round the result)
12787 if Nkind (Parent (Conv)) = N_Attribute_Reference
12788 and then Attribute_Name (Parent (Conv)) = Name_Round
12790 Set_Etype (N, Base_Type (Etype (Parent (Conv))));
12791 Set_Rounded_Result (N);
12793 -- Normal case where type comes from conversion above us
12796 Set_Etype (N, Base_Type (Etype (Conv)));
12798 end Fixup_Universal_Fixed_Operation;
12800 ---------------------------------
12801 -- Has_Inferable_Discriminants --
12802 ---------------------------------
12804 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12806 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12807 -- Determines whether the left-most prefix of a selected component is a
12808 -- formal parameter in a subprogram. Assumes N is a selected component.
12810 --------------------------------
12811 -- Prefix_Is_Formal_Parameter --
12812 --------------------------------
12814 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12815 Sel_Comp : Node_Id;
12818 -- Move to the left-most prefix by climbing up the tree
12821 while Present (Parent (Sel_Comp))
12822 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12824 Sel_Comp := Parent (Sel_Comp);
12827 return Is_Formal (Entity (Prefix (Sel_Comp)));
12828 end Prefix_Is_Formal_Parameter;
12830 -- Start of processing for Has_Inferable_Discriminants
12833 -- For selected components, the subtype of the selector must be a
12834 -- constrained Unchecked_Union. If the component is subject to a
12835 -- per-object constraint, then the enclosing object must have inferable
12838 if Nkind (N) = N_Selected_Component then
12839 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
12841 -- A small hack. If we have a per-object constrained selected
12842 -- component of a formal parameter, return True since we do not
12843 -- know the actual parameter association yet.
12845 if Prefix_Is_Formal_Parameter (N) then
12848 -- Otherwise, check the enclosing object and the selector
12851 return Has_Inferable_Discriminants (Prefix (N))
12852 and then Has_Inferable_Discriminants (Selector_Name (N));
12855 -- The call to Has_Inferable_Discriminants will determine whether
12856 -- the selector has a constrained Unchecked_Union nominal type.
12859 return Has_Inferable_Discriminants (Selector_Name (N));
12862 -- A qualified expression has inferable discriminants if its subtype
12863 -- mark is a constrained Unchecked_Union subtype.
12865 elsif Nkind (N) = N_Qualified_Expression then
12866 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12867 and then Is_Constrained (Etype (Subtype_Mark (N)));
12869 -- For all other names, it is sufficient to have a constrained
12870 -- Unchecked_Union nominal subtype.
12873 return Is_Unchecked_Union (Base_Type (Etype (N)))
12874 and then Is_Constrained (Etype (N));
12876 end Has_Inferable_Discriminants;
12878 -------------------------------
12879 -- Insert_Dereference_Action --
12880 -------------------------------
12882 procedure Insert_Dereference_Action (N : Node_Id) is
12883 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
12884 -- Return true if type of P is derived from Checked_Pool;
12886 -----------------------------
12887 -- Is_Checked_Storage_Pool --
12888 -----------------------------
12890 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
12899 while T /= Etype (T) loop
12900 if Is_RTE (T, RE_Checked_Pool) then
12908 end Is_Checked_Storage_Pool;
12912 Context : constant Node_Id := Parent (N);
12913 Ptr_Typ : constant Entity_Id := Etype (N);
12914 Desig_Typ : constant Entity_Id :=
12915 Available_View (Designated_Type (Ptr_Typ));
12916 Loc : constant Source_Ptr := Sloc (N);
12917 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ);
12923 Size_Bits : Node_Id;
12926 -- Start of processing for Insert_Dereference_Action
12929 pragma Assert (Nkind (Context) = N_Explicit_Dereference);
12931 -- Do not re-expand a dereference which has already been processed by
12934 if Has_Dereference_Action (Context) then
12937 -- Do not perform this type of expansion for internally-generated
12940 elsif not Comes_From_Source (Original_Node (Context)) then
12943 -- A dereference action is only applicable to objects which have been
12944 -- allocated on a checked pool.
12946 elsif not Is_Checked_Storage_Pool (Pool) then
12950 -- Extract the address of the dereferenced object. Generate:
12952 -- Addr : System.Address := <N>'Pool_Address;
12954 Addr := Make_Temporary (Loc, 'P');
12957 Make_Object_Declaration (Loc,
12958 Defining_Identifier => Addr,
12959 Object_Definition =>
12960 New_Occurrence_Of (RTE (RE_Address), Loc),
12962 Make_Attribute_Reference (Loc,
12963 Prefix => Duplicate_Subexpr_Move_Checks (N),
12964 Attribute_Name => Name_Pool_Address)));
12966 -- Calculate the size of the dereferenced object. Generate:
12968 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
12971 Make_Explicit_Dereference (Loc,
12972 Prefix => Duplicate_Subexpr_Move_Checks (N));
12973 Set_Has_Dereference_Action (Deref);
12976 Make_Attribute_Reference (Loc,
12978 Attribute_Name => Name_Size);
12980 -- Special case of an unconstrained array: need to add descriptor size
12982 if Is_Array_Type (Desig_Typ)
12983 and then not Is_Constrained (First_Subtype (Desig_Typ))
12988 Make_Attribute_Reference (Loc,
12990 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc),
12991 Attribute_Name => Name_Descriptor_Size),
12992 Right_Opnd => Size_Bits);
12995 Size := Make_Temporary (Loc, 'S');
12997 Make_Object_Declaration (Loc,
12998 Defining_Identifier => Size,
12999 Object_Definition =>
13000 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13002 Make_Op_Divide (Loc,
13003 Left_Opnd => Size_Bits,
13004 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
13006 -- Calculate the alignment of the dereferenced object. Generate:
13007 -- Alig : constant Storage_Count := <N>.all'Alignment;
13010 Make_Explicit_Dereference (Loc,
13011 Prefix => Duplicate_Subexpr_Move_Checks (N));
13012 Set_Has_Dereference_Action (Deref);
13014 Alig := Make_Temporary (Loc, 'A');
13016 Make_Object_Declaration (Loc,
13017 Defining_Identifier => Alig,
13018 Object_Definition =>
13019 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13021 Make_Attribute_Reference (Loc,
13023 Attribute_Name => Name_Alignment)));
13025 -- A dereference of a controlled object requires special processing. The
13026 -- finalization machinery requests additional space from the underlying
13027 -- pool to allocate and hide two pointers. As a result, a checked pool
13028 -- may mark the wrong memory as valid. Since checked pools do not have
13029 -- knowledge of hidden pointers, we have to bring the two pointers back
13030 -- in view in order to restore the original state of the object.
13032 -- The address manipulation is not performed for access types that are
13033 -- subject to pragma No_Heap_Finalization because the two pointers do
13034 -- not exist in the first place.
13036 if No_Heap_Finalization (Ptr_Typ) then
13039 elsif Needs_Finalization (Desig_Typ) then
13041 -- Adjust the address and size of the dereferenced object. Generate:
13042 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13045 Make_Procedure_Call_Statement (Loc,
13047 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
13048 Parameter_Associations => New_List (
13049 New_Occurrence_Of (Addr, Loc),
13050 New_Occurrence_Of (Size, Loc),
13051 New_Occurrence_Of (Alig, Loc)));
13053 -- Class-wide types complicate things because we cannot determine
13054 -- statically whether the actual object is truly controlled. We must
13055 -- generate a runtime check to detect this property. Generate:
13057 -- if Needs_Finalization (<N>.all'Tag) then
13061 if Is_Class_Wide_Type (Desig_Typ) then
13063 Make_Explicit_Dereference (Loc,
13064 Prefix => Duplicate_Subexpr_Move_Checks (N));
13065 Set_Has_Dereference_Action (Deref);
13068 Make_Implicit_If_Statement (N,
13070 Make_Function_Call (Loc,
13072 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
13073 Parameter_Associations => New_List (
13074 Make_Attribute_Reference (Loc,
13076 Attribute_Name => Name_Tag))),
13077 Then_Statements => New_List (Stmt));
13080 Insert_Action (N, Stmt);
13084 -- Dereference (Pool, Addr, Size, Alig);
13087 Make_Procedure_Call_Statement (Loc,
13090 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
13091 Parameter_Associations => New_List (
13092 New_Occurrence_Of (Pool, Loc),
13093 New_Occurrence_Of (Addr, Loc),
13094 New_Occurrence_Of (Size, Loc),
13095 New_Occurrence_Of (Alig, Loc))));
13097 -- Mark the explicit dereference as processed to avoid potential
13098 -- infinite expansion.
13100 Set_Has_Dereference_Action (Context);
13103 when RE_Not_Available =>
13105 end Insert_Dereference_Action;
13107 --------------------------------
13108 -- Integer_Promotion_Possible --
13109 --------------------------------
13111 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
13112 Operand : constant Node_Id := Expression (N);
13113 Operand_Type : constant Entity_Id := Etype (Operand);
13114 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
13117 pragma Assert (Nkind (N) = N_Type_Conversion);
13121 -- We only do the transformation for source constructs. We assume
13122 -- that the expander knows what it is doing when it generates code.
13124 Comes_From_Source (N)
13126 -- If the operand type is Short_Integer or Short_Short_Integer,
13127 -- then we will promote to Integer, which is available on all
13128 -- targets, and is sufficient to ensure no intermediate overflow.
13129 -- Furthermore it is likely to be as efficient or more efficient
13130 -- than using the smaller type for the computation so we do this
13131 -- unconditionally.
13134 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
13136 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
13138 -- Test for interesting operation, which includes addition,
13139 -- division, exponentiation, multiplication, subtraction, absolute
13140 -- value and unary negation. Unary "+" is omitted since it is a
13141 -- no-op and thus can't overflow.
13143 and then Nkind_In (Operand, N_Op_Abs,
13150 end Integer_Promotion_Possible;
13152 ------------------------------
13153 -- Make_Array_Comparison_Op --
13154 ------------------------------
13156 -- This is a hand-coded expansion of the following generic function:
13159 -- type elem is (<>);
13160 -- type index is (<>);
13161 -- type a is array (index range <>) of elem;
13163 -- function Gnnn (X : a; Y: a) return boolean is
13164 -- J : index := Y'first;
13167 -- if X'length = 0 then
13170 -- elsif Y'length = 0 then
13174 -- for I in X'range loop
13175 -- if X (I) = Y (J) then
13176 -- if J = Y'last then
13179 -- J := index'succ (J);
13183 -- return X (I) > Y (J);
13187 -- return X'length > Y'length;
13191 -- Note that since we are essentially doing this expansion by hand, we
13192 -- do not need to generate an actual or formal generic part, just the
13193 -- instantiated function itself.
13195 -- Perhaps we could have the actual generic available in the run-time,
13196 -- obtained by rtsfind, and actually expand a real instantiation ???
13198 function Make_Array_Comparison_Op
13200 Nod : Node_Id) return Node_Id
13202 Loc : constant Source_Ptr := Sloc (Nod);
13204 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
13205 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
13206 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
13207 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13209 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
13211 Loop_Statement : Node_Id;
13212 Loop_Body : Node_Id;
13214 Inner_If : Node_Id;
13215 Final_Expr : Node_Id;
13216 Func_Body : Node_Id;
13217 Func_Name : Entity_Id;
13223 -- if J = Y'last then
13226 -- J := index'succ (J);
13230 Make_Implicit_If_Statement (Nod,
13233 Left_Opnd => New_Occurrence_Of (J, Loc),
13235 Make_Attribute_Reference (Loc,
13236 Prefix => New_Occurrence_Of (Y, Loc),
13237 Attribute_Name => Name_Last)),
13239 Then_Statements => New_List (
13240 Make_Exit_Statement (Loc)),
13244 Make_Assignment_Statement (Loc,
13245 Name => New_Occurrence_Of (J, Loc),
13247 Make_Attribute_Reference (Loc,
13248 Prefix => New_Occurrence_Of (Index, Loc),
13249 Attribute_Name => Name_Succ,
13250 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
13252 -- if X (I) = Y (J) then
13255 -- return X (I) > Y (J);
13259 Make_Implicit_If_Statement (Nod,
13263 Make_Indexed_Component (Loc,
13264 Prefix => New_Occurrence_Of (X, Loc),
13265 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13268 Make_Indexed_Component (Loc,
13269 Prefix => New_Occurrence_Of (Y, Loc),
13270 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
13272 Then_Statements => New_List (Inner_If),
13274 Else_Statements => New_List (
13275 Make_Simple_Return_Statement (Loc,
13279 Make_Indexed_Component (Loc,
13280 Prefix => New_Occurrence_Of (X, Loc),
13281 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13284 Make_Indexed_Component (Loc,
13285 Prefix => New_Occurrence_Of (Y, Loc),
13286 Expressions => New_List (
13287 New_Occurrence_Of (J, Loc)))))));
13289 -- for I in X'range loop
13294 Make_Implicit_Loop_Statement (Nod,
13295 Identifier => Empty,
13297 Iteration_Scheme =>
13298 Make_Iteration_Scheme (Loc,
13299 Loop_Parameter_Specification =>
13300 Make_Loop_Parameter_Specification (Loc,
13301 Defining_Identifier => I,
13302 Discrete_Subtype_Definition =>
13303 Make_Attribute_Reference (Loc,
13304 Prefix => New_Occurrence_Of (X, Loc),
13305 Attribute_Name => Name_Range))),
13307 Statements => New_List (Loop_Body));
13309 -- if X'length = 0 then
13311 -- elsif Y'length = 0 then
13314 -- for ... loop ... end loop;
13315 -- return X'length > Y'length;
13319 Make_Attribute_Reference (Loc,
13320 Prefix => New_Occurrence_Of (X, Loc),
13321 Attribute_Name => Name_Length);
13324 Make_Attribute_Reference (Loc,
13325 Prefix => New_Occurrence_Of (Y, Loc),
13326 Attribute_Name => Name_Length);
13330 Left_Opnd => Length1,
13331 Right_Opnd => Length2);
13334 Make_Implicit_If_Statement (Nod,
13338 Make_Attribute_Reference (Loc,
13339 Prefix => New_Occurrence_Of (X, Loc),
13340 Attribute_Name => Name_Length),
13342 Make_Integer_Literal (Loc, 0)),
13346 Make_Simple_Return_Statement (Loc,
13347 Expression => New_Occurrence_Of (Standard_False, Loc))),
13349 Elsif_Parts => New_List (
13350 Make_Elsif_Part (Loc,
13354 Make_Attribute_Reference (Loc,
13355 Prefix => New_Occurrence_Of (Y, Loc),
13356 Attribute_Name => Name_Length),
13358 Make_Integer_Literal (Loc, 0)),
13362 Make_Simple_Return_Statement (Loc,
13363 Expression => New_Occurrence_Of (Standard_True, Loc))))),
13365 Else_Statements => New_List (
13367 Make_Simple_Return_Statement (Loc,
13368 Expression => Final_Expr)));
13372 Formals := New_List (
13373 Make_Parameter_Specification (Loc,
13374 Defining_Identifier => X,
13375 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13377 Make_Parameter_Specification (Loc,
13378 Defining_Identifier => Y,
13379 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13381 -- function Gnnn (...) return boolean is
13382 -- J : index := Y'first;
13387 Func_Name := Make_Temporary (Loc, 'G');
13390 Make_Subprogram_Body (Loc,
13392 Make_Function_Specification (Loc,
13393 Defining_Unit_Name => Func_Name,
13394 Parameter_Specifications => Formals,
13395 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
13397 Declarations => New_List (
13398 Make_Object_Declaration (Loc,
13399 Defining_Identifier => J,
13400 Object_Definition => New_Occurrence_Of (Index, Loc),
13402 Make_Attribute_Reference (Loc,
13403 Prefix => New_Occurrence_Of (Y, Loc),
13404 Attribute_Name => Name_First))),
13406 Handled_Statement_Sequence =>
13407 Make_Handled_Sequence_Of_Statements (Loc,
13408 Statements => New_List (If_Stat)));
13411 end Make_Array_Comparison_Op;
13413 ---------------------------
13414 -- Make_Boolean_Array_Op --
13415 ---------------------------
13417 -- For logical operations on boolean arrays, expand in line the following,
13418 -- replacing 'and' with 'or' or 'xor' where needed:
13420 -- function Annn (A : typ; B: typ) return typ is
13423 -- for J in A'range loop
13424 -- C (J) := A (J) op B (J);
13429 -- Here typ is the boolean array type
13431 function Make_Boolean_Array_Op
13433 N : Node_Id) return Node_Id
13435 Loc : constant Source_Ptr := Sloc (N);
13437 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
13438 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
13439 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
13440 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13448 Func_Name : Entity_Id;
13449 Func_Body : Node_Id;
13450 Loop_Statement : Node_Id;
13454 Make_Indexed_Component (Loc,
13455 Prefix => New_Occurrence_Of (A, Loc),
13456 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13459 Make_Indexed_Component (Loc,
13460 Prefix => New_Occurrence_Of (B, Loc),
13461 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13464 Make_Indexed_Component (Loc,
13465 Prefix => New_Occurrence_Of (C, Loc),
13466 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13468 if Nkind (N) = N_Op_And then
13472 Right_Opnd => B_J);
13474 elsif Nkind (N) = N_Op_Or then
13478 Right_Opnd => B_J);
13484 Right_Opnd => B_J);
13488 Make_Implicit_Loop_Statement (N,
13489 Identifier => Empty,
13491 Iteration_Scheme =>
13492 Make_Iteration_Scheme (Loc,
13493 Loop_Parameter_Specification =>
13494 Make_Loop_Parameter_Specification (Loc,
13495 Defining_Identifier => J,
13496 Discrete_Subtype_Definition =>
13497 Make_Attribute_Reference (Loc,
13498 Prefix => New_Occurrence_Of (A, Loc),
13499 Attribute_Name => Name_Range))),
13501 Statements => New_List (
13502 Make_Assignment_Statement (Loc,
13504 Expression => Op)));
13506 Formals := New_List (
13507 Make_Parameter_Specification (Loc,
13508 Defining_Identifier => A,
13509 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13511 Make_Parameter_Specification (Loc,
13512 Defining_Identifier => B,
13513 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13515 Func_Name := Make_Temporary (Loc, 'A');
13516 Set_Is_Inlined (Func_Name);
13519 Make_Subprogram_Body (Loc,
13521 Make_Function_Specification (Loc,
13522 Defining_Unit_Name => Func_Name,
13523 Parameter_Specifications => Formals,
13524 Result_Definition => New_Occurrence_Of (Typ, Loc)),
13526 Declarations => New_List (
13527 Make_Object_Declaration (Loc,
13528 Defining_Identifier => C,
13529 Object_Definition => New_Occurrence_Of (Typ, Loc))),
13531 Handled_Statement_Sequence =>
13532 Make_Handled_Sequence_Of_Statements (Loc,
13533 Statements => New_List (
13535 Make_Simple_Return_Statement (Loc,
13536 Expression => New_Occurrence_Of (C, Loc)))));
13539 end Make_Boolean_Array_Op;
13541 -----------------------------------------
13542 -- Minimized_Eliminated_Overflow_Check --
13543 -----------------------------------------
13545 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
13548 Is_Signed_Integer_Type (Etype (N))
13549 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
13550 end Minimized_Eliminated_Overflow_Check;
13552 --------------------------------
13553 -- Optimize_Length_Comparison --
13554 --------------------------------
13556 procedure Optimize_Length_Comparison (N : Node_Id) is
13557 Loc : constant Source_Ptr := Sloc (N);
13558 Typ : constant Entity_Id := Etype (N);
13563 -- First and Last attribute reference nodes, which end up as left and
13564 -- right operands of the optimized result.
13567 -- True for comparison operand of zero
13570 -- Comparison operand, set only if Is_Zero is false
13572 Ent : Entity_Id := Empty;
13573 -- Entity whose length is being compared
13575 Index : Node_Id := Empty;
13576 -- Integer_Literal node for length attribute expression, or Empty
13577 -- if there is no such expression present.
13580 -- Type of array index to which 'Length is applied
13582 Op : Node_Kind := Nkind (N);
13583 -- Kind of comparison operator, gets flipped if operands backwards
13585 function Is_Optimizable (N : Node_Id) return Boolean;
13586 -- Tests N to see if it is an optimizable comparison value (defined as
13587 -- constant zero or one, or something else where the value is known to
13588 -- be positive and in the range of 32-bits, and where the corresponding
13589 -- Length value is also known to be 32-bits. If result is true, sets
13590 -- Is_Zero, Ityp, and Comp accordingly.
13592 function Is_Entity_Length (N : Node_Id) return Boolean;
13593 -- Tests if N is a length attribute applied to a simple entity. If so,
13594 -- returns True, and sets Ent to the entity, and Index to the integer
13595 -- literal provided as an attribute expression, or to Empty if none.
13596 -- Also returns True if the expression is a generated type conversion
13597 -- whose expression is of the desired form. This latter case arises
13598 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
13599 -- to check for being in range, which is not needed in this context.
13600 -- Returns False if neither condition holds.
13602 function Prepare_64 (N : Node_Id) return Node_Id;
13603 -- Given a discrete expression, returns a Long_Long_Integer typed
13604 -- expression representing the underlying value of the expression.
13605 -- This is done with an unchecked conversion to the result type. We
13606 -- use unchecked conversion to handle the enumeration type case.
13608 ----------------------
13609 -- Is_Entity_Length --
13610 ----------------------
13612 function Is_Entity_Length (N : Node_Id) return Boolean is
13614 if Nkind (N) = N_Attribute_Reference
13615 and then Attribute_Name (N) = Name_Length
13616 and then Is_Entity_Name (Prefix (N))
13618 Ent := Entity (Prefix (N));
13620 if Present (Expressions (N)) then
13621 Index := First (Expressions (N));
13628 elsif Nkind (N) = N_Type_Conversion
13629 and then not Comes_From_Source (N)
13631 return Is_Entity_Length (Expression (N));
13636 end Is_Entity_Length;
13638 --------------------
13639 -- Is_Optimizable --
13640 --------------------
13642 function Is_Optimizable (N : Node_Id) return Boolean is
13650 if Compile_Time_Known_Value (N) then
13651 Val := Expr_Value (N);
13653 if Val = Uint_0 then
13658 elsif Val = Uint_1 then
13665 -- Here we have to make sure of being within 32-bits
13667 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
13670 or else Lo < Uint_1
13671 or else Hi > UI_From_Int (Int'Last)
13676 -- Comparison value was within range, so now we must check the index
13677 -- value to make sure it is also within 32-bits.
13679 Indx := First_Index (Etype (Ent));
13681 if Present (Index) then
13682 for J in 2 .. UI_To_Int (Intval (Index)) loop
13687 Ityp := Etype (Indx);
13689 if Esize (Ityp) > 32 then
13696 end Is_Optimizable;
13702 function Prepare_64 (N : Node_Id) return Node_Id is
13704 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
13707 -- Start of processing for Optimize_Length_Comparison
13710 -- Nothing to do if not a comparison
13712 if Op not in N_Op_Compare then
13716 -- Nothing to do if special -gnatd.P debug flag set.
13718 if Debug_Flag_Dot_PP then
13722 -- Ent'Length op 0/1
13724 if Is_Entity_Length (Left_Opnd (N))
13725 and then Is_Optimizable (Right_Opnd (N))
13729 -- 0/1 op Ent'Length
13731 elsif Is_Entity_Length (Right_Opnd (N))
13732 and then Is_Optimizable (Left_Opnd (N))
13734 -- Flip comparison to opposite sense
13737 when N_Op_Lt => Op := N_Op_Gt;
13738 when N_Op_Le => Op := N_Op_Ge;
13739 when N_Op_Gt => Op := N_Op_Lt;
13740 when N_Op_Ge => Op := N_Op_Le;
13741 when others => null;
13744 -- Else optimization not possible
13750 -- Fall through if we will do the optimization
13752 -- Cases to handle:
13754 -- X'Length = 0 => X'First > X'Last
13755 -- X'Length = 1 => X'First = X'Last
13756 -- X'Length = n => X'First + (n - 1) = X'Last
13758 -- X'Length /= 0 => X'First <= X'Last
13759 -- X'Length /= 1 => X'First /= X'Last
13760 -- X'Length /= n => X'First + (n - 1) /= X'Last
13762 -- X'Length >= 0 => always true, warn
13763 -- X'Length >= 1 => X'First <= X'Last
13764 -- X'Length >= n => X'First + (n - 1) <= X'Last
13766 -- X'Length > 0 => X'First <= X'Last
13767 -- X'Length > 1 => X'First < X'Last
13768 -- X'Length > n => X'First + (n - 1) < X'Last
13770 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
13771 -- X'Length <= 1 => X'First >= X'Last
13772 -- X'Length <= n => X'First + (n - 1) >= X'Last
13774 -- X'Length < 0 => always false (warn)
13775 -- X'Length < 1 => X'First > X'Last
13776 -- X'Length < n => X'First + (n - 1) > X'Last
13778 -- Note: for the cases of n (not constant 0,1), we require that the
13779 -- corresponding index type be integer or shorter (i.e. not 64-bit),
13780 -- and the same for the comparison value. Then we do the comparison
13781 -- using 64-bit arithmetic (actually long long integer), so that we
13782 -- cannot have overflow intefering with the result.
13784 -- First deal with warning cases
13793 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
13794 Analyze_And_Resolve (N, Typ);
13795 Warn_On_Known_Condition (N);
13802 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
13803 Analyze_And_Resolve (N, Typ);
13804 Warn_On_Known_Condition (N);
13808 if Constant_Condition_Warnings
13809 and then Comes_From_Source (Original_Node (N))
13811 Error_Msg_N ("could replace by ""'=""?c?", N);
13821 -- Build the First reference we will use
13824 Make_Attribute_Reference (Loc,
13825 Prefix => New_Occurrence_Of (Ent, Loc),
13826 Attribute_Name => Name_First);
13828 if Present (Index) then
13829 Set_Expressions (Left, New_List (New_Copy (Index)));
13832 -- If general value case, then do the addition of (n - 1), and
13833 -- also add the needed conversions to type Long_Long_Integer.
13835 if Present (Comp) then
13838 Left_Opnd => Prepare_64 (Left),
13840 Make_Op_Subtract (Loc,
13841 Left_Opnd => Prepare_64 (Comp),
13842 Right_Opnd => Make_Integer_Literal (Loc, 1)));
13845 -- Build the Last reference we will use
13848 Make_Attribute_Reference (Loc,
13849 Prefix => New_Occurrence_Of (Ent, Loc),
13850 Attribute_Name => Name_Last);
13852 if Present (Index) then
13853 Set_Expressions (Right, New_List (New_Copy (Index)));
13856 -- If general operand, convert Last reference to Long_Long_Integer
13858 if Present (Comp) then
13859 Right := Prepare_64 (Right);
13862 -- Check for cases to optimize
13864 -- X'Length = 0 => X'First > X'Last
13865 -- X'Length < 1 => X'First > X'Last
13866 -- X'Length < n => X'First + (n - 1) > X'Last
13868 if (Is_Zero and then Op = N_Op_Eq)
13869 or else (not Is_Zero and then Op = N_Op_Lt)
13874 Right_Opnd => Right);
13876 -- X'Length = 1 => X'First = X'Last
13877 -- X'Length = n => X'First + (n - 1) = X'Last
13879 elsif not Is_Zero and then Op = N_Op_Eq then
13883 Right_Opnd => Right);
13885 -- X'Length /= 0 => X'First <= X'Last
13886 -- X'Length > 0 => X'First <= X'Last
13888 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
13892 Right_Opnd => Right);
13894 -- X'Length /= 1 => X'First /= X'Last
13895 -- X'Length /= n => X'First + (n - 1) /= X'Last
13897 elsif not Is_Zero and then Op = N_Op_Ne then
13901 Right_Opnd => Right);
13903 -- X'Length >= 1 => X'First <= X'Last
13904 -- X'Length >= n => X'First + (n - 1) <= X'Last
13906 elsif not Is_Zero and then Op = N_Op_Ge then
13910 Right_Opnd => Right);
13912 -- X'Length > 1 => X'First < X'Last
13913 -- X'Length > n => X'First + (n = 1) < X'Last
13915 elsif not Is_Zero and then Op = N_Op_Gt then
13919 Right_Opnd => Right);
13921 -- X'Length <= 1 => X'First >= X'Last
13922 -- X'Length <= n => X'First + (n - 1) >= X'Last
13924 elsif not Is_Zero and then Op = N_Op_Le then
13928 Right_Opnd => Right);
13930 -- Should not happen at this stage
13933 raise Program_Error;
13936 -- Rewrite and finish up
13938 Rewrite (N, Result);
13939 Analyze_And_Resolve (N, Typ);
13941 end Optimize_Length_Comparison;
13943 --------------------------------
13944 -- Process_If_Case_Statements --
13945 --------------------------------
13947 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
13951 Decl := First (Stmts);
13952 while Present (Decl) loop
13953 if Nkind (Decl) = N_Object_Declaration
13954 and then Is_Finalizable_Transient (Decl, N)
13956 Process_Transient_In_Expression (Decl, N, Stmts);
13961 end Process_If_Case_Statements;
13963 -------------------------------------
13964 -- Process_Transient_In_Expression --
13965 -------------------------------------
13967 procedure Process_Transient_In_Expression
13968 (Obj_Decl : Node_Id;
13972 Loc : constant Source_Ptr := Sloc (Obj_Decl);
13973 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
13975 Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
13976 -- The node on which to insert the hook as an action. This is usually
13977 -- the innermost enclosing non-transient construct.
13979 Fin_Call : Node_Id;
13980 Hook_Assign : Node_Id;
13981 Hook_Clear : Node_Id;
13982 Hook_Decl : Node_Id;
13983 Hook_Insert : Node_Id;
13984 Ptr_Decl : Node_Id;
13986 Fin_Context : Node_Id;
13987 -- The node after which to insert the finalization actions of the
13988 -- transient object.
13991 pragma Assert (Nkind_In (Expr, N_Case_Expression,
13992 N_Expression_With_Actions,
13995 -- When the context is a Boolean evaluation, all three nodes capture the
13996 -- result of their computation in a local temporary:
13999 -- Trans_Id : Ctrl_Typ := ...;
14000 -- Result : constant Boolean := ... Trans_Id ...;
14001 -- <finalize Trans_Id>
14004 -- As a result, the finalization of any transient objects can safely
14005 -- take place after the result capture.
14007 -- ??? could this be extended to elementary types?
14009 if Is_Boolean_Type (Etype (Expr)) then
14010 Fin_Context := Last (Stmts);
14012 -- Otherwise the immediate context may not be safe enough to carry
14013 -- out transient object finalization due to aliasing and nesting of
14014 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14015 -- enclosing non-transient construct.
14018 Fin_Context := Hook_Context;
14021 -- Mark the transient object as successfully processed to avoid double
14024 Set_Is_Finalized_Transient (Obj_Id);
14026 -- Construct all the pieces necessary to hook and finalize a transient
14029 Build_Transient_Object_Statements
14030 (Obj_Decl => Obj_Decl,
14031 Fin_Call => Fin_Call,
14032 Hook_Assign => Hook_Assign,
14033 Hook_Clear => Hook_Clear,
14034 Hook_Decl => Hook_Decl,
14035 Ptr_Decl => Ptr_Decl,
14036 Finalize_Obj => False);
14038 -- Add the access type which provides a reference to the transient
14039 -- object. Generate:
14041 -- type Ptr_Typ is access all Desig_Typ;
14043 Insert_Action (Hook_Context, Ptr_Decl);
14045 -- Add the temporary which acts as a hook to the transient object.
14048 -- Hook : Ptr_Id := null;
14050 Insert_Action (Hook_Context, Hook_Decl);
14052 -- When the transient object is initialized by an aggregate, the hook
14053 -- must capture the object after the last aggregate assignment takes
14054 -- place. Only then is the object considered initialized. Generate:
14056 -- Hook := Ptr_Typ (Obj_Id);
14058 -- Hook := Obj_Id'Unrestricted_Access;
14060 if Ekind_In (Obj_Id, E_Constant, E_Variable)
14061 and then Present (Last_Aggregate_Assignment (Obj_Id))
14063 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
14065 -- Otherwise the hook seizes the related object immediately
14068 Hook_Insert := Obj_Decl;
14071 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
14073 -- When the node is part of a return statement, there is no need to
14074 -- insert a finalization call, as the general finalization mechanism
14075 -- (see Build_Finalizer) would take care of the transient object on
14076 -- subprogram exit. Note that it would also be impossible to insert the
14077 -- finalization code after the return statement as this will render it
14080 if Nkind (Fin_Context) = N_Simple_Return_Statement then
14083 -- Finalize the hook after the context has been evaluated. Generate:
14085 -- if Hook /= null then
14086 -- [Deep_]Finalize (Hook.all);
14091 Insert_Action_After (Fin_Context,
14092 Make_Implicit_If_Statement (Obj_Decl,
14096 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
14097 Right_Opnd => Make_Null (Loc)),
14099 Then_Statements => New_List (
14103 end Process_Transient_In_Expression;
14105 ------------------------
14106 -- Rewrite_Comparison --
14107 ------------------------
14109 procedure Rewrite_Comparison (N : Node_Id) is
14110 Typ : constant Entity_Id := Etype (N);
14112 False_Result : Boolean;
14113 True_Result : Boolean;
14116 if Nkind (N) = N_Type_Conversion then
14117 Rewrite_Comparison (Expression (N));
14120 elsif Nkind (N) not in N_Op_Compare then
14124 -- Determine the potential outcome of the comparison assuming that the
14125 -- operands are valid and emit a warning when the comparison evaluates
14126 -- to True or False only in the presence of invalid values.
14128 Warn_On_Constant_Valid_Condition (N);
14130 -- Determine the potential outcome of the comparison assuming that the
14131 -- operands are not valid.
14135 Assume_Valid => False,
14136 True_Result => True_Result,
14137 False_Result => False_Result);
14139 -- The outcome is a decisive False or True, rewrite the operator
14141 if False_Result or True_Result then
14144 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
14146 Analyze_And_Resolve (N, Typ);
14147 Warn_On_Known_Condition (N);
14149 end Rewrite_Comparison;
14151 ----------------------------
14152 -- Safe_In_Place_Array_Op --
14153 ----------------------------
14155 function Safe_In_Place_Array_Op
14158 Op2 : Node_Id) return Boolean
14160 Target : Entity_Id;
14162 function Is_Safe_Operand (Op : Node_Id) return Boolean;
14163 -- Operand is safe if it cannot overlap part of the target of the
14164 -- operation. If the operand and the target are identical, the operand
14165 -- is safe. The operand can be empty in the case of negation.
14167 function Is_Unaliased (N : Node_Id) return Boolean;
14168 -- Check that N is a stand-alone entity
14174 function Is_Unaliased (N : Node_Id) return Boolean is
14178 and then No (Address_Clause (Entity (N)))
14179 and then No (Renamed_Object (Entity (N)));
14182 ---------------------
14183 -- Is_Safe_Operand --
14184 ---------------------
14186 function Is_Safe_Operand (Op : Node_Id) return Boolean is
14191 elsif Is_Entity_Name (Op) then
14192 return Is_Unaliased (Op);
14194 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
14195 return Is_Unaliased (Prefix (Op));
14197 elsif Nkind (Op) = N_Slice then
14199 Is_Unaliased (Prefix (Op))
14200 and then Entity (Prefix (Op)) /= Target;
14202 elsif Nkind (Op) = N_Op_Not then
14203 return Is_Safe_Operand (Right_Opnd (Op));
14208 end Is_Safe_Operand;
14210 -- Start of processing for Safe_In_Place_Array_Op
14213 -- Skip this processing if the component size is different from system
14214 -- storage unit (since at least for NOT this would cause problems).
14216 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
14219 -- Cannot do in place stuff if non-standard Boolean representation
14221 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
14224 elsif not Is_Unaliased (Lhs) then
14228 Target := Entity (Lhs);
14229 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
14231 end Safe_In_Place_Array_Op;
14233 -----------------------
14234 -- Tagged_Membership --
14235 -----------------------
14237 -- There are two different cases to consider depending on whether the right
14238 -- operand is a class-wide type or not. If not we just compare the actual
14239 -- tag of the left expr to the target type tag:
14241 -- Left_Expr.Tag = Right_Type'Tag;
14243 -- If it is a class-wide type we use the RT function CW_Membership which is
14244 -- usually implemented by looking in the ancestor tables contained in the
14245 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
14247 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
14248 -- function IW_Membership which is usually implemented by looking in the
14249 -- table of abstract interface types plus the ancestor table contained in
14250 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
14252 procedure Tagged_Membership
14254 SCIL_Node : out Node_Id;
14255 Result : out Node_Id)
14257 Left : constant Node_Id := Left_Opnd (N);
14258 Right : constant Node_Id := Right_Opnd (N);
14259 Loc : constant Source_Ptr := Sloc (N);
14261 Full_R_Typ : Entity_Id;
14262 Left_Type : Entity_Id;
14263 New_Node : Node_Id;
14264 Right_Type : Entity_Id;
14268 SCIL_Node := Empty;
14270 -- Handle entities from the limited view
14272 Left_Type := Available_View (Etype (Left));
14273 Right_Type := Available_View (Etype (Right));
14275 -- In the case where the type is an access type, the test is applied
14276 -- using the designated types (needed in Ada 2012 for implicit anonymous
14277 -- access conversions, for AI05-0149).
14279 if Is_Access_Type (Right_Type) then
14280 Left_Type := Designated_Type (Left_Type);
14281 Right_Type := Designated_Type (Right_Type);
14284 if Is_Class_Wide_Type (Left_Type) then
14285 Left_Type := Root_Type (Left_Type);
14288 if Is_Class_Wide_Type (Right_Type) then
14289 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
14291 Full_R_Typ := Underlying_Type (Right_Type);
14295 Make_Selected_Component (Loc,
14296 Prefix => Relocate_Node (Left),
14298 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
14300 if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
14302 -- No need to issue a run-time check if we statically know that the
14303 -- result of this membership test is always true. For example,
14304 -- considering the following declarations:
14306 -- type Iface is interface;
14307 -- type T is tagged null record;
14308 -- type DT is new T and Iface with null record;
14313 -- These membership tests are always true:
14316 -- Obj2 in T'Class;
14317 -- Obj2 in Iface'Class;
14319 -- We do not need to handle cases where the membership is illegal.
14322 -- Obj1 in DT'Class; -- Compile time error
14323 -- Obj1 in Iface'Class; -- Compile time error
14325 if not Is_Interface (Left_Type)
14326 and then not Is_Class_Wide_Type (Left_Type)
14327 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
14328 Use_Full_View => True)
14329 or else (Is_Interface (Etype (Right_Type))
14330 and then Interface_Present_In_Ancestor
14332 Iface => Etype (Right_Type))))
14334 Result := New_Occurrence_Of (Standard_True, Loc);
14338 -- Ada 2005 (AI-251): Class-wide applied to interfaces
14340 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
14342 -- Support to: "Iface_CW_Typ in Typ'Class"
14344 or else Is_Interface (Left_Type)
14346 -- Issue error if IW_Membership operation not available in a
14347 -- configurable run time setting.
14349 if not RTE_Available (RE_IW_Membership) then
14351 ("dynamic membership test on interface types", N);
14357 Make_Function_Call (Loc,
14358 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
14359 Parameter_Associations => New_List (
14360 Make_Attribute_Reference (Loc,
14362 Attribute_Name => Name_Address),
14363 New_Occurrence_Of (
14364 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
14367 -- Ada 95: Normal case
14370 Build_CW_Membership (Loc,
14371 Obj_Tag_Node => Obj_Tag,
14373 New_Occurrence_Of (
14374 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
14376 New_Node => New_Node);
14378 -- Generate the SCIL node for this class-wide membership test.
14379 -- Done here because the previous call to Build_CW_Membership
14380 -- relocates Obj_Tag.
14382 if Generate_SCIL then
14383 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
14384 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
14385 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
14388 Result := New_Node;
14391 -- Right_Type is not a class-wide type
14394 -- No need to check the tag of the object if Right_Typ is abstract
14396 if Is_Abstract_Type (Right_Type) then
14397 Result := New_Occurrence_Of (Standard_False, Loc);
14402 Left_Opnd => Obj_Tag,
14405 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
14408 end Tagged_Membership;
14410 ------------------------------
14411 -- Unary_Op_Validity_Checks --
14412 ------------------------------
14414 procedure Unary_Op_Validity_Checks (N : Node_Id) is
14416 if Validity_Checks_On and Validity_Check_Operands then
14417 Ensure_Valid (Right_Opnd (N));
14419 end Unary_Op_Validity_Checks;