1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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;
76 package body Exp_Ch4 is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Binary_Op_Validity_Checks (N : Node_Id);
83 pragma Inline (Binary_Op_Validity_Checks);
84 -- Performs validity checks for a binary operator
86 procedure Build_Boolean_Array_Proc_Call
90 -- If a boolean array assignment can be done in place, build call to
91 -- corresponding library procedure.
93 procedure Displace_Allocator_Pointer (N : Node_Id);
94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
95 -- Expand_Allocator_Expression. Allocating class-wide interface objects
96 -- this routine displaces the pointer to the allocated object to reference
97 -- the component referencing the corresponding secondary dispatch table.
99 procedure Expand_Allocator_Expression (N : Node_Id);
100 -- Subsidiary to Expand_N_Allocator, for the case when the expression
101 -- is a qualified expression or an aggregate.
103 procedure Expand_Array_Comparison (N : Node_Id);
104 -- This routine handles expansion of the comparison operators (N_Op_Lt,
105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
106 -- code for these operators is similar, differing only in the details of
107 -- the actual comparison call that is made. Special processing (call a
110 function Expand_Array_Equality
115 Typ : Entity_Id) return Node_Id;
116 -- Expand an array equality into a call to a function implementing this
117 -- equality, and a call to it. Loc is the location for the generated nodes.
118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
119 -- on which to attach bodies of local functions that are created in the
120 -- process. It is the responsibility of the caller to insert those bodies
121 -- at the right place. Nod provides the Sloc value for the generated code.
122 -- Normally the types used for the generated equality routine are taken
123 -- from Lhs and Rhs. However, in some situations of generated code, the
124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
125 -- the type to be used for the formal parameters.
127 procedure Expand_Boolean_Operator (N : Node_Id);
128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
129 -- case of array type arguments.
131 procedure Expand_Short_Circuit_Operator (N : Node_Id);
132 -- Common expansion processing for short-circuit boolean operators
134 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
135 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
136 -- where we allow comparison of "out of range" values.
138 function Expand_Composite_Equality
143 Bodies : List_Id) return Node_Id;
144 -- Local recursive function used to expand equality for nested composite
145 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
146 -- to attach bodies of local functions that are created in the process. It
147 -- is the responsibility of the caller to insert those bodies at the right
148 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
149 -- the left and right sides for the comparison, and Typ is the type of the
150 -- objects to compare.
152 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
153 -- Routine to expand concatenation of a sequence of two or more operands
154 -- (in the list Operands) and replace node Cnode with the result of the
155 -- concatenation. The operands can be of any appropriate type, and can
156 -- include both arrays and singleton elements.
158 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
159 -- N is an N_In membership test mode, with the overflow check mode set to
160 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
161 -- integer type. This is a case where top level processing is required to
162 -- handle overflow checks in subtrees.
164 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
165 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
166 -- fixed. We do not have such a type at runtime, so the purpose of this
167 -- routine is to find the real type by looking up the tree. We also
168 -- determine if the operation must be rounded.
170 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
171 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
172 -- discriminants if it has a constrained nominal type, unless the object
173 -- is a component of an enclosing Unchecked_Union object that is subject
174 -- to a per-object constraint and the enclosing object lacks inferable
177 -- An expression of an Unchecked_Union type has inferable discriminants
178 -- if it is either a name of an object with inferable discriminants or a
179 -- qualified expression whose subtype mark denotes a constrained subtype.
181 procedure Insert_Dereference_Action (N : Node_Id);
182 -- N is an expression whose type is an access. When the type of the
183 -- associated storage pool is derived from Checked_Pool, generate a
184 -- call to the 'Dereference' primitive operation.
186 function Make_Array_Comparison_Op
188 Nod : Node_Id) return Node_Id;
189 -- Comparisons between arrays are expanded in line. This function produces
190 -- the body of the implementation of (a > b), where a and b are one-
191 -- dimensional arrays of some discrete type. The original node is then
192 -- expanded into the appropriate call to this function. Nod provides the
193 -- Sloc value for the generated code.
195 function Make_Boolean_Array_Op
197 N : Node_Id) return Node_Id;
198 -- Boolean operations on boolean arrays are expanded in line. This function
199 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
200 -- b). It is used only the normal case and not the packed case. The type
201 -- involved, Typ, is the Boolean array type, and the logical operations in
202 -- the body are simple boolean operations. Note that Typ is always a
203 -- constrained type (the caller has ensured this by using
204 -- Convert_To_Actual_Subtype if necessary).
206 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
207 -- For signed arithmetic operations when the current overflow mode is
208 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
209 -- as the first thing we do. We then return. We count on the recursive
210 -- apparatus for overflow checks to call us back with an equivalent
211 -- operation that is in CHECKED mode, avoiding a recursive entry into this
212 -- routine, and that is when we will proceed with the expansion of the
213 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
214 -- these optimizations without first making this check, since there may be
215 -- operands further down the tree that are relying on the recursive calls
216 -- triggered by the top level nodes to properly process overflow checking
217 -- and remaining expansion on these nodes. Note that this call back may be
218 -- skipped if the operation is done in Bignum mode but that's fine, since
219 -- the Bignum call takes care of everything.
221 procedure Optimize_Length_Comparison (N : Node_Id);
222 -- Given an expression, if it is of the form X'Length op N (or the other
223 -- way round), where N is known at compile time to be 0 or 1, and X is a
224 -- simple entity, and op is a comparison operator, optimizes it into a
225 -- comparison of First and Last.
227 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
228 -- Inspect and process statement list Stmt of if or case expression N for
229 -- transient objects. If such objects are found, the routine generates code
230 -- to clean them up when the context of the expression is evaluated.
232 procedure Process_Transient_In_Expression
236 -- Subsidiary routine to the expansion of expression_with_actions, if and
237 -- case expressions. Generate all necessary code to finalize a transient
238 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
239 -- denotes the declaration of the transient object, which is usually the
240 -- result of a controlled function call. Expr denotes the expression with
241 -- actions, if expression, or case expression node. Stmts denotes the
242 -- statement list which contains Decl, either at the top level or within a
245 procedure Rewrite_Comparison (N : Node_Id);
246 -- If N is the node for a comparison whose outcome can be determined at
247 -- compile time, then the node N can be rewritten with True or False. If
248 -- the outcome cannot be determined at compile time, the call has no
249 -- effect. If N is a type conversion, then this processing is applied to
250 -- its expression. If N is neither comparison nor a type conversion, the
251 -- call has no effect.
253 procedure Tagged_Membership
255 SCIL_Node : out Node_Id;
256 Result : out Node_Id);
257 -- Construct the expression corresponding to the tagged membership test.
258 -- Deals with a second operand being (or not) a class-wide type.
260 function Safe_In_Place_Array_Op
263 Op2 : Node_Id) return Boolean;
264 -- In the context of an assignment, where the right-hand side is a boolean
265 -- operation on arrays, check whether operation can be performed in place.
267 procedure Unary_Op_Validity_Checks (N : Node_Id);
268 pragma Inline (Unary_Op_Validity_Checks);
269 -- Performs validity checks for a unary operator
271 -------------------------------
272 -- Binary_Op_Validity_Checks --
273 -------------------------------
275 procedure Binary_Op_Validity_Checks (N : Node_Id) is
277 if Validity_Checks_On and Validity_Check_Operands then
278 Ensure_Valid (Left_Opnd (N));
279 Ensure_Valid (Right_Opnd (N));
281 end Binary_Op_Validity_Checks;
283 ------------------------------------
284 -- Build_Boolean_Array_Proc_Call --
285 ------------------------------------
287 procedure Build_Boolean_Array_Proc_Call
292 Loc : constant Source_Ptr := Sloc (N);
293 Kind : constant Node_Kind := Nkind (Expression (N));
294 Target : constant Node_Id :=
295 Make_Attribute_Reference (Loc,
297 Attribute_Name => Name_Address);
299 Arg1 : Node_Id := Op1;
300 Arg2 : Node_Id := Op2;
302 Proc_Name : Entity_Id;
305 if Kind = N_Op_Not then
306 if Nkind (Op1) in N_Binary_Op then
308 -- Use negated version of the binary operators
310 if Nkind (Op1) = N_Op_And then
311 Proc_Name := RTE (RE_Vector_Nand);
313 elsif Nkind (Op1) = N_Op_Or then
314 Proc_Name := RTE (RE_Vector_Nor);
316 else pragma Assert (Nkind (Op1) = N_Op_Xor);
317 Proc_Name := RTE (RE_Vector_Xor);
321 Make_Procedure_Call_Statement (Loc,
322 Name => New_Occurrence_Of (Proc_Name, Loc),
324 Parameter_Associations => New_List (
326 Make_Attribute_Reference (Loc,
327 Prefix => Left_Opnd (Op1),
328 Attribute_Name => Name_Address),
330 Make_Attribute_Reference (Loc,
331 Prefix => Right_Opnd (Op1),
332 Attribute_Name => Name_Address),
334 Make_Attribute_Reference (Loc,
335 Prefix => Left_Opnd (Op1),
336 Attribute_Name => Name_Length)));
339 Proc_Name := RTE (RE_Vector_Not);
342 Make_Procedure_Call_Statement (Loc,
343 Name => New_Occurrence_Of (Proc_Name, Loc),
344 Parameter_Associations => New_List (
347 Make_Attribute_Reference (Loc,
349 Attribute_Name => Name_Address),
351 Make_Attribute_Reference (Loc,
353 Attribute_Name => Name_Length)));
357 -- We use the following equivalences:
359 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
360 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
361 -- (not X) xor (not Y) = X xor Y
362 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
364 if Nkind (Op1) = N_Op_Not then
365 Arg1 := Right_Opnd (Op1);
366 Arg2 := Right_Opnd (Op2);
368 if Kind = N_Op_And then
369 Proc_Name := RTE (RE_Vector_Nor);
370 elsif Kind = N_Op_Or then
371 Proc_Name := RTE (RE_Vector_Nand);
373 Proc_Name := RTE (RE_Vector_Xor);
377 if Kind = N_Op_And then
378 Proc_Name := RTE (RE_Vector_And);
379 elsif Kind = N_Op_Or then
380 Proc_Name := RTE (RE_Vector_Or);
381 elsif Nkind (Op2) = N_Op_Not then
382 Proc_Name := RTE (RE_Vector_Nxor);
383 Arg2 := Right_Opnd (Op2);
385 Proc_Name := RTE (RE_Vector_Xor);
390 Make_Procedure_Call_Statement (Loc,
391 Name => New_Occurrence_Of (Proc_Name, Loc),
392 Parameter_Associations => New_List (
394 Make_Attribute_Reference (Loc,
396 Attribute_Name => Name_Address),
397 Make_Attribute_Reference (Loc,
399 Attribute_Name => Name_Address),
400 Make_Attribute_Reference (Loc,
402 Attribute_Name => Name_Length)));
405 Rewrite (N, Call_Node);
409 when RE_Not_Available =>
411 end Build_Boolean_Array_Proc_Call;
413 --------------------------------
414 -- Displace_Allocator_Pointer --
415 --------------------------------
417 procedure Displace_Allocator_Pointer (N : Node_Id) is
418 Loc : constant Source_Ptr := Sloc (N);
419 Orig_Node : constant Node_Id := Original_Node (N);
425 -- Do nothing in case of VM targets: the virtual machine will handle
426 -- interfaces directly.
428 if not Tagged_Type_Expansion then
432 pragma Assert (Nkind (N) = N_Identifier
433 and then Nkind (Orig_Node) = N_Allocator);
435 PtrT := Etype (Orig_Node);
436 Dtyp := Available_View (Designated_Type (PtrT));
437 Etyp := Etype (Expression (Orig_Node));
439 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
441 -- If the type of the allocator expression is not an interface type
442 -- we can generate code to reference the record component containing
443 -- the pointer to the secondary dispatch table.
445 if not Is_Interface (Etyp) then
447 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
450 -- 1) Get access to the allocated object
453 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
457 -- 2) Add the conversion to displace the pointer to reference
458 -- the secondary dispatch table.
460 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
461 Analyze_And_Resolve (N, Dtyp);
463 -- 3) The 'access to the secondary dispatch table will be used
464 -- as the value returned by the allocator.
467 Make_Attribute_Reference (Loc,
468 Prefix => Relocate_Node (N),
469 Attribute_Name => Name_Access));
470 Set_Etype (N, Saved_Typ);
474 -- If the type of the allocator expression is an interface type we
475 -- generate a run-time call to displace "this" to reference the
476 -- component containing the pointer to the secondary dispatch table
477 -- or else raise Constraint_Error if the actual object does not
478 -- implement the target interface. This case corresponds to the
479 -- following example:
481 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
483 -- return new Iface_2'Class'(Obj);
488 Unchecked_Convert_To (PtrT,
489 Make_Function_Call (Loc,
490 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
491 Parameter_Associations => New_List (
492 Unchecked_Convert_To (RTE (RE_Address),
498 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
500 Analyze_And_Resolve (N, PtrT);
503 end Displace_Allocator_Pointer;
505 ---------------------------------
506 -- Expand_Allocator_Expression --
507 ---------------------------------
509 procedure Expand_Allocator_Expression (N : Node_Id) is
510 Loc : constant Source_Ptr := Sloc (N);
511 Exp : constant Node_Id := Expression (Expression (N));
512 PtrT : constant Entity_Id := Etype (N);
513 DesigT : constant Entity_Id := Designated_Type (PtrT);
515 procedure Apply_Accessibility_Check
517 Built_In_Place : Boolean := False);
518 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
519 -- type, generate an accessibility check to verify that the level of the
520 -- type of the created object is not deeper than the level of the access
521 -- type. If the type of the qualified expression is class-wide, then
522 -- always generate the check (except in the case where it is known to be
523 -- unnecessary, see comment below). Otherwise, only generate the check
524 -- if the level of the qualified expression type is statically deeper
525 -- than the access type.
527 -- Although the static accessibility will generally have been performed
528 -- as a legality check, it won't have been done in cases where the
529 -- allocator appears in generic body, so a run-time check is needed in
530 -- general. One special case is when the access type is declared in the
531 -- same scope as the class-wide allocator, in which case the check can
532 -- never fail, so it need not be generated.
534 -- As an open issue, there seem to be cases where the static level
535 -- associated with the class-wide object's underlying type is not
536 -- sufficient to perform the proper accessibility check, such as for
537 -- allocators in nested subprograms or accept statements initialized by
538 -- class-wide formals when the actual originates outside at a deeper
539 -- static level. The nested subprogram case might require passing
540 -- accessibility levels along with class-wide parameters, and the task
541 -- case seems to be an actual gap in the language rules that needs to
542 -- be fixed by the ARG. ???
544 -------------------------------
545 -- Apply_Accessibility_Check --
546 -------------------------------
548 procedure Apply_Accessibility_Check
550 Built_In_Place : Boolean := False)
552 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
560 if Ada_Version >= Ada_2005
561 and then Is_Class_Wide_Type (DesigT)
562 and then Tagged_Type_Expansion
563 and then not Scope_Suppress.Suppress (Accessibility_Check)
565 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
567 (Is_Class_Wide_Type (Etype (Exp))
568 and then Scope (PtrT) /= Current_Scope))
570 -- If the allocator was built in place, Ref is already a reference
571 -- to the access object initialized to the result of the allocator
572 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
573 -- Remove_Side_Effects for cases where the build-in-place call may
574 -- still be the prefix of the reference (to avoid generating
575 -- duplicate calls). Otherwise, it is the entity associated with
576 -- the object containing the address of the allocated object.
578 if Built_In_Place then
579 Remove_Side_Effects (Ref);
580 Obj_Ref := New_Copy_Tree (Ref);
582 Obj_Ref := New_Occurrence_Of (Ref, Loc);
585 -- For access to interface types we must generate code to displace
586 -- the pointer to the base of the object since the subsequent code
587 -- references components located in the TSD of the object (which
588 -- is associated with the primary dispatch table --see a-tags.ads)
589 -- and also generates code invoking Free, which requires also a
590 -- reference to the base of the unallocated object.
592 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
594 Unchecked_Convert_To (Etype (Obj_Ref),
595 Make_Function_Call (Loc,
597 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
598 Parameter_Associations => New_List (
599 Unchecked_Convert_To (RTE (RE_Address),
600 New_Copy_Tree (Obj_Ref)))));
603 -- Step 1: Create the object clean up code
607 -- Deallocate the object if the accessibility check fails. This
608 -- is done only on targets or profiles that support deallocation.
612 if RTE_Available (RE_Free) then
613 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
614 Set_Storage_Pool (Free_Stmt, Pool_Id);
616 Append_To (Stmts, Free_Stmt);
618 -- The target or profile cannot deallocate objects
624 -- Finalize the object if applicable. Generate:
626 -- [Deep_]Finalize (Obj_Ref.all);
628 if Needs_Finalization (DesigT) then
632 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
635 -- Guard against a missing [Deep_]Finalize when the designated
636 -- type was not properly frozen.
638 if No (Fin_Call) then
639 Fin_Call := Make_Null_Statement (Loc);
642 -- When the target or profile supports deallocation, wrap the
643 -- finalization call in a block to ensure proper deallocation
644 -- even if finalization fails. Generate:
654 if Present (Free_Stmt) then
656 Make_Block_Statement (Loc,
657 Handled_Statement_Sequence =>
658 Make_Handled_Sequence_Of_Statements (Loc,
659 Statements => New_List (Fin_Call),
661 Exception_Handlers => New_List (
662 Make_Exception_Handler (Loc,
663 Exception_Choices => New_List (
664 Make_Others_Choice (Loc)),
665 Statements => New_List (
666 New_Copy_Tree (Free_Stmt),
667 Make_Raise_Statement (Loc))))));
670 Prepend_To (Stmts, Fin_Call);
673 -- Signal the accessibility failure through a Program_Error
676 Make_Raise_Program_Error (Loc,
677 Condition => New_Occurrence_Of (Standard_True, Loc),
678 Reason => PE_Accessibility_Check_Failed));
680 -- Step 2: Create the accessibility comparison
686 Make_Attribute_Reference (Loc,
688 Attribute_Name => Name_Tag);
690 -- For tagged types, determine the accessibility level by looking
691 -- at the type specific data of the dispatch table. Generate:
693 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
695 if Tagged_Type_Expansion then
696 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
698 -- Use a runtime call to determine the accessibility level when
699 -- compiling on virtual machine targets. Generate:
701 -- Get_Access_Level (Ref'Tag)
705 Make_Function_Call (Loc,
707 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
708 Parameter_Associations => New_List (Obj_Ref));
715 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
717 -- Due to the complexity and side effects of the check, utilize an
718 -- if statement instead of the regular Program_Error circuitry.
721 Make_Implicit_If_Statement (N,
723 Then_Statements => Stmts));
725 end Apply_Accessibility_Check;
729 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
730 Indic : constant Node_Id := Subtype_Mark (Expression (N));
731 T : constant Entity_Id := Entity (Indic);
734 Tag_Assign : Node_Id;
738 TagT : Entity_Id := Empty;
739 -- Type used as source for tag assignment
741 TagR : Node_Id := Empty;
742 -- Target reference for tag assignment
744 -- Start of processing for Expand_Allocator_Expression
747 -- Handle call to C++ constructor
749 if Is_CPP_Constructor_Call (Exp) then
750 Make_CPP_Constructor_Call_In_Allocator
752 Function_Call => Exp);
756 -- In the case of an Ada 2012 allocator whose initial value comes from a
757 -- function call, pass "the accessibility level determined by the point
758 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
759 -- Expand_Call but it couldn't be done there (because the Etype of the
760 -- allocator wasn't set then) so we generate the parameter here. See
761 -- the Boolean variable Defer in (a block within) Expand_Call.
763 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
768 if Nkind (Name (Exp)) = N_Explicit_Dereference then
769 Subp := Designated_Type (Etype (Prefix (Name (Exp))));
771 Subp := Entity (Name (Exp));
774 Subp := Ultimate_Alias (Subp);
776 if Present (Extra_Accessibility_Of_Result (Subp)) then
777 Add_Extra_Actual_To_Call
778 (Subprogram_Call => Exp,
779 Extra_Formal => Extra_Accessibility_Of_Result (Subp),
780 Extra_Actual => Dynamic_Accessibility_Level (PtrT));
785 -- Case of tagged type or type requiring finalization
787 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
789 -- Ada 2005 (AI-318-02): If the initialization expression is a call
790 -- to a build-in-place function, then access to the allocated object
791 -- must be passed to the function. Currently we limit such functions
792 -- to those with constrained limited result subtypes, but eventually
793 -- we plan to expand the allowed forms of functions that are treated
794 -- as build-in-place.
796 if Ada_Version >= Ada_2005
797 and then Is_Build_In_Place_Function_Call (Exp)
799 Make_Build_In_Place_Call_In_Allocator (N, Exp);
800 Apply_Accessibility_Check (N, Built_In_Place => True);
804 -- Actions inserted before:
805 -- Temp : constant ptr_T := new T'(Expression);
806 -- Temp._tag = T'tag; -- when not class-wide
807 -- [Deep_]Adjust (Temp.all);
809 -- We analyze by hand the new internal allocator to avoid any
810 -- recursion and inappropriate call to Initialize.
812 -- We don't want to remove side effects when the expression must be
813 -- built in place. In the case of a build-in-place function call,
814 -- that could lead to a duplication of the call, which was already
815 -- substituted for the allocator.
817 if not Aggr_In_Place then
818 Remove_Side_Effects (Exp);
821 Temp := Make_Temporary (Loc, 'P', N);
823 -- For a class wide allocation generate the following code:
825 -- type Equiv_Record is record ... end record;
826 -- implicit subtype CW is <Class_Wide_Subytpe>;
827 -- temp : PtrT := new CW'(CW!(expr));
829 if Is_Class_Wide_Type (T) then
830 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
832 -- Ada 2005 (AI-251): If the expression is a class-wide interface
833 -- object we generate code to move up "this" to reference the
834 -- base of the object before allocating the new object.
836 -- Note that Exp'Address is recursively expanded into a call
837 -- to Base_Address (Exp.Tag)
839 if Is_Class_Wide_Type (Etype (Exp))
840 and then Is_Interface (Etype (Exp))
841 and then Tagged_Type_Expansion
845 Unchecked_Convert_To (Entity (Indic),
846 Make_Explicit_Dereference (Loc,
847 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
848 Make_Attribute_Reference (Loc,
850 Attribute_Name => Name_Address)))));
854 Unchecked_Convert_To (Entity (Indic), Exp));
857 Analyze_And_Resolve (Expression (N), Entity (Indic));
860 -- Processing for allocators returning non-interface types
862 if not Is_Interface (Directly_Designated_Type (PtrT)) then
863 if Aggr_In_Place then
865 Make_Object_Declaration (Loc,
866 Defining_Identifier => Temp,
867 Object_Definition => New_Occurrence_Of (PtrT, Loc),
871 New_Occurrence_Of (Etype (Exp), Loc)));
873 -- Copy the Comes_From_Source flag for the allocator we just
874 -- built, since logically this allocator is a replacement of
875 -- the original allocator node. This is for proper handling of
876 -- restriction No_Implicit_Heap_Allocations.
878 Set_Comes_From_Source
879 (Expression (Temp_Decl), Comes_From_Source (N));
881 Set_No_Initialization (Expression (Temp_Decl));
882 Insert_Action (N, Temp_Decl);
884 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
885 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
888 Node := Relocate_Node (N);
892 Make_Object_Declaration (Loc,
893 Defining_Identifier => Temp,
894 Constant_Present => True,
895 Object_Definition => New_Occurrence_Of (PtrT, Loc),
898 Insert_Action (N, Temp_Decl);
899 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
902 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
903 -- interface type. In this case we use the type of the qualified
904 -- expression to allocate the object.
908 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
913 Make_Full_Type_Declaration (Loc,
914 Defining_Identifier => Def_Id,
916 Make_Access_To_Object_Definition (Loc,
918 Null_Exclusion_Present => False,
920 Is_Access_Constant (Etype (N)),
921 Subtype_Indication =>
922 New_Occurrence_Of (Etype (Exp), Loc)));
924 Insert_Action (N, New_Decl);
926 -- Inherit the allocation-related attributes from the original
929 Set_Finalization_Master
930 (Def_Id, Finalization_Master (PtrT));
932 Set_Associated_Storage_Pool
933 (Def_Id, Associated_Storage_Pool (PtrT));
935 -- Declare the object using the previous type declaration
937 if Aggr_In_Place then
939 Make_Object_Declaration (Loc,
940 Defining_Identifier => Temp,
941 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
944 New_Occurrence_Of (Etype (Exp), Loc)));
946 -- Copy the Comes_From_Source flag for the allocator we just
947 -- built, since logically this allocator is a replacement of
948 -- the original allocator node. This is for proper handling
949 -- of restriction No_Implicit_Heap_Allocations.
951 Set_Comes_From_Source
952 (Expression (Temp_Decl), Comes_From_Source (N));
954 Set_No_Initialization (Expression (Temp_Decl));
955 Insert_Action (N, Temp_Decl);
957 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
958 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
961 Node := Relocate_Node (N);
965 Make_Object_Declaration (Loc,
966 Defining_Identifier => Temp,
967 Constant_Present => True,
968 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
971 Insert_Action (N, Temp_Decl);
972 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
975 -- Generate an additional object containing the address of the
976 -- returned object. The type of this second object declaration
977 -- is the correct type required for the common processing that
978 -- is still performed by this subprogram. The displacement of
979 -- this pointer to reference the component associated with the
980 -- interface type will be done at the end of common processing.
983 Make_Object_Declaration (Loc,
984 Defining_Identifier => Make_Temporary (Loc, 'P'),
985 Object_Definition => New_Occurrence_Of (PtrT, Loc),
987 Unchecked_Convert_To (PtrT,
988 New_Occurrence_Of (Temp, Loc)));
990 Insert_Action (N, New_Decl);
992 Temp_Decl := New_Decl;
993 Temp := Defining_Identifier (New_Decl);
997 -- Generate the tag assignment
999 -- Suppress the tag assignment for VM targets because VM tags are
1000 -- represented implicitly in objects.
1002 if not Tagged_Type_Expansion then
1005 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1006 -- interface objects because in this case the tag does not change.
1008 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1009 pragma Assert (Is_Class_Wide_Type
1010 (Directly_Designated_Type (Etype (N))));
1013 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1015 TagR := New_Occurrence_Of (Temp, Loc);
1017 elsif Is_Private_Type (T)
1018 and then Is_Tagged_Type (Underlying_Type (T))
1020 TagT := Underlying_Type (T);
1022 Unchecked_Convert_To (Underlying_Type (T),
1023 Make_Explicit_Dereference (Loc,
1024 Prefix => New_Occurrence_Of (Temp, Loc)));
1027 if Present (TagT) then
1029 Full_T : constant Entity_Id := Underlying_Type (TagT);
1033 Make_Assignment_Statement (Loc,
1035 Make_Selected_Component (Loc,
1039 (First_Tag_Component (Full_T), Loc)),
1042 Unchecked_Convert_To (RTE (RE_Tag),
1045 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1048 -- The previous assignment has to be done in any case
1050 Set_Assignment_OK (Name (Tag_Assign));
1051 Insert_Action (N, Tag_Assign);
1054 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1055 -- the object may be inherently limited, in which case there is no
1056 -- Adjust procedure, and the object is built in place. In Ada 95, the
1057 -- object can be limited but not inherently limited if this allocator
1058 -- came from a return statement (we're allocating the result on the
1059 -- secondary stack). In that case, the object will be moved, so we do
1062 if Needs_Finalization (DesigT)
1063 and then Needs_Finalization (T)
1064 and then not Aggr_In_Place
1065 and then not Is_Limited_View (T)
1067 -- An unchecked conversion is needed in the classwide case because
1068 -- the designated type can be an ancestor of the subtype mark of
1074 Unchecked_Convert_To (T,
1075 Make_Explicit_Dereference (Loc,
1076 Prefix => New_Occurrence_Of (Temp, Loc))),
1079 if Present (Adj_Call) then
1080 Insert_Action (N, Adj_Call);
1084 -- Note: the accessibility check must be inserted after the call to
1085 -- [Deep_]Adjust to ensure proper completion of the assignment.
1087 Apply_Accessibility_Check (Temp);
1089 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1090 Analyze_And_Resolve (N, PtrT);
1092 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1093 -- component containing the secondary dispatch table of the interface
1096 if Is_Interface (Directly_Designated_Type (PtrT)) then
1097 Displace_Allocator_Pointer (N);
1100 -- Always force the generation of a temporary for aggregates when
1101 -- generating C code, to simplify the work in the code generator.
1104 or else (Generate_C_Code and then Nkind (Exp) = N_Aggregate)
1106 Temp := Make_Temporary (Loc, 'P', N);
1108 Make_Object_Declaration (Loc,
1109 Defining_Identifier => Temp,
1110 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1112 Make_Allocator (Loc,
1113 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1115 -- Copy the Comes_From_Source flag for the allocator we just built,
1116 -- since logically this allocator is a replacement of the original
1117 -- allocator node. This is for proper handling of restriction
1118 -- No_Implicit_Heap_Allocations.
1120 Set_Comes_From_Source
1121 (Expression (Temp_Decl), Comes_From_Source (N));
1123 Set_No_Initialization (Expression (Temp_Decl));
1124 Insert_Action (N, Temp_Decl);
1126 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1127 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1129 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1130 Analyze_And_Resolve (N, PtrT);
1132 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1133 Install_Null_Excluding_Check (Exp);
1135 elsif Is_Access_Type (DesigT)
1136 and then Nkind (Exp) = N_Allocator
1137 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1139 -- Apply constraint to designated subtype indication
1141 Apply_Constraint_Check
1142 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
1144 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1146 -- Propagate constraint_error to enclosing allocator
1148 Rewrite (Exp, New_Copy (Expression (Exp)));
1152 Build_Allocate_Deallocate_Proc (N, True);
1155 -- type A is access T1;
1156 -- X : A := new T2'(...);
1157 -- T1 and T2 can be different subtypes, and we might need to check
1158 -- both constraints. First check against the type of the qualified
1161 Apply_Constraint_Check (Exp, T, No_Sliding => True);
1163 if Do_Range_Check (Exp) then
1164 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1167 -- A check is also needed in cases where the designated subtype is
1168 -- constrained and differs from the subtype given in the qualified
1169 -- expression. Note that the check on the qualified expression does
1170 -- not allow sliding, but this check does (a relaxation from Ada 83).
1172 if Is_Constrained (DesigT)
1173 and then not Subtypes_Statically_Match (T, DesigT)
1175 Apply_Constraint_Check
1176 (Exp, DesigT, No_Sliding => False);
1178 if Do_Range_Check (Exp) then
1179 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1183 -- For an access to unconstrained packed array, GIGI needs to see an
1184 -- expression with a constrained subtype in order to compute the
1185 -- proper size for the allocator.
1187 if Is_Array_Type (T)
1188 and then not Is_Constrained (T)
1189 and then Is_Packed (T)
1192 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1193 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1196 Make_Subtype_Declaration (Loc,
1197 Defining_Identifier => ConstrT,
1198 Subtype_Indication =>
1199 Make_Subtype_From_Expr (Internal_Exp, T)));
1200 Freeze_Itype (ConstrT, Exp);
1201 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1205 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1206 -- to a build-in-place function, then access to the allocated object
1207 -- must be passed to the function. Currently we limit such functions
1208 -- to those with constrained limited result subtypes, but eventually
1209 -- we plan to expand the allowed forms of functions that are treated
1210 -- as build-in-place.
1212 if Ada_Version >= Ada_2005
1213 and then Is_Build_In_Place_Function_Call (Exp)
1215 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1220 when RE_Not_Available =>
1222 end Expand_Allocator_Expression;
1224 -----------------------------
1225 -- Expand_Array_Comparison --
1226 -----------------------------
1228 -- Expansion is only required in the case of array types. For the unpacked
1229 -- case, an appropriate runtime routine is called. For packed cases, and
1230 -- also in some other cases where a runtime routine cannot be called, the
1231 -- form of the expansion is:
1233 -- [body for greater_nn; boolean_expression]
1235 -- The body is built by Make_Array_Comparison_Op, and the form of the
1236 -- Boolean expression depends on the operator involved.
1238 procedure Expand_Array_Comparison (N : Node_Id) is
1239 Loc : constant Source_Ptr := Sloc (N);
1240 Op1 : Node_Id := Left_Opnd (N);
1241 Op2 : Node_Id := Right_Opnd (N);
1242 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1243 Ctyp : constant Entity_Id := Component_Type (Typ1);
1246 Func_Body : Node_Id;
1247 Func_Name : Entity_Id;
1251 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1252 -- True for byte addressable target
1254 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1255 -- Returns True if the length of the given operand is known to be less
1256 -- than 4. Returns False if this length is known to be four or greater
1257 -- or is not known at compile time.
1259 ------------------------
1260 -- Length_Less_Than_4 --
1261 ------------------------
1263 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1264 Otyp : constant Entity_Id := Etype (Opnd);
1267 if Ekind (Otyp) = E_String_Literal_Subtype then
1268 return String_Literal_Length (Otyp) < 4;
1272 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1273 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1274 Hi : constant Node_Id := Type_High_Bound (Ityp);
1279 if Compile_Time_Known_Value (Lo) then
1280 Lov := Expr_Value (Lo);
1285 if Compile_Time_Known_Value (Hi) then
1286 Hiv := Expr_Value (Hi);
1291 return Hiv < Lov + 3;
1294 end Length_Less_Than_4;
1296 -- Start of processing for Expand_Array_Comparison
1299 -- Deal first with unpacked case, where we can call a runtime routine
1300 -- except that we avoid this for targets for which are not addressable
1303 if not Is_Bit_Packed_Array (Typ1)
1304 and then Byte_Addressable
1306 -- The call we generate is:
1308 -- Compare_Array_xn[_Unaligned]
1309 -- (left'address, right'address, left'length, right'length) <op> 0
1311 -- x = U for unsigned, S for signed
1312 -- n = 8,16,32,64 for component size
1313 -- Add _Unaligned if length < 4 and component size is 8.
1314 -- <op> is the standard comparison operator
1316 if Component_Size (Typ1) = 8 then
1317 if Length_Less_Than_4 (Op1)
1319 Length_Less_Than_4 (Op2)
1321 if Is_Unsigned_Type (Ctyp) then
1322 Comp := RE_Compare_Array_U8_Unaligned;
1324 Comp := RE_Compare_Array_S8_Unaligned;
1328 if Is_Unsigned_Type (Ctyp) then
1329 Comp := RE_Compare_Array_U8;
1331 Comp := RE_Compare_Array_S8;
1335 elsif Component_Size (Typ1) = 16 then
1336 if Is_Unsigned_Type (Ctyp) then
1337 Comp := RE_Compare_Array_U16;
1339 Comp := RE_Compare_Array_S16;
1342 elsif Component_Size (Typ1) = 32 then
1343 if Is_Unsigned_Type (Ctyp) then
1344 Comp := RE_Compare_Array_U32;
1346 Comp := RE_Compare_Array_S32;
1349 else pragma Assert (Component_Size (Typ1) = 64);
1350 if Is_Unsigned_Type (Ctyp) then
1351 Comp := RE_Compare_Array_U64;
1353 Comp := RE_Compare_Array_S64;
1357 if RTE_Available (Comp) then
1359 -- Expand to a call only if the runtime function is available,
1360 -- otherwise fall back to inline code.
1362 Remove_Side_Effects (Op1, Name_Req => True);
1363 Remove_Side_Effects (Op2, Name_Req => True);
1366 Make_Function_Call (Sloc (Op1),
1367 Name => New_Occurrence_Of (RTE (Comp), Loc),
1369 Parameter_Associations => New_List (
1370 Make_Attribute_Reference (Loc,
1371 Prefix => Relocate_Node (Op1),
1372 Attribute_Name => Name_Address),
1374 Make_Attribute_Reference (Loc,
1375 Prefix => Relocate_Node (Op2),
1376 Attribute_Name => Name_Address),
1378 Make_Attribute_Reference (Loc,
1379 Prefix => Relocate_Node (Op1),
1380 Attribute_Name => Name_Length),
1382 Make_Attribute_Reference (Loc,
1383 Prefix => Relocate_Node (Op2),
1384 Attribute_Name => Name_Length))));
1387 Make_Integer_Literal (Sloc (Op2),
1390 Analyze_And_Resolve (Op1, Standard_Integer);
1391 Analyze_And_Resolve (Op2, Standard_Integer);
1396 -- Cases where we cannot make runtime call
1398 -- For (a <= b) we convert to not (a > b)
1400 if Chars (N) = Name_Op_Le then
1406 Right_Opnd => Op2)));
1407 Analyze_And_Resolve (N, Standard_Boolean);
1410 -- For < the Boolean expression is
1411 -- greater__nn (op2, op1)
1413 elsif Chars (N) = Name_Op_Lt then
1414 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1418 Op1 := Right_Opnd (N);
1419 Op2 := Left_Opnd (N);
1421 -- For (a >= b) we convert to not (a < b)
1423 elsif Chars (N) = Name_Op_Ge then
1429 Right_Opnd => Op2)));
1430 Analyze_And_Resolve (N, Standard_Boolean);
1433 -- For > the Boolean expression is
1434 -- greater__nn (op1, op2)
1437 pragma Assert (Chars (N) = Name_Op_Gt);
1438 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1441 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1443 Make_Function_Call (Loc,
1444 Name => New_Occurrence_Of (Func_Name, Loc),
1445 Parameter_Associations => New_List (Op1, Op2));
1447 Insert_Action (N, Func_Body);
1449 Analyze_And_Resolve (N, Standard_Boolean);
1450 end Expand_Array_Comparison;
1452 ---------------------------
1453 -- Expand_Array_Equality --
1454 ---------------------------
1456 -- Expand an equality function for multi-dimensional arrays. Here is an
1457 -- example of such a function for Nb_Dimension = 2
1459 -- function Enn (A : atyp; B : btyp) return boolean is
1461 -- if (A'length (1) = 0 or else A'length (2) = 0)
1463 -- (B'length (1) = 0 or else B'length (2) = 0)
1465 -- return True; -- RM 4.5.2(22)
1468 -- if A'length (1) /= B'length (1)
1470 -- A'length (2) /= B'length (2)
1472 -- return False; -- RM 4.5.2(23)
1476 -- A1 : Index_T1 := A'first (1);
1477 -- B1 : Index_T1 := B'first (1);
1481 -- A2 : Index_T2 := A'first (2);
1482 -- B2 : Index_T2 := B'first (2);
1485 -- if A (A1, A2) /= B (B1, B2) then
1489 -- exit when A2 = A'last (2);
1490 -- A2 := Index_T2'succ (A2);
1491 -- B2 := Index_T2'succ (B2);
1495 -- exit when A1 = A'last (1);
1496 -- A1 := Index_T1'succ (A1);
1497 -- B1 := Index_T1'succ (B1);
1504 -- Note on the formal types used (atyp and btyp). If either of the arrays
1505 -- is of a private type, we use the underlying type, and do an unchecked
1506 -- conversion of the actual. If either of the arrays has a bound depending
1507 -- on a discriminant, then we use the base type since otherwise we have an
1508 -- escaped discriminant in the function.
1510 -- If both arrays are constrained and have the same bounds, we can generate
1511 -- a loop with an explicit iteration scheme using a 'Range attribute over
1514 function Expand_Array_Equality
1519 Typ : Entity_Id) return Node_Id
1521 Loc : constant Source_Ptr := Sloc (Nod);
1522 Decls : constant List_Id := New_List;
1523 Index_List1 : constant List_Id := New_List;
1524 Index_List2 : constant List_Id := New_List;
1528 Func_Name : Entity_Id;
1529 Func_Body : Node_Id;
1531 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1532 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1536 -- The parameter types to be used for the formals
1541 Num : Int) return Node_Id;
1542 -- This builds the attribute reference Arr'Nam (Expr)
1544 function Component_Equality (Typ : Entity_Id) return Node_Id;
1545 -- Create one statement to compare corresponding components, designated
1546 -- by a full set of indexes.
1548 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1549 -- Given one of the arguments, computes the appropriate type to be used
1550 -- for that argument in the corresponding function formal
1552 function Handle_One_Dimension
1554 Index : Node_Id) return Node_Id;
1555 -- This procedure returns the following code
1558 -- Bn : Index_T := B'First (N);
1562 -- exit when An = A'Last (N);
1563 -- An := Index_T'Succ (An)
1564 -- Bn := Index_T'Succ (Bn)
1568 -- If both indexes are constrained and identical, the procedure
1569 -- returns a simpler loop:
1571 -- for An in A'Range (N) loop
1575 -- N is the dimension for which we are generating a loop. Index is the
1576 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1577 -- xxx statement is either the loop or declare for the next dimension
1578 -- or if this is the last dimension the comparison of corresponding
1579 -- components of the arrays.
1581 -- The actual way the code works is to return the comparison of
1582 -- corresponding components for the N+1 call. That's neater.
1584 function Test_Empty_Arrays return Node_Id;
1585 -- This function constructs the test for both arrays being empty
1586 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1588 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1590 function Test_Lengths_Correspond return Node_Id;
1591 -- This function constructs the test for arrays having different lengths
1592 -- in at least one index position, in which case the resulting code is:
1594 -- A'length (1) /= B'length (1)
1596 -- A'length (2) /= B'length (2)
1607 Num : Int) return Node_Id
1611 Make_Attribute_Reference (Loc,
1612 Attribute_Name => Nam,
1613 Prefix => New_Occurrence_Of (Arr, Loc),
1614 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1617 ------------------------
1618 -- Component_Equality --
1619 ------------------------
1621 function Component_Equality (Typ : Entity_Id) return Node_Id is
1626 -- if a(i1...) /= b(j1...) then return false; end if;
1629 Make_Indexed_Component (Loc,
1630 Prefix => Make_Identifier (Loc, Chars (A)),
1631 Expressions => Index_List1);
1634 Make_Indexed_Component (Loc,
1635 Prefix => Make_Identifier (Loc, Chars (B)),
1636 Expressions => Index_List2);
1638 Test := Expand_Composite_Equality
1639 (Nod, Component_Type (Typ), L, R, Decls);
1641 -- If some (sub)component is an unchecked_union, the whole operation
1642 -- will raise program error.
1644 if Nkind (Test) = N_Raise_Program_Error then
1646 -- This node is going to be inserted at a location where a
1647 -- statement is expected: clear its Etype so analysis will set
1648 -- it to the expected Standard_Void_Type.
1650 Set_Etype (Test, Empty);
1655 Make_Implicit_If_Statement (Nod,
1656 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1657 Then_Statements => New_List (
1658 Make_Simple_Return_Statement (Loc,
1659 Expression => New_Occurrence_Of (Standard_False, Loc))));
1661 end Component_Equality;
1667 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1678 T := Underlying_Type (T);
1680 X := First_Index (T);
1681 while Present (X) loop
1682 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1684 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1697 --------------------------
1698 -- Handle_One_Dimension --
1699 ---------------------------
1701 function Handle_One_Dimension
1703 Index : Node_Id) return Node_Id
1705 Need_Separate_Indexes : constant Boolean :=
1706 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1707 -- If the index types are identical, and we are working with
1708 -- constrained types, then we can use the same index for both
1711 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1714 Index_T : Entity_Id;
1719 if N > Number_Dimensions (Ltyp) then
1720 return Component_Equality (Ltyp);
1723 -- Case where we generate a loop
1725 Index_T := Base_Type (Etype (Index));
1727 if Need_Separate_Indexes then
1728 Bn := Make_Temporary (Loc, 'B');
1733 Append (New_Occurrence_Of (An, Loc), Index_List1);
1734 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1736 Stm_List := New_List (
1737 Handle_One_Dimension (N + 1, Next_Index (Index)));
1739 if Need_Separate_Indexes then
1741 -- Generate guard for loop, followed by increments of indexes
1743 Append_To (Stm_List,
1744 Make_Exit_Statement (Loc,
1747 Left_Opnd => New_Occurrence_Of (An, Loc),
1748 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1750 Append_To (Stm_List,
1751 Make_Assignment_Statement (Loc,
1752 Name => New_Occurrence_Of (An, Loc),
1754 Make_Attribute_Reference (Loc,
1755 Prefix => New_Occurrence_Of (Index_T, Loc),
1756 Attribute_Name => Name_Succ,
1757 Expressions => New_List (
1758 New_Occurrence_Of (An, Loc)))));
1760 Append_To (Stm_List,
1761 Make_Assignment_Statement (Loc,
1762 Name => New_Occurrence_Of (Bn, Loc),
1764 Make_Attribute_Reference (Loc,
1765 Prefix => New_Occurrence_Of (Index_T, Loc),
1766 Attribute_Name => Name_Succ,
1767 Expressions => New_List (
1768 New_Occurrence_Of (Bn, Loc)))));
1771 -- If separate indexes, we need a declare block for An and Bn, and a
1772 -- loop without an iteration scheme.
1774 if Need_Separate_Indexes then
1776 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1779 Make_Block_Statement (Loc,
1780 Declarations => New_List (
1781 Make_Object_Declaration (Loc,
1782 Defining_Identifier => An,
1783 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1784 Expression => Arr_Attr (A, Name_First, N)),
1786 Make_Object_Declaration (Loc,
1787 Defining_Identifier => Bn,
1788 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1789 Expression => Arr_Attr (B, Name_First, N))),
1791 Handled_Statement_Sequence =>
1792 Make_Handled_Sequence_Of_Statements (Loc,
1793 Statements => New_List (Loop_Stm)));
1795 -- If no separate indexes, return loop statement with explicit
1796 -- iteration scheme on its own
1800 Make_Implicit_Loop_Statement (Nod,
1801 Statements => Stm_List,
1803 Make_Iteration_Scheme (Loc,
1804 Loop_Parameter_Specification =>
1805 Make_Loop_Parameter_Specification (Loc,
1806 Defining_Identifier => An,
1807 Discrete_Subtype_Definition =>
1808 Arr_Attr (A, Name_Range, N))));
1811 end Handle_One_Dimension;
1813 -----------------------
1814 -- Test_Empty_Arrays --
1815 -----------------------
1817 function Test_Empty_Arrays return Node_Id is
1827 for J in 1 .. Number_Dimensions (Ltyp) loop
1830 Left_Opnd => Arr_Attr (A, Name_Length, J),
1831 Right_Opnd => Make_Integer_Literal (Loc, 0));
1835 Left_Opnd => Arr_Attr (B, Name_Length, J),
1836 Right_Opnd => Make_Integer_Literal (Loc, 0));
1845 Left_Opnd => Relocate_Node (Alist),
1846 Right_Opnd => Atest);
1850 Left_Opnd => Relocate_Node (Blist),
1851 Right_Opnd => Btest);
1858 Right_Opnd => Blist);
1859 end Test_Empty_Arrays;
1861 -----------------------------
1862 -- Test_Lengths_Correspond --
1863 -----------------------------
1865 function Test_Lengths_Correspond return Node_Id is
1871 for J in 1 .. Number_Dimensions (Ltyp) loop
1874 Left_Opnd => Arr_Attr (A, Name_Length, J),
1875 Right_Opnd => Arr_Attr (B, Name_Length, J));
1882 Left_Opnd => Relocate_Node (Result),
1883 Right_Opnd => Rtest);
1888 end Test_Lengths_Correspond;
1890 -- Start of processing for Expand_Array_Equality
1893 Ltyp := Get_Arg_Type (Lhs);
1894 Rtyp := Get_Arg_Type (Rhs);
1896 -- For now, if the argument types are not the same, go to the base type,
1897 -- since the code assumes that the formals have the same type. This is
1898 -- fixable in future ???
1900 if Ltyp /= Rtyp then
1901 Ltyp := Base_Type (Ltyp);
1902 Rtyp := Base_Type (Rtyp);
1903 pragma Assert (Ltyp = Rtyp);
1906 -- Build list of formals for function
1908 Formals := New_List (
1909 Make_Parameter_Specification (Loc,
1910 Defining_Identifier => A,
1911 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
1913 Make_Parameter_Specification (Loc,
1914 Defining_Identifier => B,
1915 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
1917 Func_Name := Make_Temporary (Loc, 'E');
1919 -- Build statement sequence for function
1922 Make_Subprogram_Body (Loc,
1924 Make_Function_Specification (Loc,
1925 Defining_Unit_Name => Func_Name,
1926 Parameter_Specifications => Formals,
1927 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
1929 Declarations => Decls,
1931 Handled_Statement_Sequence =>
1932 Make_Handled_Sequence_Of_Statements (Loc,
1933 Statements => New_List (
1935 Make_Implicit_If_Statement (Nod,
1936 Condition => Test_Empty_Arrays,
1937 Then_Statements => New_List (
1938 Make_Simple_Return_Statement (Loc,
1940 New_Occurrence_Of (Standard_True, Loc)))),
1942 Make_Implicit_If_Statement (Nod,
1943 Condition => Test_Lengths_Correspond,
1944 Then_Statements => New_List (
1945 Make_Simple_Return_Statement (Loc,
1946 Expression => New_Occurrence_Of (Standard_False, Loc)))),
1948 Handle_One_Dimension (1, First_Index (Ltyp)),
1950 Make_Simple_Return_Statement (Loc,
1951 Expression => New_Occurrence_Of (Standard_True, Loc)))));
1953 Set_Has_Completion (Func_Name, True);
1954 Set_Is_Inlined (Func_Name);
1956 -- If the array type is distinct from the type of the arguments, it
1957 -- is the full view of a private type. Apply an unchecked conversion
1958 -- to insure that analysis of the call succeeds.
1968 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1970 L := OK_Convert_To (Ltyp, Lhs);
1974 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1976 R := OK_Convert_To (Rtyp, Rhs);
1979 Actuals := New_List (L, R);
1982 Append_To (Bodies, Func_Body);
1985 Make_Function_Call (Loc,
1986 Name => New_Occurrence_Of (Func_Name, Loc),
1987 Parameter_Associations => Actuals);
1988 end Expand_Array_Equality;
1990 -----------------------------
1991 -- Expand_Boolean_Operator --
1992 -----------------------------
1994 -- Note that we first get the actual subtypes of the operands, since we
1995 -- always want to deal with types that have bounds.
1997 procedure Expand_Boolean_Operator (N : Node_Id) is
1998 Typ : constant Entity_Id := Etype (N);
2001 -- Special case of bit packed array where both operands are known to be
2002 -- properly aligned. In this case we use an efficient run time routine
2003 -- to carry out the operation (see System.Bit_Ops).
2005 if Is_Bit_Packed_Array (Typ)
2006 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2007 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2009 Expand_Packed_Boolean_Operator (N);
2013 -- For the normal non-packed case, the general expansion is to build
2014 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2015 -- and then inserting it into the tree. The original operator node is
2016 -- then rewritten as a call to this function. We also use this in the
2017 -- packed case if either operand is a possibly unaligned object.
2020 Loc : constant Source_Ptr := Sloc (N);
2021 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2022 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
2023 Func_Body : Node_Id;
2024 Func_Name : Entity_Id;
2027 Convert_To_Actual_Subtype (L);
2028 Convert_To_Actual_Subtype (R);
2029 Ensure_Defined (Etype (L), N);
2030 Ensure_Defined (Etype (R), N);
2031 Apply_Length_Check (R, Etype (L));
2033 if Nkind (N) = N_Op_Xor then
2034 Silly_Boolean_Array_Xor_Test (N, Etype (L));
2037 if Nkind (Parent (N)) = N_Assignment_Statement
2038 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2040 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2042 elsif Nkind (Parent (N)) = N_Op_Not
2043 and then Nkind (N) = N_Op_And
2044 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2045 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2050 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2051 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2052 Insert_Action (N, Func_Body);
2054 -- Now rewrite the expression with a call
2057 Make_Function_Call (Loc,
2058 Name => New_Occurrence_Of (Func_Name, Loc),
2059 Parameter_Associations =>
2062 Make_Type_Conversion
2063 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
2065 Analyze_And_Resolve (N, Typ);
2068 end Expand_Boolean_Operator;
2070 ------------------------------------------------
2071 -- Expand_Compare_Minimize_Eliminate_Overflow --
2072 ------------------------------------------------
2074 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2075 Loc : constant Source_Ptr := Sloc (N);
2077 Result_Type : constant Entity_Id := Etype (N);
2078 -- Capture result type (could be a derived boolean type)
2083 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2084 -- Entity for Long_Long_Integer'Base
2086 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2087 -- Current overflow checking mode
2090 procedure Set_False;
2091 -- These procedures rewrite N with an occurrence of Standard_True or
2092 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2098 procedure Set_False is
2100 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2101 Warn_On_Known_Condition (N);
2108 procedure Set_True is
2110 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2111 Warn_On_Known_Condition (N);
2114 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2117 -- Nothing to do unless we have a comparison operator with operands
2118 -- that are signed integer types, and we are operating in either
2119 -- MINIMIZED or ELIMINATED overflow checking mode.
2121 if Nkind (N) not in N_Op_Compare
2122 or else Check not in Minimized_Or_Eliminated
2123 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2128 -- OK, this is the case we are interested in. First step is to process
2129 -- our operands using the Minimize_Eliminate circuitry which applies
2130 -- this processing to the two operand subtrees.
2132 Minimize_Eliminate_Overflows
2133 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2134 Minimize_Eliminate_Overflows
2135 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2137 -- See if the range information decides the result of the comparison.
2138 -- We can only do this if we in fact have full range information (which
2139 -- won't be the case if either operand is bignum at this stage).
2141 if Llo /= No_Uint and then Rlo /= No_Uint then
2142 case N_Op_Compare (Nkind (N)) is
2144 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2146 elsif Llo > Rhi or else Lhi < Rlo then
2153 elsif Lhi < Rlo then
2160 elsif Lhi <= Rlo then
2167 elsif Lhi <= Rlo then
2174 elsif Lhi < Rlo then
2179 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2181 elsif Llo > Rhi or else Lhi < Rlo then
2186 -- All done if we did the rewrite
2188 if Nkind (N) not in N_Op_Compare then
2193 -- Otherwise, time to do the comparison
2196 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2197 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2200 -- If the two operands have the same signed integer type we are
2201 -- all set, nothing more to do. This is the case where either
2202 -- both operands were unchanged, or we rewrote both of them to
2203 -- be Long_Long_Integer.
2205 -- Note: Entity for the comparison may be wrong, but it's not worth
2206 -- the effort to change it, since the back end does not use it.
2208 if Is_Signed_Integer_Type (Ltype)
2209 and then Base_Type (Ltype) = Base_Type (Rtype)
2213 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2215 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2217 Left : Node_Id := Left_Opnd (N);
2218 Right : Node_Id := Right_Opnd (N);
2219 -- Bignum references for left and right operands
2222 if not Is_RTE (Ltype, RE_Bignum) then
2223 Left := Convert_To_Bignum (Left);
2224 elsif not Is_RTE (Rtype, RE_Bignum) then
2225 Right := Convert_To_Bignum (Right);
2228 -- We rewrite our node with:
2231 -- Bnn : Result_Type;
2233 -- M : Mark_Id := SS_Mark;
2235 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2243 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2244 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2248 case N_Op_Compare (Nkind (N)) is
2249 when N_Op_Eq => Ent := RE_Big_EQ;
2250 when N_Op_Ge => Ent := RE_Big_GE;
2251 when N_Op_Gt => Ent := RE_Big_GT;
2252 when N_Op_Le => Ent := RE_Big_LE;
2253 when N_Op_Lt => Ent := RE_Big_LT;
2254 when N_Op_Ne => Ent := RE_Big_NE;
2257 -- Insert assignment to Bnn into the bignum block
2260 (First (Statements (Handled_Statement_Sequence (Blk))),
2261 Make_Assignment_Statement (Loc,
2262 Name => New_Occurrence_Of (Bnn, Loc),
2264 Make_Function_Call (Loc,
2266 New_Occurrence_Of (RTE (Ent), Loc),
2267 Parameter_Associations => New_List (Left, Right))));
2269 -- Now do the rewrite with expression actions
2272 Make_Expression_With_Actions (Loc,
2273 Actions => New_List (
2274 Make_Object_Declaration (Loc,
2275 Defining_Identifier => Bnn,
2276 Object_Definition =>
2277 New_Occurrence_Of (Result_Type, Loc)),
2279 Expression => New_Occurrence_Of (Bnn, Loc)));
2280 Analyze_And_Resolve (N, Result_Type);
2284 -- No bignums involved, but types are different, so we must have
2285 -- rewritten one of the operands as a Long_Long_Integer but not
2288 -- If left operand is Long_Long_Integer, convert right operand
2289 -- and we are done (with a comparison of two Long_Long_Integers).
2291 elsif Ltype = LLIB then
2292 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2293 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2296 -- If right operand is Long_Long_Integer, convert left operand
2297 -- and we are done (with a comparison of two Long_Long_Integers).
2299 -- This is the only remaining possibility
2301 else pragma Assert (Rtype = LLIB);
2302 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2303 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2307 end Expand_Compare_Minimize_Eliminate_Overflow;
2309 -------------------------------
2310 -- Expand_Composite_Equality --
2311 -------------------------------
2313 -- This function is only called for comparing internal fields of composite
2314 -- types when these fields are themselves composites. This is a special
2315 -- case because it is not possible to respect normal Ada visibility rules.
2317 function Expand_Composite_Equality
2322 Bodies : List_Id) return Node_Id
2324 Loc : constant Source_Ptr := Sloc (Nod);
2325 Full_Type : Entity_Id;
2329 function Find_Primitive_Eq return Node_Id;
2330 -- AI05-0123: Locate primitive equality for type if it exists, and
2331 -- build the corresponding call. If operation is abstract, replace
2332 -- call with an explicit raise. Return Empty if there is no primitive.
2334 -----------------------
2335 -- Find_Primitive_Eq --
2336 -----------------------
2338 function Find_Primitive_Eq return Node_Id is
2343 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
2344 while Present (Prim_E) loop
2345 Prim := Node (Prim_E);
2347 -- Locate primitive equality with the right signature
2349 if Chars (Prim) = Name_Op_Eq
2350 and then Etype (First_Formal (Prim)) =
2351 Etype (Next_Formal (First_Formal (Prim)))
2352 and then Etype (Prim) = Standard_Boolean
2354 if Is_Abstract_Subprogram (Prim) then
2356 Make_Raise_Program_Error (Loc,
2357 Reason => PE_Explicit_Raise);
2361 Make_Function_Call (Loc,
2362 Name => New_Occurrence_Of (Prim, Loc),
2363 Parameter_Associations => New_List (Lhs, Rhs));
2370 -- If not found, predefined operation will be used
2373 end Find_Primitive_Eq;
2375 -- Start of processing for Expand_Composite_Equality
2378 if Is_Private_Type (Typ) then
2379 Full_Type := Underlying_Type (Typ);
2384 -- If the private type has no completion the context may be the
2385 -- expansion of a composite equality for a composite type with some
2386 -- still incomplete components. The expression will not be analyzed
2387 -- until the enclosing type is completed, at which point this will be
2388 -- properly expanded, unless there is a bona fide completion error.
2390 if No (Full_Type) then
2391 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2394 Full_Type := Base_Type (Full_Type);
2396 -- When the base type itself is private, use the full view to expand
2397 -- the composite equality.
2399 if Is_Private_Type (Full_Type) then
2400 Full_Type := Underlying_Type (Full_Type);
2403 -- Case of array types
2405 if Is_Array_Type (Full_Type) then
2407 -- If the operand is an elementary type other than a floating-point
2408 -- type, then we can simply use the built-in block bitwise equality,
2409 -- since the predefined equality operators always apply and bitwise
2410 -- equality is fine for all these cases.
2412 if Is_Elementary_Type (Component_Type (Full_Type))
2413 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2415 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2417 -- For composite component types, and floating-point types, use the
2418 -- expansion. This deals with tagged component types (where we use
2419 -- the applicable equality routine) and floating-point, (where we
2420 -- need to worry about negative zeroes), and also the case of any
2421 -- composite type recursively containing such fields.
2424 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
2427 -- Case of tagged record types
2429 elsif Is_Tagged_Type (Full_Type) then
2431 -- Call the primitive operation "=" of this type
2433 if Is_Class_Wide_Type (Full_Type) then
2434 Full_Type := Root_Type (Full_Type);
2437 -- If this is derived from an untagged private type completed with a
2438 -- tagged type, it does not have a full view, so we use the primitive
2439 -- operations of the private type. This check should no longer be
2440 -- necessary when these types receive their full views ???
2442 if Is_Private_Type (Typ)
2443 and then not Is_Tagged_Type (Typ)
2444 and then not Is_Controlled (Typ)
2445 and then Is_Derived_Type (Typ)
2446 and then No (Full_View (Typ))
2448 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2450 Prim := First_Elmt (Primitive_Operations (Full_Type));
2454 Eq_Op := Node (Prim);
2455 exit when Chars (Eq_Op) = Name_Op_Eq
2456 and then Etype (First_Formal (Eq_Op)) =
2457 Etype (Next_Formal (First_Formal (Eq_Op)))
2458 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
2460 pragma Assert (Present (Prim));
2463 Eq_Op := Node (Prim);
2466 Make_Function_Call (Loc,
2467 Name => New_Occurrence_Of (Eq_Op, Loc),
2468 Parameter_Associations =>
2470 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2471 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2473 -- Case of untagged record types
2475 elsif Is_Record_Type (Full_Type) then
2476 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2478 if Present (Eq_Op) then
2479 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2481 -- Inherited equality from parent type. Convert the actuals to
2482 -- match signature of operation.
2485 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2489 Make_Function_Call (Loc,
2490 Name => New_Occurrence_Of (Eq_Op, Loc),
2491 Parameter_Associations => New_List (
2492 OK_Convert_To (T, Lhs),
2493 OK_Convert_To (T, Rhs)));
2497 -- Comparison between Unchecked_Union components
2499 if Is_Unchecked_Union (Full_Type) then
2501 Lhs_Type : Node_Id := Full_Type;
2502 Rhs_Type : Node_Id := Full_Type;
2503 Lhs_Discr_Val : Node_Id;
2504 Rhs_Discr_Val : Node_Id;
2509 if Nkind (Lhs) = N_Selected_Component then
2510 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2515 if Nkind (Rhs) = N_Selected_Component then
2516 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2519 -- Lhs of the composite equality
2521 if Is_Constrained (Lhs_Type) then
2523 -- Since the enclosing record type can never be an
2524 -- Unchecked_Union (this code is executed for records
2525 -- that do not have variants), we may reference its
2528 if Nkind (Lhs) = N_Selected_Component
2529 and then Has_Per_Object_Constraint
2530 (Entity (Selector_Name (Lhs)))
2533 Make_Selected_Component (Loc,
2534 Prefix => Prefix (Lhs),
2537 (Get_Discriminant_Value
2538 (First_Discriminant (Lhs_Type),
2540 Stored_Constraint (Lhs_Type))));
2545 (Get_Discriminant_Value
2546 (First_Discriminant (Lhs_Type),
2548 Stored_Constraint (Lhs_Type)));
2552 -- It is not possible to infer the discriminant since
2553 -- the subtype is not constrained.
2556 Make_Raise_Program_Error (Loc,
2557 Reason => PE_Unchecked_Union_Restriction);
2560 -- Rhs of the composite equality
2562 if Is_Constrained (Rhs_Type) then
2563 if Nkind (Rhs) = N_Selected_Component
2564 and then Has_Per_Object_Constraint
2565 (Entity (Selector_Name (Rhs)))
2568 Make_Selected_Component (Loc,
2569 Prefix => Prefix (Rhs),
2572 (Get_Discriminant_Value
2573 (First_Discriminant (Rhs_Type),
2575 Stored_Constraint (Rhs_Type))));
2580 (Get_Discriminant_Value
2581 (First_Discriminant (Rhs_Type),
2583 Stored_Constraint (Rhs_Type)));
2588 Make_Raise_Program_Error (Loc,
2589 Reason => PE_Unchecked_Union_Restriction);
2592 -- Call the TSS equality function with the inferred
2593 -- discriminant values.
2596 Make_Function_Call (Loc,
2597 Name => New_Occurrence_Of (Eq_Op, Loc),
2598 Parameter_Associations => New_List (
2605 -- All cases other than comparing Unchecked_Union types
2609 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2612 Make_Function_Call (Loc,
2614 New_Occurrence_Of (Eq_Op, Loc),
2615 Parameter_Associations => New_List (
2616 OK_Convert_To (T, Lhs),
2617 OK_Convert_To (T, Rhs)));
2622 -- Equality composes in Ada 2012 for untagged record types. It also
2623 -- composes for bounded strings, because they are part of the
2624 -- predefined environment. We could make it compose for bounded
2625 -- strings by making them tagged, or by making sure all subcomponents
2626 -- are set to the same value, even when not used. Instead, we have
2627 -- this special case in the compiler, because it's more efficient.
2629 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2631 -- If no TSS has been created for the type, check whether there is
2632 -- a primitive equality declared for it.
2635 Op : constant Node_Id := Find_Primitive_Eq;
2638 -- Use user-defined primitive if it exists, otherwise use
2639 -- predefined equality.
2641 if Present (Op) then
2644 return Make_Op_Eq (Loc, Lhs, Rhs);
2649 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2652 -- Non-composite types (always use predefined equality)
2655 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2657 end Expand_Composite_Equality;
2659 ------------------------
2660 -- Expand_Concatenate --
2661 ------------------------
2663 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2664 Loc : constant Source_Ptr := Sloc (Cnode);
2666 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2667 -- Result type of concatenation
2669 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2670 -- Component type. Elements of this component type can appear as one
2671 -- of the operands of concatenation as well as arrays.
2673 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2676 Ityp : constant Entity_Id := Base_Type (Istyp);
2677 -- Index type. This is the base type of the index subtype, and is used
2678 -- for all computed bounds (which may be out of range of Istyp in the
2679 -- case of null ranges).
2682 -- This is the type we use to do arithmetic to compute the bounds and
2683 -- lengths of operands. The choice of this type is a little subtle and
2684 -- is discussed in a separate section at the start of the body code.
2686 Concatenation_Error : exception;
2687 -- Raised if concatenation is sure to raise a CE
2689 Result_May_Be_Null : Boolean := True;
2690 -- Reset to False if at least one operand is encountered which is known
2691 -- at compile time to be non-null. Used for handling the special case
2692 -- of setting the high bound to the last operand high bound for a null
2693 -- result, thus ensuring a proper high bound in the super-flat case.
2695 N : constant Nat := List_Length (Opnds);
2696 -- Number of concatenation operands including possibly null operands
2699 -- Number of operands excluding any known to be null, except that the
2700 -- last operand is always retained, in case it provides the bounds for
2704 -- Current operand being processed in the loop through operands. After
2705 -- this loop is complete, always contains the last operand (which is not
2706 -- the same as Operands (NN), since null operands are skipped).
2708 -- Arrays describing the operands, only the first NN entries of each
2709 -- array are set (NN < N when we exclude known null operands).
2711 Is_Fixed_Length : array (1 .. N) of Boolean;
2712 -- True if length of corresponding operand known at compile time
2714 Operands : array (1 .. N) of Node_Id;
2715 -- Set to the corresponding entry in the Opnds list (but note that null
2716 -- operands are excluded, so not all entries in the list are stored).
2718 Fixed_Length : array (1 .. N) of Uint;
2719 -- Set to length of operand. Entries in this array are set only if the
2720 -- corresponding entry in Is_Fixed_Length is True.
2722 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2723 -- Set to lower bound of operand. Either an integer literal in the case
2724 -- where the bound is known at compile time, else actual lower bound.
2725 -- The operand low bound is of type Ityp.
2727 Var_Length : array (1 .. N) of Entity_Id;
2728 -- Set to an entity of type Natural that contains the length of an
2729 -- operand whose length is not known at compile time. Entries in this
2730 -- array are set only if the corresponding entry in Is_Fixed_Length
2731 -- is False. The entity is of type Artyp.
2733 Aggr_Length : array (0 .. N) of Node_Id;
2734 -- The J'th entry in an expression node that represents the total length
2735 -- of operands 1 through J. It is either an integer literal node, or a
2736 -- reference to a constant entity with the right value, so it is fine
2737 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2738 -- entry always is set to zero. The length is of type Artyp.
2740 Low_Bound : Node_Id;
2741 -- A tree node representing the low bound of the result (of type Ityp).
2742 -- This is either an integer literal node, or an identifier reference to
2743 -- a constant entity initialized to the appropriate value.
2745 Last_Opnd_Low_Bound : Node_Id;
2746 -- A tree node representing the low bound of the last operand. This
2747 -- need only be set if the result could be null. It is used for the
2748 -- special case of setting the right low bound for a null result.
2749 -- This is of type Ityp.
2751 Last_Opnd_High_Bound : Node_Id;
2752 -- A tree node representing the high bound of the last operand. This
2753 -- need only be set if the result could be null. It is used for the
2754 -- special case of setting the right high bound for a null result.
2755 -- This is of type Ityp.
2757 High_Bound : Node_Id;
2758 -- A tree node representing the high bound of the result (of type Ityp)
2761 -- Result of the concatenation (of type Ityp)
2763 Actions : constant List_Id := New_List;
2764 -- Collect actions to be inserted
2766 Known_Non_Null_Operand_Seen : Boolean;
2767 -- Set True during generation of the assignments of operands into
2768 -- result once an operand known to be non-null has been seen.
2770 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2771 -- This function makes an N_Integer_Literal node that is returned in
2772 -- analyzed form with the type set to Artyp. Importantly this literal
2773 -- is not flagged as static, so that if we do computations with it that
2774 -- result in statically detected out of range conditions, we will not
2775 -- generate error messages but instead warning messages.
2777 function To_Artyp (X : Node_Id) return Node_Id;
2778 -- Given a node of type Ityp, returns the corresponding value of type
2779 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2780 -- For enum types, the Pos of the value is returned.
2782 function To_Ityp (X : Node_Id) return Node_Id;
2783 -- The inverse function (uses Val in the case of enumeration types)
2785 ------------------------
2786 -- Make_Artyp_Literal --
2787 ------------------------
2789 function Make_Artyp_Literal (Val : Nat) return Node_Id is
2790 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2792 Set_Etype (Result, Artyp);
2793 Set_Analyzed (Result, True);
2794 Set_Is_Static_Expression (Result, False);
2796 end Make_Artyp_Literal;
2802 function To_Artyp (X : Node_Id) return Node_Id is
2804 if Ityp = Base_Type (Artyp) then
2807 elsif Is_Enumeration_Type (Ityp) then
2809 Make_Attribute_Reference (Loc,
2810 Prefix => New_Occurrence_Of (Ityp, Loc),
2811 Attribute_Name => Name_Pos,
2812 Expressions => New_List (X));
2815 return Convert_To (Artyp, X);
2823 function To_Ityp (X : Node_Id) return Node_Id is
2825 if Is_Enumeration_Type (Ityp) then
2827 Make_Attribute_Reference (Loc,
2828 Prefix => New_Occurrence_Of (Ityp, Loc),
2829 Attribute_Name => Name_Val,
2830 Expressions => New_List (X));
2832 -- Case where we will do a type conversion
2835 if Ityp = Base_Type (Artyp) then
2838 return Convert_To (Ityp, X);
2843 -- Local Declarations
2845 Lib_Level_Target : constant Boolean :=
2846 Nkind (Parent (Cnode)) = N_Object_Declaration
2848 Is_Library_Level_Entity (Defining_Identifier (Parent (Cnode)));
2850 -- If the concatenation declares a library level entity, we call the
2851 -- built-in concatenation routines to prevent code bloat, regardless
2852 -- of optimization level. This is space-efficient, and prevent linking
2853 -- problems when units are compiled with different optimizations.
2855 Opnd_Typ : Entity_Id;
2862 -- Start of processing for Expand_Concatenate
2865 -- Choose an appropriate computational type
2867 -- We will be doing calculations of lengths and bounds in this routine
2868 -- and computing one from the other in some cases, e.g. getting the high
2869 -- bound by adding the length-1 to the low bound.
2871 -- We can't just use the index type, or even its base type for this
2872 -- purpose for two reasons. First it might be an enumeration type which
2873 -- is not suitable for computations of any kind, and second it may
2874 -- simply not have enough range. For example if the index type is
2875 -- -128..+127 then lengths can be up to 256, which is out of range of
2878 -- For enumeration types, we can simply use Standard_Integer, this is
2879 -- sufficient since the actual number of enumeration literals cannot
2880 -- possibly exceed the range of integer (remember we will be doing the
2881 -- arithmetic with POS values, not representation values).
2883 if Is_Enumeration_Type (Ityp) then
2884 Artyp := Standard_Integer;
2886 -- If index type is Positive, we use the standard unsigned type, to give
2887 -- more room on the top of the range, obviating the need for an overflow
2888 -- check when creating the upper bound. This is needed to avoid junk
2889 -- overflow checks in the common case of String types.
2891 -- ??? Disabled for now
2893 -- elsif Istyp = Standard_Positive then
2894 -- Artyp := Standard_Unsigned;
2896 -- For modular types, we use a 32-bit modular type for types whose size
2897 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2898 -- identity type, and for larger unsigned types we use 64-bits.
2900 elsif Is_Modular_Integer_Type (Ityp) then
2901 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
2902 Artyp := Standard_Unsigned;
2903 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
2906 Artyp := RTE (RE_Long_Long_Unsigned);
2909 -- Similar treatment for signed types
2912 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
2913 Artyp := Standard_Integer;
2914 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
2917 Artyp := Standard_Long_Long_Integer;
2921 -- Supply dummy entry at start of length array
2923 Aggr_Length (0) := Make_Artyp_Literal (0);
2925 -- Go through operands setting up the above arrays
2929 Opnd := Remove_Head (Opnds);
2930 Opnd_Typ := Etype (Opnd);
2932 -- The parent got messed up when we put the operands in a list,
2933 -- so now put back the proper parent for the saved operand, that
2934 -- is to say the concatenation node, to make sure that each operand
2935 -- is seen as a subexpression, e.g. if actions must be inserted.
2937 Set_Parent (Opnd, Cnode);
2939 -- Set will be True when we have setup one entry in the array
2943 -- Singleton element (or character literal) case
2945 if Base_Type (Opnd_Typ) = Ctyp then
2947 Operands (NN) := Opnd;
2948 Is_Fixed_Length (NN) := True;
2949 Fixed_Length (NN) := Uint_1;
2950 Result_May_Be_Null := False;
2952 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2953 -- since we know that the result cannot be null).
2955 Opnd_Low_Bound (NN) :=
2956 Make_Attribute_Reference (Loc,
2957 Prefix => New_Occurrence_Of (Istyp, Loc),
2958 Attribute_Name => Name_First);
2962 -- String literal case (can only occur for strings of course)
2964 elsif Nkind (Opnd) = N_String_Literal then
2965 Len := String_Literal_Length (Opnd_Typ);
2968 Result_May_Be_Null := False;
2971 -- Capture last operand low and high bound if result could be null
2973 if J = N and then Result_May_Be_Null then
2974 Last_Opnd_Low_Bound :=
2975 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
2977 Last_Opnd_High_Bound :=
2978 Make_Op_Subtract (Loc,
2980 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
2981 Right_Opnd => Make_Integer_Literal (Loc, 1));
2984 -- Skip null string literal
2986 if J < N and then Len = 0 then
2991 Operands (NN) := Opnd;
2992 Is_Fixed_Length (NN) := True;
2994 -- Set length and bounds
2996 Fixed_Length (NN) := Len;
2998 Opnd_Low_Bound (NN) :=
2999 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3006 -- Check constrained case with known bounds
3008 if Is_Constrained (Opnd_Typ) then
3010 Index : constant Node_Id := First_Index (Opnd_Typ);
3011 Indx_Typ : constant Entity_Id := Etype (Index);
3012 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3013 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3016 -- Fixed length constrained array type with known at compile
3017 -- time bounds is last case of fixed length operand.
3019 if Compile_Time_Known_Value (Lo)
3021 Compile_Time_Known_Value (Hi)
3024 Loval : constant Uint := Expr_Value (Lo);
3025 Hival : constant Uint := Expr_Value (Hi);
3026 Len : constant Uint :=
3027 UI_Max (Hival - Loval + 1, Uint_0);
3031 Result_May_Be_Null := False;
3034 -- Capture last operand bounds if result could be null
3036 if J = N and then Result_May_Be_Null then
3037 Last_Opnd_Low_Bound :=
3039 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3041 Last_Opnd_High_Bound :=
3043 Make_Integer_Literal (Loc, Expr_Value (Hi)));
3046 -- Exclude null length case unless last operand
3048 if J < N and then Len = 0 then
3053 Operands (NN) := Opnd;
3054 Is_Fixed_Length (NN) := True;
3055 Fixed_Length (NN) := Len;
3057 Opnd_Low_Bound (NN) :=
3059 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3066 -- All cases where the length is not known at compile time, or the
3067 -- special case of an operand which is known to be null but has a
3068 -- lower bound other than 1 or is other than a string type.
3073 -- Capture operand bounds
3075 Opnd_Low_Bound (NN) :=
3076 Make_Attribute_Reference (Loc,
3078 Duplicate_Subexpr (Opnd, Name_Req => True),
3079 Attribute_Name => Name_First);
3081 -- Capture last operand bounds if result could be null
3083 if J = N and Result_May_Be_Null then
3084 Last_Opnd_Low_Bound :=
3086 Make_Attribute_Reference (Loc,
3088 Duplicate_Subexpr (Opnd, Name_Req => True),
3089 Attribute_Name => Name_First));
3091 Last_Opnd_High_Bound :=
3093 Make_Attribute_Reference (Loc,
3095 Duplicate_Subexpr (Opnd, Name_Req => True),
3096 Attribute_Name => Name_Last));
3099 -- Capture length of operand in entity
3101 Operands (NN) := Opnd;
3102 Is_Fixed_Length (NN) := False;
3104 Var_Length (NN) := Make_Temporary (Loc, 'L');
3107 Make_Object_Declaration (Loc,
3108 Defining_Identifier => Var_Length (NN),
3109 Constant_Present => True,
3110 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3112 Make_Attribute_Reference (Loc,
3114 Duplicate_Subexpr (Opnd, Name_Req => True),
3115 Attribute_Name => Name_Length)));
3119 -- Set next entry in aggregate length array
3121 -- For first entry, make either integer literal for fixed length
3122 -- or a reference to the saved length for variable length.
3125 if Is_Fixed_Length (1) then
3126 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3128 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3131 -- If entry is fixed length and only fixed lengths so far, make
3132 -- appropriate new integer literal adding new length.
3134 elsif Is_Fixed_Length (NN)
3135 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3138 Make_Integer_Literal (Loc,
3139 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3141 -- All other cases, construct an addition node for the length and
3142 -- create an entity initialized to this length.
3145 Ent := Make_Temporary (Loc, 'L');
3147 if Is_Fixed_Length (NN) then
3148 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3150 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3154 Make_Object_Declaration (Loc,
3155 Defining_Identifier => Ent,
3156 Constant_Present => True,
3157 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3160 Left_Opnd => New_Copy (Aggr_Length (NN - 1)),
3161 Right_Opnd => Clen)));
3163 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3170 -- If we have only skipped null operands, return the last operand
3177 -- If we have only one non-null operand, return it and we are done.
3178 -- There is one case in which this cannot be done, and that is when
3179 -- the sole operand is of the element type, in which case it must be
3180 -- converted to an array, and the easiest way of doing that is to go
3181 -- through the normal general circuit.
3183 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3184 Result := Operands (1);
3188 -- Cases where we have a real concatenation
3190 -- Next step is to find the low bound for the result array that we
3191 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3193 -- If the ultimate ancestor of the index subtype is a constrained array
3194 -- definition, then the lower bound is that of the index subtype as
3195 -- specified by (RM 4.5.3(6)).
3197 -- The right test here is to go to the root type, and then the ultimate
3198 -- ancestor is the first subtype of this root type.
3200 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3202 Make_Attribute_Reference (Loc,
3204 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3205 Attribute_Name => Name_First);
3207 -- If the first operand in the list has known length we know that
3208 -- the lower bound of the result is the lower bound of this operand.
3210 elsif Is_Fixed_Length (1) then
3211 Low_Bound := Opnd_Low_Bound (1);
3213 -- OK, we don't know the lower bound, we have to build a horrible
3214 -- if expression node of the form
3216 -- if Cond1'Length /= 0 then
3219 -- if Opnd2'Length /= 0 then
3224 -- The nesting ends either when we hit an operand whose length is known
3225 -- at compile time, or on reaching the last operand, whose low bound we
3226 -- take unconditionally whether or not it is null. It's easiest to do
3227 -- this with a recursive procedure:
3231 function Get_Known_Bound (J : Nat) return Node_Id;
3232 -- Returns the lower bound determined by operands J .. NN
3234 ---------------------
3235 -- Get_Known_Bound --
3236 ---------------------
3238 function Get_Known_Bound (J : Nat) return Node_Id is
3240 if Is_Fixed_Length (J) or else J = NN then
3241 return New_Copy (Opnd_Low_Bound (J));
3245 Make_If_Expression (Loc,
3246 Expressions => New_List (
3250 New_Occurrence_Of (Var_Length (J), Loc),
3252 Make_Integer_Literal (Loc, 0)),
3254 New_Copy (Opnd_Low_Bound (J)),
3255 Get_Known_Bound (J + 1)));
3257 end Get_Known_Bound;
3260 Ent := Make_Temporary (Loc, 'L');
3263 Make_Object_Declaration (Loc,
3264 Defining_Identifier => Ent,
3265 Constant_Present => True,
3266 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3267 Expression => Get_Known_Bound (1)));
3269 Low_Bound := New_Occurrence_Of (Ent, Loc);
3273 -- Now we can safely compute the upper bound, normally
3274 -- Low_Bound + Length - 1.
3279 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3281 Make_Op_Subtract (Loc,
3282 Left_Opnd => New_Copy (Aggr_Length (NN)),
3283 Right_Opnd => Make_Artyp_Literal (1))));
3285 -- Note that calculation of the high bound may cause overflow in some
3286 -- very weird cases, so in the general case we need an overflow check on
3287 -- the high bound. We can avoid this for the common case of string types
3288 -- and other types whose index is Positive, since we chose a wider range
3289 -- for the arithmetic type.
3291 if Istyp /= Standard_Positive then
3292 Activate_Overflow_Check (High_Bound);
3295 -- Handle the exceptional case where the result is null, in which case
3296 -- case the bounds come from the last operand (so that we get the proper
3297 -- bounds if the last operand is super-flat).
3299 if Result_May_Be_Null then
3301 Make_If_Expression (Loc,
3302 Expressions => New_List (
3304 Left_Opnd => New_Copy (Aggr_Length (NN)),
3305 Right_Opnd => Make_Artyp_Literal (0)),
3306 Last_Opnd_Low_Bound,
3310 Make_If_Expression (Loc,
3311 Expressions => New_List (
3313 Left_Opnd => New_Copy (Aggr_Length (NN)),
3314 Right_Opnd => Make_Artyp_Literal (0)),
3315 Last_Opnd_High_Bound,
3319 -- Here is where we insert the saved up actions
3321 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3323 -- Now we construct an array object with appropriate bounds. We mark
3324 -- the target as internal to prevent useless initialization when
3325 -- Initialize_Scalars is enabled. Also since this is the actual result
3326 -- entity, we make sure we have debug information for the result.
3328 Ent := Make_Temporary (Loc, 'S');
3329 Set_Is_Internal (Ent);
3330 Set_Needs_Debug_Info (Ent);
3332 -- If the bound is statically known to be out of range, we do not want
3333 -- to abort, we want a warning and a runtime constraint error. Note that
3334 -- we have arranged that the result will not be treated as a static
3335 -- constant, so we won't get an illegality during this insertion.
3337 Insert_Action (Cnode,
3338 Make_Object_Declaration (Loc,
3339 Defining_Identifier => Ent,
3340 Object_Definition =>
3341 Make_Subtype_Indication (Loc,
3342 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3344 Make_Index_Or_Discriminant_Constraint (Loc,
3345 Constraints => New_List (
3347 Low_Bound => Low_Bound,
3348 High_Bound => High_Bound))))),
3349 Suppress => All_Checks);
3351 -- If the result of the concatenation appears as the initializing
3352 -- expression of an object declaration, we can just rename the
3353 -- result, rather than copying it.
3355 Set_OK_To_Rename (Ent);
3357 -- Catch the static out of range case now
3359 if Raises_Constraint_Error (High_Bound) then
3360 raise Concatenation_Error;
3363 -- Now we will generate the assignments to do the actual concatenation
3365 -- There is one case in which we will not do this, namely when all the
3366 -- following conditions are met:
3368 -- The result type is Standard.String
3370 -- There are nine or fewer retained (non-null) operands
3372 -- The optimization level is -O0
3374 -- The corresponding System.Concat_n.Str_Concat_n routine is
3375 -- available in the run time.
3377 -- The debug flag gnatd.c is not set
3379 -- If all these conditions are met then we generate a call to the
3380 -- relevant concatenation routine. The purpose of this is to avoid
3381 -- undesirable code bloat at -O0.
3383 if Atyp = Standard_String
3384 and then NN in 2 .. 9
3385 and then (Lib_Level_Target
3386 or else ((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3387 and then not Debug_Flag_Dot_C))
3390 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3401 if RTE_Available (RR (NN)) then
3403 Opnds : constant List_Id :=
3404 New_List (New_Occurrence_Of (Ent, Loc));
3407 for J in 1 .. NN loop
3408 if Is_List_Member (Operands (J)) then
3409 Remove (Operands (J));
3412 if Base_Type (Etype (Operands (J))) = Ctyp then
3414 Make_Aggregate (Loc,
3415 Component_Associations => New_List (
3416 Make_Component_Association (Loc,
3417 Choices => New_List (
3418 Make_Integer_Literal (Loc, 1)),
3419 Expression => Operands (J)))));
3422 Append_To (Opnds, Operands (J));
3426 Insert_Action (Cnode,
3427 Make_Procedure_Call_Statement (Loc,
3428 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3429 Parameter_Associations => Opnds));
3431 Result := New_Occurrence_Of (Ent, Loc);
3438 -- Not special case so generate the assignments
3440 Known_Non_Null_Operand_Seen := False;
3442 for J in 1 .. NN loop
3444 Lo : constant Node_Id :=
3446 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3447 Right_Opnd => Aggr_Length (J - 1));
3449 Hi : constant Node_Id :=
3451 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3453 Make_Op_Subtract (Loc,
3454 Left_Opnd => Aggr_Length (J),
3455 Right_Opnd => Make_Artyp_Literal (1)));
3458 -- Singleton case, simple assignment
3460 if Base_Type (Etype (Operands (J))) = Ctyp then
3461 Known_Non_Null_Operand_Seen := True;
3462 Insert_Action (Cnode,
3463 Make_Assignment_Statement (Loc,
3465 Make_Indexed_Component (Loc,
3466 Prefix => New_Occurrence_Of (Ent, Loc),
3467 Expressions => New_List (To_Ityp (Lo))),
3468 Expression => Operands (J)),
3469 Suppress => All_Checks);
3471 -- Array case, slice assignment, skipped when argument is fixed
3472 -- length and known to be null.
3474 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3477 Make_Assignment_Statement (Loc,
3481 New_Occurrence_Of (Ent, Loc),
3484 Low_Bound => To_Ityp (Lo),
3485 High_Bound => To_Ityp (Hi))),
3486 Expression => Operands (J));
3488 if Is_Fixed_Length (J) then
3489 Known_Non_Null_Operand_Seen := True;
3491 elsif not Known_Non_Null_Operand_Seen then
3493 -- Here if operand length is not statically known and no
3494 -- operand known to be non-null has been processed yet.
3495 -- If operand length is 0, we do not need to perform the
3496 -- assignment, and we must avoid the evaluation of the
3497 -- high bound of the slice, since it may underflow if the
3498 -- low bound is Ityp'First.
3501 Make_Implicit_If_Statement (Cnode,
3505 New_Occurrence_Of (Var_Length (J), Loc),
3506 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3507 Then_Statements => New_List (Assign));
3510 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3516 -- Finally we build the result, which is a reference to the array object
3518 Result := New_Occurrence_Of (Ent, Loc);
3521 Rewrite (Cnode, Result);
3522 Analyze_And_Resolve (Cnode, Atyp);
3525 when Concatenation_Error =>
3527 -- Kill warning generated for the declaration of the static out of
3528 -- range high bound, and instead generate a Constraint_Error with
3529 -- an appropriate specific message.
3531 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3532 Apply_Compile_Time_Constraint_Error
3534 Msg => "concatenation result upper bound out of range??",
3535 Reason => CE_Range_Check_Failed);
3536 end Expand_Concatenate;
3538 ---------------------------------------------------
3539 -- Expand_Membership_Minimize_Eliminate_Overflow --
3540 ---------------------------------------------------
3542 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3543 pragma Assert (Nkind (N) = N_In);
3544 -- Despite the name, this routine applies only to N_In, not to
3545 -- N_Not_In. The latter is always rewritten as not (X in Y).
3547 Result_Type : constant Entity_Id := Etype (N);
3548 -- Capture result type, may be a derived boolean type
3550 Loc : constant Source_Ptr := Sloc (N);
3551 Lop : constant Node_Id := Left_Opnd (N);
3552 Rop : constant Node_Id := Right_Opnd (N);
3554 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3555 -- is thus tempting to capture these values, but due to the rewrites
3556 -- that occur as a result of overflow checking, these values change
3557 -- as we go along, and it is safe just to always use Etype explicitly.
3559 Restype : constant Entity_Id := Etype (N);
3563 -- Bounds in Minimize calls, not used currently
3565 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3566 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3569 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3571 -- If right operand is a subtype name, and the subtype name has no
3572 -- predicate, then we can just replace the right operand with an
3573 -- explicit range T'First .. T'Last, and use the explicit range code.
3575 if Nkind (Rop) /= N_Range
3576 and then No (Predicate_Function (Etype (Rop)))
3579 Rtyp : constant Entity_Id := Etype (Rop);
3584 Make_Attribute_Reference (Loc,
3585 Attribute_Name => Name_First,
3586 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3588 Make_Attribute_Reference (Loc,
3589 Attribute_Name => Name_Last,
3590 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3591 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3595 -- Here for the explicit range case. Note that the bounds of the range
3596 -- have not been processed for minimized or eliminated checks.
3598 if Nkind (Rop) = N_Range then
3599 Minimize_Eliminate_Overflows
3600 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3601 Minimize_Eliminate_Overflows
3602 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3604 -- We have A in B .. C, treated as A >= B and then A <= C
3608 if Is_RTE (Etype (Lop), RE_Bignum)
3609 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3610 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3613 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3614 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3615 L : constant Entity_Id :=
3616 Make_Defining_Identifier (Loc, Name_uL);
3617 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3618 Lbound : constant Node_Id :=
3619 Convert_To_Bignum (Low_Bound (Rop));
3620 Hbound : constant Node_Id :=
3621 Convert_To_Bignum (High_Bound (Rop));
3623 -- Now we rewrite the membership test node to look like
3626 -- Bnn : Result_Type;
3628 -- M : Mark_Id := SS_Mark;
3629 -- L : Bignum := Lopnd;
3631 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3639 -- Insert declaration of L into declarations of bignum block
3642 (Last (Declarations (Blk)),
3643 Make_Object_Declaration (Loc,
3644 Defining_Identifier => L,
3645 Object_Definition =>
3646 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3647 Expression => Lopnd));
3649 -- Insert assignment to Bnn into expressions of bignum block
3652 (First (Statements (Handled_Statement_Sequence (Blk))),
3653 Make_Assignment_Statement (Loc,
3654 Name => New_Occurrence_Of (Bnn, Loc),
3658 Make_Function_Call (Loc,
3660 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3661 Parameter_Associations => New_List (
3662 New_Occurrence_Of (L, Loc),
3666 Make_Function_Call (Loc,
3668 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3669 Parameter_Associations => New_List (
3670 New_Occurrence_Of (L, Loc),
3673 -- Now rewrite the node
3676 Make_Expression_With_Actions (Loc,
3677 Actions => New_List (
3678 Make_Object_Declaration (Loc,
3679 Defining_Identifier => Bnn,
3680 Object_Definition =>
3681 New_Occurrence_Of (Result_Type, Loc)),
3683 Expression => New_Occurrence_Of (Bnn, Loc)));
3684 Analyze_And_Resolve (N, Result_Type);
3688 -- Here if no bignums around
3691 -- Case where types are all the same
3693 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3695 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3699 -- If types are not all the same, it means that we have rewritten
3700 -- at least one of them to be of type Long_Long_Integer, and we
3701 -- will convert the other operands to Long_Long_Integer.
3704 Convert_To_And_Rewrite (LLIB, Lop);
3705 Set_Analyzed (Lop, False);
3706 Analyze_And_Resolve (Lop, LLIB);
3708 -- For the right operand, avoid unnecessary recursion into
3709 -- this routine, we know that overflow is not possible.
3711 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3712 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3713 Set_Analyzed (Rop, False);
3714 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3717 -- Now the three operands are of the same signed integer type,
3718 -- so we can use the normal expansion routine for membership,
3719 -- setting the flag to prevent recursion into this procedure.
3721 Set_No_Minimize_Eliminate (N);
3725 -- Right operand is a subtype name and the subtype has a predicate. We
3726 -- have to make sure the predicate is checked, and for that we need to
3727 -- use the standard N_In circuitry with appropriate types.
3730 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3732 -- If types are "right", just call Expand_N_In preventing recursion
3734 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3735 Set_No_Minimize_Eliminate (N);
3740 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3742 -- For X in T, we want to rewrite our node as
3745 -- Bnn : Result_Type;
3748 -- M : Mark_Id := SS_Mark;
3749 -- Lnn : Long_Long_Integer'Base
3755 -- if not Bignum_In_LLI_Range (Nnn) then
3758 -- Lnn := From_Bignum (Nnn);
3760 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3761 -- and then T'Base (Lnn) in T;
3770 -- A bit gruesome, but there doesn't seem to be a simpler way
3773 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3774 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3775 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3776 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3777 T : constant Entity_Id := Etype (Rop);
3778 TB : constant Entity_Id := Base_Type (T);
3782 -- Mark the last membership operation to prevent recursion
3786 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3787 Right_Opnd => New_Occurrence_Of (T, Loc));
3788 Set_No_Minimize_Eliminate (Nin);
3790 -- Now decorate the block
3793 (Last (Declarations (Blk)),
3794 Make_Object_Declaration (Loc,
3795 Defining_Identifier => Lnn,
3796 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
3799 (Last (Declarations (Blk)),
3800 Make_Object_Declaration (Loc,
3801 Defining_Identifier => Nnn,
3802 Object_Definition =>
3803 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3806 (First (Statements (Handled_Statement_Sequence (Blk))),
3808 Make_Assignment_Statement (Loc,
3809 Name => New_Occurrence_Of (Nnn, Loc),
3810 Expression => Relocate_Node (Lop)),
3812 Make_Implicit_If_Statement (N,
3816 Make_Function_Call (Loc,
3819 (RTE (RE_Bignum_In_LLI_Range), Loc),
3820 Parameter_Associations => New_List (
3821 New_Occurrence_Of (Nnn, Loc)))),
3823 Then_Statements => New_List (
3824 Make_Assignment_Statement (Loc,
3825 Name => New_Occurrence_Of (Bnn, Loc),
3827 New_Occurrence_Of (Standard_False, Loc))),
3829 Else_Statements => New_List (
3830 Make_Assignment_Statement (Loc,
3831 Name => New_Occurrence_Of (Lnn, Loc),
3833 Make_Function_Call (Loc,
3835 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3836 Parameter_Associations => New_List (
3837 New_Occurrence_Of (Nnn, Loc)))),
3839 Make_Assignment_Statement (Loc,
3840 Name => New_Occurrence_Of (Bnn, Loc),
3845 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3850 Make_Attribute_Reference (Loc,
3851 Attribute_Name => Name_First,
3853 New_Occurrence_Of (TB, Loc))),
3857 Make_Attribute_Reference (Loc,
3858 Attribute_Name => Name_Last,
3860 New_Occurrence_Of (TB, Loc))))),
3862 Right_Opnd => Nin))))));
3864 -- Now we can do the rewrite
3867 Make_Expression_With_Actions (Loc,
3868 Actions => New_List (
3869 Make_Object_Declaration (Loc,
3870 Defining_Identifier => Bnn,
3871 Object_Definition =>
3872 New_Occurrence_Of (Result_Type, Loc)),
3874 Expression => New_Occurrence_Of (Bnn, Loc)));
3875 Analyze_And_Resolve (N, Result_Type);
3879 -- Not bignum case, but types don't match (this means we rewrote the
3880 -- left operand to be Long_Long_Integer).
3883 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
3885 -- We rewrite the membership test as (where T is the type with
3886 -- the predicate, i.e. the type of the right operand)
3888 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3889 -- and then T'Base (Lop) in T
3892 T : constant Entity_Id := Etype (Rop);
3893 TB : constant Entity_Id := Base_Type (T);
3897 -- The last membership test is marked to prevent recursion
3901 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
3902 Right_Opnd => New_Occurrence_Of (T, Loc));
3903 Set_No_Minimize_Eliminate (Nin);
3905 -- Now do the rewrite
3916 Make_Attribute_Reference (Loc,
3917 Attribute_Name => Name_First,
3919 New_Occurrence_Of (TB, Loc))),
3922 Make_Attribute_Reference (Loc,
3923 Attribute_Name => Name_Last,
3925 New_Occurrence_Of (TB, Loc))))),
3926 Right_Opnd => Nin));
3927 Set_Analyzed (N, False);
3928 Analyze_And_Resolve (N, Restype);
3932 end Expand_Membership_Minimize_Eliminate_Overflow;
3934 ------------------------
3935 -- Expand_N_Allocator --
3936 ------------------------
3938 procedure Expand_N_Allocator (N : Node_Id) is
3939 Etyp : constant Entity_Id := Etype (Expression (N));
3940 Loc : constant Source_Ptr := Sloc (N);
3941 PtrT : constant Entity_Id := Etype (N);
3943 procedure Rewrite_Coextension (N : Node_Id);
3944 -- Static coextensions have the same lifetime as the entity they
3945 -- constrain. Such occurrences can be rewritten as aliased objects
3946 -- and their unrestricted access used instead of the coextension.
3948 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
3949 -- Given a constrained array type E, returns a node representing the
3950 -- code to compute the size in storage elements for the given type.
3951 -- This is done without using the attribute (which malfunctions for
3954 -------------------------
3955 -- Rewrite_Coextension --
3956 -------------------------
3958 procedure Rewrite_Coextension (N : Node_Id) is
3959 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
3960 Temp_Decl : Node_Id;
3964 -- Cnn : aliased Etyp;
3967 Make_Object_Declaration (Loc,
3968 Defining_Identifier => Temp_Id,
3969 Aliased_Present => True,
3970 Object_Definition => New_Occurrence_Of (Etyp, Loc));
3972 if Nkind (Expression (N)) = N_Qualified_Expression then
3973 Set_Expression (Temp_Decl, Expression (Expression (N)));
3976 Insert_Action (N, Temp_Decl);
3978 Make_Attribute_Reference (Loc,
3979 Prefix => New_Occurrence_Of (Temp_Id, Loc),
3980 Attribute_Name => Name_Unrestricted_Access));
3982 Analyze_And_Resolve (N, PtrT);
3983 end Rewrite_Coextension;
3985 ------------------------------
3986 -- Size_In_Storage_Elements --
3987 ------------------------------
3989 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
3991 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3992 -- However, the reason for the existence of this function is
3993 -- to construct a test for sizes too large, which means near the
3994 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3995 -- is that we get overflows when sizes are greater than 2**31.
3997 -- So what we end up doing for array types is to use the expression:
3999 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4001 -- which avoids this problem. All this is a bit bogus, but it does
4002 -- mean we catch common cases of trying to allocate arrays that
4003 -- are too large, and which in the absence of a check results in
4004 -- undetected chaos ???
4006 -- Note in particular that this is a pessimistic estimate in the
4007 -- case of packed array types, where an array element might occupy
4008 -- just a fraction of a storage element???
4015 for J in 1 .. Number_Dimensions (E) loop
4017 Make_Attribute_Reference (Loc,
4018 Prefix => New_Occurrence_Of (E, Loc),
4019 Attribute_Name => Name_Length,
4020 Expressions => New_List (Make_Integer_Literal (Loc, J)));
4027 Make_Op_Multiply (Loc,
4034 Make_Op_Multiply (Loc,
4037 Make_Attribute_Reference (Loc,
4038 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4039 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4041 end Size_In_Storage_Elements;
4045 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4049 Rel_Typ : Entity_Id;
4052 -- Start of processing for Expand_N_Allocator
4055 -- RM E.2.3(22). We enforce that the expected type of an allocator
4056 -- shall not be a remote access-to-class-wide-limited-private type
4058 -- Why is this being done at expansion time, seems clearly wrong ???
4060 Validate_Remote_Access_To_Class_Wide_Type (N);
4062 -- Processing for anonymous access-to-controlled types. These access
4063 -- types receive a special finalization master which appears in the
4064 -- declarations of the enclosing semantic unit. This expansion is done
4065 -- now to ensure that any additional types generated by this routine or
4066 -- Expand_Allocator_Expression inherit the proper type attributes.
4068 if (Ekind (PtrT) = E_Anonymous_Access_Type
4069 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4070 and then Needs_Finalization (Dtyp)
4072 -- Detect the allocation of an anonymous controlled object where the
4073 -- type of the context is named. For example:
4075 -- procedure Proc (Ptr : Named_Access_Typ);
4076 -- Proc (new Designated_Typ);
4078 -- Regardless of the anonymous-to-named access type conversion, the
4079 -- lifetime of the object must be associated with the named access
4080 -- type. Use the finalization-related attributes of this type.
4082 if Nkind_In (Parent (N), N_Type_Conversion,
4083 N_Unchecked_Type_Conversion)
4084 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4086 E_General_Access_Type)
4088 Rel_Typ := Etype (Parent (N));
4093 -- Anonymous access-to-controlled types allocate on the global pool.
4094 -- Note that this is a "root type only" attribute.
4096 if No (Associated_Storage_Pool (PtrT)) then
4097 if Present (Rel_Typ) then
4098 Set_Associated_Storage_Pool
4099 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4101 Set_Associated_Storage_Pool
4102 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4106 -- The finalization master must be inserted and analyzed as part of
4107 -- the current semantic unit. Note that the master is updated when
4108 -- analysis changes current units. Note that this is a "root type
4111 if Present (Rel_Typ) then
4112 Set_Finalization_Master
4113 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4115 Build_Anonymous_Master (Root_Type (PtrT));
4119 -- Set the storage pool and find the appropriate version of Allocate to
4120 -- call. Do not overwrite the storage pool if it is already set, which
4121 -- can happen for build-in-place function returns (see
4122 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4124 if No (Storage_Pool (N)) then
4125 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4127 if Present (Pool) then
4128 Set_Storage_Pool (N, Pool);
4130 if Is_RTE (Pool, RE_SS_Pool) then
4131 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4133 -- In the case of an allocator for a simple storage pool, locate
4134 -- and save a reference to the pool type's Allocate routine.
4136 elsif Present (Get_Rep_Pragma
4137 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4140 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4141 Alloc_Op : Entity_Id;
4143 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4144 while Present (Alloc_Op) loop
4145 if Scope (Alloc_Op) = Scope (Pool_Type)
4146 and then Present (First_Formal (Alloc_Op))
4147 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4149 Set_Procedure_To_Call (N, Alloc_Op);
4152 Alloc_Op := Homonym (Alloc_Op);
4157 elsif Is_Class_Wide_Type (Etype (Pool)) then
4158 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4161 Set_Procedure_To_Call (N,
4162 Find_Prim_Op (Etype (Pool), Name_Allocate));
4167 -- Under certain circumstances we can replace an allocator by an access
4168 -- to statically allocated storage. The conditions, as noted in AARM
4169 -- 3.10 (10c) are as follows:
4171 -- Size and initial value is known at compile time
4172 -- Access type is access-to-constant
4174 -- The allocator is not part of a constraint on a record component,
4175 -- because in that case the inserted actions are delayed until the
4176 -- record declaration is fully analyzed, which is too late for the
4177 -- analysis of the rewritten allocator.
4179 if Is_Access_Constant (PtrT)
4180 and then Nkind (Expression (N)) = N_Qualified_Expression
4181 and then Compile_Time_Known_Value (Expression (Expression (N)))
4182 and then Size_Known_At_Compile_Time
4183 (Etype (Expression (Expression (N))))
4184 and then not Is_Record_Type (Current_Scope)
4186 -- Here we can do the optimization. For the allocator
4190 -- We insert an object declaration
4192 -- Tnn : aliased x := y;
4194 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4195 -- marked as requiring static allocation.
4197 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4198 Desig := Subtype_Mark (Expression (N));
4200 -- If context is constrained, use constrained subtype directly,
4201 -- so that the constant is not labelled as having a nominally
4202 -- unconstrained subtype.
4204 if Entity (Desig) = Base_Type (Dtyp) then
4205 Desig := New_Occurrence_Of (Dtyp, Loc);
4209 Make_Object_Declaration (Loc,
4210 Defining_Identifier => Temp,
4211 Aliased_Present => True,
4212 Constant_Present => Is_Access_Constant (PtrT),
4213 Object_Definition => Desig,
4214 Expression => Expression (Expression (N))));
4217 Make_Attribute_Reference (Loc,
4218 Prefix => New_Occurrence_Of (Temp, Loc),
4219 Attribute_Name => Name_Unrestricted_Access));
4221 Analyze_And_Resolve (N, PtrT);
4223 -- We set the variable as statically allocated, since we don't want
4224 -- it going on the stack of the current procedure.
4226 Set_Is_Statically_Allocated (Temp);
4230 -- Same if the allocator is an access discriminant for a local object:
4231 -- instead of an allocator we create a local value and constrain the
4232 -- enclosing object with the corresponding access attribute.
4234 if Is_Static_Coextension (N) then
4235 Rewrite_Coextension (N);
4239 -- Check for size too large, we do this because the back end misses
4240 -- proper checks here and can generate rubbish allocation calls when
4241 -- we are near the limit. We only do this for the 32-bit address case
4242 -- since that is from a practical point of view where we see a problem.
4244 if System_Address_Size = 32
4245 and then not Storage_Checks_Suppressed (PtrT)
4246 and then not Storage_Checks_Suppressed (Dtyp)
4247 and then not Storage_Checks_Suppressed (Etyp)
4249 -- The check we want to generate should look like
4251 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4252 -- raise Storage_Error;
4255 -- where 3.5 gigabytes is a constant large enough to accommodate any
4256 -- reasonable request for. But we can't do it this way because at
4257 -- least at the moment we don't compute this attribute right, and
4258 -- can silently give wrong results when the result gets large. Since
4259 -- this is all about large results, that's bad, so instead we only
4260 -- apply the check for constrained arrays, and manually compute the
4261 -- value of the attribute ???
4263 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
4265 Make_Raise_Storage_Error (Loc,
4268 Left_Opnd => Size_In_Storage_Elements (Etyp),
4270 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
4271 Reason => SE_Object_Too_Large));
4275 -- If no storage pool has been specified and we have the restriction
4276 -- No_Standard_Allocators_After_Elaboration is present, then generate
4277 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4279 if Nkind (N) = N_Allocator
4280 and then No (Storage_Pool (N))
4281 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4284 Make_Procedure_Call_Statement (Loc,
4286 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4289 -- Handle case of qualified expression (other than optimization above)
4290 -- First apply constraint checks, because the bounds or discriminants
4291 -- in the aggregate might not match the subtype mark in the allocator.
4293 if Nkind (Expression (N)) = N_Qualified_Expression then
4295 Exp : constant Node_Id := Expression (Expression (N));
4296 Typ : constant Entity_Id := Etype (Expression (N));
4299 Apply_Constraint_Check (Exp, Typ);
4300 Apply_Predicate_Check (Exp, Typ);
4303 Expand_Allocator_Expression (N);
4307 -- If the allocator is for a type which requires initialization, and
4308 -- there is no initial value (i.e. operand is a subtype indication
4309 -- rather than a qualified expression), then we must generate a call to
4310 -- the initialization routine using an expressions action node:
4312 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4314 -- Here ptr_T is the pointer type for the allocator, and T is the
4315 -- subtype of the allocator. A special case arises if the designated
4316 -- type of the access type is a task or contains tasks. In this case
4317 -- the call to Init (Temp.all ...) is replaced by code that ensures
4318 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4319 -- for details). In addition, if the type T is a task type, then the
4320 -- first argument to Init must be converted to the task record type.
4323 T : constant Entity_Id := Entity (Expression (N));
4329 Init_Arg1 : Node_Id;
4330 Init_Call : Node_Id;
4331 Temp_Decl : Node_Id;
4332 Temp_Type : Entity_Id;
4335 if No_Initialization (N) then
4337 -- Even though this might be a simple allocation, create a custom
4338 -- Allocate if the context requires it.
4340 if Present (Finalization_Master (PtrT)) then
4341 Build_Allocate_Deallocate_Proc
4343 Is_Allocate => True);
4346 -- Case of no initialization procedure present
4348 elsif not Has_Non_Null_Base_Init_Proc (T) then
4350 -- Case of simple initialization required
4352 if Needs_Simple_Initialization (T) then
4353 Check_Restriction (No_Default_Initialization, N);
4354 Rewrite (Expression (N),
4355 Make_Qualified_Expression (Loc,
4356 Subtype_Mark => New_Occurrence_Of (T, Loc),
4357 Expression => Get_Simple_Init_Val (T, N)));
4359 Analyze_And_Resolve (Expression (Expression (N)), T);
4360 Analyze_And_Resolve (Expression (N), T);
4361 Set_Paren_Count (Expression (Expression (N)), 1);
4362 Expand_N_Allocator (N);
4364 -- No initialization required
4370 -- Case of initialization procedure present, must be called
4373 Check_Restriction (No_Default_Initialization, N);
4375 if not Restriction_Active (No_Default_Initialization) then
4376 Init := Base_Init_Proc (T);
4378 Temp := Make_Temporary (Loc, 'P');
4380 -- Construct argument list for the initialization routine call
4383 Make_Explicit_Dereference (Loc,
4385 New_Occurrence_Of (Temp, Loc));
4387 Set_Assignment_OK (Init_Arg1);
4390 -- The initialization procedure expects a specific type. if the
4391 -- context is access to class wide, indicate that the object
4392 -- being allocated has the right specific type.
4394 if Is_Class_Wide_Type (Dtyp) then
4395 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4398 -- If designated type is a concurrent type or if it is private
4399 -- type whose definition is a concurrent type, the first
4400 -- argument in the Init routine has to be unchecked conversion
4401 -- to the corresponding record type. If the designated type is
4402 -- a derived type, also convert the argument to its root type.
4404 if Is_Concurrent_Type (T) then
4406 Unchecked_Convert_To (
4407 Corresponding_Record_Type (T), Init_Arg1);
4409 elsif Is_Private_Type (T)
4410 and then Present (Full_View (T))
4411 and then Is_Concurrent_Type (Full_View (T))
4414 Unchecked_Convert_To
4415 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
4417 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
4419 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
4422 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
4423 Set_Etype (Init_Arg1, Ftyp);
4427 Args := New_List (Init_Arg1);
4429 -- For the task case, pass the Master_Id of the access type as
4430 -- the value of the _Master parameter, and _Chain as the value
4431 -- of the _Chain parameter (_Chain will be defined as part of
4432 -- the generated code for the allocator).
4434 -- In Ada 2005, the context may be a function that returns an
4435 -- anonymous access type. In that case the Master_Id has been
4436 -- created when expanding the function declaration.
4438 if Has_Task (T) then
4439 if No (Master_Id (Base_Type (PtrT))) then
4441 -- The designated type was an incomplete type, and the
4442 -- access type did not get expanded. Salvage it now.
4444 if not Restriction_Active (No_Task_Hierarchy) then
4445 if Present (Parent (Base_Type (PtrT))) then
4446 Expand_N_Full_Type_Declaration
4447 (Parent (Base_Type (PtrT)));
4449 -- The only other possibility is an itype. For this
4450 -- case, the master must exist in the context. This is
4451 -- the case when the allocator initializes an access
4452 -- component in an init-proc.
4455 pragma Assert (Is_Itype (PtrT));
4456 Build_Master_Renaming (PtrT, N);
4461 -- If the context of the allocator is a declaration or an
4462 -- assignment, we can generate a meaningful image for it,
4463 -- even though subsequent assignments might remove the
4464 -- connection between task and entity. We build this image
4465 -- when the left-hand side is a simple variable, a simple
4466 -- indexed assignment or a simple selected component.
4468 if Nkind (Parent (N)) = N_Assignment_Statement then
4470 Nam : constant Node_Id := Name (Parent (N));
4473 if Is_Entity_Name (Nam) then
4475 Build_Task_Image_Decls
4478 (Entity (Nam), Sloc (Nam)), T);
4480 elsif Nkind_In (Nam, N_Indexed_Component,
4481 N_Selected_Component)
4482 and then Is_Entity_Name (Prefix (Nam))
4485 Build_Task_Image_Decls
4486 (Loc, Nam, Etype (Prefix (Nam)));
4488 Decls := Build_Task_Image_Decls (Loc, T, T);
4492 elsif Nkind (Parent (N)) = N_Object_Declaration then
4494 Build_Task_Image_Decls
4495 (Loc, Defining_Identifier (Parent (N)), T);
4498 Decls := Build_Task_Image_Decls (Loc, T, T);
4501 if Restriction_Active (No_Task_Hierarchy) then
4503 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
4507 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
4510 Append_To (Args, Make_Identifier (Loc, Name_uChain));
4512 Decl := Last (Decls);
4514 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
4516 -- Has_Task is false, Decls not used
4522 -- Add discriminants if discriminated type
4525 Dis : Boolean := False;
4529 if Has_Discriminants (T) then
4533 -- Type may be a private type with no visible discriminants
4534 -- in which case check full view if in scope, or the
4535 -- underlying_full_view if dealing with a type whose full
4536 -- view may be derived from a private type whose own full
4537 -- view has discriminants.
4539 elsif Is_Private_Type (T) then
4540 if Present (Full_View (T))
4541 and then Has_Discriminants (Full_View (T))
4544 Typ := Full_View (T);
4546 elsif Present (Underlying_Full_View (T))
4547 and then Has_Discriminants (Underlying_Full_View (T))
4550 Typ := Underlying_Full_View (T);
4556 -- If the allocated object will be constrained by the
4557 -- default values for discriminants, then build a subtype
4558 -- with those defaults, and change the allocated subtype
4559 -- to that. Note that this happens in fewer cases in Ada
4562 if not Is_Constrained (Typ)
4563 and then Present (Discriminant_Default_Value
4564 (First_Discriminant (Typ)))
4565 and then (Ada_Version < Ada_2005
4567 Object_Type_Has_Constrained_Partial_View
4568 (Typ, Current_Scope))
4570 Typ := Build_Default_Subtype (Typ, N);
4571 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
4574 Discr := First_Elmt (Discriminant_Constraint (Typ));
4575 while Present (Discr) loop
4576 Nod := Node (Discr);
4577 Append (New_Copy_Tree (Node (Discr)), Args);
4579 -- AI-416: when the discriminant constraint is an
4580 -- anonymous access type make sure an accessibility
4581 -- check is inserted if necessary (3.10.2(22.q/2))
4583 if Ada_Version >= Ada_2005
4585 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
4587 Apply_Accessibility_Check
4588 (Nod, Typ, Insert_Node => Nod);
4596 -- We set the allocator as analyzed so that when we analyze
4597 -- the if expression node, we do not get an unwanted recursive
4598 -- expansion of the allocator expression.
4600 Set_Analyzed (N, True);
4601 Nod := Relocate_Node (N);
4603 -- Here is the transformation:
4604 -- input: new Ctrl_Typ
4605 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4606 -- Ctrl_TypIP (Temp.all, ...);
4607 -- [Deep_]Initialize (Temp.all);
4609 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4610 -- is the subtype of the allocator.
4613 Make_Object_Declaration (Loc,
4614 Defining_Identifier => Temp,
4615 Constant_Present => True,
4616 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
4619 Set_Assignment_OK (Temp_Decl);
4620 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
4622 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
4624 -- If the designated type is a task type or contains tasks,
4625 -- create block to activate created tasks, and insert
4626 -- declaration for Task_Image variable ahead of call.
4628 if Has_Task (T) then
4630 L : constant List_Id := New_List;
4633 Build_Task_Allocate_Block (L, Nod, Args);
4635 Insert_List_Before (First (Declarations (Blk)), Decls);
4636 Insert_Actions (N, L);
4641 Make_Procedure_Call_Statement (Loc,
4642 Name => New_Occurrence_Of (Init, Loc),
4643 Parameter_Associations => Args));
4646 if Needs_Finalization (T) then
4649 -- [Deep_]Initialize (Init_Arg1);
4653 (Obj_Ref => New_Copy_Tree (Init_Arg1),
4656 -- Guard against a missing [Deep_]Initialize when the
4657 -- designated type was not properly frozen.
4659 if Present (Init_Call) then
4660 Insert_Action (N, Init_Call);
4664 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4665 Analyze_And_Resolve (N, PtrT);
4670 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4671 -- object that has been rewritten as a reference, we displace "this"
4672 -- to reference properly its secondary dispatch table.
4674 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
4675 Displace_Allocator_Pointer (N);
4679 when RE_Not_Available =>
4681 end Expand_N_Allocator;
4683 -----------------------
4684 -- Expand_N_And_Then --
4685 -----------------------
4687 procedure Expand_N_And_Then (N : Node_Id)
4688 renames Expand_Short_Circuit_Operator;
4690 ------------------------------
4691 -- Expand_N_Case_Expression --
4692 ------------------------------
4694 procedure Expand_N_Case_Expression (N : Node_Id) is
4695 Loc : constant Source_Ptr := Sloc (N);
4696 Par : constant Node_Id := Parent (N);
4697 Typ : constant Entity_Id := Etype (N);
4700 Case_Stmt : Node_Id;
4704 Target_Typ : Entity_Id;
4706 In_Predicate : Boolean := False;
4707 -- Flag set when the case expression appears within a predicate
4709 Optimize_Return_Stmt : Boolean := False;
4710 -- Flag set when the case expression can be optimized in the context of
4711 -- a simple return statement.
4714 -- Check for MINIMIZED/ELIMINATED overflow mode
4716 if Minimized_Eliminated_Overflow_Check (N) then
4717 Apply_Arithmetic_Overflow_Check (N);
4721 -- If the case expression is a predicate specification, and the type
4722 -- to which it applies has a static predicate aspect, do not expand,
4723 -- because it will be converted to the proper predicate form later.
4725 if Ekind_In (Current_Scope, E_Function, E_Procedure)
4726 and then Is_Predicate_Function (Current_Scope)
4728 In_Predicate := True;
4730 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
4736 -- When the type of the case expression is elementary, expand
4738 -- (case X is when A => AX, when B => BX ...)
4753 -- In all other cases expand into
4756 -- type Ptr_Typ is access all Typ;
4757 -- Target : Ptr_Typ;
4760 -- Target := AX'Unrestricted_Access;
4762 -- Target := BX'Unrestricted_Access;
4765 -- in Target.all end;
4767 -- This approach avoids extra copies of potentially large objects. It
4768 -- also allows handling of values of limited or unconstrained types.
4770 -- Small optimization: when the case expression appears in the context
4771 -- of a simple return statement, expand into
4782 Make_Case_Statement (Loc,
4783 Expression => Expression (N),
4784 Alternatives => New_List);
4786 -- Preserve the original context for which the case statement is being
4787 -- generated. This is needed by the finalization machinery to prevent
4788 -- the premature finalization of controlled objects found within the
4791 Set_From_Conditional_Expression (Case_Stmt);
4796 if Is_Elementary_Type (Typ) then
4799 -- ??? Do not perform the optimization when the return statement is
4800 -- within a predicate function as this causes supurious errors. Could
4801 -- this be a possible mismatch in handling this case somewhere else
4802 -- in semantic analysis?
4804 Optimize_Return_Stmt :=
4805 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
4807 -- Otherwise create an access type to handle the general case using
4808 -- 'Unrestricted_Access.
4811 -- type Ptr_Typ is access all Typ;
4814 Target_Typ := Make_Temporary (Loc, 'P');
4817 Make_Full_Type_Declaration (Loc,
4818 Defining_Identifier => Target_Typ,
4820 Make_Access_To_Object_Definition (Loc,
4821 All_Present => True,
4822 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
4825 -- Create the declaration of the target which captures the value of the
4829 -- Target : [Ptr_]Typ;
4831 if not Optimize_Return_Stmt then
4832 Target := Make_Temporary (Loc, 'T');
4835 Make_Object_Declaration (Loc,
4836 Defining_Identifier => Target,
4837 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
4838 Set_No_Initialization (Decl);
4840 Append_To (Acts, Decl);
4843 -- Process the alternatives
4845 Alt := First (Alternatives (N));
4846 while Present (Alt) loop
4848 Alt_Expr : Node_Id := Expression (Alt);
4849 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
4853 -- Take the unrestricted access of the expression value for non-
4854 -- scalar types. This approach avoids big copies and covers the
4855 -- limited and unconstrained cases.
4858 -- AX'Unrestricted_Access
4860 if not Is_Elementary_Type (Typ) then
4862 Make_Attribute_Reference (Alt_Loc,
4863 Prefix => Relocate_Node (Alt_Expr),
4864 Attribute_Name => Name_Unrestricted_Access);
4868 -- return AX['Unrestricted_Access];
4870 if Optimize_Return_Stmt then
4872 Make_Simple_Return_Statement (Alt_Loc,
4873 Expression => Alt_Expr));
4876 -- Target := AX['Unrestricted_Access];
4880 Make_Assignment_Statement (Alt_Loc,
4881 Name => New_Occurrence_Of (Target, Loc),
4882 Expression => Alt_Expr));
4885 -- Propagate declarations inserted in the node by Insert_Actions
4886 -- (for example, temporaries generated to remove side effects).
4887 -- These actions must remain attached to the alternative, given
4888 -- that they are generated by the corresponding expression.
4890 if Present (Actions (Alt)) then
4891 Prepend_List (Actions (Alt), Stmts);
4894 -- Finalize any transient objects on exit from the alternative.
4895 -- This is done only in the return optimization case because
4896 -- otherwise the case expression is converted into an expression
4897 -- with actions which already contains this form of processing.
4899 if Optimize_Return_Stmt then
4900 Process_If_Case_Statements (N, Stmts);
4904 (Alternatives (Case_Stmt),
4905 Make_Case_Statement_Alternative (Sloc (Alt),
4906 Discrete_Choices => Discrete_Choices (Alt),
4907 Statements => Stmts));
4913 -- Rewrite the parent return statement as a case statement
4915 if Optimize_Return_Stmt then
4916 Rewrite (Par, Case_Stmt);
4919 -- Otherwise convert the case expression into an expression with actions
4922 Append_To (Acts, Case_Stmt);
4924 if Is_Elementary_Type (Typ) then
4925 Expr := New_Occurrence_Of (Target, Loc);
4929 Make_Explicit_Dereference (Loc,
4930 Prefix => New_Occurrence_Of (Target, Loc));
4936 -- in Target[.all] end;
4939 Make_Expression_With_Actions (Loc,
4943 Analyze_And_Resolve (N, Typ);
4945 end Expand_N_Case_Expression;
4947 -----------------------------------
4948 -- Expand_N_Explicit_Dereference --
4949 -----------------------------------
4951 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
4953 -- Insert explicit dereference call for the checked storage pool case
4955 Insert_Dereference_Action (Prefix (N));
4957 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
4958 -- we set the atomic sync flag.
4960 if Is_Atomic (Etype (N))
4961 and then not Atomic_Synchronization_Disabled (Etype (N))
4963 Activate_Atomic_Synchronization (N);
4965 end Expand_N_Explicit_Dereference;
4967 --------------------------------------
4968 -- Expand_N_Expression_With_Actions --
4969 --------------------------------------
4971 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
4972 Acts : constant List_Id := Actions (N);
4974 procedure Force_Boolean_Evaluation (Expr : Node_Id);
4975 -- Force the evaluation of Boolean expression Expr
4977 function Process_Action (Act : Node_Id) return Traverse_Result;
4978 -- Inspect and process a single action of an expression_with_actions for
4979 -- transient objects. If such objects are found, the routine generates
4980 -- code to clean them up when the context of the expression is evaluated
4983 ------------------------------
4984 -- Force_Boolean_Evaluation --
4985 ------------------------------
4987 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
4988 Loc : constant Source_Ptr := Sloc (N);
4989 Flag_Decl : Node_Id;
4990 Flag_Id : Entity_Id;
4993 -- Relocate the expression to the actions list by capturing its value
4994 -- in a Boolean flag. Generate:
4995 -- Flag : constant Boolean := Expr;
4997 Flag_Id := Make_Temporary (Loc, 'F');
5000 Make_Object_Declaration (Loc,
5001 Defining_Identifier => Flag_Id,
5002 Constant_Present => True,
5003 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5004 Expression => Relocate_Node (Expr));
5006 Append (Flag_Decl, Acts);
5007 Analyze (Flag_Decl);
5009 -- Replace the expression with a reference to the flag
5011 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
5012 Analyze (Expression (N));
5013 end Force_Boolean_Evaluation;
5015 --------------------
5016 -- Process_Action --
5017 --------------------
5019 function Process_Action (Act : Node_Id) return Traverse_Result is
5021 if Nkind (Act) = N_Object_Declaration
5022 and then Is_Finalizable_Transient (Act, N)
5024 Process_Transient_In_Expression (Act, N, Acts);
5027 -- Avoid processing temporary function results multiple times when
5028 -- dealing with nested expression_with_actions.
5030 elsif Nkind (Act) = N_Expression_With_Actions then
5033 -- Do not process temporary function results in loops. This is done
5034 -- by Expand_N_Loop_Statement and Build_Finalizer.
5036 elsif Nkind (Act) = N_Loop_Statement then
5043 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5049 -- Start of processing for Expand_N_Expression_With_Actions
5052 -- Do not evaluate the expression when it denotes an entity because the
5053 -- expression_with_actions node will be replaced by the reference.
5055 if Is_Entity_Name (Expression (N)) then
5058 -- Do not evaluate the expression when there are no actions because the
5059 -- expression_with_actions node will be replaced by the expression.
5061 elsif No (Acts) or else Is_Empty_List (Acts) then
5064 -- Force the evaluation of the expression by capturing its value in a
5065 -- temporary. This ensures that aliases of transient objects do not leak
5066 -- to the expression of the expression_with_actions node:
5069 -- Trans_Id : Ctrl_Typ := ...;
5070 -- Alias : ... := Trans_Id;
5071 -- in ... Alias ... end;
5073 -- In the example above, Trans_Id cannot be finalized at the end of the
5074 -- actions list because this may affect the alias and the final value of
5075 -- the expression_with_actions. Forcing the evaluation encapsulates the
5076 -- reference to the Alias within the actions list:
5079 -- Trans_Id : Ctrl_Typ := ...;
5080 -- Alias : ... := Trans_Id;
5081 -- Val : constant Boolean := ... Alias ...;
5082 -- <finalize Trans_Id>
5085 -- Once this transformation is performed, it is safe to finalize the
5086 -- transient object at the end of the actions list.
5088 -- Note that Force_Evaluation does not remove side effects in operators
5089 -- because it assumes that all operands are evaluated and side effect
5090 -- free. This is not the case when an operand depends implicitly on the
5091 -- transient object through the use of access types.
5093 elsif Is_Boolean_Type (Etype (Expression (N))) then
5094 Force_Boolean_Evaluation (Expression (N));
5096 -- The expression of an expression_with_actions node may not necessarily
5097 -- be Boolean when the node appears in an if expression. In this case do
5098 -- the usual forced evaluation to encapsulate potential aliasing.
5101 Force_Evaluation (Expression (N));
5104 -- Process all transient objects found within the actions of the EWA
5107 Act := First (Acts);
5108 while Present (Act) loop
5109 Process_Single_Action (Act);
5113 -- Deal with case where there are no actions. In this case we simply
5114 -- rewrite the node with its expression since we don't need the actions
5115 -- and the specification of this node does not allow a null action list.
5117 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5118 -- the expanded tree and relying on being able to retrieve the original
5119 -- tree in cases like this. This raises a whole lot of issues of whether
5120 -- we have problems elsewhere, which will be addressed in the future???
5122 if Is_Empty_List (Acts) then
5123 Rewrite (N, Relocate_Node (Expression (N)));
5125 end Expand_N_Expression_With_Actions;
5127 ----------------------------
5128 -- Expand_N_If_Expression --
5129 ----------------------------
5131 -- Deal with limited types and condition actions
5133 procedure Expand_N_If_Expression (N : Node_Id) is
5134 Cond : constant Node_Id := First (Expressions (N));
5135 Loc : constant Source_Ptr := Sloc (N);
5136 Thenx : constant Node_Id := Next (Cond);
5137 Elsex : constant Node_Id := Next (Thenx);
5138 Typ : constant Entity_Id := Etype (N);
5146 Ptr_Typ : Entity_Id;
5149 -- Check for MINIMIZED/ELIMINATED overflow mode
5151 if Minimized_Eliminated_Overflow_Check (N) then
5152 Apply_Arithmetic_Overflow_Check (N);
5156 -- Fold at compile time if condition known. We have already folded
5157 -- static if expressions, but it is possible to fold any case in which
5158 -- the condition is known at compile time, even though the result is
5161 -- Note that we don't do the fold of such cases in Sem_Elab because
5162 -- it can cause infinite loops with the expander adding a conditional
5163 -- expression, and Sem_Elab circuitry removing it repeatedly.
5165 if Compile_Time_Known_Value (Cond) then
5167 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5168 -- Fold at compile time. Assumes condition known. Return True if
5169 -- folding occurred, meaning we're done.
5171 ----------------------
5172 -- Fold_Known_Value --
5173 ----------------------
5175 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5177 if Is_True (Expr_Value (Cond)) then
5179 Actions := Then_Actions (N);
5182 Actions := Else_Actions (N);
5187 if Present (Actions) then
5189 -- To minimize the use of Expression_With_Actions, just skip
5190 -- the optimization as it is not critical for correctness.
5192 if Minimize_Expression_With_Actions then
5197 Make_Expression_With_Actions (Loc,
5198 Expression => Relocate_Node (Expr),
5199 Actions => Actions));
5200 Analyze_And_Resolve (N, Typ);
5203 Rewrite (N, Relocate_Node (Expr));
5206 -- Note that the result is never static (legitimate cases of
5207 -- static if expressions were folded in Sem_Eval).
5209 Set_Is_Static_Expression (N, False);
5211 end Fold_Known_Value;
5214 if Fold_Known_Value (Cond) then
5220 -- If the type is limited, and the back end does not handle limited
5221 -- types, then we expand as follows to avoid the possibility of
5222 -- improper copying.
5224 -- type Ptr is access all Typ;
5228 -- Cnn := then-expr'Unrestricted_Access;
5231 -- Cnn := else-expr'Unrestricted_Access;
5234 -- and replace the if expression by a reference to Cnn.all.
5236 -- This special case can be skipped if the back end handles limited
5237 -- types properly and ensures that no incorrect copies are made.
5239 if Is_By_Reference_Type (Typ)
5240 and then not Back_End_Handles_Limited_Types
5242 -- When the "then" or "else" expressions involve controlled function
5243 -- calls, generated temporaries are chained on the corresponding list
5244 -- of actions. These temporaries need to be finalized after the if
5245 -- expression is evaluated.
5247 Process_If_Case_Statements (N, Then_Actions (N));
5248 Process_If_Case_Statements (N, Else_Actions (N));
5251 -- type Ann is access all Typ;
5253 Ptr_Typ := Make_Temporary (Loc, 'A');
5256 Make_Full_Type_Declaration (Loc,
5257 Defining_Identifier => Ptr_Typ,
5259 Make_Access_To_Object_Definition (Loc,
5260 All_Present => True,
5261 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5266 Cnn := Make_Temporary (Loc, 'C', N);
5269 Make_Object_Declaration (Loc,
5270 Defining_Identifier => Cnn,
5271 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
5275 -- Cnn := <Thenx>'Unrestricted_Access;
5277 -- Cnn := <Elsex>'Unrestricted_Access;
5281 Make_Implicit_If_Statement (N,
5282 Condition => Relocate_Node (Cond),
5283 Then_Statements => New_List (
5284 Make_Assignment_Statement (Sloc (Thenx),
5285 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5287 Make_Attribute_Reference (Loc,
5288 Prefix => Relocate_Node (Thenx),
5289 Attribute_Name => Name_Unrestricted_Access))),
5291 Else_Statements => New_List (
5292 Make_Assignment_Statement (Sloc (Elsex),
5293 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5295 Make_Attribute_Reference (Loc,
5296 Prefix => Relocate_Node (Elsex),
5297 Attribute_Name => Name_Unrestricted_Access))));
5299 -- Preserve the original context for which the if statement is being
5300 -- generated. This is needed by the finalization machinery to prevent
5301 -- the premature finalization of controlled objects found within the
5304 Set_From_Conditional_Expression (New_If);
5307 Make_Explicit_Dereference (Loc,
5308 Prefix => New_Occurrence_Of (Cnn, Loc));
5310 -- If the result is an unconstrained array and the if expression is in a
5311 -- context other than the initializing expression of the declaration of
5312 -- an object, then we pull out the if expression as follows:
5314 -- Cnn : constant typ := if-expression
5316 -- and then replace the if expression with an occurrence of Cnn. This
5317 -- avoids the need in the back end to create on-the-fly variable length
5318 -- temporaries (which it cannot do!)
5320 -- Note that the test for being in an object declaration avoids doing an
5321 -- unnecessary expansion, and also avoids infinite recursion.
5323 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
5324 and then (Nkind (Parent (N)) /= N_Object_Declaration
5325 or else Expression (Parent (N)) /= N)
5328 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5331 Make_Object_Declaration (Loc,
5332 Defining_Identifier => Cnn,
5333 Constant_Present => True,
5334 Object_Definition => New_Occurrence_Of (Typ, Loc),
5335 Expression => Relocate_Node (N),
5336 Has_Init_Expression => True));
5338 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
5342 -- For other types, we only need to expand if there are other actions
5343 -- associated with either branch.
5345 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5347 -- We now wrap the actions into the appropriate expression
5349 if Minimize_Expression_With_Actions
5350 and then (Is_Elementary_Type (Underlying_Type (Typ))
5351 or else Is_Constrained (Underlying_Type (Typ)))
5353 -- If we can't use N_Expression_With_Actions nodes, then we insert
5354 -- the following sequence of actions (using Insert_Actions):
5359 -- Cnn := then-expr;
5365 -- and replace the if expression by a reference to Cnn
5367 Cnn := Make_Temporary (Loc, 'C', N);
5370 Make_Object_Declaration (Loc,
5371 Defining_Identifier => Cnn,
5372 Object_Definition => New_Occurrence_Of (Typ, Loc));
5375 Make_Implicit_If_Statement (N,
5376 Condition => Relocate_Node (Cond),
5378 Then_Statements => New_List (
5379 Make_Assignment_Statement (Sloc (Thenx),
5380 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5381 Expression => Relocate_Node (Thenx))),
5383 Else_Statements => New_List (
5384 Make_Assignment_Statement (Sloc (Elsex),
5385 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5386 Expression => Relocate_Node (Elsex))));
5388 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
5389 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
5391 New_N := New_Occurrence_Of (Cnn, Loc);
5393 -- Regular path using Expression_With_Actions
5396 if Present (Then_Actions (N)) then
5398 Make_Expression_With_Actions (Sloc (Thenx),
5399 Actions => Then_Actions (N),
5400 Expression => Relocate_Node (Thenx)));
5402 Set_Then_Actions (N, No_List);
5403 Analyze_And_Resolve (Thenx, Typ);
5406 if Present (Else_Actions (N)) then
5408 Make_Expression_With_Actions (Sloc (Elsex),
5409 Actions => Else_Actions (N),
5410 Expression => Relocate_Node (Elsex)));
5412 Set_Else_Actions (N, No_List);
5413 Analyze_And_Resolve (Elsex, Typ);
5419 -- If no actions then no expansion needed, gigi will handle it using the
5420 -- same approach as a C conditional expression.
5426 -- Fall through here for either the limited expansion, or the case of
5427 -- inserting actions for non-limited types. In both these cases, we must
5428 -- move the SLOC of the parent If statement to the newly created one and
5429 -- change it to the SLOC of the expression which, after expansion, will
5430 -- correspond to what is being evaluated.
5432 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
5433 Set_Sloc (New_If, Sloc (Parent (N)));
5434 Set_Sloc (Parent (N), Loc);
5437 -- Make sure Then_Actions and Else_Actions are appropriately moved
5438 -- to the new if statement.
5440 if Present (Then_Actions (N)) then
5442 (First (Then_Statements (New_If)), Then_Actions (N));
5445 if Present (Else_Actions (N)) then
5447 (First (Else_Statements (New_If)), Else_Actions (N));
5450 Insert_Action (N, Decl);
5451 Insert_Action (N, New_If);
5453 Analyze_And_Resolve (N, Typ);
5454 end Expand_N_If_Expression;
5460 procedure Expand_N_In (N : Node_Id) is
5461 Loc : constant Source_Ptr := Sloc (N);
5462 Restyp : constant Entity_Id := Etype (N);
5463 Lop : constant Node_Id := Left_Opnd (N);
5464 Rop : constant Node_Id := Right_Opnd (N);
5465 Static : constant Boolean := Is_OK_Static_Expression (N);
5467 procedure Substitute_Valid_Check;
5468 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5469 -- test for the left operand being in range of its subtype.
5471 ----------------------------
5472 -- Substitute_Valid_Check --
5473 ----------------------------
5475 procedure Substitute_Valid_Check is
5476 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
5477 -- Determine whether arbitrary node Nod denotes a source object that
5478 -- may safely act as prefix of attribute 'Valid.
5480 ----------------------------
5481 -- Is_OK_Object_Reference --
5482 ----------------------------
5484 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
5488 -- Inspect the original operand
5490 Obj_Ref := Original_Node (Nod);
5492 -- The object reference must be a source construct, otherwise the
5493 -- codefix suggestion may refer to nonexistent code from a user
5496 if Comes_From_Source (Obj_Ref) then
5498 -- Recover the actual object reference. There may be more cases
5502 if Nkind_In (Obj_Ref, N_Type_Conversion,
5503 N_Unchecked_Type_Conversion)
5505 Obj_Ref := Expression (Obj_Ref);
5511 return Is_Object_Reference (Obj_Ref);
5515 end Is_OK_Object_Reference;
5517 -- Start of processing for Substitute_Valid_Check
5521 Make_Attribute_Reference (Loc,
5522 Prefix => Relocate_Node (Lop),
5523 Attribute_Name => Name_Valid));
5525 Analyze_And_Resolve (N, Restyp);
5527 -- Emit a warning when the left-hand operand of the membership test
5528 -- is a source object, otherwise the use of attribute 'Valid would be
5529 -- illegal. The warning is not given when overflow checking is either
5530 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
5531 -- eliminated above.
5533 if Is_OK_Object_Reference (Lop)
5534 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
5537 ("??explicit membership test may be optimized away", N);
5538 Error_Msg_N -- CODEFIX
5539 ("\??use ''Valid attribute instead", N);
5541 end Substitute_Valid_Check;
5548 -- Start of processing for Expand_N_In
5551 -- If set membership case, expand with separate procedure
5553 if Present (Alternatives (N)) then
5554 Expand_Set_Membership (N);
5558 -- Not set membership, proceed with expansion
5560 Ltyp := Etype (Left_Opnd (N));
5561 Rtyp := Etype (Right_Opnd (N));
5563 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5564 -- type, then expand with a separate procedure. Note the use of the
5565 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5567 if Overflow_Check_Mode in Minimized_Or_Eliminated
5568 and then Is_Signed_Integer_Type (Ltyp)
5569 and then not No_Minimize_Eliminate (N)
5571 Expand_Membership_Minimize_Eliminate_Overflow (N);
5575 -- Check case of explicit test for an expression in range of its
5576 -- subtype. This is suspicious usage and we replace it with a 'Valid
5577 -- test and give a warning for scalar types.
5579 if Is_Scalar_Type (Ltyp)
5581 -- Only relevant for source comparisons
5583 and then Comes_From_Source (N)
5585 -- In floating-point this is a standard way to check for finite values
5586 -- and using 'Valid would typically be a pessimization.
5588 and then not Is_Floating_Point_Type (Ltyp)
5590 -- Don't give the message unless right operand is a type entity and
5591 -- the type of the left operand matches this type. Note that this
5592 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5593 -- checks have changed the type of the left operand.
5595 and then Nkind (Rop) in N_Has_Entity
5596 and then Ltyp = Entity (Rop)
5598 -- Skip this for predicated types, where such expressions are a
5599 -- reasonable way of testing if something meets the predicate.
5601 and then not Present (Predicate_Function (Ltyp))
5603 Substitute_Valid_Check;
5607 -- Do validity check on operands
5609 if Validity_Checks_On and Validity_Check_Operands then
5610 Ensure_Valid (Left_Opnd (N));
5611 Validity_Check_Range (Right_Opnd (N));
5614 -- Case of explicit range
5616 if Nkind (Rop) = N_Range then
5618 Lo : constant Node_Id := Low_Bound (Rop);
5619 Hi : constant Node_Id := High_Bound (Rop);
5621 Lo_Orig : constant Node_Id := Original_Node (Lo);
5622 Hi_Orig : constant Node_Id := Original_Node (Hi);
5624 Lcheck : Compare_Result;
5625 Ucheck : Compare_Result;
5627 Warn1 : constant Boolean :=
5628 Constant_Condition_Warnings
5629 and then Comes_From_Source (N)
5630 and then not In_Instance;
5631 -- This must be true for any of the optimization warnings, we
5632 -- clearly want to give them only for source with the flag on. We
5633 -- also skip these warnings in an instance since it may be the
5634 -- case that different instantiations have different ranges.
5636 Warn2 : constant Boolean :=
5638 and then Nkind (Original_Node (Rop)) = N_Range
5639 and then Is_Integer_Type (Etype (Lo));
5640 -- For the case where only one bound warning is elided, we also
5641 -- insist on an explicit range and an integer type. The reason is
5642 -- that the use of enumeration ranges including an end point is
5643 -- common, as is the use of a subtype name, one of whose bounds is
5644 -- the same as the type of the expression.
5647 -- If test is explicit x'First .. x'Last, replace by valid check
5649 -- Could use some individual comments for this complex test ???
5651 if Is_Scalar_Type (Ltyp)
5653 -- And left operand is X'First where X matches left operand
5654 -- type (this eliminates cases of type mismatch, including
5655 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5656 -- type of the left operand.
5658 and then Nkind (Lo_Orig) = N_Attribute_Reference
5659 and then Attribute_Name (Lo_Orig) = Name_First
5660 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
5661 and then Entity (Prefix (Lo_Orig)) = Ltyp
5663 -- Same tests for right operand
5665 and then Nkind (Hi_Orig) = N_Attribute_Reference
5666 and then Attribute_Name (Hi_Orig) = Name_Last
5667 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
5668 and then Entity (Prefix (Hi_Orig)) = Ltyp
5670 -- Relevant only for source cases
5672 and then Comes_From_Source (N)
5674 Substitute_Valid_Check;
5678 -- If bounds of type are known at compile time, and the end points
5679 -- are known at compile time and identical, this is another case
5680 -- for substituting a valid test. We only do this for discrete
5681 -- types, since it won't arise in practice for float types.
5683 if Comes_From_Source (N)
5684 and then Is_Discrete_Type (Ltyp)
5685 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
5686 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
5687 and then Compile_Time_Known_Value (Lo)
5688 and then Compile_Time_Known_Value (Hi)
5689 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
5690 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
5692 -- Kill warnings in instances, since they may be cases where we
5693 -- have a test in the generic that makes sense with some types
5694 -- and not with other types.
5696 and then not In_Instance
5698 Substitute_Valid_Check;
5702 -- If we have an explicit range, do a bit of optimization based on
5703 -- range analysis (we may be able to kill one or both checks).
5705 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
5706 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
5708 -- If either check is known to fail, replace result by False since
5709 -- the other check does not matter. Preserve the static flag for
5710 -- legality checks, because we are constant-folding beyond RM 4.9.
5712 if Lcheck = LT or else Ucheck = GT then
5714 Error_Msg_N ("?c?range test optimized away", N);
5715 Error_Msg_N ("\?c?value is known to be out of range", N);
5718 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5719 Analyze_And_Resolve (N, Restyp);
5720 Set_Is_Static_Expression (N, Static);
5723 -- If both checks are known to succeed, replace result by True,
5724 -- since we know we are in range.
5726 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5728 Error_Msg_N ("?c?range test optimized away", N);
5729 Error_Msg_N ("\?c?value is known to be in range", N);
5732 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5733 Analyze_And_Resolve (N, Restyp);
5734 Set_Is_Static_Expression (N, Static);
5737 -- If lower bound check succeeds and upper bound check is not
5738 -- known to succeed or fail, then replace the range check with
5739 -- a comparison against the upper bound.
5741 elsif Lcheck in Compare_GE then
5742 if Warn2 and then not In_Instance then
5743 Error_Msg_N ("??lower bound test optimized away", Lo);
5744 Error_Msg_N ("\??value is known to be in range", Lo);
5750 Right_Opnd => High_Bound (Rop)));
5751 Analyze_And_Resolve (N, Restyp);
5754 -- If upper bound check succeeds and lower bound check is not
5755 -- known to succeed or fail, then replace the range check with
5756 -- a comparison against the lower bound.
5758 elsif Ucheck in Compare_LE then
5759 if Warn2 and then not In_Instance then
5760 Error_Msg_N ("??upper bound test optimized away", Hi);
5761 Error_Msg_N ("\??value is known to be in range", Hi);
5767 Right_Opnd => Low_Bound (Rop)));
5768 Analyze_And_Resolve (N, Restyp);
5772 -- We couldn't optimize away the range check, but there is one
5773 -- more issue. If we are checking constant conditionals, then we
5774 -- see if we can determine the outcome assuming everything is
5775 -- valid, and if so give an appropriate warning.
5777 if Warn1 and then not Assume_No_Invalid_Values then
5778 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
5779 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
5781 -- Result is out of range for valid value
5783 if Lcheck = LT or else Ucheck = GT then
5785 ("?c?value can only be in range if it is invalid", N);
5787 -- Result is in range for valid value
5789 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5791 ("?c?value can only be out of range if it is invalid", N);
5793 -- Lower bound check succeeds if value is valid
5795 elsif Warn2 and then Lcheck in Compare_GE then
5797 ("?c?lower bound check only fails if it is invalid", Lo);
5799 -- Upper bound check succeeds if value is valid
5801 elsif Warn2 and then Ucheck in Compare_LE then
5803 ("?c?upper bound check only fails for invalid values", Hi);
5808 -- For all other cases of an explicit range, nothing to be done
5812 -- Here right operand is a subtype mark
5816 Typ : Entity_Id := Etype (Rop);
5817 Is_Acc : constant Boolean := Is_Access_Type (Typ);
5818 Cond : Node_Id := Empty;
5820 Obj : Node_Id := Lop;
5821 SCIL_Node : Node_Id;
5824 Remove_Side_Effects (Obj);
5826 -- For tagged type, do tagged membership operation
5828 if Is_Tagged_Type (Typ) then
5830 -- No expansion will be performed for VM targets, as the VM
5831 -- back-ends will handle the membership tests directly.
5833 if Tagged_Type_Expansion then
5834 Tagged_Membership (N, SCIL_Node, New_N);
5836 Analyze_And_Resolve (N, Restyp);
5838 -- Update decoration of relocated node referenced by the
5841 if Generate_SCIL and then Present (SCIL_Node) then
5842 Set_SCIL_Node (N, SCIL_Node);
5848 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5849 -- This reason we do this is that the bounds may have the wrong
5850 -- type if they come from the original type definition. Also this
5851 -- way we get all the processing above for an explicit range.
5853 -- Don't do this for predicated types, since in this case we
5854 -- want to check the predicate.
5856 elsif Is_Scalar_Type (Typ) then
5857 if No (Predicate_Function (Typ)) then
5861 Make_Attribute_Reference (Loc,
5862 Attribute_Name => Name_First,
5863 Prefix => New_Occurrence_Of (Typ, Loc)),
5866 Make_Attribute_Reference (Loc,
5867 Attribute_Name => Name_Last,
5868 Prefix => New_Occurrence_Of (Typ, Loc))));
5869 Analyze_And_Resolve (N, Restyp);
5874 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5875 -- a membership test if the subtype mark denotes a constrained
5876 -- Unchecked_Union subtype and the expression lacks inferable
5879 elsif Is_Unchecked_Union (Base_Type (Typ))
5880 and then Is_Constrained (Typ)
5881 and then not Has_Inferable_Discriminants (Lop)
5884 Make_Raise_Program_Error (Loc,
5885 Reason => PE_Unchecked_Union_Restriction));
5887 -- Prevent Gigi from generating incorrect code by rewriting the
5888 -- test as False. What is this undocumented thing about ???
5890 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5894 -- Here we have a non-scalar type
5897 Typ := Designated_Type (Typ);
5900 if not Is_Constrained (Typ) then
5901 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5902 Analyze_And_Resolve (N, Restyp);
5904 -- For the constrained array case, we have to check the subscripts
5905 -- for an exact match if the lengths are non-zero (the lengths
5906 -- must match in any case).
5908 elsif Is_Array_Type (Typ) then
5909 Check_Subscripts : declare
5910 function Build_Attribute_Reference
5913 Dim : Nat) return Node_Id;
5914 -- Build attribute reference E'Nam (Dim)
5916 -------------------------------
5917 -- Build_Attribute_Reference --
5918 -------------------------------
5920 function Build_Attribute_Reference
5923 Dim : Nat) return Node_Id
5927 Make_Attribute_Reference (Loc,
5929 Attribute_Name => Nam,
5930 Expressions => New_List (
5931 Make_Integer_Literal (Loc, Dim)));
5932 end Build_Attribute_Reference;
5934 -- Start of processing for Check_Subscripts
5937 for J in 1 .. Number_Dimensions (Typ) loop
5938 Evolve_And_Then (Cond,
5941 Build_Attribute_Reference
5942 (Duplicate_Subexpr_No_Checks (Obj),
5945 Build_Attribute_Reference
5946 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
5948 Evolve_And_Then (Cond,
5951 Build_Attribute_Reference
5952 (Duplicate_Subexpr_No_Checks (Obj),
5955 Build_Attribute_Reference
5956 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
5965 Right_Opnd => Make_Null (Loc)),
5966 Right_Opnd => Cond);
5970 Analyze_And_Resolve (N, Restyp);
5971 end Check_Subscripts;
5973 -- These are the cases where constraint checks may be required,
5974 -- e.g. records with possible discriminants
5977 -- Expand the test into a series of discriminant comparisons.
5978 -- The expression that is built is the negation of the one that
5979 -- is used for checking discriminant constraints.
5981 Obj := Relocate_Node (Left_Opnd (N));
5983 if Has_Discriminants (Typ) then
5984 Cond := Make_Op_Not (Loc,
5985 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
5988 Cond := Make_Or_Else (Loc,
5992 Right_Opnd => Make_Null (Loc)),
5993 Right_Opnd => Cond);
5997 Cond := New_Occurrence_Of (Standard_True, Loc);
6001 Analyze_And_Resolve (N, Restyp);
6004 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6005 -- expression of an anonymous access type. This can involve an
6006 -- accessibility test and a tagged type membership test in the
6007 -- case of tagged designated types.
6009 if Ada_Version >= Ada_2012
6011 and then Ekind (Ltyp) = E_Anonymous_Access_Type
6014 Expr_Entity : Entity_Id := Empty;
6016 Param_Level : Node_Id;
6017 Type_Level : Node_Id;
6020 if Is_Entity_Name (Lop) then
6021 Expr_Entity := Param_Entity (Lop);
6023 if not Present (Expr_Entity) then
6024 Expr_Entity := Entity (Lop);
6028 -- If a conversion of the anonymous access value to the
6029 -- tested type would be illegal, then the result is False.
6031 if not Valid_Conversion
6032 (Lop, Rtyp, Lop, Report_Errs => False)
6034 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6035 Analyze_And_Resolve (N, Restyp);
6037 -- Apply an accessibility check if the access object has an
6038 -- associated access level and when the level of the type is
6039 -- less deep than the level of the access parameter. This
6040 -- only occur for access parameters and stand-alone objects
6041 -- of an anonymous access type.
6044 if Present (Expr_Entity)
6047 (Effective_Extra_Accessibility (Expr_Entity))
6048 and then UI_Gt (Object_Access_Level (Lop),
6049 Type_Access_Level (Rtyp))
6053 (Effective_Extra_Accessibility (Expr_Entity), Loc);
6056 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6058 -- Return True only if the accessibility level of the
6059 -- expression entity is not deeper than the level of
6060 -- the tested access type.
6064 Left_Opnd => Relocate_Node (N),
6065 Right_Opnd => Make_Op_Le (Loc,
6066 Left_Opnd => Param_Level,
6067 Right_Opnd => Type_Level)));
6069 Analyze_And_Resolve (N);
6072 -- If the designated type is tagged, do tagged membership
6075 -- *** NOTE: we have to check not null before doing the
6076 -- tagged membership test (but maybe that can be done
6077 -- inside Tagged_Membership?).
6079 if Is_Tagged_Type (Typ) then
6082 Left_Opnd => Relocate_Node (N),
6086 Right_Opnd => Make_Null (Loc))));
6088 -- No expansion will be performed for VM targets, as
6089 -- the VM back-ends will handle the membership tests
6092 if Tagged_Type_Expansion then
6094 -- Note that we have to pass Original_Node, because
6095 -- the membership test might already have been
6096 -- rewritten by earlier parts of membership test.
6099 (Original_Node (N), SCIL_Node, New_N);
6101 -- Update decoration of relocated node referenced
6102 -- by the SCIL node.
6104 if Generate_SCIL and then Present (SCIL_Node) then
6105 Set_SCIL_Node (New_N, SCIL_Node);
6110 Left_Opnd => Relocate_Node (N),
6111 Right_Opnd => New_N));
6113 Analyze_And_Resolve (N, Restyp);
6122 -- At this point, we have done the processing required for the basic
6123 -- membership test, but not yet dealt with the predicate.
6127 -- If a predicate is present, then we do the predicate test, but we
6128 -- most certainly want to omit this if we are within the predicate
6129 -- function itself, since otherwise we have an infinite recursion.
6130 -- The check should also not be emitted when testing against a range
6131 -- (the check is only done when the right operand is a subtype; see
6132 -- RM12-4.5.2 (28.1/3-30/3)).
6134 Predicate_Check : declare
6135 function In_Range_Check return Boolean;
6136 -- Within an expanded range check that may raise Constraint_Error do
6137 -- not generate a predicate check as well. It is redundant because
6138 -- the context will add an explicit predicate check, and it will
6139 -- raise the wrong exception if it fails.
6141 --------------------
6142 -- In_Range_Check --
6143 --------------------
6145 function In_Range_Check return Boolean is
6149 while Present (P) loop
6150 if Nkind (P) = N_Raise_Constraint_Error then
6153 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
6154 or else Nkind (P) = N_Procedure_Call_Statement
6155 or else Nkind (P) in N_Declaration
6168 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6171 -- Start of processing for Predicate_Check
6175 and then Current_Scope /= PFunc
6176 and then Nkind (Rop) /= N_Range
6178 if not In_Range_Check then
6179 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
6181 R_Op := New_Occurrence_Of (Standard_True, Loc);
6186 Left_Opnd => Relocate_Node (N),
6187 Right_Opnd => R_Op));
6189 -- Analyze new expression, mark left operand as analyzed to
6190 -- avoid infinite recursion adding predicate calls. Similarly,
6191 -- suppress further range checks on the call.
6193 Set_Analyzed (Left_Opnd (N));
6194 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6196 -- All done, skip attempt at compile time determination of result
6200 end Predicate_Check;
6203 --------------------------------
6204 -- Expand_N_Indexed_Component --
6205 --------------------------------
6207 procedure Expand_N_Indexed_Component (N : Node_Id) is
6208 Loc : constant Source_Ptr := Sloc (N);
6209 Typ : constant Entity_Id := Etype (N);
6210 P : constant Node_Id := Prefix (N);
6211 T : constant Entity_Id := Etype (P);
6215 -- A special optimization, if we have an indexed component that is
6216 -- selecting from a slice, then we can eliminate the slice, since, for
6217 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6218 -- the range check required by the slice. The range check for the slice
6219 -- itself has already been generated. The range check for the
6220 -- subscripting operation is ensured by converting the subject to
6221 -- the subtype of the slice.
6223 -- This optimization not only generates better code, avoiding slice
6224 -- messing especially in the packed case, but more importantly bypasses
6225 -- some problems in handling this peculiar case, for example, the issue
6226 -- of dealing specially with object renamings.
6228 if Nkind (P) = N_Slice
6230 -- This optimization is disabled for CodePeer because it can transform
6231 -- an index-check constraint_error into a range-check constraint_error
6232 -- and CodePeer cares about that distinction.
6234 and then not CodePeer_Mode
6237 Make_Indexed_Component (Loc,
6238 Prefix => Prefix (P),
6239 Expressions => New_List (
6241 (Etype (First_Index (Etype (P))),
6242 First (Expressions (N))))));
6243 Analyze_And_Resolve (N, Typ);
6247 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6248 -- function, then additional actuals must be passed.
6250 if Ada_Version >= Ada_2005
6251 and then Is_Build_In_Place_Function_Call (P)
6253 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6256 -- If the prefix is an access type, then we unconditionally rewrite if
6257 -- as an explicit dereference. This simplifies processing for several
6258 -- cases, including packed array cases and certain cases in which checks
6259 -- must be generated. We used to try to do this only when it was
6260 -- necessary, but it cleans up the code to do it all the time.
6262 if Is_Access_Type (T) then
6263 Insert_Explicit_Dereference (P);
6264 Analyze_And_Resolve (P, Designated_Type (T));
6265 Atp := Designated_Type (T);
6270 -- Generate index and validity checks
6272 Generate_Index_Checks (N);
6274 if Validity_Checks_On and then Validity_Check_Subscripts then
6275 Apply_Subscript_Validity_Checks (N);
6278 -- If selecting from an array with atomic components, and atomic sync
6279 -- is not suppressed for this array type, set atomic sync flag.
6281 if (Has_Atomic_Components (Atp)
6282 and then not Atomic_Synchronization_Disabled (Atp))
6283 or else (Is_Atomic (Typ)
6284 and then not Atomic_Synchronization_Disabled (Typ))
6285 or else (Is_Entity_Name (P)
6286 and then Has_Atomic_Components (Entity (P))
6287 and then not Atomic_Synchronization_Disabled (Entity (P)))
6289 Activate_Atomic_Synchronization (N);
6292 -- All done if the prefix is not a packed array implemented specially
6294 if not (Is_Packed (Etype (Prefix (N)))
6295 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
6300 -- For packed arrays that are not bit-packed (i.e. the case of an array
6301 -- with one or more index types with a non-contiguous enumeration type),
6302 -- we can always use the normal packed element get circuit.
6304 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6305 Expand_Packed_Element_Reference (N);
6309 -- For a reference to a component of a bit packed array, we convert it
6310 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6311 -- want to do this for simple references, and not for:
6313 -- Left side of assignment, or prefix of left side of assignment, or
6314 -- prefix of the prefix, to handle packed arrays of packed arrays,
6315 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6317 -- Renaming objects in renaming associations
6318 -- This case is handled when a use of the renamed variable occurs
6320 -- Actual parameters for a procedure call
6321 -- This case is handled in Exp_Ch6.Expand_Actuals
6323 -- The second expression in a 'Read attribute reference
6325 -- The prefix of an address or bit or size attribute reference
6327 -- The following circuit detects these exceptions. Note that we need to
6328 -- deal with implicit dereferences when climbing up the parent chain,
6329 -- with the additional difficulty that the type of parents may have yet
6330 -- to be resolved since prefixes are usually resolved first.
6333 Child : Node_Id := N;
6334 Parnt : Node_Id := Parent (N);
6338 if Nkind (Parnt) = N_Unchecked_Expression then
6341 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
6342 N_Procedure_Call_Statement)
6343 or else (Nkind (Parnt) = N_Parameter_Association
6345 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
6349 elsif Nkind (Parnt) = N_Attribute_Reference
6350 and then Nam_In (Attribute_Name (Parnt), Name_Address,
6353 and then Prefix (Parnt) = Child
6357 elsif Nkind (Parnt) = N_Assignment_Statement
6358 and then Name (Parnt) = Child
6362 -- If the expression is an index of an indexed component, it must
6363 -- be expanded regardless of context.
6365 elsif Nkind (Parnt) = N_Indexed_Component
6366 and then Child /= Prefix (Parnt)
6368 Expand_Packed_Element_Reference (N);
6371 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
6372 and then Name (Parent (Parnt)) = Parnt
6376 elsif Nkind (Parnt) = N_Attribute_Reference
6377 and then Attribute_Name (Parnt) = Name_Read
6378 and then Next (First (Expressions (Parnt))) = Child
6382 elsif Nkind (Parnt) = N_Indexed_Component
6383 and then Prefix (Parnt) = Child
6387 elsif Nkind (Parnt) = N_Selected_Component
6388 and then Prefix (Parnt) = Child
6389 and then not (Present (Etype (Selector_Name (Parnt)))
6391 Is_Access_Type (Etype (Selector_Name (Parnt))))
6395 -- If the parent is a dereference, either implicit or explicit,
6396 -- then the packed reference needs to be expanded.
6399 Expand_Packed_Element_Reference (N);
6403 -- Keep looking up tree for unchecked expression, or if we are the
6404 -- prefix of a possible assignment left side.
6407 Parnt := Parent (Child);
6410 end Expand_N_Indexed_Component;
6412 ---------------------
6413 -- Expand_N_Not_In --
6414 ---------------------
6416 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6417 -- can be done. This avoids needing to duplicate this expansion code.
6419 procedure Expand_N_Not_In (N : Node_Id) is
6420 Loc : constant Source_Ptr := Sloc (N);
6421 Typ : constant Entity_Id := Etype (N);
6422 Cfs : constant Boolean := Comes_From_Source (N);
6429 Left_Opnd => Left_Opnd (N),
6430 Right_Opnd => Right_Opnd (N))));
6432 -- If this is a set membership, preserve list of alternatives
6434 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
6436 -- We want this to appear as coming from source if original does (see
6437 -- transformations in Expand_N_In).
6439 Set_Comes_From_Source (N, Cfs);
6440 Set_Comes_From_Source (Right_Opnd (N), Cfs);
6442 -- Now analyze transformed node
6444 Analyze_And_Resolve (N, Typ);
6445 end Expand_N_Not_In;
6451 -- The only replacement required is for the case of a null of a type that
6452 -- is an access to protected subprogram, or a subtype thereof. We represent
6453 -- such access values as a record, and so we must replace the occurrence of
6454 -- null by the equivalent record (with a null address and a null pointer in
6455 -- it), so that the backend creates the proper value.
6457 procedure Expand_N_Null (N : Node_Id) is
6458 Loc : constant Source_Ptr := Sloc (N);
6459 Typ : constant Entity_Id := Base_Type (Etype (N));
6463 if Is_Access_Protected_Subprogram_Type (Typ) then
6465 Make_Aggregate (Loc,
6466 Expressions => New_List (
6467 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
6471 Analyze_And_Resolve (N, Equivalent_Type (Typ));
6473 -- For subsequent semantic analysis, the node must retain its type.
6474 -- Gigi in any case replaces this type by the corresponding record
6475 -- type before processing the node.
6481 when RE_Not_Available =>
6485 ---------------------
6486 -- Expand_N_Op_Abs --
6487 ---------------------
6489 procedure Expand_N_Op_Abs (N : Node_Id) is
6490 Loc : constant Source_Ptr := Sloc (N);
6491 Expr : constant Node_Id := Right_Opnd (N);
6494 Unary_Op_Validity_Checks (N);
6496 -- Check for MINIMIZED/ELIMINATED overflow mode
6498 if Minimized_Eliminated_Overflow_Check (N) then
6499 Apply_Arithmetic_Overflow_Check (N);
6503 -- Deal with software overflow checking
6505 if not Backend_Overflow_Checks_On_Target
6506 and then Is_Signed_Integer_Type (Etype (N))
6507 and then Do_Overflow_Check (N)
6509 -- The only case to worry about is when the argument is equal to the
6510 -- largest negative number, so what we do is to insert the check:
6512 -- [constraint_error when Expr = typ'Base'First]
6514 -- with the usual Duplicate_Subexpr use coding for expr
6517 Make_Raise_Constraint_Error (Loc,
6520 Left_Opnd => Duplicate_Subexpr (Expr),
6522 Make_Attribute_Reference (Loc,
6524 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
6525 Attribute_Name => Name_First)),
6526 Reason => CE_Overflow_Check_Failed));
6528 end Expand_N_Op_Abs;
6530 ---------------------
6531 -- Expand_N_Op_Add --
6532 ---------------------
6534 procedure Expand_N_Op_Add (N : Node_Id) is
6535 Typ : constant Entity_Id := Etype (N);
6538 Binary_Op_Validity_Checks (N);
6540 -- Check for MINIMIZED/ELIMINATED overflow mode
6542 if Minimized_Eliminated_Overflow_Check (N) then
6543 Apply_Arithmetic_Overflow_Check (N);
6547 -- N + 0 = 0 + N = N for integer types
6549 if Is_Integer_Type (Typ) then
6550 if Compile_Time_Known_Value (Right_Opnd (N))
6551 and then Expr_Value (Right_Opnd (N)) = Uint_0
6553 Rewrite (N, Left_Opnd (N));
6556 elsif Compile_Time_Known_Value (Left_Opnd (N))
6557 and then Expr_Value (Left_Opnd (N)) = Uint_0
6559 Rewrite (N, Right_Opnd (N));
6564 -- Arithmetic overflow checks for signed integer/fixed point types
6566 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
6567 Apply_Arithmetic_Overflow_Check (N);
6571 -- Overflow checks for floating-point if -gnateF mode active
6573 Check_Float_Op_Overflow (N);
6574 end Expand_N_Op_Add;
6576 ---------------------
6577 -- Expand_N_Op_And --
6578 ---------------------
6580 procedure Expand_N_Op_And (N : Node_Id) is
6581 Typ : constant Entity_Id := Etype (N);
6584 Binary_Op_Validity_Checks (N);
6586 if Is_Array_Type (Etype (N)) then
6587 Expand_Boolean_Operator (N);
6589 elsif Is_Boolean_Type (Etype (N)) then
6590 Adjust_Condition (Left_Opnd (N));
6591 Adjust_Condition (Right_Opnd (N));
6592 Set_Etype (N, Standard_Boolean);
6593 Adjust_Result_Type (N, Typ);
6595 elsif Is_Intrinsic_Subprogram (Entity (N)) then
6596 Expand_Intrinsic_Call (N, Entity (N));
6599 end Expand_N_Op_And;
6601 ------------------------
6602 -- Expand_N_Op_Concat --
6603 ------------------------
6605 procedure Expand_N_Op_Concat (N : Node_Id) is
6607 -- List of operands to be concatenated
6610 -- Node which is to be replaced by the result of concatenating the nodes
6611 -- in the list Opnds.
6614 -- Ensure validity of both operands
6616 Binary_Op_Validity_Checks (N);
6618 -- If we are the left operand of a concatenation higher up the tree,
6619 -- then do nothing for now, since we want to deal with a series of
6620 -- concatenations as a unit.
6622 if Nkind (Parent (N)) = N_Op_Concat
6623 and then N = Left_Opnd (Parent (N))
6628 -- We get here with a concatenation whose left operand may be a
6629 -- concatenation itself with a consistent type. We need to process
6630 -- these concatenation operands from left to right, which means
6631 -- from the deepest node in the tree to the highest node.
6634 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
6635 Cnode := Left_Opnd (Cnode);
6638 -- Now Cnode is the deepest concatenation, and its parents are the
6639 -- concatenation nodes above, so now we process bottom up, doing the
6642 -- The outer loop runs more than once if more than one concatenation
6643 -- type is involved.
6646 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
6647 Set_Parent (Opnds, N);
6649 -- The inner loop gathers concatenation operands
6651 Inner : while Cnode /= N
6652 and then Base_Type (Etype (Cnode)) =
6653 Base_Type (Etype (Parent (Cnode)))
6655 Cnode := Parent (Cnode);
6656 Append (Right_Opnd (Cnode), Opnds);
6659 -- Note: The following code is a temporary workaround for N731-034
6660 -- and N829-028 and will be kept until the general issue of internal
6661 -- symbol serialization is addressed. The workaround is kept under a
6662 -- debug switch to avoid permiating into the general case.
6664 -- Wrap the node to concatenate into an expression actions node to
6665 -- keep it nicely packaged. This is useful in the case of an assert
6666 -- pragma with a concatenation where we want to be able to delete
6667 -- the concatenation and all its expansion stuff.
6669 if Debug_Flag_Dot_H then
6671 Cnod : constant Node_Id := Relocate_Node (Cnode);
6672 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
6675 -- Note: use Rewrite rather than Replace here, so that for
6676 -- example Why_Not_Static can find the original concatenation
6680 Make_Expression_With_Actions (Sloc (Cnode),
6681 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
6682 Expression => Cnod));
6684 Expand_Concatenate (Cnod, Opnds);
6685 Analyze_And_Resolve (Cnode, Typ);
6691 Expand_Concatenate (Cnode, Opnds);
6694 exit Outer when Cnode = N;
6695 Cnode := Parent (Cnode);
6697 end Expand_N_Op_Concat;
6699 ------------------------
6700 -- Expand_N_Op_Divide --
6701 ------------------------
6703 procedure Expand_N_Op_Divide (N : Node_Id) is
6704 Loc : constant Source_Ptr := Sloc (N);
6705 Lopnd : constant Node_Id := Left_Opnd (N);
6706 Ropnd : constant Node_Id := Right_Opnd (N);
6707 Ltyp : constant Entity_Id := Etype (Lopnd);
6708 Rtyp : constant Entity_Id := Etype (Ropnd);
6709 Typ : Entity_Id := Etype (N);
6710 Rknow : constant Boolean := Is_Integer_Type (Typ)
6712 Compile_Time_Known_Value (Ropnd);
6716 Binary_Op_Validity_Checks (N);
6718 -- Check for MINIMIZED/ELIMINATED overflow mode
6720 if Minimized_Eliminated_Overflow_Check (N) then
6721 Apply_Arithmetic_Overflow_Check (N);
6725 -- Otherwise proceed with expansion of division
6728 Rval := Expr_Value (Ropnd);
6731 -- N / 1 = N for integer types
6733 if Rknow and then Rval = Uint_1 then
6738 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6739 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6740 -- operand is an unsigned integer, as required for this to work.
6742 if Nkind (Ropnd) = N_Op_Expon
6743 and then Is_Power_Of_2_For_Shift (Ropnd)
6745 -- We cannot do this transformation in configurable run time mode if we
6746 -- have 64-bit integers and long shifts are not available.
6748 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
6751 Make_Op_Shift_Right (Loc,
6754 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
6755 Analyze_And_Resolve (N, Typ);
6759 -- Do required fixup of universal fixed operation
6761 if Typ = Universal_Fixed then
6762 Fixup_Universal_Fixed_Operation (N);
6766 -- Divisions with fixed-point results
6768 if Is_Fixed_Point_Type (Typ) then
6770 -- Deal with divide-by-zero check if back end cannot handle them
6771 -- and the flag is set indicating that we need such a check. Note
6772 -- that we don't need to bother here with the case of mixed-mode
6773 -- (Right operand an integer type), since these will be rewritten
6774 -- with conversions to a divide with a fixed-point right operand.
6776 if Do_Division_Check (N)
6777 and then not Backend_Divide_Checks_On_Target
6778 and then not Is_Integer_Type (Rtyp)
6780 Set_Do_Division_Check (N, False);
6782 Make_Raise_Constraint_Error (Loc,
6785 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
6786 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
6787 Reason => CE_Divide_By_Zero));
6790 -- No special processing if Treat_Fixed_As_Integer is set, since
6791 -- from a semantic point of view such operations are simply integer
6792 -- operations and will be treated that way.
6794 if not Treat_Fixed_As_Integer (N) then
6795 if Is_Integer_Type (Rtyp) then
6796 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
6798 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
6802 -- Other cases of division of fixed-point operands. Again we exclude the
6803 -- case where Treat_Fixed_As_Integer is set.
6805 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6806 and then not Treat_Fixed_As_Integer (N)
6808 if Is_Integer_Type (Typ) then
6809 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
6811 pragma Assert (Is_Floating_Point_Type (Typ));
6812 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
6815 -- Mixed-mode operations can appear in a non-static universal context,
6816 -- in which case the integer argument must be converted explicitly.
6818 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
6820 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
6822 Analyze_And_Resolve (Ropnd, Universal_Real);
6824 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
6826 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
6828 Analyze_And_Resolve (Lopnd, Universal_Real);
6830 -- Non-fixed point cases, do integer zero divide and overflow checks
6832 elsif Is_Integer_Type (Typ) then
6833 Apply_Divide_Checks (N);
6836 -- Overflow checks for floating-point if -gnateF mode active
6838 Check_Float_Op_Overflow (N);
6839 end Expand_N_Op_Divide;
6841 --------------------
6842 -- Expand_N_Op_Eq --
6843 --------------------
6845 procedure Expand_N_Op_Eq (N : Node_Id) is
6846 Loc : constant Source_Ptr := Sloc (N);
6847 Typ : constant Entity_Id := Etype (N);
6848 Lhs : constant Node_Id := Left_Opnd (N);
6849 Rhs : constant Node_Id := Right_Opnd (N);
6850 Bodies : constant List_Id := New_List;
6851 A_Typ : constant Entity_Id := Etype (Lhs);
6853 Typl : Entity_Id := A_Typ;
6854 Op_Name : Entity_Id;
6857 procedure Build_Equality_Call (Eq : Entity_Id);
6858 -- If a constructed equality exists for the type or for its parent,
6859 -- build and analyze call, adding conversions if the operation is
6862 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
6863 -- Determines whether a type has a subcomponent of an unconstrained
6864 -- Unchecked_Union subtype. Typ is a record type.
6866 -------------------------
6867 -- Build_Equality_Call --
6868 -------------------------
6870 procedure Build_Equality_Call (Eq : Entity_Id) is
6871 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
6872 L_Exp : Node_Id := Relocate_Node (Lhs);
6873 R_Exp : Node_Id := Relocate_Node (Rhs);
6876 -- Adjust operands if necessary to comparison type
6878 if Base_Type (Op_Type) /= Base_Type (A_Typ)
6879 and then not Is_Class_Wide_Type (A_Typ)
6881 L_Exp := OK_Convert_To (Op_Type, L_Exp);
6882 R_Exp := OK_Convert_To (Op_Type, R_Exp);
6885 -- If we have an Unchecked_Union, we need to add the inferred
6886 -- discriminant values as actuals in the function call. At this
6887 -- point, the expansion has determined that both operands have
6888 -- inferable discriminants.
6890 if Is_Unchecked_Union (Op_Type) then
6892 Lhs_Type : constant Node_Id := Etype (L_Exp);
6893 Rhs_Type : constant Node_Id := Etype (R_Exp);
6895 Lhs_Discr_Vals : Elist_Id;
6896 -- List of inferred discriminant values for left operand.
6898 Rhs_Discr_Vals : Elist_Id;
6899 -- List of inferred discriminant values for right operand.
6904 Lhs_Discr_Vals := New_Elmt_List;
6905 Rhs_Discr_Vals := New_Elmt_List;
6907 -- Per-object constrained selected components require special
6908 -- attention. If the enclosing scope of the component is an
6909 -- Unchecked_Union, we cannot reference its discriminants
6910 -- directly. This is why we use the extra parameters of the
6911 -- equality function of the enclosing Unchecked_Union.
6913 -- type UU_Type (Discr : Integer := 0) is
6916 -- pragma Unchecked_Union (UU_Type);
6918 -- 1. Unchecked_Union enclosing record:
6920 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6922 -- Comp : UU_Type (Discr);
6924 -- end Enclosing_UU_Type;
6925 -- pragma Unchecked_Union (Enclosing_UU_Type);
6927 -- Obj1 : Enclosing_UU_Type;
6928 -- Obj2 : Enclosing_UU_Type (1);
6930 -- [. . .] Obj1 = Obj2 [. . .]
6934 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6936 -- A and B are the formal parameters of the equality function
6937 -- of Enclosing_UU_Type. The function always has two extra
6938 -- formals to capture the inferred discriminant values for
6939 -- each discriminant of the type.
6941 -- 2. Non-Unchecked_Union enclosing record:
6944 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6947 -- Comp : UU_Type (Discr);
6949 -- end Enclosing_Non_UU_Type;
6951 -- Obj1 : Enclosing_Non_UU_Type;
6952 -- Obj2 : Enclosing_Non_UU_Type (1);
6954 -- ... Obj1 = Obj2 ...
6958 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6959 -- obj1.discr, obj2.discr)) then
6961 -- In this case we can directly reference the discriminants of
6962 -- the enclosing record.
6964 -- Process left operand of equality
6966 if Nkind (Lhs) = N_Selected_Component
6968 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
6970 -- If enclosing record is an Unchecked_Union, use formals
6971 -- corresponding to each discriminant. The name of the
6972 -- formal is that of the discriminant, with added suffix,
6973 -- see Exp_Ch3.Build_Record_Equality for details.
6975 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
6979 (Scope (Entity (Selector_Name (Lhs))));
6980 while Present (Discr) loop
6982 (Make_Identifier (Loc,
6983 Chars => New_External_Name (Chars (Discr), 'A')),
6984 To => Lhs_Discr_Vals);
6985 Next_Discriminant (Discr);
6988 -- If enclosing record is of a non-Unchecked_Union type, it
6989 -- is possible to reference its discriminants directly.
6992 Discr := First_Discriminant (Lhs_Type);
6993 while Present (Discr) loop
6995 (Make_Selected_Component (Loc,
6996 Prefix => Prefix (Lhs),
6999 (Get_Discriminant_Value (Discr,
7001 Stored_Constraint (Lhs_Type)))),
7002 To => Lhs_Discr_Vals);
7003 Next_Discriminant (Discr);
7007 -- Otherwise operand is on object with a constrained type.
7008 -- Infer the discriminant values from the constraint.
7012 Discr := First_Discriminant (Lhs_Type);
7013 while Present (Discr) loop
7016 (Get_Discriminant_Value (Discr,
7018 Stored_Constraint (Lhs_Type))),
7019 To => Lhs_Discr_Vals);
7020 Next_Discriminant (Discr);
7024 -- Similar processing for right operand of equality
7026 if Nkind (Rhs) = N_Selected_Component
7028 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7030 if Is_Unchecked_Union
7031 (Scope (Entity (Selector_Name (Rhs))))
7035 (Scope (Entity (Selector_Name (Rhs))));
7036 while Present (Discr) loop
7038 (Make_Identifier (Loc,
7039 Chars => New_External_Name (Chars (Discr), 'B')),
7040 To => Rhs_Discr_Vals);
7041 Next_Discriminant (Discr);
7045 Discr := First_Discriminant (Rhs_Type);
7046 while Present (Discr) loop
7048 (Make_Selected_Component (Loc,
7049 Prefix => Prefix (Rhs),
7051 New_Copy (Get_Discriminant_Value
7054 Stored_Constraint (Rhs_Type)))),
7055 To => Rhs_Discr_Vals);
7056 Next_Discriminant (Discr);
7061 Discr := First_Discriminant (Rhs_Type);
7062 while Present (Discr) loop
7064 (New_Copy (Get_Discriminant_Value
7067 Stored_Constraint (Rhs_Type))),
7068 To => Rhs_Discr_Vals);
7069 Next_Discriminant (Discr);
7073 -- Now merge the list of discriminant values so that values
7074 -- of corresponding discriminants are adjacent.
7082 Params := New_List (L_Exp, R_Exp);
7083 L_Elmt := First_Elmt (Lhs_Discr_Vals);
7084 R_Elmt := First_Elmt (Rhs_Discr_Vals);
7085 while Present (L_Elmt) loop
7086 Append_To (Params, Node (L_Elmt));
7087 Append_To (Params, Node (R_Elmt));
7093 Make_Function_Call (Loc,
7094 Name => New_Occurrence_Of (Eq, Loc),
7095 Parameter_Associations => Params));
7099 -- Normal case, not an unchecked union
7103 Make_Function_Call (Loc,
7104 Name => New_Occurrence_Of (Eq, Loc),
7105 Parameter_Associations => New_List (L_Exp, R_Exp)));
7108 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7109 end Build_Equality_Call;
7111 ------------------------------------
7112 -- Has_Unconstrained_UU_Component --
7113 ------------------------------------
7115 function Has_Unconstrained_UU_Component
7116 (Typ : Node_Id) return Boolean
7118 Tdef : constant Node_Id :=
7119 Type_Definition (Declaration_Node (Base_Type (Typ)));
7123 function Component_Is_Unconstrained_UU
7124 (Comp : Node_Id) return Boolean;
7125 -- Determines whether the subtype of the component is an
7126 -- unconstrained Unchecked_Union.
7128 function Variant_Is_Unconstrained_UU
7129 (Variant : Node_Id) return Boolean;
7130 -- Determines whether a component of the variant has an unconstrained
7131 -- Unchecked_Union subtype.
7133 -----------------------------------
7134 -- Component_Is_Unconstrained_UU --
7135 -----------------------------------
7137 function Component_Is_Unconstrained_UU
7138 (Comp : Node_Id) return Boolean
7141 if Nkind (Comp) /= N_Component_Declaration then
7146 Sindic : constant Node_Id :=
7147 Subtype_Indication (Component_Definition (Comp));
7150 -- Unconstrained nominal type. In the case of a constraint
7151 -- present, the node kind would have been N_Subtype_Indication.
7153 if Nkind (Sindic) = N_Identifier then
7154 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7159 end Component_Is_Unconstrained_UU;
7161 ---------------------------------
7162 -- Variant_Is_Unconstrained_UU --
7163 ---------------------------------
7165 function Variant_Is_Unconstrained_UU
7166 (Variant : Node_Id) return Boolean
7168 Clist : constant Node_Id := Component_List (Variant);
7171 if Is_Empty_List (Component_Items (Clist)) then
7175 -- We only need to test one component
7178 Comp : Node_Id := First (Component_Items (Clist));
7181 while Present (Comp) loop
7182 if Component_Is_Unconstrained_UU (Comp) then
7190 -- None of the components withing the variant were of
7191 -- unconstrained Unchecked_Union type.
7194 end Variant_Is_Unconstrained_UU;
7196 -- Start of processing for Has_Unconstrained_UU_Component
7199 if Null_Present (Tdef) then
7203 Clist := Component_List (Tdef);
7204 Vpart := Variant_Part (Clist);
7206 -- Inspect available components
7208 if Present (Component_Items (Clist)) then
7210 Comp : Node_Id := First (Component_Items (Clist));
7213 while Present (Comp) loop
7215 -- One component is sufficient
7217 if Component_Is_Unconstrained_UU (Comp) then
7226 -- Inspect available components withing variants
7228 if Present (Vpart) then
7230 Variant : Node_Id := First (Variants (Vpart));
7233 while Present (Variant) loop
7235 -- One component within a variant is sufficient
7237 if Variant_Is_Unconstrained_UU (Variant) then
7246 -- Neither the available components, nor the components inside the
7247 -- variant parts were of an unconstrained Unchecked_Union subtype.
7250 end Has_Unconstrained_UU_Component;
7252 -- Start of processing for Expand_N_Op_Eq
7255 Binary_Op_Validity_Checks (N);
7257 -- Deal with private types
7259 if Ekind (Typl) = E_Private_Type then
7260 Typl := Underlying_Type (Typl);
7261 elsif Ekind (Typl) = E_Private_Subtype then
7262 Typl := Underlying_Type (Base_Type (Typl));
7267 -- It may happen in error situations that the underlying type is not
7268 -- set. The error will be detected later, here we just defend the
7275 -- Now get the implementation base type (note that plain Base_Type here
7276 -- might lead us back to the private type, which is not what we want!)
7278 Typl := Implementation_Base_Type (Typl);
7280 -- Equality between variant records results in a call to a routine
7281 -- that has conditional tests of the discriminant value(s), and hence
7282 -- violates the No_Implicit_Conditionals restriction.
7284 if Has_Variant_Part (Typl) then
7289 Check_Restriction (Msg, No_Implicit_Conditionals, N);
7293 ("\comparison of variant records tests discriminants", N);
7299 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7300 -- means we no longer have a comparison operation, we are all done.
7302 Expand_Compare_Minimize_Eliminate_Overflow (N);
7304 if Nkind (N) /= N_Op_Eq then
7308 -- Boolean types (requiring handling of non-standard case)
7310 if Is_Boolean_Type (Typl) then
7311 Adjust_Condition (Left_Opnd (N));
7312 Adjust_Condition (Right_Opnd (N));
7313 Set_Etype (N, Standard_Boolean);
7314 Adjust_Result_Type (N, Typ);
7318 elsif Is_Array_Type (Typl) then
7320 -- If we are doing full validity checking, and it is possible for the
7321 -- array elements to be invalid then expand out array comparisons to
7322 -- make sure that we check the array elements.
7324 if Validity_Check_Operands
7325 and then not Is_Known_Valid (Component_Type (Typl))
7328 Save_Force_Validity_Checks : constant Boolean :=
7329 Force_Validity_Checks;
7331 Force_Validity_Checks := True;
7333 Expand_Array_Equality
7335 Relocate_Node (Lhs),
7336 Relocate_Node (Rhs),
7339 Insert_Actions (N, Bodies);
7340 Analyze_And_Resolve (N, Standard_Boolean);
7341 Force_Validity_Checks := Save_Force_Validity_Checks;
7344 -- Packed case where both operands are known aligned
7346 elsif Is_Bit_Packed_Array (Typl)
7347 and then not Is_Possibly_Unaligned_Object (Lhs)
7348 and then not Is_Possibly_Unaligned_Object (Rhs)
7350 Expand_Packed_Eq (N);
7352 -- Where the component type is elementary we can use a block bit
7353 -- comparison (if supported on the target) exception in the case
7354 -- of floating-point (negative zero issues require element by
7355 -- element comparison), and atomic/VFA types (where we must be sure
7356 -- to load elements independently) and possibly unaligned arrays.
7358 elsif Is_Elementary_Type (Component_Type (Typl))
7359 and then not Is_Floating_Point_Type (Component_Type (Typl))
7360 and then not Is_Atomic_Or_VFA (Component_Type (Typl))
7361 and then not Is_Possibly_Unaligned_Object (Lhs)
7362 and then not Is_Possibly_Unaligned_Object (Rhs)
7363 and then Support_Composite_Compare_On_Target
7367 -- For composite and floating-point cases, expand equality loop to
7368 -- make sure of using proper comparisons for tagged types, and
7369 -- correctly handling the floating-point case.
7373 Expand_Array_Equality
7375 Relocate_Node (Lhs),
7376 Relocate_Node (Rhs),
7379 Insert_Actions (N, Bodies, Suppress => All_Checks);
7380 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7385 elsif Is_Record_Type (Typl) then
7387 -- For tagged types, use the primitive "="
7389 if Is_Tagged_Type (Typl) then
7391 -- No need to do anything else compiling under restriction
7392 -- No_Dispatching_Calls. During the semantic analysis we
7393 -- already notified such violation.
7395 if Restriction_Active (No_Dispatching_Calls) then
7399 -- If this is derived from an untagged private type completed with
7400 -- a tagged type, it does not have a full view, so we use the
7401 -- primitive operations of the private type. This check should no
7402 -- longer be necessary when these types get their full views???
7404 if Is_Private_Type (A_Typ)
7405 and then not Is_Tagged_Type (A_Typ)
7406 and then Is_Derived_Type (A_Typ)
7407 and then No (Full_View (A_Typ))
7409 -- Search for equality operation, checking that the operands
7410 -- have the same type. Note that we must find a matching entry,
7411 -- or something is very wrong.
7413 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
7415 while Present (Prim) loop
7416 exit when Chars (Node (Prim)) = Name_Op_Eq
7417 and then Etype (First_Formal (Node (Prim))) =
7418 Etype (Next_Formal (First_Formal (Node (Prim))))
7420 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7425 pragma Assert (Present (Prim));
7426 Op_Name := Node (Prim);
7428 -- Find the type's predefined equality or an overriding
7429 -- user-defined equality. The reason for not simply calling
7430 -- Find_Prim_Op here is that there may be a user-defined
7431 -- overloaded equality op that precedes the equality that we
7432 -- want, so we have to explicitly search (e.g., there could be
7433 -- an equality with two different parameter types).
7436 if Is_Class_Wide_Type (Typl) then
7437 Typl := Find_Specific_Type (Typl);
7440 Prim := First_Elmt (Primitive_Operations (Typl));
7441 while Present (Prim) loop
7442 exit when Chars (Node (Prim)) = Name_Op_Eq
7443 and then Etype (First_Formal (Node (Prim))) =
7444 Etype (Next_Formal (First_Formal (Node (Prim))))
7446 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7451 pragma Assert (Present (Prim));
7452 Op_Name := Node (Prim);
7455 Build_Equality_Call (Op_Name);
7457 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7458 -- predefined equality operator for a type which has a subcomponent
7459 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7461 elsif Has_Unconstrained_UU_Component (Typl) then
7463 Make_Raise_Program_Error (Loc,
7464 Reason => PE_Unchecked_Union_Restriction));
7466 -- Prevent Gigi from generating incorrect code by rewriting the
7467 -- equality as a standard False. (is this documented somewhere???)
7470 New_Occurrence_Of (Standard_False, Loc));
7472 elsif Is_Unchecked_Union (Typl) then
7474 -- If we can infer the discriminants of the operands, we make a
7475 -- call to the TSS equality function.
7477 if Has_Inferable_Discriminants (Lhs)
7479 Has_Inferable_Discriminants (Rhs)
7482 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7485 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7486 -- the predefined equality operator for an Unchecked_Union type
7487 -- if either of the operands lack inferable discriminants.
7490 Make_Raise_Program_Error (Loc,
7491 Reason => PE_Unchecked_Union_Restriction));
7493 -- Emit a warning on source equalities only, otherwise the
7494 -- message may appear out of place due to internal use. The
7495 -- warning is unconditional because it is required by the
7498 if Comes_From_Source (N) then
7500 ("Unchecked_Union discriminants cannot be determined??",
7503 ("\Program_Error will be raised for equality operation??",
7507 -- Prevent Gigi from generating incorrect code by rewriting
7508 -- the equality as a standard False (documented where???).
7511 New_Occurrence_Of (Standard_False, Loc));
7514 -- If a type support function is present (for complex cases), use it
7516 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
7518 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7520 -- When comparing two Bounded_Strings, use the primitive equality of
7521 -- the root Super_String type.
7523 elsif Is_Bounded_String (Typl) then
7525 First_Elmt (Collect_Primitive_Operations (Root_Type (Typl)));
7527 while Present (Prim) loop
7528 exit when Chars (Node (Prim)) = Name_Op_Eq
7529 and then Etype (First_Formal (Node (Prim))) =
7530 Etype (Next_Formal (First_Formal (Node (Prim))))
7531 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7536 -- A Super_String type should always have a primitive equality
7538 pragma Assert (Present (Prim));
7539 Build_Equality_Call (Node (Prim));
7541 -- Otherwise expand the component by component equality. Note that
7542 -- we never use block-bit comparisons for records, because of the
7543 -- problems with gaps. The backend will often be able to recombine
7544 -- the separate comparisons that we generate here.
7547 Remove_Side_Effects (Lhs);
7548 Remove_Side_Effects (Rhs);
7550 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
7552 Insert_Actions (N, Bodies, Suppress => All_Checks);
7553 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7557 -- Test if result is known at compile time
7559 Rewrite_Comparison (N);
7561 -- Special optimization of length comparison
7563 Optimize_Length_Comparison (N);
7565 -- One more special case: if we have a comparison of X'Result = expr
7566 -- in floating-point, then if not already there, change expr to be
7567 -- f'Machine (expr) to eliminate surprise from extra precision.
7569 if Is_Floating_Point_Type (Typl)
7570 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
7571 and then Attribute_Name (Original_Node (Lhs)) = Name_Result
7573 -- Stick in the Typ'Machine call if not already there
7575 if Nkind (Rhs) /= N_Attribute_Reference
7576 or else Attribute_Name (Rhs) /= Name_Machine
7579 Make_Attribute_Reference (Loc,
7580 Prefix => New_Occurrence_Of (Typl, Loc),
7581 Attribute_Name => Name_Machine,
7582 Expressions => New_List (Relocate_Node (Rhs))));
7583 Analyze_And_Resolve (Rhs, Typl);
7588 -----------------------
7589 -- Expand_N_Op_Expon --
7590 -----------------------
7592 procedure Expand_N_Op_Expon (N : Node_Id) is
7593 Loc : constant Source_Ptr := Sloc (N);
7594 Typ : constant Entity_Id := Etype (N);
7595 Rtyp : constant Entity_Id := Root_Type (Typ);
7596 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
7597 Bastyp : constant Node_Id := Etype (Base);
7598 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
7599 Exptyp : constant Entity_Id := Etype (Exp);
7600 Ovflo : constant Boolean := Do_Overflow_Check (N);
7608 function Wrap_MA (Exp : Node_Id) return Node_Id;
7609 -- Given an expression Exp, if the root type is Float or Long_Float,
7610 -- then wrap the expression in a call of Bastyp'Machine, to stop any
7611 -- extra precision. This is done to ensure that X**A = X**B when A is
7612 -- a static constant and B is a variable with the same value. For any
7613 -- other type, the node Exp is returned unchanged.
7619 function Wrap_MA (Exp : Node_Id) return Node_Id is
7620 Loc : constant Source_Ptr := Sloc (Exp);
7622 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
7624 Make_Attribute_Reference (Loc,
7625 Attribute_Name => Name_Machine,
7626 Prefix => New_Occurrence_Of (Bastyp, Loc),
7627 Expressions => New_List (Relocate_Node (Exp)));
7633 -- Start of processing for Expand_N_Op
7636 Binary_Op_Validity_Checks (N);
7638 -- CodePeer wants to see the unexpanded N_Op_Expon node
7640 if CodePeer_Mode then
7644 -- If either operand is of a private type, then we have the use of an
7645 -- intrinsic operator, and we get rid of the privateness, by using root
7646 -- types of underlying types for the actual operation. Otherwise the
7647 -- private types will cause trouble if we expand multiplications or
7648 -- shifts etc. We also do this transformation if the result type is
7649 -- different from the base type.
7651 if Is_Private_Type (Etype (Base))
7652 or else Is_Private_Type (Typ)
7653 or else Is_Private_Type (Exptyp)
7654 or else Rtyp /= Root_Type (Bastyp)
7657 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
7658 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
7661 Unchecked_Convert_To (Typ,
7663 Left_Opnd => Unchecked_Convert_To (Bt, Base),
7664 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
7665 Analyze_And_Resolve (N, Typ);
7670 -- Check for MINIMIZED/ELIMINATED overflow mode
7672 if Minimized_Eliminated_Overflow_Check (N) then
7673 Apply_Arithmetic_Overflow_Check (N);
7677 -- Test for case of known right argument where we can replace the
7678 -- exponentiation by an equivalent expression using multiplication.
7680 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7681 -- configurable run-time mode, we may not have the exponentiation
7682 -- routine available, and we don't want the legality of the program
7683 -- to depend on how clever the compiler is in knowing values.
7685 if CRT_Safe_Compile_Time_Known_Value (Exp) then
7686 Expv := Expr_Value (Exp);
7688 -- We only fold small non-negative exponents. You might think we
7689 -- could fold small negative exponents for the real case, but we
7690 -- can't because we are required to raise Constraint_Error for
7691 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7692 -- See ACVC test C4A012B, and it is not worth generating the test.
7694 if Expv >= 0 and then Expv <= 4 then
7696 -- X ** 0 = 1 (or 1.0)
7700 -- Call Remove_Side_Effects to ensure that any side effects
7701 -- in the ignored left operand (in particular function calls
7702 -- to user defined functions) are properly executed.
7704 Remove_Side_Effects (Base);
7706 if Ekind (Typ) in Integer_Kind then
7707 Xnode := Make_Integer_Literal (Loc, Intval => 1);
7709 Xnode := Make_Real_Literal (Loc, Ureal_1);
7722 Make_Op_Multiply (Loc,
7723 Left_Opnd => Duplicate_Subexpr (Base),
7724 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
7726 -- X ** 3 = X * X * X
7731 Make_Op_Multiply (Loc,
7733 Make_Op_Multiply (Loc,
7734 Left_Opnd => Duplicate_Subexpr (Base),
7735 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
7736 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
7741 -- En : constant base'type := base * base;
7746 pragma Assert (Expv = 4);
7747 Temp := Make_Temporary (Loc, 'E', Base);
7750 Make_Expression_With_Actions (Loc,
7751 Actions => New_List (
7752 Make_Object_Declaration (Loc,
7753 Defining_Identifier => Temp,
7754 Constant_Present => True,
7755 Object_Definition => New_Occurrence_Of (Typ, Loc),
7758 Make_Op_Multiply (Loc,
7760 Duplicate_Subexpr (Base),
7762 Duplicate_Subexpr_No_Checks (Base))))),
7766 Make_Op_Multiply (Loc,
7767 Left_Opnd => New_Occurrence_Of (Temp, Loc),
7768 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
7772 Analyze_And_Resolve (N, Typ);
7777 -- Deal with optimizing 2 ** expression to shift where possible
7779 -- Note: we used to check that Exptyp was an unsigned type. But that is
7780 -- an unnecessary check, since if Exp is negative, we have a run-time
7781 -- error that is either caught (so we get the right result) or we have
7782 -- suppressed the check, in which case the code is erroneous anyway.
7784 if Is_Integer_Type (Rtyp)
7786 -- The base value must be "safe compile-time known", and exactly 2
7788 and then Nkind (Base) = N_Integer_Literal
7789 and then CRT_Safe_Compile_Time_Known_Value (Base)
7790 and then Expr_Value (Base) = Uint_2
7792 -- We only handle cases where the right type is a integer
7794 and then Is_Integer_Type (Root_Type (Exptyp))
7795 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
7797 -- This transformation is not applicable for a modular type with a
7798 -- nonbinary modulus because we do not handle modular reduction in
7799 -- a correct manner if we attempt this transformation in this case.
7801 and then not Non_Binary_Modulus (Typ)
7803 -- Handle the cases where our parent is a division or multiplication
7804 -- specially. In these cases we can convert to using a shift at the
7805 -- parent level if we are not doing overflow checking, since it is
7806 -- too tricky to combine the overflow check at the parent level.
7809 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply)
7812 P : constant Node_Id := Parent (N);
7813 L : constant Node_Id := Left_Opnd (P);
7814 R : constant Node_Id := Right_Opnd (P);
7817 if (Nkind (P) = N_Op_Multiply
7819 ((Is_Integer_Type (Etype (L)) and then R = N)
7821 (Is_Integer_Type (Etype (R)) and then L = N))
7822 and then not Do_Overflow_Check (P))
7825 (Nkind (P) = N_Op_Divide
7826 and then Is_Integer_Type (Etype (L))
7827 and then Is_Unsigned_Type (Etype (L))
7829 and then not Do_Overflow_Check (P))
7831 Set_Is_Power_Of_2_For_Shift (N);
7836 -- Here we just have 2 ** N on its own, so we can convert this to a
7837 -- shift node. We are prepared to deal with overflow here, and we
7838 -- also have to handle proper modular reduction for binary modular.
7847 -- Maximum shift count with no overflow
7850 -- Set True if we must test the shift count
7853 -- Node for test against TestS
7856 -- Compute maximum shift based on the underlying size. For a
7857 -- modular type this is one less than the size.
7859 if Is_Modular_Integer_Type (Typ) then
7861 -- For modular integer types, this is the size of the value
7862 -- being shifted minus one. Any larger values will cause
7863 -- modular reduction to a result of zero. Note that we do
7864 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
7865 -- of 6, since 2**7 should be reduced to zero).
7867 MaxS := RM_Size (Rtyp) - 1;
7869 -- For signed integer types, we use the size of the value
7870 -- being shifted minus 2. Larger values cause overflow.
7873 MaxS := Esize (Rtyp) - 2;
7876 -- Determine range to see if it can be larger than MaxS
7879 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
7880 TestS := (not OK) or else Hi > MaxS;
7882 -- Signed integer case
7884 if Is_Signed_Integer_Type (Typ) then
7886 -- Generate overflow check if overflow is active. Note that
7887 -- we can simply ignore the possibility of overflow if the
7888 -- flag is not set (means that overflow cannot happen or
7889 -- that overflow checks are suppressed).
7891 if Ovflo and TestS then
7893 Make_Raise_Constraint_Error (Loc,
7896 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
7897 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
7898 Reason => CE_Overflow_Check_Failed));
7901 -- Now rewrite node as Shift_Left (1, right-operand)
7904 Make_Op_Shift_Left (Loc,
7905 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
7906 Right_Opnd => Right_Opnd (N)));
7908 -- Modular integer case
7910 else pragma Assert (Is_Modular_Integer_Type (Typ));
7912 -- If shift count can be greater than MaxS, we need to wrap
7913 -- the shift in a test that will reduce the result value to
7914 -- zero if this shift count is exceeded.
7918 -- Note: build node for the comparison first, before we
7919 -- reuse the Right_Opnd, so that we have proper parents
7920 -- in place for the Duplicate_Subexpr call.
7924 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
7925 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
7928 Make_If_Expression (Loc,
7929 Expressions => New_List (
7931 Make_Integer_Literal (Loc, Uint_0),
7932 Make_Op_Shift_Left (Loc,
7933 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
7934 Right_Opnd => Right_Opnd (N)))));
7936 -- If we know shift count cannot be greater than MaxS, then
7937 -- it is safe to just rewrite as a shift with no test.
7941 Make_Op_Shift_Left (Loc,
7942 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
7943 Right_Opnd => Right_Opnd (N)));
7947 Analyze_And_Resolve (N, Typ);
7953 -- Fall through if exponentiation must be done using a runtime routine
7955 -- First deal with modular case
7957 if Is_Modular_Integer_Type (Rtyp) then
7959 -- Nonbinary modular case, we call the special exponentiation
7960 -- routine for the nonbinary case, converting the argument to
7961 -- Long_Long_Integer and passing the modulus value. Then the
7962 -- result is converted back to the base type.
7964 if Non_Binary_Modulus (Rtyp) then
7967 Make_Function_Call (Loc,
7969 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
7970 Parameter_Associations => New_List (
7971 Convert_To (RTE (RE_Unsigned), Base),
7972 Make_Integer_Literal (Loc, Modulus (Rtyp)),
7975 -- Binary modular case, in this case, we call one of two routines,
7976 -- either the unsigned integer case, or the unsigned long long
7977 -- integer case, with a final "and" operation to do the required mod.
7980 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
7981 Ent := RTE (RE_Exp_Unsigned);
7983 Ent := RTE (RE_Exp_Long_Long_Unsigned);
7990 Make_Function_Call (Loc,
7991 Name => New_Occurrence_Of (Ent, Loc),
7992 Parameter_Associations => New_List (
7993 Convert_To (Etype (First_Formal (Ent)), Base),
7996 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
8000 -- Common exit point for modular type case
8002 Analyze_And_Resolve (N, Typ);
8005 -- Signed integer cases, done using either Integer or Long_Long_Integer.
8006 -- It is not worth having routines for Short_[Short_]Integer, since for
8007 -- most machines it would not help, and it would generate more code that
8008 -- might need certification when a certified run time is required.
8010 -- In the integer cases, we have two routines, one for when overflow
8011 -- checks are required, and one when they are not required, since there
8012 -- is a real gain in omitting checks on many machines.
8014 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
8015 or else (Rtyp = Base_Type (Standard_Long_Integer)
8017 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
8018 or else Rtyp = Universal_Integer
8020 Etyp := Standard_Long_Long_Integer;
8023 Rent := RE_Exp_Long_Long_Integer;
8025 Rent := RE_Exn_Long_Long_Integer;
8028 elsif Is_Signed_Integer_Type (Rtyp) then
8029 Etyp := Standard_Integer;
8032 Rent := RE_Exp_Integer;
8034 Rent := RE_Exn_Integer;
8037 -- Floating-point cases. We do not need separate routines for the
8038 -- overflow case here, since in the case of floating-point, we generate
8039 -- infinities anyway as a rule (either that or we automatically trap
8040 -- overflow), and if there is an infinity generated and a range check
8041 -- is required, the check will fail anyway.
8043 -- Historical note: we used to convert everything to Long_Long_Float
8044 -- and call a single common routine, but this had the undesirable effect
8045 -- of giving different results for small static exponent values and the
8046 -- same dynamic values.
8049 pragma Assert (Is_Floating_Point_Type (Rtyp));
8051 if Rtyp = Standard_Float then
8052 Etyp := Standard_Float;
8053 Rent := RE_Exn_Float;
8055 elsif Rtyp = Standard_Long_Float then
8056 Etyp := Standard_Long_Float;
8057 Rent := RE_Exn_Long_Float;
8060 Etyp := Standard_Long_Long_Float;
8061 Rent := RE_Exn_Long_Long_Float;
8065 -- Common processing for integer cases and floating-point cases.
8066 -- If we are in the right type, we can call runtime routine directly
8069 and then Rtyp /= Universal_Integer
8070 and then Rtyp /= Universal_Real
8074 Make_Function_Call (Loc,
8075 Name => New_Occurrence_Of (RTE (Rent), Loc),
8076 Parameter_Associations => New_List (Base, Exp))));
8078 -- Otherwise we have to introduce conversions (conversions are also
8079 -- required in the universal cases, since the runtime routine is
8080 -- typed using one of the standard types).
8085 Make_Function_Call (Loc,
8086 Name => New_Occurrence_Of (RTE (Rent), Loc),
8087 Parameter_Associations => New_List (
8088 Convert_To (Etyp, Base),
8092 Analyze_And_Resolve (N, Typ);
8096 when RE_Not_Available =>
8098 end Expand_N_Op_Expon;
8100 --------------------
8101 -- Expand_N_Op_Ge --
8102 --------------------
8104 procedure Expand_N_Op_Ge (N : Node_Id) is
8105 Typ : constant Entity_Id := Etype (N);
8106 Op1 : constant Node_Id := Left_Opnd (N);
8107 Op2 : constant Node_Id := Right_Opnd (N);
8108 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8111 Binary_Op_Validity_Checks (N);
8113 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8114 -- means we no longer have a comparison operation, we are all done.
8116 Expand_Compare_Minimize_Eliminate_Overflow (N);
8118 if Nkind (N) /= N_Op_Ge then
8124 if Is_Array_Type (Typ1) then
8125 Expand_Array_Comparison (N);
8129 -- Deal with boolean operands
8131 if Is_Boolean_Type (Typ1) then
8132 Adjust_Condition (Op1);
8133 Adjust_Condition (Op2);
8134 Set_Etype (N, Standard_Boolean);
8135 Adjust_Result_Type (N, Typ);
8138 Rewrite_Comparison (N);
8140 Optimize_Length_Comparison (N);
8143 --------------------
8144 -- Expand_N_Op_Gt --
8145 --------------------
8147 procedure Expand_N_Op_Gt (N : Node_Id) is
8148 Typ : constant Entity_Id := Etype (N);
8149 Op1 : constant Node_Id := Left_Opnd (N);
8150 Op2 : constant Node_Id := Right_Opnd (N);
8151 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8154 Binary_Op_Validity_Checks (N);
8156 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8157 -- means we no longer have a comparison operation, we are all done.
8159 Expand_Compare_Minimize_Eliminate_Overflow (N);
8161 if Nkind (N) /= N_Op_Gt then
8165 -- Deal with array type operands
8167 if Is_Array_Type (Typ1) then
8168 Expand_Array_Comparison (N);
8172 -- Deal with boolean type operands
8174 if Is_Boolean_Type (Typ1) then
8175 Adjust_Condition (Op1);
8176 Adjust_Condition (Op2);
8177 Set_Etype (N, Standard_Boolean);
8178 Adjust_Result_Type (N, Typ);
8181 Rewrite_Comparison (N);
8183 Optimize_Length_Comparison (N);
8186 --------------------
8187 -- Expand_N_Op_Le --
8188 --------------------
8190 procedure Expand_N_Op_Le (N : Node_Id) is
8191 Typ : constant Entity_Id := Etype (N);
8192 Op1 : constant Node_Id := Left_Opnd (N);
8193 Op2 : constant Node_Id := Right_Opnd (N);
8194 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8197 Binary_Op_Validity_Checks (N);
8199 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8200 -- means we no longer have a comparison operation, we are all done.
8202 Expand_Compare_Minimize_Eliminate_Overflow (N);
8204 if Nkind (N) /= N_Op_Le then
8208 -- Deal with array type operands
8210 if Is_Array_Type (Typ1) then
8211 Expand_Array_Comparison (N);
8215 -- Deal with Boolean type operands
8217 if Is_Boolean_Type (Typ1) then
8218 Adjust_Condition (Op1);
8219 Adjust_Condition (Op2);
8220 Set_Etype (N, Standard_Boolean);
8221 Adjust_Result_Type (N, Typ);
8224 Rewrite_Comparison (N);
8226 Optimize_Length_Comparison (N);
8229 --------------------
8230 -- Expand_N_Op_Lt --
8231 --------------------
8233 procedure Expand_N_Op_Lt (N : Node_Id) is
8234 Typ : constant Entity_Id := Etype (N);
8235 Op1 : constant Node_Id := Left_Opnd (N);
8236 Op2 : constant Node_Id := Right_Opnd (N);
8237 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8240 Binary_Op_Validity_Checks (N);
8242 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8243 -- means we no longer have a comparison operation, we are all done.
8245 Expand_Compare_Minimize_Eliminate_Overflow (N);
8247 if Nkind (N) /= N_Op_Lt then
8251 -- Deal with array type operands
8253 if Is_Array_Type (Typ1) then
8254 Expand_Array_Comparison (N);
8258 -- Deal with Boolean type operands
8260 if Is_Boolean_Type (Typ1) then
8261 Adjust_Condition (Op1);
8262 Adjust_Condition (Op2);
8263 Set_Etype (N, Standard_Boolean);
8264 Adjust_Result_Type (N, Typ);
8267 Rewrite_Comparison (N);
8269 Optimize_Length_Comparison (N);
8272 -----------------------
8273 -- Expand_N_Op_Minus --
8274 -----------------------
8276 procedure Expand_N_Op_Minus (N : Node_Id) is
8277 Loc : constant Source_Ptr := Sloc (N);
8278 Typ : constant Entity_Id := Etype (N);
8281 Unary_Op_Validity_Checks (N);
8283 -- Check for MINIMIZED/ELIMINATED overflow mode
8285 if Minimized_Eliminated_Overflow_Check (N) then
8286 Apply_Arithmetic_Overflow_Check (N);
8290 if not Backend_Overflow_Checks_On_Target
8291 and then Is_Signed_Integer_Type (Etype (N))
8292 and then Do_Overflow_Check (N)
8294 -- Software overflow checking expands -expr into (0 - expr)
8297 Make_Op_Subtract (Loc,
8298 Left_Opnd => Make_Integer_Literal (Loc, 0),
8299 Right_Opnd => Right_Opnd (N)));
8301 Analyze_And_Resolve (N, Typ);
8303 end Expand_N_Op_Minus;
8305 ---------------------
8306 -- Expand_N_Op_Mod --
8307 ---------------------
8309 procedure Expand_N_Op_Mod (N : Node_Id) is
8310 Loc : constant Source_Ptr := Sloc (N);
8311 Typ : constant Entity_Id := Etype (N);
8312 DDC : constant Boolean := Do_Division_Check (N);
8325 pragma Warnings (Off, Lhi);
8328 Binary_Op_Validity_Checks (N);
8330 -- Check for MINIMIZED/ELIMINATED overflow mode
8332 if Minimized_Eliminated_Overflow_Check (N) then
8333 Apply_Arithmetic_Overflow_Check (N);
8337 if Is_Integer_Type (Etype (N)) then
8338 Apply_Divide_Checks (N);
8340 -- All done if we don't have a MOD any more, which can happen as a
8341 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8343 if Nkind (N) /= N_Op_Mod then
8348 -- Proceed with expansion of mod operator
8350 Left := Left_Opnd (N);
8351 Right := Right_Opnd (N);
8353 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
8354 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
8356 -- Convert mod to rem if operands are both known to be non-negative, or
8357 -- both known to be non-positive (these are the cases in which rem and
8358 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8359 -- likely that this will improve the quality of code, (the operation now
8360 -- corresponds to the hardware remainder), and it does not seem likely
8361 -- that it could be harmful. It also avoids some cases of the elaborate
8362 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8365 and then ((Llo >= 0 and then Rlo >= 0)
8367 (Lhi <= 0 and then Rhi <= 0))
8370 Make_Op_Rem (Sloc (N),
8371 Left_Opnd => Left_Opnd (N),
8372 Right_Opnd => Right_Opnd (N)));
8374 -- Instead of reanalyzing the node we do the analysis manually. This
8375 -- avoids anomalies when the replacement is done in an instance and
8376 -- is epsilon more efficient.
8378 Set_Entity (N, Standard_Entity (S_Op_Rem));
8380 Set_Do_Division_Check (N, DDC);
8381 Expand_N_Op_Rem (N);
8385 -- Otherwise, normal mod processing
8388 -- Apply optimization x mod 1 = 0. We don't really need that with
8389 -- gcc, but it is useful with other back ends and is certainly
8392 if Is_Integer_Type (Etype (N))
8393 and then Compile_Time_Known_Value (Right)
8394 and then Expr_Value (Right) = Uint_1
8396 -- Call Remove_Side_Effects to ensure that any side effects in
8397 -- the ignored left operand (in particular function calls to
8398 -- user defined functions) are properly executed.
8400 Remove_Side_Effects (Left);
8402 Rewrite (N, Make_Integer_Literal (Loc, 0));
8403 Analyze_And_Resolve (N, Typ);
8407 -- If we still have a mod operator and we are in Modify_Tree_For_C
8408 -- mode, and we have a signed integer type, then here is where we do
8409 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8410 -- for the special handling of the annoying case of largest negative
8411 -- number mod minus one.
8413 if Nkind (N) = N_Op_Mod
8414 and then Is_Signed_Integer_Type (Typ)
8415 and then Modify_Tree_For_C
8417 -- In the general case, we expand A mod B as
8419 -- Tnn : constant typ := A rem B;
8421 -- (if (A >= 0) = (B >= 0) then Tnn
8422 -- elsif Tnn = 0 then 0
8425 -- The comparison can be written simply as A >= 0 if we know that
8426 -- B >= 0 which is a very common case.
8428 -- An important optimization is when B is known at compile time
8429 -- to be 2**K for some constant. In this case we can simply AND
8430 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8431 -- and that works for both the positive and negative cases.
8434 P2 : constant Nat := Power_Of_Two (Right);
8439 Unchecked_Convert_To (Typ,
8442 Unchecked_Convert_To
8443 (Corresponding_Unsigned_Type (Typ), Left),
8445 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
8446 Analyze_And_Resolve (N, Typ);
8451 -- Here for the full rewrite
8454 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
8460 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
8461 Right_Opnd => Make_Integer_Literal (Loc, 0));
8463 if not LOK or else Rlo < 0 then
8469 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
8470 Right_Opnd => Make_Integer_Literal (Loc, 0)));
8474 Make_Object_Declaration (Loc,
8475 Defining_Identifier => Tnn,
8476 Constant_Present => True,
8477 Object_Definition => New_Occurrence_Of (Typ, Loc),
8481 Right_Opnd => Right)));
8484 Make_If_Expression (Loc,
8485 Expressions => New_List (
8487 New_Occurrence_Of (Tnn, Loc),
8488 Make_If_Expression (Loc,
8490 Expressions => New_List (
8492 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8493 Right_Opnd => Make_Integer_Literal (Loc, 0)),
8494 Make_Integer_Literal (Loc, 0),
8496 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8498 Duplicate_Subexpr_No_Checks (Right)))))));
8500 Analyze_And_Resolve (N, Typ);
8505 -- Deal with annoying case of largest negative number mod minus one.
8506 -- Gigi may not handle this case correctly, because on some targets,
8507 -- the mod value is computed using a divide instruction which gives
8508 -- an overflow trap for this case.
8510 -- It would be a bit more efficient to figure out which targets
8511 -- this is really needed for, but in practice it is reasonable
8512 -- to do the following special check in all cases, since it means
8513 -- we get a clearer message, and also the overhead is minimal given
8514 -- that division is expensive in any case.
8516 -- In fact the check is quite easy, if the right operand is -1, then
8517 -- the mod value is always 0, and we can just ignore the left operand
8518 -- completely in this case.
8520 -- This only applies if we still have a mod operator. Skip if we
8521 -- have already rewritten this (e.g. in the case of eliminated
8522 -- overflow checks which have driven us into bignum mode).
8524 if Nkind (N) = N_Op_Mod then
8526 -- The operand type may be private (e.g. in the expansion of an
8527 -- intrinsic operation) so we must use the underlying type to get
8528 -- the bounds, and convert the literals explicitly.
8532 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
8534 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
8535 and then ((not LOK) or else (Llo = LLB))
8538 Make_If_Expression (Loc,
8539 Expressions => New_List (
8541 Left_Opnd => Duplicate_Subexpr (Right),
8543 Unchecked_Convert_To (Typ,
8544 Make_Integer_Literal (Loc, -1))),
8545 Unchecked_Convert_To (Typ,
8546 Make_Integer_Literal (Loc, Uint_0)),
8547 Relocate_Node (N))));
8549 Set_Analyzed (Next (Next (First (Expressions (N)))));
8550 Analyze_And_Resolve (N, Typ);
8554 end Expand_N_Op_Mod;
8556 --------------------------
8557 -- Expand_N_Op_Multiply --
8558 --------------------------
8560 procedure Expand_N_Op_Multiply (N : Node_Id) is
8561 Loc : constant Source_Ptr := Sloc (N);
8562 Lop : constant Node_Id := Left_Opnd (N);
8563 Rop : constant Node_Id := Right_Opnd (N);
8565 Lp2 : constant Boolean :=
8566 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
8567 Rp2 : constant Boolean :=
8568 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
8570 Ltyp : constant Entity_Id := Etype (Lop);
8571 Rtyp : constant Entity_Id := Etype (Rop);
8572 Typ : Entity_Id := Etype (N);
8575 Binary_Op_Validity_Checks (N);
8577 -- Check for MINIMIZED/ELIMINATED overflow mode
8579 if Minimized_Eliminated_Overflow_Check (N) then
8580 Apply_Arithmetic_Overflow_Check (N);
8584 -- Special optimizations for integer types
8586 if Is_Integer_Type (Typ) then
8588 -- N * 0 = 0 for integer types
8590 if Compile_Time_Known_Value (Rop)
8591 and then Expr_Value (Rop) = Uint_0
8593 -- Call Remove_Side_Effects to ensure that any side effects in
8594 -- the ignored left operand (in particular function calls to
8595 -- user defined functions) are properly executed.
8597 Remove_Side_Effects (Lop);
8599 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8600 Analyze_And_Resolve (N, Typ);
8604 -- Similar handling for 0 * N = 0
8606 if Compile_Time_Known_Value (Lop)
8607 and then Expr_Value (Lop) = Uint_0
8609 Remove_Side_Effects (Rop);
8610 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8611 Analyze_And_Resolve (N, Typ);
8615 -- N * 1 = 1 * N = N for integer types
8617 -- This optimisation is not done if we are going to
8618 -- rewrite the product 1 * 2 ** N to a shift.
8620 if Compile_Time_Known_Value (Rop)
8621 and then Expr_Value (Rop) = Uint_1
8627 elsif Compile_Time_Known_Value (Lop)
8628 and then Expr_Value (Lop) = Uint_1
8636 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8637 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8638 -- operand is an integer, as required for this to work.
8643 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8647 Left_Opnd => Make_Integer_Literal (Loc, 2),
8650 Left_Opnd => Right_Opnd (Lop),
8651 Right_Opnd => Right_Opnd (Rop))));
8652 Analyze_And_Resolve (N, Typ);
8656 -- If the result is modular, perform the reduction of the result
8659 if Is_Modular_Integer_Type (Typ)
8660 and then not Non_Binary_Modulus (Typ)
8665 Make_Op_Shift_Left (Loc,
8668 Convert_To (Standard_Natural, Right_Opnd (Rop))),
8670 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8674 Make_Op_Shift_Left (Loc,
8677 Convert_To (Standard_Natural, Right_Opnd (Rop))));
8680 Analyze_And_Resolve (N, Typ);
8684 -- Same processing for the operands the other way round
8687 if Is_Modular_Integer_Type (Typ)
8688 and then not Non_Binary_Modulus (Typ)
8693 Make_Op_Shift_Left (Loc,
8696 Convert_To (Standard_Natural, Right_Opnd (Lop))),
8698 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8702 Make_Op_Shift_Left (Loc,
8705 Convert_To (Standard_Natural, Right_Opnd (Lop))));
8708 Analyze_And_Resolve (N, Typ);
8712 -- Do required fixup of universal fixed operation
8714 if Typ = Universal_Fixed then
8715 Fixup_Universal_Fixed_Operation (N);
8719 -- Multiplications with fixed-point results
8721 if Is_Fixed_Point_Type (Typ) then
8723 -- No special processing if Treat_Fixed_As_Integer is set, since from
8724 -- a semantic point of view such operations are simply integer
8725 -- operations and will be treated that way.
8727 if not Treat_Fixed_As_Integer (N) then
8729 -- Case of fixed * integer => fixed
8731 if Is_Integer_Type (Rtyp) then
8732 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
8734 -- Case of integer * fixed => fixed
8736 elsif Is_Integer_Type (Ltyp) then
8737 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
8739 -- Case of fixed * fixed => fixed
8742 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
8746 -- Other cases of multiplication of fixed-point operands. Again we
8747 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8749 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
8750 and then not Treat_Fixed_As_Integer (N)
8752 if Is_Integer_Type (Typ) then
8753 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
8755 pragma Assert (Is_Floating_Point_Type (Typ));
8756 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
8759 -- Mixed-mode operations can appear in a non-static universal context,
8760 -- in which case the integer argument must be converted explicitly.
8762 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
8763 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
8764 Analyze_And_Resolve (Rop, Universal_Real);
8766 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
8767 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
8768 Analyze_And_Resolve (Lop, Universal_Real);
8770 -- Non-fixed point cases, check software overflow checking required
8772 elsif Is_Signed_Integer_Type (Etype (N)) then
8773 Apply_Arithmetic_Overflow_Check (N);
8776 -- Overflow checks for floating-point if -gnateF mode active
8778 Check_Float_Op_Overflow (N);
8779 end Expand_N_Op_Multiply;
8781 --------------------
8782 -- Expand_N_Op_Ne --
8783 --------------------
8785 procedure Expand_N_Op_Ne (N : Node_Id) is
8786 Typ : constant Entity_Id := Etype (Left_Opnd (N));
8789 -- Case of elementary type with standard operator
8791 if Is_Elementary_Type (Typ)
8792 and then Sloc (Entity (N)) = Standard_Location
8794 Binary_Op_Validity_Checks (N);
8796 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8797 -- means we no longer have a /= operation, we are all done.
8799 Expand_Compare_Minimize_Eliminate_Overflow (N);
8801 if Nkind (N) /= N_Op_Ne then
8805 -- Boolean types (requiring handling of non-standard case)
8807 if Is_Boolean_Type (Typ) then
8808 Adjust_Condition (Left_Opnd (N));
8809 Adjust_Condition (Right_Opnd (N));
8810 Set_Etype (N, Standard_Boolean);
8811 Adjust_Result_Type (N, Typ);
8814 Rewrite_Comparison (N);
8816 -- For all cases other than elementary types, we rewrite node as the
8817 -- negation of an equality operation, and reanalyze. The equality to be
8818 -- used is defined in the same scope and has the same signature. This
8819 -- signature must be set explicitly since in an instance it may not have
8820 -- the same visibility as in the generic unit. This avoids duplicating
8821 -- or factoring the complex code for record/array equality tests etc.
8825 Loc : constant Source_Ptr := Sloc (N);
8827 Ne : constant Entity_Id := Entity (N);
8830 Binary_Op_Validity_Checks (N);
8836 Left_Opnd => Left_Opnd (N),
8837 Right_Opnd => Right_Opnd (N)));
8838 Set_Paren_Count (Right_Opnd (Neg), 1);
8840 if Scope (Ne) /= Standard_Standard then
8841 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
8844 -- For navigation purposes, we want to treat the inequality as an
8845 -- implicit reference to the corresponding equality. Preserve the
8846 -- Comes_From_ source flag to generate proper Xref entries.
8848 Preserve_Comes_From_Source (Neg, N);
8849 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
8851 Analyze_And_Resolve (N, Standard_Boolean);
8855 Optimize_Length_Comparison (N);
8858 ---------------------
8859 -- Expand_N_Op_Not --
8860 ---------------------
8862 -- If the argument is other than a Boolean array type, there is no special
8863 -- expansion required, except for dealing with validity checks, and non-
8864 -- standard boolean representations.
8866 -- For the packed array case, we call the special routine in Exp_Pakd,
8867 -- except that if the component size is greater than one, we use the
8868 -- standard routine generating a gruesome loop (it is so peculiar to have
8869 -- packed arrays with non-standard Boolean representations anyway, so it
8870 -- does not matter that we do not handle this case efficiently).
8872 -- For the unpacked array case (and for the special packed case where we
8873 -- have non standard Booleans, as discussed above), we generate and insert
8874 -- into the tree the following function definition:
8876 -- function Nnnn (A : arr) is
8879 -- for J in a'range loop
8880 -- B (J) := not A (J);
8885 -- Here arr is the actual subtype of the parameter (and hence always
8886 -- constrained). Then we replace the not with a call to this function.
8888 procedure Expand_N_Op_Not (N : Node_Id) is
8889 Loc : constant Source_Ptr := Sloc (N);
8890 Typ : constant Entity_Id := Etype (N);
8899 Func_Name : Entity_Id;
8900 Loop_Statement : Node_Id;
8903 Unary_Op_Validity_Checks (N);
8905 -- For boolean operand, deal with non-standard booleans
8907 if Is_Boolean_Type (Typ) then
8908 Adjust_Condition (Right_Opnd (N));
8909 Set_Etype (N, Standard_Boolean);
8910 Adjust_Result_Type (N, Typ);
8914 -- Only array types need any other processing
8916 if not Is_Array_Type (Typ) then
8920 -- Case of array operand. If bit packed with a component size of 1,
8921 -- handle it in Exp_Pakd if the operand is known to be aligned.
8923 if Is_Bit_Packed_Array (Typ)
8924 and then Component_Size (Typ) = 1
8925 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
8927 Expand_Packed_Not (N);
8931 -- Case of array operand which is not bit-packed. If the context is
8932 -- a safe assignment, call in-place operation, If context is a larger
8933 -- boolean expression in the context of a safe assignment, expansion is
8934 -- done by enclosing operation.
8936 Opnd := Relocate_Node (Right_Opnd (N));
8937 Convert_To_Actual_Subtype (Opnd);
8938 Arr := Etype (Opnd);
8939 Ensure_Defined (Arr, N);
8940 Silly_Boolean_Array_Not_Test (N, Arr);
8942 if Nkind (Parent (N)) = N_Assignment_Statement then
8943 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
8944 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8947 -- Special case the negation of a binary operation
8949 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
8950 and then Safe_In_Place_Array_Op
8951 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
8953 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8957 elsif Nkind (Parent (N)) in N_Binary_Op
8958 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
8961 Op1 : constant Node_Id := Left_Opnd (Parent (N));
8962 Op2 : constant Node_Id := Right_Opnd (Parent (N));
8963 Lhs : constant Node_Id := Name (Parent (Parent (N)));
8966 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
8968 -- (not A) op (not B) can be reduced to a single call
8970 if N = Op1 and then Nkind (Op2) = N_Op_Not then
8973 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
8976 -- A xor (not B) can also be special-cased
8978 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
8985 A := Make_Defining_Identifier (Loc, Name_uA);
8986 B := Make_Defining_Identifier (Loc, Name_uB);
8987 J := Make_Defining_Identifier (Loc, Name_uJ);
8990 Make_Indexed_Component (Loc,
8991 Prefix => New_Occurrence_Of (A, Loc),
8992 Expressions => New_List (New_Occurrence_Of (J, Loc)));
8995 Make_Indexed_Component (Loc,
8996 Prefix => New_Occurrence_Of (B, Loc),
8997 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9000 Make_Implicit_Loop_Statement (N,
9001 Identifier => Empty,
9004 Make_Iteration_Scheme (Loc,
9005 Loop_Parameter_Specification =>
9006 Make_Loop_Parameter_Specification (Loc,
9007 Defining_Identifier => J,
9008 Discrete_Subtype_Definition =>
9009 Make_Attribute_Reference (Loc,
9010 Prefix => Make_Identifier (Loc, Chars (A)),
9011 Attribute_Name => Name_Range))),
9013 Statements => New_List (
9014 Make_Assignment_Statement (Loc,
9016 Expression => Make_Op_Not (Loc, A_J))));
9018 Func_Name := Make_Temporary (Loc, 'N');
9019 Set_Is_Inlined (Func_Name);
9022 Make_Subprogram_Body (Loc,
9024 Make_Function_Specification (Loc,
9025 Defining_Unit_Name => Func_Name,
9026 Parameter_Specifications => New_List (
9027 Make_Parameter_Specification (Loc,
9028 Defining_Identifier => A,
9029 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9030 Result_Definition => New_Occurrence_Of (Typ, Loc)),
9032 Declarations => New_List (
9033 Make_Object_Declaration (Loc,
9034 Defining_Identifier => B,
9035 Object_Definition => New_Occurrence_Of (Arr, Loc))),
9037 Handled_Statement_Sequence =>
9038 Make_Handled_Sequence_Of_Statements (Loc,
9039 Statements => New_List (
9041 Make_Simple_Return_Statement (Loc,
9042 Expression => Make_Identifier (Loc, Chars (B)))))));
9045 Make_Function_Call (Loc,
9046 Name => New_Occurrence_Of (Func_Name, Loc),
9047 Parameter_Associations => New_List (Opnd)));
9049 Analyze_And_Resolve (N, Typ);
9050 end Expand_N_Op_Not;
9052 --------------------
9053 -- Expand_N_Op_Or --
9054 --------------------
9056 procedure Expand_N_Op_Or (N : Node_Id) is
9057 Typ : constant Entity_Id := Etype (N);
9060 Binary_Op_Validity_Checks (N);
9062 if Is_Array_Type (Etype (N)) then
9063 Expand_Boolean_Operator (N);
9065 elsif Is_Boolean_Type (Etype (N)) then
9066 Adjust_Condition (Left_Opnd (N));
9067 Adjust_Condition (Right_Opnd (N));
9068 Set_Etype (N, Standard_Boolean);
9069 Adjust_Result_Type (N, Typ);
9071 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9072 Expand_Intrinsic_Call (N, Entity (N));
9077 ----------------------
9078 -- Expand_N_Op_Plus --
9079 ----------------------
9081 procedure Expand_N_Op_Plus (N : Node_Id) is
9083 Unary_Op_Validity_Checks (N);
9085 -- Check for MINIMIZED/ELIMINATED overflow mode
9087 if Minimized_Eliminated_Overflow_Check (N) then
9088 Apply_Arithmetic_Overflow_Check (N);
9091 end Expand_N_Op_Plus;
9093 ---------------------
9094 -- Expand_N_Op_Rem --
9095 ---------------------
9097 procedure Expand_N_Op_Rem (N : Node_Id) is
9098 Loc : constant Source_Ptr := Sloc (N);
9099 Typ : constant Entity_Id := Etype (N);
9110 -- Set if corresponding operand can be negative
9112 pragma Unreferenced (Hi);
9115 Binary_Op_Validity_Checks (N);
9117 -- Check for MINIMIZED/ELIMINATED overflow mode
9119 if Minimized_Eliminated_Overflow_Check (N) then
9120 Apply_Arithmetic_Overflow_Check (N);
9124 if Is_Integer_Type (Etype (N)) then
9125 Apply_Divide_Checks (N);
9127 -- All done if we don't have a REM any more, which can happen as a
9128 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9130 if Nkind (N) /= N_Op_Rem then
9135 -- Proceed with expansion of REM
9137 Left := Left_Opnd (N);
9138 Right := Right_Opnd (N);
9140 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9141 -- but it is useful with other back ends, and is certainly harmless.
9143 if Is_Integer_Type (Etype (N))
9144 and then Compile_Time_Known_Value (Right)
9145 and then Expr_Value (Right) = Uint_1
9147 -- Call Remove_Side_Effects to ensure that any side effects in the
9148 -- ignored left operand (in particular function calls to user defined
9149 -- functions) are properly executed.
9151 Remove_Side_Effects (Left);
9153 Rewrite (N, Make_Integer_Literal (Loc, 0));
9154 Analyze_And_Resolve (N, Typ);
9158 -- Deal with annoying case of largest negative number remainder minus
9159 -- one. Gigi may not handle this case correctly, because on some
9160 -- targets, the mod value is computed using a divide instruction
9161 -- which gives an overflow trap for this case.
9163 -- It would be a bit more efficient to figure out which targets this
9164 -- is really needed for, but in practice it is reasonable to do the
9165 -- following special check in all cases, since it means we get a clearer
9166 -- message, and also the overhead is minimal given that division is
9167 -- expensive in any case.
9169 -- In fact the check is quite easy, if the right operand is -1, then
9170 -- the remainder is always 0, and we can just ignore the left operand
9171 -- completely in this case.
9173 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9174 Lneg := (not OK) or else Lo < 0;
9176 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
9177 Rneg := (not OK) or else Lo < 0;
9179 -- We won't mess with trying to find out if the left operand can really
9180 -- be the largest negative number (that's a pain in the case of private
9181 -- types and this is really marginal). We will just assume that we need
9182 -- the test if the left operand can be negative at all.
9184 if Lneg and Rneg then
9186 Make_If_Expression (Loc,
9187 Expressions => New_List (
9189 Left_Opnd => Duplicate_Subexpr (Right),
9191 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
9193 Unchecked_Convert_To (Typ,
9194 Make_Integer_Literal (Loc, Uint_0)),
9196 Relocate_Node (N))));
9198 Set_Analyzed (Next (Next (First (Expressions (N)))));
9199 Analyze_And_Resolve (N, Typ);
9201 end Expand_N_Op_Rem;
9203 -----------------------------
9204 -- Expand_N_Op_Rotate_Left --
9205 -----------------------------
9207 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
9209 Binary_Op_Validity_Checks (N);
9211 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9212 -- so we rewrite in terms of logical shifts
9214 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9216 -- where Bits is the shift count mod Esize (the mod operation here
9217 -- deals with ludicrous large shift counts, which are apparently OK).
9219 -- What about nonbinary modulus ???
9222 Loc : constant Source_Ptr := Sloc (N);
9223 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
9224 Typ : constant Entity_Id := Etype (N);
9227 if Modify_Tree_For_C then
9228 Rewrite (Right_Opnd (N),
9230 Left_Opnd => Relocate_Node (Right_Opnd (N)),
9231 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
9233 Analyze_And_Resolve (Right_Opnd (N), Rtp);
9238 Make_Op_Shift_Left (Loc,
9239 Left_Opnd => Left_Opnd (N),
9240 Right_Opnd => Right_Opnd (N)),
9243 Make_Op_Shift_Right (Loc,
9244 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9246 Make_Op_Subtract (Loc,
9247 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9249 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9251 Analyze_And_Resolve (N, Typ);
9254 end Expand_N_Op_Rotate_Left;
9256 ------------------------------
9257 -- Expand_N_Op_Rotate_Right --
9258 ------------------------------
9260 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
9262 Binary_Op_Validity_Checks (N);
9264 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9265 -- so we rewrite in terms of logical shifts
9267 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9269 -- where Bits is the shift count mod Esize (the mod operation here
9270 -- deals with ludicrous large shift counts, which are apparently OK).
9272 -- What about nonbinary modulus ???
9275 Loc : constant Source_Ptr := Sloc (N);
9276 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
9277 Typ : constant Entity_Id := Etype (N);
9280 Rewrite (Right_Opnd (N),
9282 Left_Opnd => Relocate_Node (Right_Opnd (N)),
9283 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
9285 Analyze_And_Resolve (Right_Opnd (N), Rtp);
9287 if Modify_Tree_For_C then
9291 Make_Op_Shift_Right (Loc,
9292 Left_Opnd => Left_Opnd (N),
9293 Right_Opnd => Right_Opnd (N)),
9296 Make_Op_Shift_Left (Loc,
9297 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9299 Make_Op_Subtract (Loc,
9300 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9302 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9304 Analyze_And_Resolve (N, Typ);
9307 end Expand_N_Op_Rotate_Right;
9309 ----------------------------
9310 -- Expand_N_Op_Shift_Left --
9311 ----------------------------
9313 -- Note: nothing in this routine depends on left as opposed to right shifts
9314 -- so we share the routine for expanding shift right operations.
9316 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
9318 Binary_Op_Validity_Checks (N);
9320 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9321 -- operand is not greater than the word size (since that would not
9322 -- be defined properly by the corresponding C shift operator).
9324 if Modify_Tree_For_C then
9326 Right : constant Node_Id := Right_Opnd (N);
9327 Loc : constant Source_Ptr := Sloc (Right);
9328 Typ : constant Entity_Id := Etype (N);
9329 Siz : constant Uint := Esize (Typ);
9336 if Compile_Time_Known_Value (Right) then
9337 if Expr_Value (Right) >= Siz then
9338 Rewrite (N, Make_Integer_Literal (Loc, 0));
9339 Analyze_And_Resolve (N, Typ);
9342 -- Not compile time known, find range
9345 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9347 -- Nothing to do if known to be OK range, otherwise expand
9349 if not OK or else Hi >= Siz then
9351 -- Prevent recursion on copy of shift node
9353 Orig := Relocate_Node (N);
9354 Set_Analyzed (Orig);
9356 -- Now do the rewrite
9359 Make_If_Expression (Loc,
9360 Expressions => New_List (
9362 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
9363 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
9364 Make_Integer_Literal (Loc, 0),
9366 Analyze_And_Resolve (N, Typ);
9371 end Expand_N_Op_Shift_Left;
9373 -----------------------------
9374 -- Expand_N_Op_Shift_Right --
9375 -----------------------------
9377 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
9379 -- Share shift left circuit
9381 Expand_N_Op_Shift_Left (N);
9382 end Expand_N_Op_Shift_Right;
9384 ----------------------------------------
9385 -- Expand_N_Op_Shift_Right_Arithmetic --
9386 ----------------------------------------
9388 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
9390 Binary_Op_Validity_Checks (N);
9392 -- If we are in Modify_Tree_For_C mode, there is no shift right
9393 -- arithmetic in C, so we rewrite in terms of logical shifts.
9395 -- Shift_Right (Num, Bits) or
9397 -- then not (Shift_Right (Mask, bits))
9400 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9402 -- Note: in almost all C compilers it would work to just shift a
9403 -- signed integer right, but it's undefined and we cannot rely on it.
9405 -- Note: the above works fine for shift counts greater than or equal
9406 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9407 -- generates all 1'bits.
9409 -- What about nonbinary modulus ???
9412 Loc : constant Source_Ptr := Sloc (N);
9413 Typ : constant Entity_Id := Etype (N);
9414 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
9415 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
9416 Left : constant Node_Id := Left_Opnd (N);
9417 Right : constant Node_Id := Right_Opnd (N);
9421 if Modify_Tree_For_C then
9423 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9424 -- compile time as a single constant.
9426 if Compile_Time_Known_Value (Right) then
9428 Val : constant Uint := Expr_Value (Right);
9431 if Val >= Esize (Typ) then
9432 Maskx := Make_Integer_Literal (Loc, Mask);
9436 Make_Integer_Literal (Loc,
9437 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
9445 Make_Op_Shift_Right (Loc,
9446 Left_Opnd => Make_Integer_Literal (Loc, Mask),
9447 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
9450 -- Now do the rewrite
9455 Make_Op_Shift_Right (Loc,
9457 Right_Opnd => Right),
9459 Make_If_Expression (Loc,
9460 Expressions => New_List (
9462 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9463 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
9465 Make_Integer_Literal (Loc, 0)))));
9466 Analyze_And_Resolve (N, Typ);
9469 end Expand_N_Op_Shift_Right_Arithmetic;
9471 --------------------------
9472 -- Expand_N_Op_Subtract --
9473 --------------------------
9475 procedure Expand_N_Op_Subtract (N : Node_Id) is
9476 Typ : constant Entity_Id := Etype (N);
9479 Binary_Op_Validity_Checks (N);
9481 -- Check for MINIMIZED/ELIMINATED overflow mode
9483 if Minimized_Eliminated_Overflow_Check (N) then
9484 Apply_Arithmetic_Overflow_Check (N);
9488 -- N - 0 = N for integer types
9490 if Is_Integer_Type (Typ)
9491 and then Compile_Time_Known_Value (Right_Opnd (N))
9492 and then Expr_Value (Right_Opnd (N)) = 0
9494 Rewrite (N, Left_Opnd (N));
9498 -- Arithmetic overflow checks for signed integer/fixed point types
9500 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
9501 Apply_Arithmetic_Overflow_Check (N);
9504 -- Overflow checks for floating-point if -gnateF mode active
9506 Check_Float_Op_Overflow (N);
9507 end Expand_N_Op_Subtract;
9509 ---------------------
9510 -- Expand_N_Op_Xor --
9511 ---------------------
9513 procedure Expand_N_Op_Xor (N : Node_Id) is
9514 Typ : constant Entity_Id := Etype (N);
9517 Binary_Op_Validity_Checks (N);
9519 if Is_Array_Type (Etype (N)) then
9520 Expand_Boolean_Operator (N);
9522 elsif Is_Boolean_Type (Etype (N)) then
9523 Adjust_Condition (Left_Opnd (N));
9524 Adjust_Condition (Right_Opnd (N));
9525 Set_Etype (N, Standard_Boolean);
9526 Adjust_Result_Type (N, Typ);
9528 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9529 Expand_Intrinsic_Call (N, Entity (N));
9532 end Expand_N_Op_Xor;
9534 ----------------------
9535 -- Expand_N_Or_Else --
9536 ----------------------
9538 procedure Expand_N_Or_Else (N : Node_Id)
9539 renames Expand_Short_Circuit_Operator;
9541 -----------------------------------
9542 -- Expand_N_Qualified_Expression --
9543 -----------------------------------
9545 procedure Expand_N_Qualified_Expression (N : Node_Id) is
9546 Operand : constant Node_Id := Expression (N);
9547 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
9550 -- Do validity check if validity checking operands
9552 if Validity_Checks_On and Validity_Check_Operands then
9553 Ensure_Valid (Operand);
9556 -- Apply possible constraint check
9558 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
9560 if Do_Range_Check (Operand) then
9561 Set_Do_Range_Check (Operand, False);
9562 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
9564 end Expand_N_Qualified_Expression;
9566 ------------------------------------
9567 -- Expand_N_Quantified_Expression --
9568 ------------------------------------
9572 -- for all X in range => Cond
9577 -- for X in range loop
9584 -- Similarly, an existentially quantified expression:
9586 -- for some X in range => Cond
9591 -- for X in range loop
9598 -- In both cases, the iteration may be over a container in which case it is
9599 -- given by an iterator specification, not a loop parameter specification.
9601 procedure Expand_N_Quantified_Expression (N : Node_Id) is
9602 Actions : constant List_Id := New_List;
9603 For_All : constant Boolean := All_Present (N);
9604 Iter_Spec : constant Node_Id := Iterator_Specification (N);
9605 Loc : constant Source_Ptr := Sloc (N);
9606 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
9613 -- Create the declaration of the flag which tracks the status of the
9614 -- quantified expression. Generate:
9616 -- Flag : Boolean := (True | False);
9618 Flag := Make_Temporary (Loc, 'T', N);
9621 Make_Object_Declaration (Loc,
9622 Defining_Identifier => Flag,
9623 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
9625 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
9627 -- Construct the circuitry which tracks the status of the quantified
9628 -- expression. Generate:
9630 -- if [not] Cond then
9631 -- Flag := (False | True);
9635 Cond := Relocate_Node (Condition (N));
9638 Cond := Make_Op_Not (Loc, Cond);
9642 Make_Implicit_If_Statement (N,
9644 Then_Statements => New_List (
9645 Make_Assignment_Statement (Loc,
9646 Name => New_Occurrence_Of (Flag, Loc),
9648 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
9649 Make_Exit_Statement (Loc))));
9651 -- Build the loop equivalent of the quantified expression
9653 if Present (Iter_Spec) then
9655 Make_Iteration_Scheme (Loc,
9656 Iterator_Specification => Iter_Spec);
9659 Make_Iteration_Scheme (Loc,
9660 Loop_Parameter_Specification => Loop_Spec);
9664 Make_Loop_Statement (Loc,
9665 Iteration_Scheme => Scheme,
9666 Statements => Stmts,
9667 End_Label => Empty));
9669 -- Transform the quantified expression
9672 Make_Expression_With_Actions (Loc,
9673 Expression => New_Occurrence_Of (Flag, Loc),
9674 Actions => Actions));
9675 Analyze_And_Resolve (N, Standard_Boolean);
9676 end Expand_N_Quantified_Expression;
9678 ---------------------------------
9679 -- Expand_N_Selected_Component --
9680 ---------------------------------
9682 procedure Expand_N_Selected_Component (N : Node_Id) is
9683 Loc : constant Source_Ptr := Sloc (N);
9684 Par : constant Node_Id := Parent (N);
9685 P : constant Node_Id := Prefix (N);
9686 S : constant Node_Id := Selector_Name (N);
9687 Ptyp : Entity_Id := Underlying_Type (Etype (P));
9693 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
9694 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9695 -- unless the context of an assignment can provide size information.
9696 -- Don't we have a general routine that does this???
9698 function Is_Subtype_Declaration return Boolean;
9699 -- The replacement of a discriminant reference by its value is required
9700 -- if this is part of the initialization of an temporary generated by a
9701 -- change of representation. This shows up as the construction of a
9702 -- discriminant constraint for a subtype declared at the same point as
9703 -- the entity in the prefix of the selected component. We recognize this
9704 -- case when the context of the reference is:
9705 -- subtype ST is T(Obj.D);
9706 -- where the entity for Obj comes from source, and ST has the same sloc.
9708 -----------------------
9709 -- In_Left_Hand_Side --
9710 -----------------------
9712 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
9714 return (Nkind (Parent (Comp)) = N_Assignment_Statement
9715 and then Comp = Name (Parent (Comp)))
9716 or else (Present (Parent (Comp))
9717 and then Nkind (Parent (Comp)) in N_Subexpr
9718 and then In_Left_Hand_Side (Parent (Comp)));
9719 end In_Left_Hand_Side;
9721 -----------------------------
9722 -- Is_Subtype_Declaration --
9723 -----------------------------
9725 function Is_Subtype_Declaration return Boolean is
9726 Par : constant Node_Id := Parent (N);
9729 Nkind (Par) = N_Index_Or_Discriminant_Constraint
9730 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
9731 and then Comes_From_Source (Entity (Prefix (N)))
9732 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
9733 end Is_Subtype_Declaration;
9735 -- Start of processing for Expand_N_Selected_Component
9738 -- Insert explicit dereference if required
9740 if Is_Access_Type (Ptyp) then
9742 -- First set prefix type to proper access type, in case it currently
9743 -- has a private (non-access) view of this type.
9745 Set_Etype (P, Ptyp);
9747 Insert_Explicit_Dereference (P);
9748 Analyze_And_Resolve (P, Designated_Type (Ptyp));
9750 if Ekind (Etype (P)) = E_Private_Subtype
9751 and then Is_For_Access_Subtype (Etype (P))
9753 Set_Etype (P, Base_Type (Etype (P)));
9759 -- Deal with discriminant check required
9761 if Do_Discriminant_Check (N) then
9762 if Present (Discriminant_Checking_Func
9763 (Original_Record_Component (Entity (S))))
9765 -- Present the discriminant checking function to the backend, so
9766 -- that it can inline the call to the function.
9769 (Discriminant_Checking_Func
9770 (Original_Record_Component (Entity (S))),
9773 -- Now reset the flag and generate the call
9775 Set_Do_Discriminant_Check (N, False);
9776 Generate_Discriminant_Check (N);
9778 -- In the case of Unchecked_Union, no discriminant checking is
9779 -- actually performed.
9782 Set_Do_Discriminant_Check (N, False);
9786 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9787 -- function, then additional actuals must be passed.
9789 if Ada_Version >= Ada_2005
9790 and then Is_Build_In_Place_Function_Call (P)
9792 Make_Build_In_Place_Call_In_Anonymous_Context (P);
9795 -- Gigi cannot handle unchecked conversions that are the prefix of a
9796 -- selected component with discriminants. This must be checked during
9797 -- expansion, because during analysis the type of the selector is not
9798 -- known at the point the prefix is analyzed. If the conversion is the
9799 -- target of an assignment, then we cannot force the evaluation.
9801 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
9802 and then Has_Discriminants (Etype (N))
9803 and then not In_Left_Hand_Side (N)
9805 Force_Evaluation (Prefix (N));
9808 -- Remaining processing applies only if selector is a discriminant
9810 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
9812 -- If the selector is a discriminant of a constrained record type,
9813 -- we may be able to rewrite the expression with the actual value
9814 -- of the discriminant, a useful optimization in some cases.
9816 if Is_Record_Type (Ptyp)
9817 and then Has_Discriminants (Ptyp)
9818 and then Is_Constrained (Ptyp)
9820 -- Do this optimization for discrete types only, and not for
9821 -- access types (access discriminants get us into trouble).
9823 if not Is_Discrete_Type (Etype (N)) then
9826 -- Don't do this on the left-hand side of an assignment statement.
9827 -- Normally one would think that references like this would not
9828 -- occur, but they do in generated code, and mean that we really
9829 -- do want to assign the discriminant.
9831 elsif Nkind (Par) = N_Assignment_Statement
9832 and then Name (Par) = N
9836 -- Don't do this optimization for the prefix of an attribute or
9837 -- the name of an object renaming declaration since these are
9838 -- contexts where we do not want the value anyway.
9840 elsif (Nkind (Par) = N_Attribute_Reference
9841 and then Prefix (Par) = N)
9842 or else Is_Renamed_Object (N)
9846 -- Don't do this optimization if we are within the code for a
9847 -- discriminant check, since the whole point of such a check may
9848 -- be to verify the condition on which the code below depends.
9850 elsif Is_In_Discriminant_Check (N) then
9853 -- Green light to see if we can do the optimization. There is
9854 -- still one condition that inhibits the optimization below but
9855 -- now is the time to check the particular discriminant.
9858 -- Loop through discriminants to find the matching discriminant
9859 -- constraint to see if we can copy it.
9861 Disc := First_Discriminant (Ptyp);
9862 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
9863 Discr_Loop : while Present (Dcon) loop
9864 Dval := Node (Dcon);
9866 -- Check if this is the matching discriminant and if the
9867 -- discriminant value is simple enough to make sense to
9868 -- copy. We don't want to copy complex expressions, and
9869 -- indeed to do so can cause trouble (before we put in
9870 -- this guard, a discriminant expression containing an
9871 -- AND THEN was copied, causing problems for coverage
9874 -- However, if the reference is part of the initialization
9875 -- code generated for an object declaration, we must use
9876 -- the discriminant value from the subtype constraint,
9877 -- because the selected component may be a reference to the
9878 -- object being initialized, whose discriminant is not yet
9879 -- set. This only happens in complex cases involving changes
9880 -- or representation.
9882 if Disc = Entity (Selector_Name (N))
9883 and then (Is_Entity_Name (Dval)
9884 or else Compile_Time_Known_Value (Dval)
9885 or else Is_Subtype_Declaration)
9887 -- Here we have the matching discriminant. Check for
9888 -- the case of a discriminant of a component that is
9889 -- constrained by an outer discriminant, which cannot
9890 -- be optimized away.
9892 if Denotes_Discriminant
9893 (Dval, Check_Concurrent => True)
9897 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
9899 Denotes_Discriminant
9900 (Selector_Name (Original_Node (Dval)), True)
9904 -- Do not retrieve value if constraint is not static. It
9905 -- is generally not useful, and the constraint may be a
9906 -- rewritten outer discriminant in which case it is in
9909 elsif Is_Entity_Name (Dval)
9911 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
9912 and then Present (Expression (Parent (Entity (Dval))))
9914 Is_OK_Static_Expression
9915 (Expression (Parent (Entity (Dval))))
9919 -- In the context of a case statement, the expression may
9920 -- have the base type of the discriminant, and we need to
9921 -- preserve the constraint to avoid spurious errors on
9924 elsif Nkind (Parent (N)) = N_Case_Statement
9925 and then Etype (Dval) /= Etype (Disc)
9928 Make_Qualified_Expression (Loc,
9930 New_Occurrence_Of (Etype (Disc), Loc),
9932 New_Copy_Tree (Dval)));
9933 Analyze_And_Resolve (N, Etype (Disc));
9935 -- In case that comes out as a static expression,
9936 -- reset it (a selected component is never static).
9938 Set_Is_Static_Expression (N, False);
9941 -- Otherwise we can just copy the constraint, but the
9942 -- result is certainly not static. In some cases the
9943 -- discriminant constraint has been analyzed in the
9944 -- context of the original subtype indication, but for
9945 -- itypes the constraint might not have been analyzed
9946 -- yet, and this must be done now.
9949 Rewrite (N, New_Copy_Tree (Dval));
9950 Analyze_And_Resolve (N);
9951 Set_Is_Static_Expression (N, False);
9957 Next_Discriminant (Disc);
9958 end loop Discr_Loop;
9960 -- Note: the above loop should always find a matching
9961 -- discriminant, but if it does not, we just missed an
9962 -- optimization due to some glitch (perhaps a previous
9963 -- error), so ignore.
9968 -- The only remaining processing is in the case of a discriminant of
9969 -- a concurrent object, where we rewrite the prefix to denote the
9970 -- corresponding record type. If the type is derived and has renamed
9971 -- discriminants, use corresponding discriminant, which is the one
9972 -- that appears in the corresponding record.
9974 if not Is_Concurrent_Type (Ptyp) then
9978 Disc := Entity (Selector_Name (N));
9980 if Is_Derived_Type (Ptyp)
9981 and then Present (Corresponding_Discriminant (Disc))
9983 Disc := Corresponding_Discriminant (Disc);
9987 Make_Selected_Component (Loc,
9989 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
9991 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
9997 -- Set Atomic_Sync_Required if necessary for atomic component
9999 if Nkind (N) = N_Selected_Component then
10001 E : constant Entity_Id := Entity (Selector_Name (N));
10005 -- If component is atomic, but type is not, setting depends on
10006 -- disable/enable state for the component.
10008 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
10009 Set := not Atomic_Synchronization_Disabled (E);
10011 -- If component is not atomic, but its type is atomic, setting
10012 -- depends on disable/enable state for the type.
10014 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10015 Set := not Atomic_Synchronization_Disabled (Etype (E));
10017 -- If both component and type are atomic, we disable if either
10018 -- component or its type have sync disabled.
10020 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10021 Set := (not Atomic_Synchronization_Disabled (E))
10023 (not Atomic_Synchronization_Disabled (Etype (E)));
10029 -- Set flag if required
10032 Activate_Atomic_Synchronization (N);
10036 end Expand_N_Selected_Component;
10038 --------------------
10039 -- Expand_N_Slice --
10040 --------------------
10042 procedure Expand_N_Slice (N : Node_Id) is
10043 Loc : constant Source_Ptr := Sloc (N);
10044 Typ : constant Entity_Id := Etype (N);
10046 function Is_Procedure_Actual (N : Node_Id) return Boolean;
10047 -- Check whether the argument is an actual for a procedure call, in
10048 -- which case the expansion of a bit-packed slice is deferred until the
10049 -- call itself is expanded. The reason this is required is that we might
10050 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10051 -- that copy out would be missed if we created a temporary here in
10052 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10053 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10054 -- is harmless to defer expansion in the IN case, since the call
10055 -- processing will still generate the appropriate copy in operation,
10056 -- which will take care of the slice.
10058 procedure Make_Temporary_For_Slice;
10059 -- Create a named variable for the value of the slice, in cases where
10060 -- the back-end cannot handle it properly, e.g. when packed types or
10061 -- unaligned slices are involved.
10063 -------------------------
10064 -- Is_Procedure_Actual --
10065 -------------------------
10067 function Is_Procedure_Actual (N : Node_Id) return Boolean is
10068 Par : Node_Id := Parent (N);
10072 -- If our parent is a procedure call we can return
10074 if Nkind (Par) = N_Procedure_Call_Statement then
10077 -- If our parent is a type conversion, keep climbing the tree,
10078 -- since a type conversion can be a procedure actual. Also keep
10079 -- climbing if parameter association or a qualified expression,
10080 -- since these are additional cases that do can appear on
10081 -- procedure actuals.
10083 elsif Nkind_In (Par, N_Type_Conversion,
10084 N_Parameter_Association,
10085 N_Qualified_Expression)
10087 Par := Parent (Par);
10089 -- Any other case is not what we are looking for
10095 end Is_Procedure_Actual;
10097 ------------------------------
10098 -- Make_Temporary_For_Slice --
10099 ------------------------------
10101 procedure Make_Temporary_For_Slice is
10102 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
10107 Make_Object_Declaration (Loc,
10108 Defining_Identifier => Ent,
10109 Object_Definition => New_Occurrence_Of (Typ, Loc));
10111 Set_No_Initialization (Decl);
10113 Insert_Actions (N, New_List (
10115 Make_Assignment_Statement (Loc,
10116 Name => New_Occurrence_Of (Ent, Loc),
10117 Expression => Relocate_Node (N))));
10119 Rewrite (N, New_Occurrence_Of (Ent, Loc));
10120 Analyze_And_Resolve (N, Typ);
10121 end Make_Temporary_For_Slice;
10125 Pref : constant Node_Id := Prefix (N);
10126 Pref_Typ : Entity_Id := Etype (Pref);
10128 -- Start of processing for Expand_N_Slice
10131 -- Special handling for access types
10133 if Is_Access_Type (Pref_Typ) then
10134 Pref_Typ := Designated_Type (Pref_Typ);
10137 Make_Explicit_Dereference (Sloc (N),
10138 Prefix => Relocate_Node (Pref)));
10140 Analyze_And_Resolve (Pref, Pref_Typ);
10143 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10144 -- function, then additional actuals must be passed.
10146 if Ada_Version >= Ada_2005
10147 and then Is_Build_In_Place_Function_Call (Pref)
10149 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
10152 -- The remaining case to be handled is packed slices. We can leave
10153 -- packed slices as they are in the following situations:
10155 -- 1. Right or left side of an assignment (we can handle this
10156 -- situation correctly in the assignment statement expansion).
10158 -- 2. Prefix of indexed component (the slide is optimized away in this
10159 -- case, see the start of Expand_N_Slice.)
10161 -- 3. Object renaming declaration, since we want the name of the
10162 -- slice, not the value.
10164 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10165 -- be required, and this is handled in the expansion of call
10168 -- 5. Prefix of an address attribute (this is an error which is caught
10169 -- elsewhere, and the expansion would interfere with generating the
10172 if not Is_Packed (Typ) then
10174 -- Apply transformation for actuals of a function call, where
10175 -- Expand_Actuals is not used.
10177 if Nkind (Parent (N)) = N_Function_Call
10178 and then Is_Possibly_Unaligned_Slice (N)
10180 Make_Temporary_For_Slice;
10183 elsif Nkind (Parent (N)) = N_Assignment_Statement
10184 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
10185 and then Parent (N) = Name (Parent (Parent (N))))
10189 elsif Nkind (Parent (N)) = N_Indexed_Component
10190 or else Is_Renamed_Object (N)
10191 or else Is_Procedure_Actual (N)
10195 elsif Nkind (Parent (N)) = N_Attribute_Reference
10196 and then Attribute_Name (Parent (N)) = Name_Address
10201 Make_Temporary_For_Slice;
10203 end Expand_N_Slice;
10205 ------------------------------
10206 -- Expand_N_Type_Conversion --
10207 ------------------------------
10209 procedure Expand_N_Type_Conversion (N : Node_Id) is
10210 Loc : constant Source_Ptr := Sloc (N);
10211 Operand : constant Node_Id := Expression (N);
10212 Target_Type : constant Entity_Id := Etype (N);
10213 Operand_Type : Entity_Id := Etype (Operand);
10215 procedure Handle_Changed_Representation;
10216 -- This is called in the case of record and array type conversions to
10217 -- see if there is a change of representation to be handled. Change of
10218 -- representation is actually handled at the assignment statement level,
10219 -- and what this procedure does is rewrite node N conversion as an
10220 -- assignment to temporary. If there is no change of representation,
10221 -- then the conversion node is unchanged.
10223 procedure Raise_Accessibility_Error;
10224 -- Called when we know that an accessibility check will fail. Rewrites
10225 -- node N to an appropriate raise statement and outputs warning msgs.
10226 -- The Etype of the raise node is set to Target_Type. Note that in this
10227 -- case the rest of the processing should be skipped (i.e. the call to
10228 -- this procedure will be followed by "goto Done").
10230 procedure Real_Range_Check;
10231 -- Handles generation of range check for real target value
10233 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
10234 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10235 -- evaluates to True.
10237 -----------------------------------
10238 -- Handle_Changed_Representation --
10239 -----------------------------------
10241 procedure Handle_Changed_Representation is
10250 -- Nothing else to do if no change of representation
10252 if Same_Representation (Operand_Type, Target_Type) then
10255 -- The real change of representation work is done by the assignment
10256 -- statement processing. So if this type conversion is appearing as
10257 -- the expression of an assignment statement, nothing needs to be
10258 -- done to the conversion.
10260 elsif Nkind (Parent (N)) = N_Assignment_Statement then
10263 -- Otherwise we need to generate a temporary variable, and do the
10264 -- change of representation assignment into that temporary variable.
10265 -- The conversion is then replaced by a reference to this variable.
10270 -- If type is unconstrained we have to add a constraint, copied
10271 -- from the actual value of the left-hand side.
10273 if not Is_Constrained (Target_Type) then
10274 if Has_Discriminants (Operand_Type) then
10275 Disc := First_Discriminant (Operand_Type);
10277 if Disc /= First_Stored_Discriminant (Operand_Type) then
10278 Disc := First_Stored_Discriminant (Operand_Type);
10282 while Present (Disc) loop
10284 Make_Selected_Component (Loc,
10286 Duplicate_Subexpr_Move_Checks (Operand),
10288 Make_Identifier (Loc, Chars (Disc))));
10289 Next_Discriminant (Disc);
10292 elsif Is_Array_Type (Operand_Type) then
10293 N_Ix := First_Index (Target_Type);
10296 for J in 1 .. Number_Dimensions (Operand_Type) loop
10298 -- We convert the bounds explicitly. We use an unchecked
10299 -- conversion because bounds checks are done elsewhere.
10304 Unchecked_Convert_To (Etype (N_Ix),
10305 Make_Attribute_Reference (Loc,
10307 Duplicate_Subexpr_No_Checks
10308 (Operand, Name_Req => True),
10309 Attribute_Name => Name_First,
10310 Expressions => New_List (
10311 Make_Integer_Literal (Loc, J)))),
10314 Unchecked_Convert_To (Etype (N_Ix),
10315 Make_Attribute_Reference (Loc,
10317 Duplicate_Subexpr_No_Checks
10318 (Operand, Name_Req => True),
10319 Attribute_Name => Name_Last,
10320 Expressions => New_List (
10321 Make_Integer_Literal (Loc, J))))));
10328 Odef := New_Occurrence_Of (Target_Type, Loc);
10330 if Present (Cons) then
10332 Make_Subtype_Indication (Loc,
10333 Subtype_Mark => Odef,
10335 Make_Index_Or_Discriminant_Constraint (Loc,
10336 Constraints => Cons));
10339 Temp := Make_Temporary (Loc, 'C');
10341 Make_Object_Declaration (Loc,
10342 Defining_Identifier => Temp,
10343 Object_Definition => Odef);
10345 Set_No_Initialization (Decl, True);
10347 -- Insert required actions. It is essential to suppress checks
10348 -- since we have suppressed default initialization, which means
10349 -- that the variable we create may have no discriminants.
10354 Make_Assignment_Statement (Loc,
10355 Name => New_Occurrence_Of (Temp, Loc),
10356 Expression => Relocate_Node (N))),
10357 Suppress => All_Checks);
10359 Rewrite (N, New_Occurrence_Of (Temp, Loc));
10362 end Handle_Changed_Representation;
10364 -------------------------------
10365 -- Raise_Accessibility_Error --
10366 -------------------------------
10368 procedure Raise_Accessibility_Error is
10370 Error_Msg_Warn := SPARK_Mode /= On;
10372 Make_Raise_Program_Error (Sloc (N),
10373 Reason => PE_Accessibility_Check_Failed));
10374 Set_Etype (N, Target_Type);
10376 Error_Msg_N ("<<accessibility check failure", N);
10377 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
10378 end Raise_Accessibility_Error;
10380 ----------------------
10381 -- Real_Range_Check --
10382 ----------------------
10384 -- Case of conversions to floating-point or fixed-point. If range checks
10385 -- are enabled and the target type has a range constraint, we convert:
10391 -- Tnn : typ'Base := typ'Base (x);
10392 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10395 -- This is necessary when there is a conversion of integer to float or
10396 -- to fixed-point to ensure that the correct checks are made. It is not
10397 -- necessary for float to float where it is enough to simply set the
10398 -- Do_Range_Check flag.
10400 procedure Real_Range_Check is
10401 Btyp : constant Entity_Id := Base_Type (Target_Type);
10402 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
10403 Hi : constant Node_Id := Type_High_Bound (Target_Type);
10404 Xtyp : constant Entity_Id := Etype (Operand);
10409 -- Nothing to do if conversion was rewritten
10411 if Nkind (N) /= N_Type_Conversion then
10415 -- Nothing to do if range checks suppressed, or target has the same
10416 -- range as the base type (or is the base type).
10418 if Range_Checks_Suppressed (Target_Type)
10419 or else (Lo = Type_Low_Bound (Btyp)
10421 Hi = Type_High_Bound (Btyp))
10426 -- Nothing to do if expression is an entity on which checks have been
10429 if Is_Entity_Name (Operand)
10430 and then Range_Checks_Suppressed (Entity (Operand))
10435 -- Nothing to do if bounds are all static and we can tell that the
10436 -- expression is within the bounds of the target. Note that if the
10437 -- operand is of an unconstrained floating-point type, then we do
10438 -- not trust it to be in range (might be infinite)
10441 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
10442 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
10445 if (not Is_Floating_Point_Type (Xtyp)
10446 or else Is_Constrained (Xtyp))
10447 and then Compile_Time_Known_Value (S_Lo)
10448 and then Compile_Time_Known_Value (S_Hi)
10449 and then Compile_Time_Known_Value (Hi)
10450 and then Compile_Time_Known_Value (Lo)
10453 D_Lov : constant Ureal := Expr_Value_R (Lo);
10454 D_Hiv : constant Ureal := Expr_Value_R (Hi);
10459 if Is_Real_Type (Xtyp) then
10460 S_Lov := Expr_Value_R (S_Lo);
10461 S_Hiv := Expr_Value_R (S_Hi);
10463 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
10464 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
10468 and then S_Lov >= D_Lov
10469 and then S_Hiv <= D_Hiv
10471 -- Unset the range check flag on the current value of
10472 -- Expression (N), since the captured Operand may have
10473 -- been rewritten (such as for the case of a conversion
10474 -- to a fixed-point type).
10476 Set_Do_Range_Check (Expression (N), False);
10484 -- For float to float conversions, we are done
10486 if Is_Floating_Point_Type (Xtyp)
10488 Is_Floating_Point_Type (Btyp)
10493 -- Otherwise rewrite the conversion as described above
10495 Conv := Relocate_Node (N);
10496 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
10497 Set_Etype (Conv, Btyp);
10499 -- Enable overflow except for case of integer to float conversions,
10500 -- where it is never required, since we can never have overflow in
10503 if not Is_Integer_Type (Etype (Operand)) then
10504 Enable_Overflow_Check (Conv);
10507 Tnn := Make_Temporary (Loc, 'T', Conv);
10509 Insert_Actions (N, New_List (
10510 Make_Object_Declaration (Loc,
10511 Defining_Identifier => Tnn,
10512 Object_Definition => New_Occurrence_Of (Btyp, Loc),
10513 Constant_Present => True,
10514 Expression => Conv),
10516 Make_Raise_Constraint_Error (Loc,
10521 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10523 Make_Attribute_Reference (Loc,
10524 Attribute_Name => Name_First,
10526 New_Occurrence_Of (Target_Type, Loc))),
10530 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10532 Make_Attribute_Reference (Loc,
10533 Attribute_Name => Name_Last,
10535 New_Occurrence_Of (Target_Type, Loc)))),
10536 Reason => CE_Range_Check_Failed)));
10538 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
10539 Analyze_And_Resolve (N, Btyp);
10540 end Real_Range_Check;
10542 -----------------------------
10543 -- Has_Extra_Accessibility --
10544 -----------------------------
10546 -- Returns true for a formal of an anonymous access type or for
10547 -- an Ada 2012-style stand-alone object of an anonymous access type.
10549 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
10551 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
10552 return Present (Effective_Extra_Accessibility (Id));
10556 end Has_Extra_Accessibility;
10558 -- Start of processing for Expand_N_Type_Conversion
10561 -- First remove check marks put by the semantic analysis on the type
10562 -- conversion between array types. We need these checks, and they will
10563 -- be generated by this expansion routine, but we do not depend on these
10564 -- flags being set, and since we do intend to expand the checks in the
10565 -- front end, we don't want them on the tree passed to the back end.
10567 if Is_Array_Type (Target_Type) then
10568 if Is_Constrained (Target_Type) then
10569 Set_Do_Length_Check (N, False);
10571 Set_Do_Range_Check (Operand, False);
10575 -- Nothing at all to do if conversion is to the identical type so remove
10576 -- the conversion completely, it is useless, except that it may carry
10577 -- an Assignment_OK attribute, which must be propagated to the operand.
10579 if Operand_Type = Target_Type then
10580 if Assignment_OK (N) then
10581 Set_Assignment_OK (Operand);
10584 Rewrite (N, Relocate_Node (Operand));
10588 -- Nothing to do if this is the second argument of read. This is a
10589 -- "backwards" conversion that will be handled by the specialized code
10590 -- in attribute processing.
10592 if Nkind (Parent (N)) = N_Attribute_Reference
10593 and then Attribute_Name (Parent (N)) = Name_Read
10594 and then Next (First (Expressions (Parent (N)))) = N
10599 -- Check for case of converting to a type that has an invariant
10600 -- associated with it. This requires an invariant check. We insert
10603 -- invariant_check (typ (expr))
10605 -- in the code, after removing side effects from the expression.
10606 -- This is clearer than replacing the conversion into an expression
10607 -- with actions, because the context may impose additional actions
10608 -- (tag checks, membership tests, etc.) that conflict with this
10609 -- rewriting (used previously).
10611 -- Note: the Comes_From_Source check, and then the resetting of this
10612 -- flag prevents what would otherwise be an infinite recursion.
10614 if Has_Invariants (Target_Type)
10615 and then Present (Invariant_Procedure (Target_Type))
10616 and then Comes_From_Source (N)
10618 Set_Comes_From_Source (N, False);
10619 Remove_Side_Effects (N);
10620 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
10624 -- Here if we may need to expand conversion
10626 -- If the operand of the type conversion is an arithmetic operation on
10627 -- signed integers, and the based type of the signed integer type in
10628 -- question is smaller than Standard.Integer, we promote both of the
10629 -- operands to type Integer.
10631 -- For example, if we have
10633 -- target-type (opnd1 + opnd2)
10635 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10638 -- target-type (integer(opnd1) + integer(opnd2))
10640 -- We do this because we are always allowed to compute in a larger type
10641 -- if we do the right thing with the result, and in this case we are
10642 -- going to do a conversion which will do an appropriate check to make
10643 -- sure that things are in range of the target type in any case. This
10644 -- avoids some unnecessary intermediate overflows.
10646 -- We might consider a similar transformation in the case where the
10647 -- target is a real type or a 64-bit integer type, and the operand
10648 -- is an arithmetic operation using a 32-bit integer type. However,
10649 -- we do not bother with this case, because it could cause significant
10650 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10651 -- much cheaper, but we don't want different behavior on 32-bit and
10652 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10653 -- handles the configurable run-time cases where 64-bit arithmetic
10654 -- may simply be unavailable.
10656 -- Note: this circuit is partially redundant with respect to the circuit
10657 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10658 -- the processing here. Also we still need the Checks circuit, since we
10659 -- have to be sure not to generate junk overflow checks in the first
10660 -- place, since it would be trick to remove them here.
10662 if Integer_Promotion_Possible (N) then
10664 -- All conditions met, go ahead with transformation
10672 Make_Type_Conversion (Loc,
10673 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
10674 Expression => Relocate_Node (Right_Opnd (Operand)));
10676 Opnd := New_Op_Node (Nkind (Operand), Loc);
10677 Set_Right_Opnd (Opnd, R);
10679 if Nkind (Operand) in N_Binary_Op then
10681 Make_Type_Conversion (Loc,
10682 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
10683 Expression => Relocate_Node (Left_Opnd (Operand)));
10685 Set_Left_Opnd (Opnd, L);
10689 Make_Type_Conversion (Loc,
10690 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
10691 Expression => Opnd));
10693 Analyze_And_Resolve (N, Target_Type);
10698 -- Do validity check if validity checking operands
10700 if Validity_Checks_On and Validity_Check_Operands then
10701 Ensure_Valid (Operand);
10704 -- Special case of converting from non-standard boolean type
10706 if Is_Boolean_Type (Operand_Type)
10707 and then (Nonzero_Is_True (Operand_Type))
10709 Adjust_Condition (Operand);
10710 Set_Etype (Operand, Standard_Boolean);
10711 Operand_Type := Standard_Boolean;
10714 -- Case of converting to an access type
10716 if Is_Access_Type (Target_Type) then
10718 -- Apply an accessibility check when the conversion operand is an
10719 -- access parameter (or a renaming thereof), unless conversion was
10720 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10721 -- Note that other checks may still need to be applied below (such
10722 -- as tagged type checks).
10724 if Is_Entity_Name (Operand)
10725 and then Has_Extra_Accessibility (Entity (Operand))
10726 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
10727 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
10728 or else Attribute_Name (Original_Node (N)) = Name_Access)
10730 Apply_Accessibility_Check
10731 (Operand, Target_Type, Insert_Node => Operand);
10733 -- If the level of the operand type is statically deeper than the
10734 -- level of the target type, then force Program_Error. Note that this
10735 -- can only occur for cases where the attribute is within the body of
10736 -- an instantiation, otherwise the conversion will already have been
10737 -- rejected as illegal.
10739 -- Note: warnings are issued by the analyzer for the instance cases
10741 elsif In_Instance_Body
10743 -- The case where the target type is an anonymous access type of
10744 -- a discriminant is excluded, because the level of such a type
10745 -- depends on the context and currently the level returned for such
10746 -- types is zero, resulting in warnings about about check failures
10747 -- in certain legal cases involving class-wide interfaces as the
10748 -- designated type (some cases, such as return statements, are
10749 -- checked at run time, but not clear if these are handled right
10750 -- in general, see 3.10.2(12/2-12.5/3) ???).
10753 not (Ekind (Target_Type) = E_Anonymous_Access_Type
10754 and then Present (Associated_Node_For_Itype (Target_Type))
10755 and then Nkind (Associated_Node_For_Itype (Target_Type)) =
10756 N_Discriminant_Specification)
10758 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
10760 Raise_Accessibility_Error;
10763 -- When the operand is a selected access discriminant the check needs
10764 -- to be made against the level of the object denoted by the prefix
10765 -- of the selected name. Force Program_Error for this case as well
10766 -- (this accessibility violation can only happen if within the body
10767 -- of an instantiation).
10769 elsif In_Instance_Body
10770 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
10771 and then Nkind (Operand) = N_Selected_Component
10772 and then Object_Access_Level (Operand) >
10773 Type_Access_Level (Target_Type)
10775 Raise_Accessibility_Error;
10780 -- Case of conversions of tagged types and access to tagged types
10782 -- When needed, that is to say when the expression is class-wide, Add
10783 -- runtime a tag check for (strict) downward conversion by using the
10784 -- membership test, generating:
10786 -- [constraint_error when Operand not in Target_Type'Class]
10788 -- or in the access type case
10790 -- [constraint_error
10791 -- when Operand /= null
10792 -- and then Operand.all not in
10793 -- Designated_Type (Target_Type)'Class]
10795 if (Is_Access_Type (Target_Type)
10796 and then Is_Tagged_Type (Designated_Type (Target_Type)))
10797 or else Is_Tagged_Type (Target_Type)
10799 -- Do not do any expansion in the access type case if the parent is a
10800 -- renaming, since this is an error situation which will be caught by
10801 -- Sem_Ch8, and the expansion can interfere with this error check.
10803 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
10807 -- Otherwise, proceed with processing tagged conversion
10809 Tagged_Conversion : declare
10810 Actual_Op_Typ : Entity_Id;
10811 Actual_Targ_Typ : Entity_Id;
10812 Make_Conversion : Boolean := False;
10813 Root_Op_Typ : Entity_Id;
10815 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
10816 -- Create a membership check to test whether Operand is a member
10817 -- of Targ_Typ. If the original Target_Type is an access, include
10818 -- a test for null value. The check is inserted at N.
10820 --------------------
10821 -- Make_Tag_Check --
10822 --------------------
10824 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
10829 -- [Constraint_Error
10830 -- when Operand /= null
10831 -- and then Operand.all not in Targ_Typ]
10833 if Is_Access_Type (Target_Type) then
10835 Make_And_Then (Loc,
10838 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10839 Right_Opnd => Make_Null (Loc)),
10844 Make_Explicit_Dereference (Loc,
10845 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
10846 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
10849 -- [Constraint_Error when Operand not in Targ_Typ]
10854 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10855 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
10859 Make_Raise_Constraint_Error (Loc,
10861 Reason => CE_Tag_Check_Failed));
10862 end Make_Tag_Check;
10864 -- Start of processing for Tagged_Conversion
10867 -- Handle entities from the limited view
10869 if Is_Access_Type (Operand_Type) then
10871 Available_View (Designated_Type (Operand_Type));
10873 Actual_Op_Typ := Operand_Type;
10876 if Is_Access_Type (Target_Type) then
10878 Available_View (Designated_Type (Target_Type));
10880 Actual_Targ_Typ := Target_Type;
10883 Root_Op_Typ := Root_Type (Actual_Op_Typ);
10885 -- Ada 2005 (AI-251): Handle interface type conversion
10887 if Is_Interface (Actual_Op_Typ)
10889 Is_Interface (Actual_Targ_Typ)
10891 Expand_Interface_Conversion (N);
10895 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
10897 -- Create a runtime tag check for a downward class-wide type
10900 if Is_Class_Wide_Type (Actual_Op_Typ)
10901 and then Actual_Op_Typ /= Actual_Targ_Typ
10902 and then Root_Op_Typ /= Actual_Targ_Typ
10903 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
10904 Use_Full_View => True)
10906 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
10907 Make_Conversion := True;
10910 -- AI05-0073: If the result subtype of the function is defined
10911 -- by an access_definition designating a specific tagged type
10912 -- T, a check is made that the result value is null or the tag
10913 -- of the object designated by the result value identifies T.
10914 -- Constraint_Error is raised if this check fails.
10916 if Nkind (Parent (N)) = N_Simple_Return_Statement then
10919 Func_Typ : Entity_Id;
10922 -- Climb scope stack looking for the enclosing function
10924 Func := Current_Scope;
10925 while Present (Func)
10926 and then Ekind (Func) /= E_Function
10928 Func := Scope (Func);
10931 -- The function's return subtype must be defined using
10932 -- an access definition.
10934 if Nkind (Result_Definition (Parent (Func))) =
10935 N_Access_Definition
10937 Func_Typ := Directly_Designated_Type (Etype (Func));
10939 -- The return subtype denotes a specific tagged type,
10940 -- in other words, a non class-wide type.
10942 if Is_Tagged_Type (Func_Typ)
10943 and then not Is_Class_Wide_Type (Func_Typ)
10945 Make_Tag_Check (Actual_Targ_Typ);
10946 Make_Conversion := True;
10952 -- We have generated a tag check for either a class-wide type
10953 -- conversion or for AI05-0073.
10955 if Make_Conversion then
10960 Make_Unchecked_Type_Conversion (Loc,
10961 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
10962 Expression => Relocate_Node (Expression (N)));
10964 Analyze_And_Resolve (N, Target_Type);
10968 end Tagged_Conversion;
10970 -- Case of other access type conversions
10972 elsif Is_Access_Type (Target_Type) then
10973 Apply_Constraint_Check (Operand, Target_Type);
10975 -- Case of conversions from a fixed-point type
10977 -- These conversions require special expansion and processing, found in
10978 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10979 -- since from a semantic point of view, these are simple integer
10980 -- conversions, which do not need further processing.
10982 elsif Is_Fixed_Point_Type (Operand_Type)
10983 and then not Conversion_OK (N)
10985 -- We should never see universal fixed at this case, since the
10986 -- expansion of the constituent divide or multiply should have
10987 -- eliminated the explicit mention of universal fixed.
10989 pragma Assert (Operand_Type /= Universal_Fixed);
10991 -- Check for special case of the conversion to universal real that
10992 -- occurs as a result of the use of a round attribute. In this case,
10993 -- the real type for the conversion is taken from the target type of
10994 -- the Round attribute and the result must be marked as rounded.
10996 if Target_Type = Universal_Real
10997 and then Nkind (Parent (N)) = N_Attribute_Reference
10998 and then Attribute_Name (Parent (N)) = Name_Round
11000 Set_Rounded_Result (N);
11001 Set_Etype (N, Etype (Parent (N)));
11004 -- Otherwise do correct fixed-conversion, but skip these if the
11005 -- Conversion_OK flag is set, because from a semantic point of view
11006 -- these are simple integer conversions needing no further processing
11007 -- (the backend will simply treat them as integers).
11009 if not Conversion_OK (N) then
11010 if Is_Fixed_Point_Type (Etype (N)) then
11011 Expand_Convert_Fixed_To_Fixed (N);
11014 elsif Is_Integer_Type (Etype (N)) then
11015 Expand_Convert_Fixed_To_Integer (N);
11018 pragma Assert (Is_Floating_Point_Type (Etype (N)));
11019 Expand_Convert_Fixed_To_Float (N);
11024 -- Case of conversions to a fixed-point type
11026 -- These conversions require special expansion and processing, found in
11027 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
11028 -- since from a semantic point of view, these are simple integer
11029 -- conversions, which do not need further processing.
11031 elsif Is_Fixed_Point_Type (Target_Type)
11032 and then not Conversion_OK (N)
11034 if Is_Integer_Type (Operand_Type) then
11035 Expand_Convert_Integer_To_Fixed (N);
11038 pragma Assert (Is_Floating_Point_Type (Operand_Type));
11039 Expand_Convert_Float_To_Fixed (N);
11043 -- Case of float-to-integer conversions
11045 -- We also handle float-to-fixed conversions with Conversion_OK set
11046 -- since semantically the fixed-point target is treated as though it
11047 -- were an integer in such cases.
11049 elsif Is_Floating_Point_Type (Operand_Type)
11051 (Is_Integer_Type (Target_Type)
11053 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
11055 -- One more check here, gcc is still not able to do conversions of
11056 -- this type with proper overflow checking, and so gigi is doing an
11057 -- approximation of what is required by doing floating-point compares
11058 -- with the end-point. But that can lose precision in some cases, and
11059 -- give a wrong result. Converting the operand to Universal_Real is
11060 -- helpful, but still does not catch all cases with 64-bit integers
11061 -- on targets with only 64-bit floats.
11063 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
11064 -- Can this code be removed ???
11066 if Do_Range_Check (Operand) then
11068 Make_Type_Conversion (Loc,
11070 New_Occurrence_Of (Universal_Real, Loc),
11072 Relocate_Node (Operand)));
11074 Set_Etype (Operand, Universal_Real);
11075 Enable_Range_Check (Operand);
11076 Set_Do_Range_Check (Expression (Operand), False);
11079 -- Case of array conversions
11081 -- Expansion of array conversions, add required length/range checks but
11082 -- only do this if there is no change of representation. For handling of
11083 -- this case, see Handle_Changed_Representation.
11085 elsif Is_Array_Type (Target_Type) then
11086 if Is_Constrained (Target_Type) then
11087 Apply_Length_Check (Operand, Target_Type);
11089 Apply_Range_Check (Operand, Target_Type);
11092 Handle_Changed_Representation;
11094 -- Case of conversions of discriminated types
11096 -- Add required discriminant checks if target is constrained. Again this
11097 -- change is skipped if we have a change of representation.
11099 elsif Has_Discriminants (Target_Type)
11100 and then Is_Constrained (Target_Type)
11102 Apply_Discriminant_Check (Operand, Target_Type);
11103 Handle_Changed_Representation;
11105 -- Case of all other record conversions. The only processing required
11106 -- is to check for a change of representation requiring the special
11107 -- assignment processing.
11109 elsif Is_Record_Type (Target_Type) then
11111 -- Ada 2005 (AI-216): Program_Error is raised when converting from
11112 -- a derived Unchecked_Union type to an unconstrained type that is
11113 -- not Unchecked_Union if the operand lacks inferable discriminants.
11115 if Is_Derived_Type (Operand_Type)
11116 and then Is_Unchecked_Union (Base_Type (Operand_Type))
11117 and then not Is_Constrained (Target_Type)
11118 and then not Is_Unchecked_Union (Base_Type (Target_Type))
11119 and then not Has_Inferable_Discriminants (Operand)
11121 -- To prevent Gigi from generating illegal code, we generate a
11122 -- Program_Error node, but we give it the target type of the
11123 -- conversion (is this requirement documented somewhere ???)
11126 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
11127 Reason => PE_Unchecked_Union_Restriction);
11130 Set_Etype (PE, Target_Type);
11135 Handle_Changed_Representation;
11138 -- Case of conversions of enumeration types
11140 elsif Is_Enumeration_Type (Target_Type) then
11142 -- Special processing is required if there is a change of
11143 -- representation (from enumeration representation clauses).
11145 if not Same_Representation (Target_Type, Operand_Type) then
11147 -- Convert: x(y) to x'val (ytyp'val (y))
11150 Make_Attribute_Reference (Loc,
11151 Prefix => New_Occurrence_Of (Target_Type, Loc),
11152 Attribute_Name => Name_Val,
11153 Expressions => New_List (
11154 Make_Attribute_Reference (Loc,
11155 Prefix => New_Occurrence_Of (Operand_Type, Loc),
11156 Attribute_Name => Name_Pos,
11157 Expressions => New_List (Operand)))));
11159 Analyze_And_Resolve (N, Target_Type);
11162 -- Case of conversions to floating-point
11164 elsif Is_Floating_Point_Type (Target_Type) then
11168 -- At this stage, either the conversion node has been transformed into
11169 -- some other equivalent expression, or left as a conversion that can be
11170 -- handled by Gigi, in the following cases:
11172 -- Conversions with no change of representation or type
11174 -- Numeric conversions involving integer, floating- and fixed-point
11175 -- values. Fixed-point values are allowed only if Conversion_OK is
11176 -- set, i.e. if the fixed-point values are to be treated as integers.
11178 -- No other conversions should be passed to Gigi
11180 -- Check: are these rules stated in sinfo??? if so, why restate here???
11182 -- The only remaining step is to generate a range check if we still have
11183 -- a type conversion at this stage and Do_Range_Check is set. For now we
11184 -- do this only for conversions of discrete types and for float-to-float
11187 if Nkind (N) = N_Type_Conversion then
11189 -- For now we only support floating-point cases where both source
11190 -- and target are floating-point types. Conversions where the source
11191 -- and target involve integer or fixed-point types are still TBD,
11192 -- though not clear whether those can even happen at this point, due
11193 -- to transformations above. ???
11195 if Is_Floating_Point_Type (Etype (N))
11196 and then Is_Floating_Point_Type (Etype (Expression (N)))
11198 if Do_Range_Check (Expression (N))
11199 and then Is_Floating_Point_Type (Target_Type)
11201 Generate_Range_Check
11202 (Expression (N), Target_Type, CE_Range_Check_Failed);
11205 -- Discrete-to-discrete conversions
11207 elsif Is_Discrete_Type (Etype (N)) then
11209 Expr : constant Node_Id := Expression (N);
11214 if Do_Range_Check (Expr)
11215 and then Is_Discrete_Type (Etype (Expr))
11217 Set_Do_Range_Check (Expr, False);
11219 -- Before we do a range check, we have to deal with treating
11220 -- a fixed-point operand as an integer. The way we do this
11221 -- is simply to do an unchecked conversion to an appropriate
11222 -- integer type large enough to hold the result.
11224 -- This code is not active yet, because we are only dealing
11225 -- with discrete types so far ???
11227 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
11228 and then Treat_Fixed_As_Integer (Expr)
11230 Ftyp := Base_Type (Etype (Expr));
11232 if Esize (Ftyp) >= Esize (Standard_Integer) then
11233 Ityp := Standard_Long_Long_Integer;
11235 Ityp := Standard_Integer;
11238 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11241 -- Reset overflow flag, since the range check will include
11242 -- dealing with possible overflow, and generate the check.
11243 -- If Address is either a source type or target type,
11244 -- suppress range check to avoid typing anomalies when
11245 -- it is a visible integer type.
11247 Set_Do_Overflow_Check (N, False);
11249 if not Is_Descendant_Of_Address (Etype (Expr))
11250 and then not Is_Descendant_Of_Address (Target_Type)
11252 Generate_Range_Check
11253 (Expr, Target_Type, CE_Range_Check_Failed);
11260 -- Here at end of processing
11263 -- Apply predicate check if required. Note that we can't just call
11264 -- Apply_Predicate_Check here, because the type looks right after
11265 -- the conversion and it would omit the check. The Comes_From_Source
11266 -- guard is necessary to prevent infinite recursions when we generate
11267 -- internal conversions for the purpose of checking predicates.
11269 if Present (Predicate_Function (Target_Type))
11270 and then not Predicates_Ignored (Target_Type)
11271 and then Target_Type /= Operand_Type
11272 and then Comes_From_Source (N)
11275 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
11278 -- Avoid infinite recursion on the subsequent expansion of
11279 -- of the copy of the original type conversion.
11281 Set_Comes_From_Source (New_Expr, False);
11282 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr));
11285 end Expand_N_Type_Conversion;
11287 -----------------------------------
11288 -- Expand_N_Unchecked_Expression --
11289 -----------------------------------
11291 -- Remove the unchecked expression node from the tree. Its job was simply
11292 -- to make sure that its constituent expression was handled with checks
11293 -- off, and now that that is done, we can remove it from the tree, and
11294 -- indeed must, since Gigi does not expect to see these nodes.
11296 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
11297 Exp : constant Node_Id := Expression (N);
11299 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
11301 end Expand_N_Unchecked_Expression;
11303 ----------------------------------------
11304 -- Expand_N_Unchecked_Type_Conversion --
11305 ----------------------------------------
11307 -- If this cannot be handled by Gigi and we haven't already made a
11308 -- temporary for it, do it now.
11310 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
11311 Target_Type : constant Entity_Id := Etype (N);
11312 Operand : constant Node_Id := Expression (N);
11313 Operand_Type : constant Entity_Id := Etype (Operand);
11316 -- Nothing at all to do if conversion is to the identical type so remove
11317 -- the conversion completely, it is useless, except that it may carry
11318 -- an Assignment_OK indication which must be propagated to the operand.
11320 if Operand_Type = Target_Type then
11322 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11324 if Assignment_OK (N) then
11325 Set_Assignment_OK (Operand);
11328 Rewrite (N, Relocate_Node (Operand));
11332 -- If we have a conversion of a compile time known value to a target
11333 -- type and the value is in range of the target type, then we can simply
11334 -- replace the construct by an integer literal of the correct type. We
11335 -- only apply this to integer types being converted. Possibly it may
11336 -- apply in other cases, but it is too much trouble to worry about.
11338 -- Note that we do not do this transformation if the Kill_Range_Check
11339 -- flag is set, since then the value may be outside the expected range.
11340 -- This happens in the Normalize_Scalars case.
11342 -- We also skip this if either the target or operand type is biased
11343 -- because in this case, the unchecked conversion is supposed to
11344 -- preserve the bit pattern, not the integer value.
11346 if Is_Integer_Type (Target_Type)
11347 and then not Has_Biased_Representation (Target_Type)
11348 and then Is_Integer_Type (Operand_Type)
11349 and then not Has_Biased_Representation (Operand_Type)
11350 and then Compile_Time_Known_Value (Operand)
11351 and then not Kill_Range_Check (N)
11354 Val : constant Uint := Expr_Value (Operand);
11357 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
11359 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
11361 Val >= Expr_Value (Type_Low_Bound (Target_Type))
11363 Val <= Expr_Value (Type_High_Bound (Target_Type))
11365 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
11367 -- If Address is the target type, just set the type to avoid a
11368 -- spurious type error on the literal when Address is a visible
11371 if Is_Descendant_Of_Address (Target_Type) then
11372 Set_Etype (N, Target_Type);
11374 Analyze_And_Resolve (N, Target_Type);
11382 -- Nothing to do if conversion is safe
11384 if Safe_Unchecked_Type_Conversion (N) then
11388 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11389 -- flag indicates ??? More comments needed here)
11391 if Assignment_OK (N) then
11394 Force_Evaluation (N);
11396 end Expand_N_Unchecked_Type_Conversion;
11398 ----------------------------
11399 -- Expand_Record_Equality --
11400 ----------------------------
11402 -- For non-variant records, Equality is expanded when needed into:
11404 -- and then Lhs.Discr1 = Rhs.Discr1
11406 -- and then Lhs.Discrn = Rhs.Discrn
11407 -- and then Lhs.Cmp1 = Rhs.Cmp1
11409 -- and then Lhs.Cmpn = Rhs.Cmpn
11411 -- The expression is folded by the back-end for adjacent fields. This
11412 -- function is called for tagged record in only one occasion: for imple-
11413 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11414 -- otherwise the primitive "=" is used directly.
11416 function Expand_Record_Equality
11421 Bodies : List_Id) return Node_Id
11423 Loc : constant Source_Ptr := Sloc (Nod);
11428 First_Time : Boolean := True;
11430 function Element_To_Compare (C : Entity_Id) return Entity_Id;
11431 -- Return the next discriminant or component to compare, starting with
11432 -- C, skipping inherited components.
11434 ------------------------
11435 -- Element_To_Compare --
11436 ------------------------
11438 function Element_To_Compare (C : Entity_Id) return Entity_Id is
11444 -- Exit loop when the next element to be compared is found, or
11445 -- there is no more such element.
11447 exit when No (Comp);
11449 exit when Ekind_In (Comp, E_Discriminant, E_Component)
11452 -- Skip inherited components
11454 -- Note: for a tagged type, we always generate the "=" primitive
11455 -- for the base type (not on the first subtype), so the test for
11456 -- Comp /= Original_Record_Component (Comp) is True for
11457 -- inherited components only.
11459 (Is_Tagged_Type (Typ)
11460 and then Comp /= Original_Record_Component (Comp))
11464 or else Chars (Comp) = Name_uTag
11466 -- Skip interface elements (secondary tags???)
11468 or else Is_Interface (Etype (Comp)));
11470 Next_Entity (Comp);
11474 end Element_To_Compare;
11476 -- Start of processing for Expand_Record_Equality
11479 -- Generates the following code: (assuming that Typ has one Discr and
11480 -- component C2 is also a record)
11483 -- and then Lhs.Discr1 = Rhs.Discr1
11484 -- and then Lhs.C1 = Rhs.C1
11485 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11487 -- and then Lhs.Cmpn = Rhs.Cmpn
11489 Result := New_Occurrence_Of (Standard_True, Loc);
11490 C := Element_To_Compare (First_Entity (Typ));
11491 while Present (C) loop
11499 First_Time := False;
11503 New_Lhs := New_Copy_Tree (Lhs);
11504 New_Rhs := New_Copy_Tree (Rhs);
11508 Expand_Composite_Equality (Nod, Etype (C),
11510 Make_Selected_Component (Loc,
11512 Selector_Name => New_Occurrence_Of (C, Loc)),
11514 Make_Selected_Component (Loc,
11516 Selector_Name => New_Occurrence_Of (C, Loc)),
11519 -- If some (sub)component is an unchecked_union, the whole
11520 -- operation will raise program error.
11522 if Nkind (Check) = N_Raise_Program_Error then
11524 Set_Etype (Result, Standard_Boolean);
11528 Make_And_Then (Loc,
11529 Left_Opnd => Result,
11530 Right_Opnd => Check);
11534 C := Element_To_Compare (Next_Entity (C));
11538 end Expand_Record_Equality;
11540 ---------------------------
11541 -- Expand_Set_Membership --
11542 ---------------------------
11544 procedure Expand_Set_Membership (N : Node_Id) is
11545 Lop : constant Node_Id := Left_Opnd (N);
11549 function Make_Cond (Alt : Node_Id) return Node_Id;
11550 -- If the alternative is a subtype mark, create a simple membership
11551 -- test. Otherwise create an equality test for it.
11557 function Make_Cond (Alt : Node_Id) return Node_Id is
11559 L : constant Node_Id := New_Copy (Lop);
11560 R : constant Node_Id := Relocate_Node (Alt);
11563 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
11564 or else Nkind (Alt) = N_Range
11567 Make_In (Sloc (Alt),
11572 Make_Op_Eq (Sloc (Alt),
11580 -- Start of processing for Expand_Set_Membership
11583 Remove_Side_Effects (Lop);
11585 Alt := Last (Alternatives (N));
11586 Res := Make_Cond (Alt);
11589 while Present (Alt) loop
11591 Make_Or_Else (Sloc (Alt),
11592 Left_Opnd => Make_Cond (Alt),
11593 Right_Opnd => Res);
11598 Analyze_And_Resolve (N, Standard_Boolean);
11599 end Expand_Set_Membership;
11601 -----------------------------------
11602 -- Expand_Short_Circuit_Operator --
11603 -----------------------------------
11605 -- Deal with special expansion if actions are present for the right operand
11606 -- and deal with optimizing case of arguments being True or False. We also
11607 -- deal with the special case of non-standard boolean values.
11609 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
11610 Loc : constant Source_Ptr := Sloc (N);
11611 Typ : constant Entity_Id := Etype (N);
11612 Left : constant Node_Id := Left_Opnd (N);
11613 Right : constant Node_Id := Right_Opnd (N);
11614 LocR : constant Source_Ptr := Sloc (Right);
11617 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
11618 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
11619 -- If Left = Shortcut_Value then Right need not be evaluated
11621 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
11622 -- For Opnd a boolean expression, return a Boolean expression equivalent
11623 -- to Opnd /= Shortcut_Value.
11625 --------------------
11626 -- Make_Test_Expr --
11627 --------------------
11629 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
11631 if Shortcut_Value then
11632 return Make_Op_Not (Sloc (Opnd), Opnd);
11636 end Make_Test_Expr;
11640 Op_Var : Entity_Id;
11641 -- Entity for a temporary variable holding the value of the operator,
11642 -- used for expansion in the case where actions are present.
11644 -- Start of processing for Expand_Short_Circuit_Operator
11647 -- Deal with non-standard booleans
11649 if Is_Boolean_Type (Typ) then
11650 Adjust_Condition (Left);
11651 Adjust_Condition (Right);
11652 Set_Etype (N, Standard_Boolean);
11655 -- Check for cases where left argument is known to be True or False
11657 if Compile_Time_Known_Value (Left) then
11659 -- Mark SCO for left condition as compile time known
11661 if Generate_SCO and then Comes_From_Source (Left) then
11662 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
11665 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11666 -- Any actions associated with Right will be executed unconditionally
11667 -- and can thus be inserted into the tree unconditionally.
11669 if Expr_Value_E (Left) /= Shortcut_Ent then
11670 if Present (Actions (N)) then
11671 Insert_Actions (N, Actions (N));
11674 Rewrite (N, Right);
11676 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11677 -- In this case we can forget the actions associated with Right,
11678 -- since they will never be executed.
11681 Kill_Dead_Code (Right);
11682 Kill_Dead_Code (Actions (N));
11683 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11686 Adjust_Result_Type (N, Typ);
11690 -- If Actions are present for the right operand, we have to do some
11691 -- special processing. We can't just let these actions filter back into
11692 -- code preceding the short circuit (which is what would have happened
11693 -- if we had not trapped them in the short-circuit form), since they
11694 -- must only be executed if the right operand of the short circuit is
11695 -- executed and not otherwise.
11697 if Present (Actions (N)) then
11698 Actlist := Actions (N);
11700 -- The old approach is to expand:
11702 -- left AND THEN right
11706 -- C : Boolean := False;
11714 -- and finally rewrite the operator into a reference to C. Similarly
11715 -- for left OR ELSE right, with negated values. Note that this
11716 -- rewrite causes some difficulties for coverage analysis because
11717 -- of the introduction of the new variable C, which obscures the
11718 -- structure of the test.
11720 -- We use this "old approach" if Minimize_Expression_With_Actions
11723 if Minimize_Expression_With_Actions then
11724 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
11727 Make_Object_Declaration (Loc,
11728 Defining_Identifier => Op_Var,
11729 Object_Definition =>
11730 New_Occurrence_Of (Standard_Boolean, Loc),
11732 New_Occurrence_Of (Shortcut_Ent, Loc)));
11734 Append_To (Actlist,
11735 Make_Implicit_If_Statement (Right,
11736 Condition => Make_Test_Expr (Right),
11737 Then_Statements => New_List (
11738 Make_Assignment_Statement (LocR,
11739 Name => New_Occurrence_Of (Op_Var, LocR),
11742 (Boolean_Literals (not Shortcut_Value), LocR)))));
11745 Make_Implicit_If_Statement (Left,
11746 Condition => Make_Test_Expr (Left),
11747 Then_Statements => Actlist));
11749 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
11750 Analyze_And_Resolve (N, Standard_Boolean);
11752 -- The new approach (the default) is to use an
11753 -- Expression_With_Actions node for the right operand of the
11754 -- short-circuit form. Note that this solves the traceability
11755 -- problems for coverage analysis.
11759 Make_Expression_With_Actions (LocR,
11760 Expression => Relocate_Node (Right),
11761 Actions => Actlist));
11763 Set_Actions (N, No_List);
11764 Analyze_And_Resolve (Right, Standard_Boolean);
11767 Adjust_Result_Type (N, Typ);
11771 -- No actions present, check for cases of right argument True/False
11773 if Compile_Time_Known_Value (Right) then
11775 -- Mark SCO for left condition as compile time known
11777 if Generate_SCO and then Comes_From_Source (Right) then
11778 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
11781 -- Change (Left and then True), (Left or else False) to Left. Note
11782 -- that we know there are no actions associated with the right
11783 -- operand, since we just checked for this case above.
11785 if Expr_Value_E (Right) /= Shortcut_Ent then
11788 -- Change (Left and then False), (Left or else True) to Right,
11789 -- making sure to preserve any side effects associated with the Left
11793 Remove_Side_Effects (Left);
11794 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11798 Adjust_Result_Type (N, Typ);
11799 end Expand_Short_Circuit_Operator;
11801 -------------------------------------
11802 -- Fixup_Universal_Fixed_Operation --
11803 -------------------------------------
11805 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
11806 Conv : constant Node_Id := Parent (N);
11809 -- We must have a type conversion immediately above us
11811 pragma Assert (Nkind (Conv) = N_Type_Conversion);
11813 -- Normally the type conversion gives our target type. The exception
11814 -- occurs in the case of the Round attribute, where the conversion
11815 -- will be to universal real, and our real type comes from the Round
11816 -- attribute (as well as an indication that we must round the result)
11818 if Nkind (Parent (Conv)) = N_Attribute_Reference
11819 and then Attribute_Name (Parent (Conv)) = Name_Round
11821 Set_Etype (N, Etype (Parent (Conv)));
11822 Set_Rounded_Result (N);
11824 -- Normal case where type comes from conversion above us
11827 Set_Etype (N, Etype (Conv));
11829 end Fixup_Universal_Fixed_Operation;
11831 ---------------------------------
11832 -- Has_Inferable_Discriminants --
11833 ---------------------------------
11835 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
11837 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
11838 -- Determines whether the left-most prefix of a selected component is a
11839 -- formal parameter in a subprogram. Assumes N is a selected component.
11841 --------------------------------
11842 -- Prefix_Is_Formal_Parameter --
11843 --------------------------------
11845 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
11846 Sel_Comp : Node_Id;
11849 -- Move to the left-most prefix by climbing up the tree
11852 while Present (Parent (Sel_Comp))
11853 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
11855 Sel_Comp := Parent (Sel_Comp);
11858 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
11859 end Prefix_Is_Formal_Parameter;
11861 -- Start of processing for Has_Inferable_Discriminants
11864 -- For selected components, the subtype of the selector must be a
11865 -- constrained Unchecked_Union. If the component is subject to a
11866 -- per-object constraint, then the enclosing object must have inferable
11869 if Nkind (N) = N_Selected_Component then
11870 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
11872 -- A small hack. If we have a per-object constrained selected
11873 -- component of a formal parameter, return True since we do not
11874 -- know the actual parameter association yet.
11876 if Prefix_Is_Formal_Parameter (N) then
11879 -- Otherwise, check the enclosing object and the selector
11882 return Has_Inferable_Discriminants (Prefix (N))
11883 and then Has_Inferable_Discriminants (Selector_Name (N));
11886 -- The call to Has_Inferable_Discriminants will determine whether
11887 -- the selector has a constrained Unchecked_Union nominal type.
11890 return Has_Inferable_Discriminants (Selector_Name (N));
11893 -- A qualified expression has inferable discriminants if its subtype
11894 -- mark is a constrained Unchecked_Union subtype.
11896 elsif Nkind (N) = N_Qualified_Expression then
11897 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
11898 and then Is_Constrained (Etype (Subtype_Mark (N)));
11900 -- For all other names, it is sufficient to have a constrained
11901 -- Unchecked_Union nominal subtype.
11904 return Is_Unchecked_Union (Base_Type (Etype (N)))
11905 and then Is_Constrained (Etype (N));
11907 end Has_Inferable_Discriminants;
11909 -------------------------------
11910 -- Insert_Dereference_Action --
11911 -------------------------------
11913 procedure Insert_Dereference_Action (N : Node_Id) is
11915 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
11916 -- Return true if type of P is derived from Checked_Pool;
11918 -----------------------------
11919 -- Is_Checked_Storage_Pool --
11920 -----------------------------
11922 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
11931 while T /= Etype (T) loop
11932 if Is_RTE (T, RE_Checked_Pool) then
11940 end Is_Checked_Storage_Pool;
11944 Typ : constant Entity_Id := Etype (N);
11945 Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
11946 Loc : constant Source_Ptr := Sloc (N);
11947 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
11948 Pnod : constant Node_Id := Parent (N);
11954 Size_Bits : Node_Id;
11957 -- Start of processing for Insert_Dereference_Action
11960 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
11962 -- Do not re-expand a dereference which has already been processed by
11965 if Has_Dereference_Action (Pnod) then
11968 -- Do not perform this type of expansion for internally-generated
11971 elsif not Comes_From_Source (Original_Node (Pnod)) then
11974 -- A dereference action is only applicable to objects which have been
11975 -- allocated on a checked pool.
11977 elsif not Is_Checked_Storage_Pool (Pool) then
11981 -- Extract the address of the dereferenced object. Generate:
11983 -- Addr : System.Address := <N>'Pool_Address;
11985 Addr := Make_Temporary (Loc, 'P');
11988 Make_Object_Declaration (Loc,
11989 Defining_Identifier => Addr,
11990 Object_Definition =>
11991 New_Occurrence_Of (RTE (RE_Address), Loc),
11993 Make_Attribute_Reference (Loc,
11994 Prefix => Duplicate_Subexpr_Move_Checks (N),
11995 Attribute_Name => Name_Pool_Address)));
11997 -- Calculate the size of the dereferenced object. Generate:
11999 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
12002 Make_Explicit_Dereference (Loc,
12003 Prefix => Duplicate_Subexpr_Move_Checks (N));
12004 Set_Has_Dereference_Action (Deref);
12007 Make_Attribute_Reference (Loc,
12009 Attribute_Name => Name_Size);
12011 -- Special case of an unconstrained array: need to add descriptor size
12013 if Is_Array_Type (Desig)
12014 and then not Is_Constrained (First_Subtype (Desig))
12019 Make_Attribute_Reference (Loc,
12021 New_Occurrence_Of (First_Subtype (Desig), Loc),
12022 Attribute_Name => Name_Descriptor_Size),
12023 Right_Opnd => Size_Bits);
12026 Size := Make_Temporary (Loc, 'S');
12028 Make_Object_Declaration (Loc,
12029 Defining_Identifier => Size,
12030 Object_Definition =>
12031 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
12033 Make_Op_Divide (Loc,
12034 Left_Opnd => Size_Bits,
12035 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
12037 -- Calculate the alignment of the dereferenced object. Generate:
12038 -- Alig : constant Storage_Count := <N>.all'Alignment;
12041 Make_Explicit_Dereference (Loc,
12042 Prefix => Duplicate_Subexpr_Move_Checks (N));
12043 Set_Has_Dereference_Action (Deref);
12045 Alig := Make_Temporary (Loc, 'A');
12047 Make_Object_Declaration (Loc,
12048 Defining_Identifier => Alig,
12049 Object_Definition =>
12050 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
12052 Make_Attribute_Reference (Loc,
12054 Attribute_Name => Name_Alignment)));
12056 -- A dereference of a controlled object requires special processing. The
12057 -- finalization machinery requests additional space from the underlying
12058 -- pool to allocate and hide two pointers. As a result, a checked pool
12059 -- may mark the wrong memory as valid. Since checked pools do not have
12060 -- knowledge of hidden pointers, we have to bring the two pointers back
12061 -- in view in order to restore the original state of the object.
12063 if Needs_Finalization (Desig) then
12065 -- Adjust the address and size of the dereferenced object. Generate:
12066 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
12069 Make_Procedure_Call_Statement (Loc,
12071 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
12072 Parameter_Associations => New_List (
12073 New_Occurrence_Of (Addr, Loc),
12074 New_Occurrence_Of (Size, Loc),
12075 New_Occurrence_Of (Alig, Loc)));
12077 -- Class-wide types complicate things because we cannot determine
12078 -- statically whether the actual object is truly controlled. We must
12079 -- generate a runtime check to detect this property. Generate:
12081 -- if Needs_Finalization (<N>.all'Tag) then
12085 if Is_Class_Wide_Type (Desig) then
12087 Make_Explicit_Dereference (Loc,
12088 Prefix => Duplicate_Subexpr_Move_Checks (N));
12089 Set_Has_Dereference_Action (Deref);
12092 Make_Implicit_If_Statement (N,
12094 Make_Function_Call (Loc,
12096 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
12097 Parameter_Associations => New_List (
12098 Make_Attribute_Reference (Loc,
12100 Attribute_Name => Name_Tag))),
12101 Then_Statements => New_List (Stmt));
12104 Insert_Action (N, Stmt);
12108 -- Dereference (Pool, Addr, Size, Alig);
12111 Make_Procedure_Call_Statement (Loc,
12114 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
12115 Parameter_Associations => New_List (
12116 New_Occurrence_Of (Pool, Loc),
12117 New_Occurrence_Of (Addr, Loc),
12118 New_Occurrence_Of (Size, Loc),
12119 New_Occurrence_Of (Alig, Loc))));
12121 -- Mark the explicit dereference as processed to avoid potential
12122 -- infinite expansion.
12124 Set_Has_Dereference_Action (Pnod);
12127 when RE_Not_Available =>
12129 end Insert_Dereference_Action;
12131 --------------------------------
12132 -- Integer_Promotion_Possible --
12133 --------------------------------
12135 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
12136 Operand : constant Node_Id := Expression (N);
12137 Operand_Type : constant Entity_Id := Etype (Operand);
12138 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
12141 pragma Assert (Nkind (N) = N_Type_Conversion);
12145 -- We only do the transformation for source constructs. We assume
12146 -- that the expander knows what it is doing when it generates code.
12148 Comes_From_Source (N)
12150 -- If the operand type is Short_Integer or Short_Short_Integer,
12151 -- then we will promote to Integer, which is available on all
12152 -- targets, and is sufficient to ensure no intermediate overflow.
12153 -- Furthermore it is likely to be as efficient or more efficient
12154 -- than using the smaller type for the computation so we do this
12155 -- unconditionally.
12158 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
12160 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
12162 -- Test for interesting operation, which includes addition,
12163 -- division, exponentiation, multiplication, subtraction, absolute
12164 -- value and unary negation. Unary "+" is omitted since it is a
12165 -- no-op and thus can't overflow.
12167 and then Nkind_In (Operand, N_Op_Abs,
12174 end Integer_Promotion_Possible;
12176 ------------------------------
12177 -- Make_Array_Comparison_Op --
12178 ------------------------------
12180 -- This is a hand-coded expansion of the following generic function:
12183 -- type elem is (<>);
12184 -- type index is (<>);
12185 -- type a is array (index range <>) of elem;
12187 -- function Gnnn (X : a; Y: a) return boolean is
12188 -- J : index := Y'first;
12191 -- if X'length = 0 then
12194 -- elsif Y'length = 0 then
12198 -- for I in X'range loop
12199 -- if X (I) = Y (J) then
12200 -- if J = Y'last then
12203 -- J := index'succ (J);
12207 -- return X (I) > Y (J);
12211 -- return X'length > Y'length;
12215 -- Note that since we are essentially doing this expansion by hand, we
12216 -- do not need to generate an actual or formal generic part, just the
12217 -- instantiated function itself.
12219 -- Perhaps we could have the actual generic available in the run-time,
12220 -- obtained by rtsfind, and actually expand a real instantiation ???
12222 function Make_Array_Comparison_Op
12224 Nod : Node_Id) return Node_Id
12226 Loc : constant Source_Ptr := Sloc (Nod);
12228 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
12229 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
12230 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
12231 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
12233 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
12235 Loop_Statement : Node_Id;
12236 Loop_Body : Node_Id;
12238 Inner_If : Node_Id;
12239 Final_Expr : Node_Id;
12240 Func_Body : Node_Id;
12241 Func_Name : Entity_Id;
12247 -- if J = Y'last then
12250 -- J := index'succ (J);
12254 Make_Implicit_If_Statement (Nod,
12257 Left_Opnd => New_Occurrence_Of (J, Loc),
12259 Make_Attribute_Reference (Loc,
12260 Prefix => New_Occurrence_Of (Y, Loc),
12261 Attribute_Name => Name_Last)),
12263 Then_Statements => New_List (
12264 Make_Exit_Statement (Loc)),
12268 Make_Assignment_Statement (Loc,
12269 Name => New_Occurrence_Of (J, Loc),
12271 Make_Attribute_Reference (Loc,
12272 Prefix => New_Occurrence_Of (Index, Loc),
12273 Attribute_Name => Name_Succ,
12274 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
12276 -- if X (I) = Y (J) then
12279 -- return X (I) > Y (J);
12283 Make_Implicit_If_Statement (Nod,
12287 Make_Indexed_Component (Loc,
12288 Prefix => New_Occurrence_Of (X, Loc),
12289 Expressions => New_List (New_Occurrence_Of (I, Loc))),
12292 Make_Indexed_Component (Loc,
12293 Prefix => New_Occurrence_Of (Y, Loc),
12294 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
12296 Then_Statements => New_List (Inner_If),
12298 Else_Statements => New_List (
12299 Make_Simple_Return_Statement (Loc,
12303 Make_Indexed_Component (Loc,
12304 Prefix => New_Occurrence_Of (X, Loc),
12305 Expressions => New_List (New_Occurrence_Of (I, Loc))),
12308 Make_Indexed_Component (Loc,
12309 Prefix => New_Occurrence_Of (Y, Loc),
12310 Expressions => New_List (
12311 New_Occurrence_Of (J, Loc)))))));
12313 -- for I in X'range loop
12318 Make_Implicit_Loop_Statement (Nod,
12319 Identifier => Empty,
12321 Iteration_Scheme =>
12322 Make_Iteration_Scheme (Loc,
12323 Loop_Parameter_Specification =>
12324 Make_Loop_Parameter_Specification (Loc,
12325 Defining_Identifier => I,
12326 Discrete_Subtype_Definition =>
12327 Make_Attribute_Reference (Loc,
12328 Prefix => New_Occurrence_Of (X, Loc),
12329 Attribute_Name => Name_Range))),
12331 Statements => New_List (Loop_Body));
12333 -- if X'length = 0 then
12335 -- elsif Y'length = 0 then
12338 -- for ... loop ... end loop;
12339 -- return X'length > Y'length;
12343 Make_Attribute_Reference (Loc,
12344 Prefix => New_Occurrence_Of (X, Loc),
12345 Attribute_Name => Name_Length);
12348 Make_Attribute_Reference (Loc,
12349 Prefix => New_Occurrence_Of (Y, Loc),
12350 Attribute_Name => Name_Length);
12354 Left_Opnd => Length1,
12355 Right_Opnd => Length2);
12358 Make_Implicit_If_Statement (Nod,
12362 Make_Attribute_Reference (Loc,
12363 Prefix => New_Occurrence_Of (X, Loc),
12364 Attribute_Name => Name_Length),
12366 Make_Integer_Literal (Loc, 0)),
12370 Make_Simple_Return_Statement (Loc,
12371 Expression => New_Occurrence_Of (Standard_False, Loc))),
12373 Elsif_Parts => New_List (
12374 Make_Elsif_Part (Loc,
12378 Make_Attribute_Reference (Loc,
12379 Prefix => New_Occurrence_Of (Y, Loc),
12380 Attribute_Name => Name_Length),
12382 Make_Integer_Literal (Loc, 0)),
12386 Make_Simple_Return_Statement (Loc,
12387 Expression => New_Occurrence_Of (Standard_True, Loc))))),
12389 Else_Statements => New_List (
12391 Make_Simple_Return_Statement (Loc,
12392 Expression => Final_Expr)));
12396 Formals := New_List (
12397 Make_Parameter_Specification (Loc,
12398 Defining_Identifier => X,
12399 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
12401 Make_Parameter_Specification (Loc,
12402 Defining_Identifier => Y,
12403 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
12405 -- function Gnnn (...) return boolean is
12406 -- J : index := Y'first;
12411 Func_Name := Make_Temporary (Loc, 'G');
12414 Make_Subprogram_Body (Loc,
12416 Make_Function_Specification (Loc,
12417 Defining_Unit_Name => Func_Name,
12418 Parameter_Specifications => Formals,
12419 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
12421 Declarations => New_List (
12422 Make_Object_Declaration (Loc,
12423 Defining_Identifier => J,
12424 Object_Definition => New_Occurrence_Of (Index, Loc),
12426 Make_Attribute_Reference (Loc,
12427 Prefix => New_Occurrence_Of (Y, Loc),
12428 Attribute_Name => Name_First))),
12430 Handled_Statement_Sequence =>
12431 Make_Handled_Sequence_Of_Statements (Loc,
12432 Statements => New_List (If_Stat)));
12435 end Make_Array_Comparison_Op;
12437 ---------------------------
12438 -- Make_Boolean_Array_Op --
12439 ---------------------------
12441 -- For logical operations on boolean arrays, expand in line the following,
12442 -- replacing 'and' with 'or' or 'xor' where needed:
12444 -- function Annn (A : typ; B: typ) return typ is
12447 -- for J in A'range loop
12448 -- C (J) := A (J) op B (J);
12453 -- Here typ is the boolean array type
12455 function Make_Boolean_Array_Op
12457 N : Node_Id) return Node_Id
12459 Loc : constant Source_Ptr := Sloc (N);
12461 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
12462 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
12463 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
12464 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
12472 Func_Name : Entity_Id;
12473 Func_Body : Node_Id;
12474 Loop_Statement : Node_Id;
12478 Make_Indexed_Component (Loc,
12479 Prefix => New_Occurrence_Of (A, Loc),
12480 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12483 Make_Indexed_Component (Loc,
12484 Prefix => New_Occurrence_Of (B, Loc),
12485 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12488 Make_Indexed_Component (Loc,
12489 Prefix => New_Occurrence_Of (C, Loc),
12490 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12492 if Nkind (N) = N_Op_And then
12496 Right_Opnd => B_J);
12498 elsif Nkind (N) = N_Op_Or then
12502 Right_Opnd => B_J);
12508 Right_Opnd => B_J);
12512 Make_Implicit_Loop_Statement (N,
12513 Identifier => Empty,
12515 Iteration_Scheme =>
12516 Make_Iteration_Scheme (Loc,
12517 Loop_Parameter_Specification =>
12518 Make_Loop_Parameter_Specification (Loc,
12519 Defining_Identifier => J,
12520 Discrete_Subtype_Definition =>
12521 Make_Attribute_Reference (Loc,
12522 Prefix => New_Occurrence_Of (A, Loc),
12523 Attribute_Name => Name_Range))),
12525 Statements => New_List (
12526 Make_Assignment_Statement (Loc,
12528 Expression => Op)));
12530 Formals := New_List (
12531 Make_Parameter_Specification (Loc,
12532 Defining_Identifier => A,
12533 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
12535 Make_Parameter_Specification (Loc,
12536 Defining_Identifier => B,
12537 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
12539 Func_Name := Make_Temporary (Loc, 'A');
12540 Set_Is_Inlined (Func_Name);
12543 Make_Subprogram_Body (Loc,
12545 Make_Function_Specification (Loc,
12546 Defining_Unit_Name => Func_Name,
12547 Parameter_Specifications => Formals,
12548 Result_Definition => New_Occurrence_Of (Typ, Loc)),
12550 Declarations => New_List (
12551 Make_Object_Declaration (Loc,
12552 Defining_Identifier => C,
12553 Object_Definition => New_Occurrence_Of (Typ, Loc))),
12555 Handled_Statement_Sequence =>
12556 Make_Handled_Sequence_Of_Statements (Loc,
12557 Statements => New_List (
12559 Make_Simple_Return_Statement (Loc,
12560 Expression => New_Occurrence_Of (C, Loc)))));
12563 end Make_Boolean_Array_Op;
12565 -----------------------------------------
12566 -- Minimized_Eliminated_Overflow_Check --
12567 -----------------------------------------
12569 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
12572 Is_Signed_Integer_Type (Etype (N))
12573 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
12574 end Minimized_Eliminated_Overflow_Check;
12576 --------------------------------
12577 -- Optimize_Length_Comparison --
12578 --------------------------------
12580 procedure Optimize_Length_Comparison (N : Node_Id) is
12581 Loc : constant Source_Ptr := Sloc (N);
12582 Typ : constant Entity_Id := Etype (N);
12587 -- First and Last attribute reference nodes, which end up as left and
12588 -- right operands of the optimized result.
12591 -- True for comparison operand of zero
12594 -- Comparison operand, set only if Is_Zero is false
12597 -- Entity whose length is being compared
12600 -- Integer_Literal node for length attribute expression, or Empty
12601 -- if there is no such expression present.
12604 -- Type of array index to which 'Length is applied
12606 Op : Node_Kind := Nkind (N);
12607 -- Kind of comparison operator, gets flipped if operands backwards
12609 function Is_Optimizable (N : Node_Id) return Boolean;
12610 -- Tests N to see if it is an optimizable comparison value (defined as
12611 -- constant zero or one, or something else where the value is known to
12612 -- be positive and in the range of 32-bits, and where the corresponding
12613 -- Length value is also known to be 32-bits. If result is true, sets
12614 -- Is_Zero, Ityp, and Comp accordingly.
12616 function Is_Entity_Length (N : Node_Id) return Boolean;
12617 -- Tests if N is a length attribute applied to a simple entity. If so,
12618 -- returns True, and sets Ent to the entity, and Index to the integer
12619 -- literal provided as an attribute expression, or to Empty if none.
12620 -- Also returns True if the expression is a generated type conversion
12621 -- whose expression is of the desired form. This latter case arises
12622 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12623 -- to check for being in range, which is not needed in this context.
12624 -- Returns False if neither condition holds.
12626 function Prepare_64 (N : Node_Id) return Node_Id;
12627 -- Given a discrete expression, returns a Long_Long_Integer typed
12628 -- expression representing the underlying value of the expression.
12629 -- This is done with an unchecked conversion to the result type. We
12630 -- use unchecked conversion to handle the enumeration type case.
12632 ----------------------
12633 -- Is_Entity_Length --
12634 ----------------------
12636 function Is_Entity_Length (N : Node_Id) return Boolean is
12638 if Nkind (N) = N_Attribute_Reference
12639 and then Attribute_Name (N) = Name_Length
12640 and then Is_Entity_Name (Prefix (N))
12642 Ent := Entity (Prefix (N));
12644 if Present (Expressions (N)) then
12645 Index := First (Expressions (N));
12652 elsif Nkind (N) = N_Type_Conversion
12653 and then not Comes_From_Source (N)
12655 return Is_Entity_Length (Expression (N));
12660 end Is_Entity_Length;
12662 --------------------
12663 -- Is_Optimizable --
12664 --------------------
12666 function Is_Optimizable (N : Node_Id) return Boolean is
12674 if Compile_Time_Known_Value (N) then
12675 Val := Expr_Value (N);
12677 if Val = Uint_0 then
12682 elsif Val = Uint_1 then
12689 -- Here we have to make sure of being within 32-bits
12691 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
12694 or else Lo < Uint_1
12695 or else Hi > UI_From_Int (Int'Last)
12700 -- Comparison value was within range, so now we must check the index
12701 -- value to make sure it is also within 32-bits.
12703 Indx := First_Index (Etype (Ent));
12705 if Present (Index) then
12706 for J in 2 .. UI_To_Int (Intval (Index)) loop
12711 Ityp := Etype (Indx);
12713 if Esize (Ityp) > 32 then
12720 end Is_Optimizable;
12726 function Prepare_64 (N : Node_Id) return Node_Id is
12728 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
12731 -- Start of processing for Optimize_Length_Comparison
12734 -- Nothing to do if not a comparison
12736 if Op not in N_Op_Compare then
12740 -- Nothing to do if special -gnatd.P debug flag set.
12742 if Debug_Flag_Dot_PP then
12746 -- Ent'Length op 0/1
12748 if Is_Entity_Length (Left_Opnd (N))
12749 and then Is_Optimizable (Right_Opnd (N))
12753 -- 0/1 op Ent'Length
12755 elsif Is_Entity_Length (Right_Opnd (N))
12756 and then Is_Optimizable (Left_Opnd (N))
12758 -- Flip comparison to opposite sense
12761 when N_Op_Lt => Op := N_Op_Gt;
12762 when N_Op_Le => Op := N_Op_Ge;
12763 when N_Op_Gt => Op := N_Op_Lt;
12764 when N_Op_Ge => Op := N_Op_Le;
12765 when others => null;
12768 -- Else optimization not possible
12774 -- Fall through if we will do the optimization
12776 -- Cases to handle:
12778 -- X'Length = 0 => X'First > X'Last
12779 -- X'Length = 1 => X'First = X'Last
12780 -- X'Length = n => X'First + (n - 1) = X'Last
12782 -- X'Length /= 0 => X'First <= X'Last
12783 -- X'Length /= 1 => X'First /= X'Last
12784 -- X'Length /= n => X'First + (n - 1) /= X'Last
12786 -- X'Length >= 0 => always true, warn
12787 -- X'Length >= 1 => X'First <= X'Last
12788 -- X'Length >= n => X'First + (n - 1) <= X'Last
12790 -- X'Length > 0 => X'First <= X'Last
12791 -- X'Length > 1 => X'First < X'Last
12792 -- X'Length > n => X'First + (n - 1) < X'Last
12794 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12795 -- X'Length <= 1 => X'First >= X'Last
12796 -- X'Length <= n => X'First + (n - 1) >= X'Last
12798 -- X'Length < 0 => always false (warn)
12799 -- X'Length < 1 => X'First > X'Last
12800 -- X'Length < n => X'First + (n - 1) > X'Last
12802 -- Note: for the cases of n (not constant 0,1), we require that the
12803 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12804 -- and the same for the comparison value. Then we do the comparison
12805 -- using 64-bit arithmetic (actually long long integer), so that we
12806 -- cannot have overflow intefering with the result.
12808 -- First deal with warning cases
12817 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
12818 Analyze_And_Resolve (N, Typ);
12819 Warn_On_Known_Condition (N);
12826 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
12827 Analyze_And_Resolve (N, Typ);
12828 Warn_On_Known_Condition (N);
12832 if Constant_Condition_Warnings
12833 and then Comes_From_Source (Original_Node (N))
12835 Error_Msg_N ("could replace by ""'=""?c?", N);
12845 -- Build the First reference we will use
12848 Make_Attribute_Reference (Loc,
12849 Prefix => New_Occurrence_Of (Ent, Loc),
12850 Attribute_Name => Name_First);
12852 if Present (Index) then
12853 Set_Expressions (Left, New_List (New_Copy (Index)));
12856 -- If general value case, then do the addition of (n - 1), and
12857 -- also add the needed conversions to type Long_Long_Integer.
12859 if Present (Comp) then
12862 Left_Opnd => Prepare_64 (Left),
12864 Make_Op_Subtract (Loc,
12865 Left_Opnd => Prepare_64 (Comp),
12866 Right_Opnd => Make_Integer_Literal (Loc, 1)));
12869 -- Build the Last reference we will use
12872 Make_Attribute_Reference (Loc,
12873 Prefix => New_Occurrence_Of (Ent, Loc),
12874 Attribute_Name => Name_Last);
12876 if Present (Index) then
12877 Set_Expressions (Right, New_List (New_Copy (Index)));
12880 -- If general operand, convert Last reference to Long_Long_Integer
12882 if Present (Comp) then
12883 Right := Prepare_64 (Right);
12886 -- Check for cases to optimize
12888 -- X'Length = 0 => X'First > X'Last
12889 -- X'Length < 1 => X'First > X'Last
12890 -- X'Length < n => X'First + (n - 1) > X'Last
12892 if (Is_Zero and then Op = N_Op_Eq)
12893 or else (not Is_Zero and then Op = N_Op_Lt)
12898 Right_Opnd => Right);
12900 -- X'Length = 1 => X'First = X'Last
12901 -- X'Length = n => X'First + (n - 1) = X'Last
12903 elsif not Is_Zero and then Op = N_Op_Eq then
12907 Right_Opnd => Right);
12909 -- X'Length /= 0 => X'First <= X'Last
12910 -- X'Length > 0 => X'First <= X'Last
12912 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
12916 Right_Opnd => Right);
12918 -- X'Length /= 1 => X'First /= X'Last
12919 -- X'Length /= n => X'First + (n - 1) /= X'Last
12921 elsif not Is_Zero and then Op = N_Op_Ne then
12925 Right_Opnd => Right);
12927 -- X'Length >= 1 => X'First <= X'Last
12928 -- X'Length >= n => X'First + (n - 1) <= X'Last
12930 elsif not Is_Zero and then Op = N_Op_Ge then
12934 Right_Opnd => Right);
12936 -- X'Length > 1 => X'First < X'Last
12937 -- X'Length > n => X'First + (n = 1) < X'Last
12939 elsif not Is_Zero and then Op = N_Op_Gt then
12943 Right_Opnd => Right);
12945 -- X'Length <= 1 => X'First >= X'Last
12946 -- X'Length <= n => X'First + (n - 1) >= X'Last
12948 elsif not Is_Zero and then Op = N_Op_Le then
12952 Right_Opnd => Right);
12954 -- Should not happen at this stage
12957 raise Program_Error;
12960 -- Rewrite and finish up
12962 Rewrite (N, Result);
12963 Analyze_And_Resolve (N, Typ);
12965 end Optimize_Length_Comparison;
12967 --------------------------------
12968 -- Process_If_Case_Statements --
12969 --------------------------------
12971 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
12975 Decl := First (Stmts);
12976 while Present (Decl) loop
12977 if Nkind (Decl) = N_Object_Declaration
12978 and then Is_Finalizable_Transient (Decl, N)
12980 Process_Transient_In_Expression (Decl, N, Stmts);
12985 end Process_If_Case_Statements;
12987 -------------------------------------
12988 -- Process_Transient_In_Expression --
12989 -------------------------------------
12991 procedure Process_Transient_In_Expression
12992 (Obj_Decl : Node_Id;
12996 Loc : constant Source_Ptr := Sloc (Obj_Decl);
12997 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
12999 Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
13000 -- The node on which to insert the hook as an action. This is usually
13001 -- the innermost enclosing non-transient construct.
13003 Fin_Call : Node_Id;
13004 Hook_Assign : Node_Id;
13005 Hook_Clear : Node_Id;
13006 Hook_Decl : Node_Id;
13007 Hook_Insert : Node_Id;
13008 Ptr_Decl : Node_Id;
13010 Fin_Context : Node_Id;
13011 -- The node after which to insert the finalization actions of the
13012 -- transient object.
13015 pragma Assert (Nkind_In (Expr, N_Case_Expression,
13016 N_Expression_With_Actions,
13019 -- When the context is a Boolean evaluation, all three nodes capture the
13020 -- result of their computation in a local temporary:
13023 -- Trans_Id : Ctrl_Typ := ...;
13024 -- Result : constant Boolean := ... Trans_Id ...;
13025 -- <finalize Trans_Id>
13028 -- As a result, the finalization of any transient objects can safely
13029 -- take place after the result capture.
13031 -- ??? could this be extended to elementary types?
13033 if Is_Boolean_Type (Etype (Expr)) then
13034 Fin_Context := Last (Stmts);
13036 -- Otherwise the immediate context may not be safe enough to carry
13037 -- out transient object finalization due to aliasing and nesting of
13038 -- constructs. Insert calls to [Deep_]Finalize after the innermost
13039 -- enclosing non-transient construct.
13042 Fin_Context := Hook_Context;
13045 -- Mark the transient object as successfully processed to avoid double
13048 Set_Is_Finalized_Transient (Obj_Id);
13050 -- Construct all the pieces necessary to hook and finalize a transient
13053 Build_Transient_Object_Statements
13054 (Obj_Decl => Obj_Decl,
13055 Fin_Call => Fin_Call,
13056 Hook_Assign => Hook_Assign,
13057 Hook_Clear => Hook_Clear,
13058 Hook_Decl => Hook_Decl,
13059 Ptr_Decl => Ptr_Decl,
13060 Finalize_Obj => False);
13062 -- Add the access type which provides a reference to the transient
13063 -- object. Generate:
13065 -- type Ptr_Typ is access all Desig_Typ;
13067 Insert_Action (Hook_Context, Ptr_Decl);
13069 -- Add the temporary which acts as a hook to the transient object.
13072 -- Hook : Ptr_Id := null;
13074 Insert_Action (Hook_Context, Hook_Decl);
13076 -- When the transient object is initialized by an aggregate, the hook
13077 -- must capture the object after the last aggregate assignment takes
13078 -- place. Only then is the object considered initialized. Generate:
13080 -- Hook := Ptr_Typ (Obj_Id);
13082 -- Hook := Obj_Id'Unrestricted_Access;
13084 if Ekind_In (Obj_Id, E_Constant, E_Variable)
13085 and then Present (Last_Aggregate_Assignment (Obj_Id))
13087 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
13089 -- Otherwise the hook seizes the related object immediately
13092 Hook_Insert := Obj_Decl;
13095 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
13097 -- When the node is part of a return statement, there is no need to
13098 -- insert a finalization call, as the general finalization mechanism
13099 -- (see Build_Finalizer) would take care of the transient object on
13100 -- subprogram exit. Note that it would also be impossible to insert the
13101 -- finalization code after the return statement as this will render it
13104 if Nkind (Fin_Context) = N_Simple_Return_Statement then
13107 -- Finalize the hook after the context has been evaluated. Generate:
13109 -- if Hook /= null then
13110 -- [Deep_]Finalize (Hook.all);
13115 Insert_Action_After (Fin_Context,
13116 Make_Implicit_If_Statement (Obj_Decl,
13120 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
13121 Right_Opnd => Make_Null (Loc)),
13123 Then_Statements => New_List (
13127 end Process_Transient_In_Expression;
13129 ------------------------
13130 -- Rewrite_Comparison --
13131 ------------------------
13133 procedure Rewrite_Comparison (N : Node_Id) is
13134 Warning_Generated : Boolean := False;
13135 -- Set to True if first pass with Assume_Valid generates a warning in
13136 -- which case we skip the second pass to avoid warning overloaded.
13139 -- Set to Standard_True or Standard_False
13142 if Nkind (N) = N_Type_Conversion then
13143 Rewrite_Comparison (Expression (N));
13146 elsif Nkind (N) not in N_Op_Compare then
13150 -- Now start looking at the comparison in detail. We potentially go
13151 -- through this loop twice. The first time, Assume_Valid is set False
13152 -- in the call to Compile_Time_Compare. If this call results in a
13153 -- clear result of always True or Always False, that's decisive and
13154 -- we are done. Otherwise we repeat the processing with Assume_Valid
13155 -- set to True to generate additional warnings. We can skip that step
13156 -- if Constant_Condition_Warnings is False.
13158 for AV in False .. True loop
13160 Typ : constant Entity_Id := Etype (N);
13161 Op1 : constant Node_Id := Left_Opnd (N);
13162 Op2 : constant Node_Id := Right_Opnd (N);
13164 Res : constant Compare_Result :=
13165 Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
13166 -- Res indicates if compare outcome can be compile time determined
13168 True_Result : Boolean;
13169 False_Result : Boolean;
13172 case N_Op_Compare (Nkind (N)) is
13174 True_Result := Res = EQ;
13175 False_Result := Res = LT or else Res = GT or else Res = NE;
13178 True_Result := Res in Compare_GE;
13179 False_Result := Res = LT;
13182 and then Constant_Condition_Warnings
13183 and then Comes_From_Source (Original_Node (N))
13184 and then Nkind (Original_Node (N)) = N_Op_Ge
13185 and then not In_Instance
13186 and then Is_Integer_Type (Etype (Left_Opnd (N)))
13187 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
13190 ("can never be greater than, could replace by ""'=""?c?",
13192 Warning_Generated := True;
13196 True_Result := Res = GT;
13197 False_Result := Res in Compare_LE;
13200 True_Result := Res = LT;
13201 False_Result := Res in Compare_GE;
13204 True_Result := Res in Compare_LE;
13205 False_Result := Res = GT;
13208 and then Constant_Condition_Warnings
13209 and then Comes_From_Source (Original_Node (N))
13210 and then Nkind (Original_Node (N)) = N_Op_Le
13211 and then not In_Instance
13212 and then Is_Integer_Type (Etype (Left_Opnd (N)))
13213 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
13216 ("can never be less than, could replace by ""'=""?c?", N);
13217 Warning_Generated := True;
13221 True_Result := Res = NE or else Res = GT or else Res = LT;
13222 False_Result := Res = EQ;
13225 -- If this is the first iteration, then we actually convert the
13226 -- comparison into True or False, if the result is certain.
13229 if True_Result or False_Result then
13230 Result := Boolean_Literals (True_Result);
13233 New_Occurrence_Of (Result, Sloc (N))));
13234 Analyze_And_Resolve (N, Typ);
13235 Warn_On_Known_Condition (N);
13239 -- If this is the second iteration (AV = True), and the original
13240 -- node comes from source and we are not in an instance, then give
13241 -- a warning if we know result would be True or False. Note: we
13242 -- know Constant_Condition_Warnings is set if we get here.
13244 elsif Comes_From_Source (Original_Node (N))
13245 and then not In_Instance
13247 if True_Result then
13249 ("condition can only be False if invalid values present??",
13251 elsif False_Result then
13253 ("condition can only be True if invalid values present??",
13259 -- Skip second iteration if not warning on constant conditions or
13260 -- if the first iteration already generated a warning of some kind or
13261 -- if we are in any case assuming all values are valid (so that the
13262 -- first iteration took care of the valid case).
13264 exit when not Constant_Condition_Warnings;
13265 exit when Warning_Generated;
13266 exit when Assume_No_Invalid_Values;
13268 end Rewrite_Comparison;
13270 ----------------------------
13271 -- Safe_In_Place_Array_Op --
13272 ----------------------------
13274 function Safe_In_Place_Array_Op
13277 Op2 : Node_Id) return Boolean
13279 Target : Entity_Id;
13281 function Is_Safe_Operand (Op : Node_Id) return Boolean;
13282 -- Operand is safe if it cannot overlap part of the target of the
13283 -- operation. If the operand and the target are identical, the operand
13284 -- is safe. The operand can be empty in the case of negation.
13286 function Is_Unaliased (N : Node_Id) return Boolean;
13287 -- Check that N is a stand-alone entity
13293 function Is_Unaliased (N : Node_Id) return Boolean is
13297 and then No (Address_Clause (Entity (N)))
13298 and then No (Renamed_Object (Entity (N)));
13301 ---------------------
13302 -- Is_Safe_Operand --
13303 ---------------------
13305 function Is_Safe_Operand (Op : Node_Id) return Boolean is
13310 elsif Is_Entity_Name (Op) then
13311 return Is_Unaliased (Op);
13313 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
13314 return Is_Unaliased (Prefix (Op));
13316 elsif Nkind (Op) = N_Slice then
13318 Is_Unaliased (Prefix (Op))
13319 and then Entity (Prefix (Op)) /= Target;
13321 elsif Nkind (Op) = N_Op_Not then
13322 return Is_Safe_Operand (Right_Opnd (Op));
13327 end Is_Safe_Operand;
13329 -- Start of processing for Safe_In_Place_Array_Op
13332 -- Skip this processing if the component size is different from system
13333 -- storage unit (since at least for NOT this would cause problems).
13335 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
13338 -- Cannot do in place stuff if non-standard Boolean representation
13340 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
13343 elsif not Is_Unaliased (Lhs) then
13347 Target := Entity (Lhs);
13348 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
13350 end Safe_In_Place_Array_Op;
13352 -----------------------
13353 -- Tagged_Membership --
13354 -----------------------
13356 -- There are two different cases to consider depending on whether the right
13357 -- operand is a class-wide type or not. If not we just compare the actual
13358 -- tag of the left expr to the target type tag:
13360 -- Left_Expr.Tag = Right_Type'Tag;
13362 -- If it is a class-wide type we use the RT function CW_Membership which is
13363 -- usually implemented by looking in the ancestor tables contained in the
13364 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13366 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13367 -- function IW_Membership which is usually implemented by looking in the
13368 -- table of abstract interface types plus the ancestor table contained in
13369 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13371 procedure Tagged_Membership
13373 SCIL_Node : out Node_Id;
13374 Result : out Node_Id)
13376 Left : constant Node_Id := Left_Opnd (N);
13377 Right : constant Node_Id := Right_Opnd (N);
13378 Loc : constant Source_Ptr := Sloc (N);
13380 Full_R_Typ : Entity_Id;
13381 Left_Type : Entity_Id;
13382 New_Node : Node_Id;
13383 Right_Type : Entity_Id;
13387 SCIL_Node := Empty;
13389 -- Handle entities from the limited view
13391 Left_Type := Available_View (Etype (Left));
13392 Right_Type := Available_View (Etype (Right));
13394 -- In the case where the type is an access type, the test is applied
13395 -- using the designated types (needed in Ada 2012 for implicit anonymous
13396 -- access conversions, for AI05-0149).
13398 if Is_Access_Type (Right_Type) then
13399 Left_Type := Designated_Type (Left_Type);
13400 Right_Type := Designated_Type (Right_Type);
13403 if Is_Class_Wide_Type (Left_Type) then
13404 Left_Type := Root_Type (Left_Type);
13407 if Is_Class_Wide_Type (Right_Type) then
13408 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
13410 Full_R_Typ := Underlying_Type (Right_Type);
13414 Make_Selected_Component (Loc,
13415 Prefix => Relocate_Node (Left),
13417 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
13419 if Is_Class_Wide_Type (Right_Type) then
13421 -- No need to issue a run-time check if we statically know that the
13422 -- result of this membership test is always true. For example,
13423 -- considering the following declarations:
13425 -- type Iface is interface;
13426 -- type T is tagged null record;
13427 -- type DT is new T and Iface with null record;
13432 -- These membership tests are always true:
13435 -- Obj2 in T'Class;
13436 -- Obj2 in Iface'Class;
13438 -- We do not need to handle cases where the membership is illegal.
13441 -- Obj1 in DT'Class; -- Compile time error
13442 -- Obj1 in Iface'Class; -- Compile time error
13444 if not Is_Class_Wide_Type (Left_Type)
13445 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
13446 Use_Full_View => True)
13447 or else (Is_Interface (Etype (Right_Type))
13448 and then Interface_Present_In_Ancestor
13450 Iface => Etype (Right_Type))))
13452 Result := New_Occurrence_Of (Standard_True, Loc);
13456 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13458 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
13460 -- Support to: "Iface_CW_Typ in Typ'Class"
13462 or else Is_Interface (Left_Type)
13464 -- Issue error if IW_Membership operation not available in a
13465 -- configurable run time setting.
13467 if not RTE_Available (RE_IW_Membership) then
13469 ("dynamic membership test on interface types", N);
13475 Make_Function_Call (Loc,
13476 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
13477 Parameter_Associations => New_List (
13478 Make_Attribute_Reference (Loc,
13480 Attribute_Name => Name_Address),
13481 New_Occurrence_Of (
13482 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
13485 -- Ada 95: Normal case
13488 Build_CW_Membership (Loc,
13489 Obj_Tag_Node => Obj_Tag,
13491 New_Occurrence_Of (
13492 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
13494 New_Node => New_Node);
13496 -- Generate the SCIL node for this class-wide membership test.
13497 -- Done here because the previous call to Build_CW_Membership
13498 -- relocates Obj_Tag.
13500 if Generate_SCIL then
13501 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
13502 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
13503 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
13506 Result := New_Node;
13509 -- Right_Type is not a class-wide type
13512 -- No need to check the tag of the object if Right_Typ is abstract
13514 if Is_Abstract_Type (Right_Type) then
13515 Result := New_Occurrence_Of (Standard_False, Loc);
13520 Left_Opnd => Obj_Tag,
13523 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
13526 end Tagged_Membership;
13528 ------------------------------
13529 -- Unary_Op_Validity_Checks --
13530 ------------------------------
13532 procedure Unary_Op_Validity_Checks (N : Node_Id) is
13534 if Validity_Checks_On and Validity_Check_Operands then
13535 Ensure_Valid (Right_Opnd (N));
13537 end Unary_Op_Validity_Checks;