1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Exp_VFpt; use Exp_VFpt;
46 with Freeze; use Freeze;
47 with Inline; use Inline;
49 with Namet; use Namet;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
53 with Par_SCO; use Par_SCO;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
58 with Sem_Aux; use Sem_Aux;
59 with Sem_Cat; use Sem_Cat;
60 with Sem_Ch3; use Sem_Ch3;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Eval; use Sem_Eval;
64 with Sem_Res; use Sem_Res;
65 with Sem_Type; use Sem_Type;
66 with Sem_Util; use Sem_Util;
67 with Sem_Warn; use Sem_Warn;
68 with Sinfo; use Sinfo;
69 with Snames; use Snames;
70 with Stand; use Stand;
71 with SCIL_LL; use SCIL_LL;
72 with Targparm; use Targparm;
73 with Tbuild; use Tbuild;
74 with Ttypes; use Ttypes;
75 with Uintp; use Uintp;
76 with Urealp; use Urealp;
77 with Validsw; use Validsw;
79 package body Exp_Ch4 is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 procedure Binary_Op_Validity_Checks (N : Node_Id);
86 pragma Inline (Binary_Op_Validity_Checks);
87 -- Performs validity checks for a binary operator
89 procedure Build_Boolean_Array_Proc_Call
93 -- If a boolean array assignment can be done in place, build call to
94 -- corresponding library procedure.
96 function Current_Anonymous_Master return Entity_Id;
97 -- Return the entity of the heterogeneous finalization master belonging to
98 -- the current unit (either function, package or procedure). This master
99 -- services all anonymous access-to-controlled types. If the current unit
100 -- does not have such master, create one.
102 procedure Displace_Allocator_Pointer (N : Node_Id);
103 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
104 -- Expand_Allocator_Expression. Allocating class-wide interface objects
105 -- this routine displaces the pointer to the allocated object to reference
106 -- the component referencing the corresponding secondary dispatch table.
108 procedure Expand_Allocator_Expression (N : Node_Id);
109 -- Subsidiary to Expand_N_Allocator, for the case when the expression
110 -- is a qualified expression or an aggregate.
112 procedure Expand_Array_Comparison (N : Node_Id);
113 -- This routine handles expansion of the comparison operators (N_Op_Lt,
114 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
115 -- code for these operators is similar, differing only in the details of
116 -- the actual comparison call that is made. Special processing (call a
119 function Expand_Array_Equality
124 Typ : Entity_Id) return Node_Id;
125 -- Expand an array equality into a call to a function implementing this
126 -- equality, and a call to it. Loc is the location for the generated nodes.
127 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
128 -- on which to attach bodies of local functions that are created in the
129 -- process. It is the responsibility of the caller to insert those bodies
130 -- at the right place. Nod provides the Sloc value for the generated code.
131 -- Normally the types used for the generated equality routine are taken
132 -- from Lhs and Rhs. However, in some situations of generated code, the
133 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
134 -- the type to be used for the formal parameters.
136 procedure Expand_Boolean_Operator (N : Node_Id);
137 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
138 -- case of array type arguments.
140 procedure Expand_Short_Circuit_Operator (N : Node_Id);
141 -- Common expansion processing for short-circuit boolean operators
143 function Expand_Composite_Equality
148 Bodies : List_Id) return Node_Id;
149 -- Local recursive function used to expand equality for nested composite
150 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
151 -- to attach bodies of local functions that are created in the process.
152 -- This is the responsibility of the caller to insert those bodies at the
153 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
154 -- are the left and right sides for the comparison, and Typ is the type of
155 -- the arrays to compare.
157 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
158 -- Routine to expand concatenation of a sequence of two or more operands
159 -- (in the list Operands) and replace node Cnode with the result of the
160 -- concatenation. The operands can be of any appropriate type, and can
161 -- include both arrays and singleton elements.
163 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
164 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
165 -- fixed. We do not have such a type at runtime, so the purpose of this
166 -- routine is to find the real type by looking up the tree. We also
167 -- determine if the operation must be rounded.
169 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
170 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
171 -- discriminants if it has a constrained nominal type, unless the object
172 -- is a component of an enclosing Unchecked_Union object that is subject
173 -- to a per-object constraint and the enclosing object lacks inferable
176 -- An expression of an Unchecked_Union type has inferable discriminants
177 -- if it is either a name of an object with inferable discriminants or a
178 -- qualified expression whose subtype mark denotes a constrained subtype.
180 procedure Insert_Dereference_Action (N : Node_Id);
181 -- N is an expression whose type is an access. When the type of the
182 -- associated storage pool is derived from Checked_Pool, generate a
183 -- call to the 'Dereference' primitive operation.
185 function Make_Array_Comparison_Op
187 Nod : Node_Id) return Node_Id;
188 -- Comparisons between arrays are expanded in line. This function produces
189 -- the body of the implementation of (a > b), where a and b are one-
190 -- dimensional arrays of some discrete type. The original node is then
191 -- expanded into the appropriate call to this function. Nod provides the
192 -- Sloc value for the generated code.
194 function Make_Boolean_Array_Op
196 N : Node_Id) return Node_Id;
197 -- Boolean operations on boolean arrays are expanded in line. This function
198 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
199 -- b). It is used only the normal case and not the packed case. The type
200 -- involved, Typ, is the Boolean array type, and the logical operations in
201 -- the body are simple boolean operations. Note that Typ is always a
202 -- constrained type (the caller has ensured this by using
203 -- Convert_To_Actual_Subtype if necessary).
205 procedure Optimize_Length_Comparison (N : Node_Id);
206 -- Given an expression, if it is of the form X'Length op N (or the other
207 -- way round), where N is known at compile time to be 0 or 1, and X is a
208 -- simple entity, and op is a comparison operator, optimizes it into a
209 -- comparison of First and Last.
211 procedure Rewrite_Comparison (N : Node_Id);
212 -- If N is the node for a comparison whose outcome can be determined at
213 -- compile time, then the node N can be rewritten with True or False. If
214 -- the outcome cannot be determined at compile time, the call has no
215 -- effect. If N is a type conversion, then this processing is applied to
216 -- its expression. If N is neither comparison nor a type conversion, the
217 -- call has no effect.
219 procedure Tagged_Membership
221 SCIL_Node : out Node_Id;
222 Result : out Node_Id);
223 -- Construct the expression corresponding to the tagged membership test.
224 -- Deals with a second operand being (or not) a class-wide type.
226 function Safe_In_Place_Array_Op
229 Op2 : Node_Id) return Boolean;
230 -- In the context of an assignment, where the right-hand side is a boolean
231 -- operation on arrays, check whether operation can be performed in place.
233 procedure Unary_Op_Validity_Checks (N : Node_Id);
234 pragma Inline (Unary_Op_Validity_Checks);
235 -- Performs validity checks for a unary operator
237 -------------------------------
238 -- Binary_Op_Validity_Checks --
239 -------------------------------
241 procedure Binary_Op_Validity_Checks (N : Node_Id) is
243 if Validity_Checks_On and Validity_Check_Operands then
244 Ensure_Valid (Left_Opnd (N));
245 Ensure_Valid (Right_Opnd (N));
247 end Binary_Op_Validity_Checks;
249 ------------------------------------
250 -- Build_Boolean_Array_Proc_Call --
251 ------------------------------------
253 procedure Build_Boolean_Array_Proc_Call
258 Loc : constant Source_Ptr := Sloc (N);
259 Kind : constant Node_Kind := Nkind (Expression (N));
260 Target : constant Node_Id :=
261 Make_Attribute_Reference (Loc,
263 Attribute_Name => Name_Address);
265 Arg1 : Node_Id := Op1;
266 Arg2 : Node_Id := Op2;
268 Proc_Name : Entity_Id;
271 if Kind = N_Op_Not then
272 if Nkind (Op1) in N_Binary_Op then
274 -- Use negated version of the binary operators
276 if Nkind (Op1) = N_Op_And then
277 Proc_Name := RTE (RE_Vector_Nand);
279 elsif Nkind (Op1) = N_Op_Or then
280 Proc_Name := RTE (RE_Vector_Nor);
282 else pragma Assert (Nkind (Op1) = N_Op_Xor);
283 Proc_Name := RTE (RE_Vector_Xor);
287 Make_Procedure_Call_Statement (Loc,
288 Name => New_Occurrence_Of (Proc_Name, Loc),
290 Parameter_Associations => New_List (
292 Make_Attribute_Reference (Loc,
293 Prefix => Left_Opnd (Op1),
294 Attribute_Name => Name_Address),
296 Make_Attribute_Reference (Loc,
297 Prefix => Right_Opnd (Op1),
298 Attribute_Name => Name_Address),
300 Make_Attribute_Reference (Loc,
301 Prefix => Left_Opnd (Op1),
302 Attribute_Name => Name_Length)));
305 Proc_Name := RTE (RE_Vector_Not);
308 Make_Procedure_Call_Statement (Loc,
309 Name => New_Occurrence_Of (Proc_Name, Loc),
310 Parameter_Associations => New_List (
313 Make_Attribute_Reference (Loc,
315 Attribute_Name => Name_Address),
317 Make_Attribute_Reference (Loc,
319 Attribute_Name => Name_Length)));
323 -- We use the following equivalences:
325 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
326 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
327 -- (not X) xor (not Y) = X xor Y
328 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
330 if Nkind (Op1) = N_Op_Not then
331 Arg1 := Right_Opnd (Op1);
332 Arg2 := Right_Opnd (Op2);
333 if Kind = N_Op_And then
334 Proc_Name := RTE (RE_Vector_Nor);
335 elsif Kind = N_Op_Or then
336 Proc_Name := RTE (RE_Vector_Nand);
338 Proc_Name := RTE (RE_Vector_Xor);
342 if Kind = N_Op_And then
343 Proc_Name := RTE (RE_Vector_And);
344 elsif Kind = N_Op_Or then
345 Proc_Name := RTE (RE_Vector_Or);
346 elsif Nkind (Op2) = N_Op_Not then
347 Proc_Name := RTE (RE_Vector_Nxor);
348 Arg2 := Right_Opnd (Op2);
350 Proc_Name := RTE (RE_Vector_Xor);
355 Make_Procedure_Call_Statement (Loc,
356 Name => New_Occurrence_Of (Proc_Name, Loc),
357 Parameter_Associations => New_List (
359 Make_Attribute_Reference (Loc,
361 Attribute_Name => Name_Address),
362 Make_Attribute_Reference (Loc,
364 Attribute_Name => Name_Address),
365 Make_Attribute_Reference (Loc,
367 Attribute_Name => Name_Length)));
370 Rewrite (N, Call_Node);
374 when RE_Not_Available =>
376 end Build_Boolean_Array_Proc_Call;
378 ------------------------------
379 -- Current_Anonymous_Master --
380 ------------------------------
382 function Current_Anonymous_Master return Entity_Id is
384 Fin_Mas_Id : Entity_Id;
391 Unit_Id := Cunit_Entity (Current_Sem_Unit);
393 -- Find the entity of the current unit
395 if Ekind (Unit_Id) = E_Subprogram_Body then
397 -- When processing subprogram bodies, the proper scope is always that
400 Subp_Body := Unit_Id;
401 while Present (Subp_Body)
402 and then Nkind (Subp_Body) /= N_Subprogram_Body
404 Subp_Body := Parent (Subp_Body);
407 Unit_Id := Corresponding_Spec (Subp_Body);
410 Loc := Sloc (Unit_Id);
411 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
413 -- Find the declarations list of the current unit
415 if Nkind (Unit_Decl) = N_Package_Declaration then
416 Unit_Decl := Specification (Unit_Decl);
417 Decls := Visible_Declarations (Unit_Decl);
420 Decls := New_List (Make_Null_Statement (Loc));
421 Set_Visible_Declarations (Unit_Decl, Decls);
423 elsif Is_Empty_List (Decls) then
424 Append_To (Decls, Make_Null_Statement (Loc));
428 Decls := Declarations (Unit_Decl);
431 Decls := New_List (Make_Null_Statement (Loc));
432 Set_Declarations (Unit_Decl, Decls);
434 elsif Is_Empty_List (Decls) then
435 Append_To (Decls, Make_Null_Statement (Loc));
439 -- The current unit has an existing anonymous master, traverse its
440 -- declarations and locate the entity.
442 if Has_Anonymous_Master (Unit_Id) then
443 Fin_Mas_Id := First_Entity (Unit_Id);
444 while Present (Fin_Mas_Id) loop
446 -- Look for the first variable whose type is Finalization_Master
448 if Ekind (Fin_Mas_Id) = E_Variable
449 and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
454 Next_Entity (Fin_Mas_Id);
459 -- Create a new anonymous master
463 First_Decl : constant Node_Id := First (Decls);
467 -- Since the master and its associated initialization is inserted
468 -- at top level, use the scope of the unit when analyzing.
470 Push_Scope (Unit_Id);
472 -- Create the finalization master
475 Make_Defining_Identifier (Loc,
476 Chars => New_External_Name (Chars (Unit_Id), "AM"));
479 -- <Fin_Mas_Id> : Finalization_Master;
482 Make_Object_Declaration (Loc,
483 Defining_Identifier => Fin_Mas_Id,
485 New_Reference_To (RTE (RE_Finalization_Master), Loc));
487 Insert_Before_And_Analyze (First_Decl, Action);
489 -- Mark the unit to prevent the generation of multiple masters
491 Set_Has_Anonymous_Master (Unit_Id);
493 -- Do not set the base pool and mode of operation on .NET/JVM
494 -- since those targets do not support pools and all VM masters
495 -- are heterogeneous by default.
497 if VM_Target = No_VM then
501 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
504 Make_Procedure_Call_Statement (Loc,
506 New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
508 Parameter_Associations => New_List (
509 New_Reference_To (Fin_Mas_Id, Loc),
510 Make_Attribute_Reference (Loc,
512 New_Reference_To (RTE (RE_Global_Pool_Object), Loc),
513 Attribute_Name => Name_Unrestricted_Access)));
515 Insert_Before_And_Analyze (First_Decl, Action);
518 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
521 Make_Procedure_Call_Statement (Loc,
523 New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc),
524 Parameter_Associations => New_List (
525 New_Reference_To (Fin_Mas_Id, Loc)));
527 Insert_Before_And_Analyze (First_Decl, Action);
530 -- Restore the original state of the scope stack
537 end Current_Anonymous_Master;
539 --------------------------------
540 -- Displace_Allocator_Pointer --
541 --------------------------------
543 procedure Displace_Allocator_Pointer (N : Node_Id) is
544 Loc : constant Source_Ptr := Sloc (N);
545 Orig_Node : constant Node_Id := Original_Node (N);
551 -- Do nothing in case of VM targets: the virtual machine will handle
552 -- interfaces directly.
554 if not Tagged_Type_Expansion then
558 pragma Assert (Nkind (N) = N_Identifier
559 and then Nkind (Orig_Node) = N_Allocator);
561 PtrT := Etype (Orig_Node);
562 Dtyp := Available_View (Designated_Type (PtrT));
563 Etyp := Etype (Expression (Orig_Node));
565 if Is_Class_Wide_Type (Dtyp)
566 and then Is_Interface (Dtyp)
568 -- If the type of the allocator expression is not an interface type
569 -- we can generate code to reference the record component containing
570 -- the pointer to the secondary dispatch table.
572 if not Is_Interface (Etyp) then
574 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
577 -- 1) Get access to the allocated object
580 Make_Explicit_Dereference (Loc,
585 -- 2) Add the conversion to displace the pointer to reference
586 -- the secondary dispatch table.
588 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
589 Analyze_And_Resolve (N, Dtyp);
591 -- 3) The 'access to the secondary dispatch table will be used
592 -- as the value returned by the allocator.
595 Make_Attribute_Reference (Loc,
596 Prefix => Relocate_Node (N),
597 Attribute_Name => Name_Access));
598 Set_Etype (N, Saved_Typ);
602 -- If the type of the allocator expression is an interface type we
603 -- generate a run-time call to displace "this" to reference the
604 -- component containing the pointer to the secondary dispatch table
605 -- or else raise Constraint_Error if the actual object does not
606 -- implement the target interface. This case corresponds with the
607 -- following example:
609 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
611 -- return new Iface_2'Class'(Obj);
616 Unchecked_Convert_To (PtrT,
617 Make_Function_Call (Loc,
618 Name => New_Reference_To (RTE (RE_Displace), Loc),
619 Parameter_Associations => New_List (
620 Unchecked_Convert_To (RTE (RE_Address),
626 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
628 Analyze_And_Resolve (N, PtrT);
631 end Displace_Allocator_Pointer;
633 ---------------------------------
634 -- Expand_Allocator_Expression --
635 ---------------------------------
637 procedure Expand_Allocator_Expression (N : Node_Id) is
638 Loc : constant Source_Ptr := Sloc (N);
639 Exp : constant Node_Id := Expression (Expression (N));
640 PtrT : constant Entity_Id := Etype (N);
641 DesigT : constant Entity_Id := Designated_Type (PtrT);
643 procedure Apply_Accessibility_Check
645 Built_In_Place : Boolean := False);
646 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
647 -- type, generate an accessibility check to verify that the level of the
648 -- type of the created object is not deeper than the level of the access
649 -- type. If the type of the qualified expression is class- wide, then
650 -- always generate the check (except in the case where it is known to be
651 -- unnecessary, see comment below). Otherwise, only generate the check
652 -- if the level of the qualified expression type is statically deeper
653 -- than the access type.
655 -- Although the static accessibility will generally have been performed
656 -- as a legality check, it won't have been done in cases where the
657 -- allocator appears in generic body, so a run-time check is needed in
658 -- general. One special case is when the access type is declared in the
659 -- same scope as the class-wide allocator, in which case the check can
660 -- never fail, so it need not be generated.
662 -- As an open issue, there seem to be cases where the static level
663 -- associated with the class-wide object's underlying type is not
664 -- sufficient to perform the proper accessibility check, such as for
665 -- allocators in nested subprograms or accept statements initialized by
666 -- class-wide formals when the actual originates outside at a deeper
667 -- static level. The nested subprogram case might require passing
668 -- accessibility levels along with class-wide parameters, and the task
669 -- case seems to be an actual gap in the language rules that needs to
670 -- be fixed by the ARG. ???
672 -------------------------------
673 -- Apply_Accessibility_Check --
674 -------------------------------
676 procedure Apply_Accessibility_Check
678 Built_In_Place : Boolean := False)
683 if Ada_Version >= Ada_2005
684 and then Is_Class_Wide_Type (DesigT)
685 and then not Scope_Suppress (Accessibility_Check)
687 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
689 (Is_Class_Wide_Type (Etype (Exp))
690 and then Scope (PtrT) /= Current_Scope))
692 -- If the allocator was built in place Ref is already a reference
693 -- to the access object initialized to the result of the allocator
694 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
695 -- it is the entity associated with the object containing the
696 -- address of the allocated object.
698 if Built_In_Place then
699 New_Node := New_Copy (Ref);
701 New_Node := New_Reference_To (Ref, Loc);
705 Make_Attribute_Reference (Loc,
707 Attribute_Name => Name_Tag);
709 if Tagged_Type_Expansion then
710 New_Node := Build_Get_Access_Level (Loc, New_Node);
712 elsif VM_Target /= No_VM then
714 Make_Function_Call (Loc,
715 Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc),
716 Parameter_Associations => New_List (New_Node));
718 -- Cannot generate the runtime check
725 Make_Raise_Program_Error (Loc,
728 Left_Opnd => New_Node,
730 Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
731 Reason => PE_Accessibility_Check_Failed));
733 end Apply_Accessibility_Check;
737 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
738 Indic : constant Node_Id := Subtype_Mark (Expression (N));
739 T : constant Entity_Id := Entity (Indic);
741 Tag_Assign : Node_Id;
745 TagT : Entity_Id := Empty;
746 -- Type used as source for tag assignment
748 TagR : Node_Id := Empty;
749 -- Target reference for tag assignment
751 -- Start of processing for Expand_Allocator_Expression
754 -- WOuld be nice to comment the branches of this very long if ???
756 if Is_Tagged_Type (T)
757 or else Needs_Finalization (T)
759 if Is_CPP_Constructor_Call (Exp) then
762 -- Pnnn : constant ptr_T := new (T);
763 -- Init (Pnnn.all,...);
765 -- Allocate the object without an expression
767 Node := Relocate_Node (N);
768 Set_Expression (Node, New_Reference_To (Etype (Exp), Loc));
770 -- Avoid its expansion to avoid generating a call to the default
775 Temp := Make_Temporary (Loc, 'P', N);
778 Make_Object_Declaration (Loc,
779 Defining_Identifier => Temp,
780 Constant_Present => True,
781 Object_Definition => New_Reference_To (PtrT, Loc),
783 Insert_Action (N, Temp_Decl);
785 Apply_Accessibility_Check (Temp);
787 -- Locate the enclosing list and insert the C++ constructor call
794 while not Is_List_Member (P) loop
798 Insert_List_After_And_Analyze (P,
799 Build_Initialization_Call (Loc,
801 Make_Explicit_Dereference (Loc,
802 Prefix => New_Reference_To (Temp, Loc)),
804 Constructor_Ref => Exp));
807 Rewrite (N, New_Reference_To (Temp, Loc));
808 Analyze_And_Resolve (N, PtrT);
812 -- Ada 2005 (AI-318-02): If the initialization expression is a call
813 -- to a build-in-place function, then access to the allocated object
814 -- must be passed to the function. Currently we limit such functions
815 -- to those with constrained limited result subtypes, but eventually
816 -- we plan to expand the allowed forms of functions that are treated
817 -- as build-in-place.
819 if Ada_Version >= Ada_2005
820 and then Is_Build_In_Place_Function_Call (Exp)
822 Make_Build_In_Place_Call_In_Allocator (N, Exp);
823 Apply_Accessibility_Check (N, Built_In_Place => True);
827 -- Actions inserted before:
828 -- Temp : constant ptr_T := new T'(Expression);
829 -- Temp._tag = T'tag; -- when not class-wide
830 -- [Deep_]Adjust (Temp.all);
832 -- We analyze by hand the new internal allocator to avoid any
833 -- recursion and inappropriate call to Initialize
835 -- We don't want to remove side effects when the expression must be
836 -- built in place. In the case of a build-in-place function call,
837 -- that could lead to a duplication of the call, which was already
838 -- substituted for the allocator.
840 if not Aggr_In_Place then
841 Remove_Side_Effects (Exp);
844 Temp := Make_Temporary (Loc, 'P', N);
846 -- For a class wide allocation generate the following code:
848 -- type Equiv_Record is record ... end record;
849 -- implicit subtype CW is <Class_Wide_Subytpe>;
850 -- temp : PtrT := new CW'(CW!(expr));
852 if Is_Class_Wide_Type (T) then
853 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
855 -- Ada 2005 (AI-251): If the expression is a class-wide interface
856 -- object we generate code to move up "this" to reference the
857 -- base of the object before allocating the new object.
859 -- Note that Exp'Address is recursively expanded into a call
860 -- to Base_Address (Exp.Tag)
862 if Is_Class_Wide_Type (Etype (Exp))
863 and then Is_Interface (Etype (Exp))
864 and then Tagged_Type_Expansion
868 Unchecked_Convert_To (Entity (Indic),
869 Make_Explicit_Dereference (Loc,
870 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
871 Make_Attribute_Reference (Loc,
873 Attribute_Name => Name_Address)))));
877 Unchecked_Convert_To (Entity (Indic), Exp));
880 Analyze_And_Resolve (Expression (N), Entity (Indic));
883 -- Processing for allocators returning non-interface types
885 if not Is_Interface (Directly_Designated_Type (PtrT)) then
886 if Aggr_In_Place then
888 Make_Object_Declaration (Loc,
889 Defining_Identifier => Temp,
890 Object_Definition => New_Reference_To (PtrT, Loc),
894 New_Reference_To (Etype (Exp), Loc)));
896 -- Copy the Comes_From_Source flag for the allocator we just
897 -- built, since logically this allocator is a replacement of
898 -- the original allocator node. This is for proper handling of
899 -- restriction No_Implicit_Heap_Allocations.
901 Set_Comes_From_Source
902 (Expression (Temp_Decl), Comes_From_Source (N));
904 Set_No_Initialization (Expression (Temp_Decl));
905 Insert_Action (N, Temp_Decl);
907 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
908 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
910 -- Attach the object to the associated finalization master.
911 -- This is done manually on .NET/JVM since those compilers do
912 -- no support pools and can't benefit from internally generated
913 -- Allocate / Deallocate procedures.
915 if VM_Target /= No_VM
916 and then Is_Controlled (DesigT)
917 and then Present (Finalization_Master (PtrT))
922 New_Reference_To (Temp, Loc),
927 Node := Relocate_Node (N);
931 Make_Object_Declaration (Loc,
932 Defining_Identifier => Temp,
933 Constant_Present => True,
934 Object_Definition => New_Reference_To (PtrT, Loc),
937 Insert_Action (N, Temp_Decl);
938 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
940 -- Attach the object to the associated finalization master.
941 -- This is done manually on .NET/JVM since those compilers do
942 -- no support pools and can't benefit from internally generated
943 -- Allocate / Deallocate procedures.
945 if VM_Target /= No_VM
946 and then Is_Controlled (DesigT)
947 and then Present (Finalization_Master (PtrT))
952 New_Reference_To (Temp, Loc),
957 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
958 -- interface type. In this case we use the type of the qualified
959 -- expression to allocate the object.
963 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
968 Make_Full_Type_Declaration (Loc,
969 Defining_Identifier => Def_Id,
971 Make_Access_To_Object_Definition (Loc,
973 Null_Exclusion_Present => False,
974 Constant_Present => False,
975 Subtype_Indication =>
976 New_Reference_To (Etype (Exp), Loc)));
978 Insert_Action (N, New_Decl);
980 -- Inherit the allocation-related attributes from the original
983 Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
985 Set_Associated_Storage_Pool (Def_Id,
986 Associated_Storage_Pool (PtrT));
988 -- Declare the object using the previous type declaration
990 if Aggr_In_Place then
992 Make_Object_Declaration (Loc,
993 Defining_Identifier => Temp,
994 Object_Definition => New_Reference_To (Def_Id, Loc),
997 New_Reference_To (Etype (Exp), Loc)));
999 -- Copy the Comes_From_Source flag for the allocator we just
1000 -- built, since logically this allocator is a replacement of
1001 -- the original allocator node. This is for proper handling
1002 -- of restriction No_Implicit_Heap_Allocations.
1004 Set_Comes_From_Source
1005 (Expression (Temp_Decl), Comes_From_Source (N));
1007 Set_No_Initialization (Expression (Temp_Decl));
1008 Insert_Action (N, Temp_Decl);
1010 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1011 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1014 Node := Relocate_Node (N);
1015 Set_Analyzed (Node);
1018 Make_Object_Declaration (Loc,
1019 Defining_Identifier => Temp,
1020 Constant_Present => True,
1021 Object_Definition => New_Reference_To (Def_Id, Loc),
1022 Expression => Node);
1024 Insert_Action (N, Temp_Decl);
1025 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1028 -- Generate an additional object containing the address of the
1029 -- returned object. The type of this second object declaration
1030 -- is the correct type required for the common processing that
1031 -- is still performed by this subprogram. The displacement of
1032 -- this pointer to reference the component associated with the
1033 -- interface type will be done at the end of common processing.
1036 Make_Object_Declaration (Loc,
1037 Defining_Identifier => Make_Temporary (Loc, 'P'),
1038 Object_Definition => New_Reference_To (PtrT, Loc),
1040 Unchecked_Convert_To (PtrT,
1041 New_Reference_To (Temp, Loc)));
1043 Insert_Action (N, New_Decl);
1045 Temp_Decl := New_Decl;
1046 Temp := Defining_Identifier (New_Decl);
1050 Apply_Accessibility_Check (Temp);
1052 -- Generate the tag assignment
1054 -- Suppress the tag assignment when VM_Target because VM tags are
1055 -- represented implicitly in objects.
1057 if not Tagged_Type_Expansion then
1060 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1061 -- interface objects because in this case the tag does not change.
1063 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1064 pragma Assert (Is_Class_Wide_Type
1065 (Directly_Designated_Type (Etype (N))));
1068 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1070 TagR := New_Reference_To (Temp, Loc);
1072 elsif Is_Private_Type (T)
1073 and then Is_Tagged_Type (Underlying_Type (T))
1075 TagT := Underlying_Type (T);
1077 Unchecked_Convert_To (Underlying_Type (T),
1078 Make_Explicit_Dereference (Loc,
1079 Prefix => New_Reference_To (Temp, Loc)));
1082 if Present (TagT) then
1084 Full_T : constant Entity_Id := Underlying_Type (TagT);
1087 Make_Assignment_Statement (Loc,
1089 Make_Selected_Component (Loc,
1092 New_Reference_To (First_Tag_Component (Full_T), Loc)),
1094 Unchecked_Convert_To (RTE (RE_Tag),
1097 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1100 -- The previous assignment has to be done in any case
1102 Set_Assignment_OK (Name (Tag_Assign));
1103 Insert_Action (N, Tag_Assign);
1106 if Needs_Finalization (DesigT)
1107 and then Needs_Finalization (T)
1109 -- Generate an Adjust call if the object will be moved. In Ada
1110 -- 2005, the object may be inherently limited, in which case
1111 -- there is no Adjust procedure, and the object is built in
1112 -- place. In Ada 95, the object can be limited but not
1113 -- inherently limited if this allocator came from a return
1114 -- statement (we're allocating the result on the secondary
1115 -- stack). In that case, the object will be moved, so we _do_
1118 if not Aggr_In_Place
1119 and then not Is_Immutably_Limited_Type (T)
1125 -- An unchecked conversion is needed in the classwide
1126 -- case because the designated type can be an ancestor
1127 -- of the subtype mark of the allocator.
1129 Unchecked_Convert_To (T,
1130 Make_Explicit_Dereference (Loc,
1131 Prefix => New_Reference_To (Temp, Loc))),
1136 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1138 -- Since .NET/JVM compilers do not support address arithmetic,
1139 -- this call is skipped. The same is done for CodePeer because
1140 -- primitive Finalize_Address is never generated. Do not create
1141 -- this call if there is no allocator available any more.
1143 if VM_Target = No_VM
1144 and then not CodePeer_Mode
1145 and then Present (Finalization_Master (PtrT))
1146 and then Present (Temp_Decl)
1147 and then Nkind (Expression (Temp_Decl)) = N_Allocator
1150 Make_Set_Finalize_Address_Call
1157 Rewrite (N, New_Reference_To (Temp, Loc));
1158 Analyze_And_Resolve (N, PtrT);
1160 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1161 -- component containing the secondary dispatch table of the interface
1164 if Is_Interface (Directly_Designated_Type (PtrT)) then
1165 Displace_Allocator_Pointer (N);
1168 elsif Aggr_In_Place then
1169 Temp := Make_Temporary (Loc, 'P', N);
1171 Make_Object_Declaration (Loc,
1172 Defining_Identifier => Temp,
1173 Object_Definition => New_Reference_To (PtrT, Loc),
1175 Make_Allocator (Loc,
1176 Expression => New_Reference_To (Etype (Exp), Loc)));
1178 -- Copy the Comes_From_Source flag for the allocator we just built,
1179 -- since logically this allocator is a replacement of the original
1180 -- allocator node. This is for proper handling of restriction
1181 -- No_Implicit_Heap_Allocations.
1183 Set_Comes_From_Source
1184 (Expression (Temp_Decl), Comes_From_Source (N));
1186 Set_No_Initialization (Expression (Temp_Decl));
1187 Insert_Action (N, Temp_Decl);
1189 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1190 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1192 -- Attach the object to the associated finalization master. Thisis
1193 -- done manually on .NET/JVM since those compilers do no support
1194 -- pools and cannot benefit from internally generated Allocate and
1195 -- Deallocate procedures.
1197 if VM_Target /= No_VM
1198 and then Is_Controlled (DesigT)
1199 and then Present (Finalization_Master (PtrT))
1203 (Obj_Ref => New_Reference_To (Temp, Loc),
1207 Rewrite (N, New_Reference_To (Temp, Loc));
1208 Analyze_And_Resolve (N, PtrT);
1210 elsif Is_Access_Type (T)
1211 and then Can_Never_Be_Null (T)
1213 Install_Null_Excluding_Check (Exp);
1215 elsif Is_Access_Type (DesigT)
1216 and then Nkind (Exp) = N_Allocator
1217 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1219 -- Apply constraint to designated subtype indication
1221 Apply_Constraint_Check (Expression (Exp),
1222 Designated_Type (DesigT),
1223 No_Sliding => True);
1225 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1227 -- Propagate constraint_error to enclosing allocator
1229 Rewrite (Exp, New_Copy (Expression (Exp)));
1233 Build_Allocate_Deallocate_Proc (N, True);
1236 -- type A is access T1;
1237 -- X : A := new T2'(...);
1238 -- T1 and T2 can be different subtypes, and we might need to check
1239 -- both constraints. First check against the type of the qualified
1242 Apply_Constraint_Check (Exp, T, No_Sliding => True);
1244 if Do_Range_Check (Exp) then
1245 Set_Do_Range_Check (Exp, False);
1246 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1249 -- A check is also needed in cases where the designated subtype is
1250 -- constrained and differs from the subtype given in the qualified
1251 -- expression. Note that the check on the qualified expression does
1252 -- not allow sliding, but this check does (a relaxation from Ada 83).
1254 if Is_Constrained (DesigT)
1255 and then not Subtypes_Statically_Match (T, DesigT)
1257 Apply_Constraint_Check
1258 (Exp, DesigT, No_Sliding => False);
1260 if Do_Range_Check (Exp) then
1261 Set_Do_Range_Check (Exp, False);
1262 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1266 -- For an access to unconstrained packed array, GIGI needs to see an
1267 -- expression with a constrained subtype in order to compute the
1268 -- proper size for the allocator.
1270 if Is_Array_Type (T)
1271 and then not Is_Constrained (T)
1272 and then Is_Packed (T)
1275 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1276 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1279 Make_Subtype_Declaration (Loc,
1280 Defining_Identifier => ConstrT,
1281 Subtype_Indication =>
1282 Make_Subtype_From_Expr (Internal_Exp, T)));
1283 Freeze_Itype (ConstrT, Exp);
1284 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1288 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1289 -- to a build-in-place function, then access to the allocated object
1290 -- must be passed to the function. Currently we limit such functions
1291 -- to those with constrained limited result subtypes, but eventually
1292 -- we plan to expand the allowed forms of functions that are treated
1293 -- as build-in-place.
1295 if Ada_Version >= Ada_2005
1296 and then Is_Build_In_Place_Function_Call (Exp)
1298 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1303 when RE_Not_Available =>
1305 end Expand_Allocator_Expression;
1307 -----------------------------
1308 -- Expand_Array_Comparison --
1309 -----------------------------
1311 -- Expansion is only required in the case of array types. For the unpacked
1312 -- case, an appropriate runtime routine is called. For packed cases, and
1313 -- also in some other cases where a runtime routine cannot be called, the
1314 -- form of the expansion is:
1316 -- [body for greater_nn; boolean_expression]
1318 -- The body is built by Make_Array_Comparison_Op, and the form of the
1319 -- Boolean expression depends on the operator involved.
1321 procedure Expand_Array_Comparison (N : Node_Id) is
1322 Loc : constant Source_Ptr := Sloc (N);
1323 Op1 : Node_Id := Left_Opnd (N);
1324 Op2 : Node_Id := Right_Opnd (N);
1325 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1326 Ctyp : constant Entity_Id := Component_Type (Typ1);
1329 Func_Body : Node_Id;
1330 Func_Name : Entity_Id;
1334 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1335 -- True for byte addressable target
1337 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1338 -- Returns True if the length of the given operand is known to be less
1339 -- than 4. Returns False if this length is known to be four or greater
1340 -- or is not known at compile time.
1342 ------------------------
1343 -- Length_Less_Than_4 --
1344 ------------------------
1346 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1347 Otyp : constant Entity_Id := Etype (Opnd);
1350 if Ekind (Otyp) = E_String_Literal_Subtype then
1351 return String_Literal_Length (Otyp) < 4;
1355 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1356 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1357 Hi : constant Node_Id := Type_High_Bound (Ityp);
1362 if Compile_Time_Known_Value (Lo) then
1363 Lov := Expr_Value (Lo);
1368 if Compile_Time_Known_Value (Hi) then
1369 Hiv := Expr_Value (Hi);
1374 return Hiv < Lov + 3;
1377 end Length_Less_Than_4;
1379 -- Start of processing for Expand_Array_Comparison
1382 -- Deal first with unpacked case, where we can call a runtime routine
1383 -- except that we avoid this for targets for which are not addressable
1384 -- by bytes, and for the JVM/CIL, since they do not support direct
1385 -- addressing of array components.
1387 if not Is_Bit_Packed_Array (Typ1)
1388 and then Byte_Addressable
1389 and then VM_Target = No_VM
1391 -- The call we generate is:
1393 -- Compare_Array_xn[_Unaligned]
1394 -- (left'address, right'address, left'length, right'length) <op> 0
1396 -- x = U for unsigned, S for signed
1397 -- n = 8,16,32,64 for component size
1398 -- Add _Unaligned if length < 4 and component size is 8.
1399 -- <op> is the standard comparison operator
1401 if Component_Size (Typ1) = 8 then
1402 if Length_Less_Than_4 (Op1)
1404 Length_Less_Than_4 (Op2)
1406 if Is_Unsigned_Type (Ctyp) then
1407 Comp := RE_Compare_Array_U8_Unaligned;
1409 Comp := RE_Compare_Array_S8_Unaligned;
1413 if Is_Unsigned_Type (Ctyp) then
1414 Comp := RE_Compare_Array_U8;
1416 Comp := RE_Compare_Array_S8;
1420 elsif Component_Size (Typ1) = 16 then
1421 if Is_Unsigned_Type (Ctyp) then
1422 Comp := RE_Compare_Array_U16;
1424 Comp := RE_Compare_Array_S16;
1427 elsif Component_Size (Typ1) = 32 then
1428 if Is_Unsigned_Type (Ctyp) then
1429 Comp := RE_Compare_Array_U32;
1431 Comp := RE_Compare_Array_S32;
1434 else pragma Assert (Component_Size (Typ1) = 64);
1435 if Is_Unsigned_Type (Ctyp) then
1436 Comp := RE_Compare_Array_U64;
1438 Comp := RE_Compare_Array_S64;
1442 Remove_Side_Effects (Op1, Name_Req => True);
1443 Remove_Side_Effects (Op2, Name_Req => True);
1446 Make_Function_Call (Sloc (Op1),
1447 Name => New_Occurrence_Of (RTE (Comp), Loc),
1449 Parameter_Associations => New_List (
1450 Make_Attribute_Reference (Loc,
1451 Prefix => Relocate_Node (Op1),
1452 Attribute_Name => Name_Address),
1454 Make_Attribute_Reference (Loc,
1455 Prefix => Relocate_Node (Op2),
1456 Attribute_Name => Name_Address),
1458 Make_Attribute_Reference (Loc,
1459 Prefix => Relocate_Node (Op1),
1460 Attribute_Name => Name_Length),
1462 Make_Attribute_Reference (Loc,
1463 Prefix => Relocate_Node (Op2),
1464 Attribute_Name => Name_Length))));
1467 Make_Integer_Literal (Sloc (Op2),
1470 Analyze_And_Resolve (Op1, Standard_Integer);
1471 Analyze_And_Resolve (Op2, Standard_Integer);
1475 -- Cases where we cannot make runtime call
1477 -- For (a <= b) we convert to not (a > b)
1479 if Chars (N) = Name_Op_Le then
1485 Right_Opnd => Op2)));
1486 Analyze_And_Resolve (N, Standard_Boolean);
1489 -- For < the Boolean expression is
1490 -- greater__nn (op2, op1)
1492 elsif Chars (N) = Name_Op_Lt then
1493 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1497 Op1 := Right_Opnd (N);
1498 Op2 := Left_Opnd (N);
1500 -- For (a >= b) we convert to not (a < b)
1502 elsif Chars (N) = Name_Op_Ge then
1508 Right_Opnd => Op2)));
1509 Analyze_And_Resolve (N, Standard_Boolean);
1512 -- For > the Boolean expression is
1513 -- greater__nn (op1, op2)
1516 pragma Assert (Chars (N) = Name_Op_Gt);
1517 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1520 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1522 Make_Function_Call (Loc,
1523 Name => New_Reference_To (Func_Name, Loc),
1524 Parameter_Associations => New_List (Op1, Op2));
1526 Insert_Action (N, Func_Body);
1528 Analyze_And_Resolve (N, Standard_Boolean);
1531 when RE_Not_Available =>
1533 end Expand_Array_Comparison;
1535 ---------------------------
1536 -- Expand_Array_Equality --
1537 ---------------------------
1539 -- Expand an equality function for multi-dimensional arrays. Here is an
1540 -- example of such a function for Nb_Dimension = 2
1542 -- function Enn (A : atyp; B : btyp) return boolean is
1544 -- if (A'length (1) = 0 or else A'length (2) = 0)
1546 -- (B'length (1) = 0 or else B'length (2) = 0)
1548 -- return True; -- RM 4.5.2(22)
1551 -- if A'length (1) /= B'length (1)
1553 -- A'length (2) /= B'length (2)
1555 -- return False; -- RM 4.5.2(23)
1559 -- A1 : Index_T1 := A'first (1);
1560 -- B1 : Index_T1 := B'first (1);
1564 -- A2 : Index_T2 := A'first (2);
1565 -- B2 : Index_T2 := B'first (2);
1568 -- if A (A1, A2) /= B (B1, B2) then
1572 -- exit when A2 = A'last (2);
1573 -- A2 := Index_T2'succ (A2);
1574 -- B2 := Index_T2'succ (B2);
1578 -- exit when A1 = A'last (1);
1579 -- A1 := Index_T1'succ (A1);
1580 -- B1 := Index_T1'succ (B1);
1587 -- Note on the formal types used (atyp and btyp). If either of the arrays
1588 -- is of a private type, we use the underlying type, and do an unchecked
1589 -- conversion of the actual. If either of the arrays has a bound depending
1590 -- on a discriminant, then we use the base type since otherwise we have an
1591 -- escaped discriminant in the function.
1593 -- If both arrays are constrained and have the same bounds, we can generate
1594 -- a loop with an explicit iteration scheme using a 'Range attribute over
1597 function Expand_Array_Equality
1602 Typ : Entity_Id) return Node_Id
1604 Loc : constant Source_Ptr := Sloc (Nod);
1605 Decls : constant List_Id := New_List;
1606 Index_List1 : constant List_Id := New_List;
1607 Index_List2 : constant List_Id := New_List;
1611 Func_Name : Entity_Id;
1612 Func_Body : Node_Id;
1614 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1615 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1619 -- The parameter types to be used for the formals
1624 Num : Int) return Node_Id;
1625 -- This builds the attribute reference Arr'Nam (Expr)
1627 function Component_Equality (Typ : Entity_Id) return Node_Id;
1628 -- Create one statement to compare corresponding components, designated
1629 -- by a full set of indexes.
1631 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1632 -- Given one of the arguments, computes the appropriate type to be used
1633 -- for that argument in the corresponding function formal
1635 function Handle_One_Dimension
1637 Index : Node_Id) return Node_Id;
1638 -- This procedure returns the following code
1641 -- Bn : Index_T := B'First (N);
1645 -- exit when An = A'Last (N);
1646 -- An := Index_T'Succ (An)
1647 -- Bn := Index_T'Succ (Bn)
1651 -- If both indexes are constrained and identical, the procedure
1652 -- returns a simpler loop:
1654 -- for An in A'Range (N) loop
1658 -- N is the dimension for which we are generating a loop. Index is the
1659 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1660 -- xxx statement is either the loop or declare for the next dimension
1661 -- or if this is the last dimension the comparison of corresponding
1662 -- components of the arrays.
1664 -- The actual way the code works is to return the comparison of
1665 -- corresponding components for the N+1 call. That's neater!
1667 function Test_Empty_Arrays return Node_Id;
1668 -- This function constructs the test for both arrays being empty
1669 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1671 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1673 function Test_Lengths_Correspond return Node_Id;
1674 -- This function constructs the test for arrays having different lengths
1675 -- in at least one index position, in which case the resulting code is:
1677 -- A'length (1) /= B'length (1)
1679 -- A'length (2) /= B'length (2)
1690 Num : Int) return Node_Id
1694 Make_Attribute_Reference (Loc,
1695 Attribute_Name => Nam,
1696 Prefix => New_Reference_To (Arr, Loc),
1697 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1700 ------------------------
1701 -- Component_Equality --
1702 ------------------------
1704 function Component_Equality (Typ : Entity_Id) return Node_Id is
1709 -- if a(i1...) /= b(j1...) then return false; end if;
1712 Make_Indexed_Component (Loc,
1713 Prefix => Make_Identifier (Loc, Chars (A)),
1714 Expressions => Index_List1);
1717 Make_Indexed_Component (Loc,
1718 Prefix => Make_Identifier (Loc, Chars (B)),
1719 Expressions => Index_List2);
1721 Test := Expand_Composite_Equality
1722 (Nod, Component_Type (Typ), L, R, Decls);
1724 -- If some (sub)component is an unchecked_union, the whole operation
1725 -- will raise program error.
1727 if Nkind (Test) = N_Raise_Program_Error then
1729 -- This node is going to be inserted at a location where a
1730 -- statement is expected: clear its Etype so analysis will set
1731 -- it to the expected Standard_Void_Type.
1733 Set_Etype (Test, Empty);
1738 Make_Implicit_If_Statement (Nod,
1739 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1740 Then_Statements => New_List (
1741 Make_Simple_Return_Statement (Loc,
1742 Expression => New_Occurrence_Of (Standard_False, Loc))));
1744 end Component_Equality;
1750 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1761 T := Underlying_Type (T);
1763 X := First_Index (T);
1764 while Present (X) loop
1765 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1767 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1780 --------------------------
1781 -- Handle_One_Dimension --
1782 ---------------------------
1784 function Handle_One_Dimension
1786 Index : Node_Id) return Node_Id
1788 Need_Separate_Indexes : constant Boolean :=
1790 or else not Is_Constrained (Ltyp);
1791 -- If the index types are identical, and we are working with
1792 -- constrained types, then we can use the same index for both
1795 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1798 Index_T : Entity_Id;
1803 if N > Number_Dimensions (Ltyp) then
1804 return Component_Equality (Ltyp);
1807 -- Case where we generate a loop
1809 Index_T := Base_Type (Etype (Index));
1811 if Need_Separate_Indexes then
1812 Bn := Make_Temporary (Loc, 'B');
1817 Append (New_Reference_To (An, Loc), Index_List1);
1818 Append (New_Reference_To (Bn, Loc), Index_List2);
1820 Stm_List := New_List (
1821 Handle_One_Dimension (N + 1, Next_Index (Index)));
1823 if Need_Separate_Indexes then
1825 -- Generate guard for loop, followed by increments of indexes
1827 Append_To (Stm_List,
1828 Make_Exit_Statement (Loc,
1831 Left_Opnd => New_Reference_To (An, Loc),
1832 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1834 Append_To (Stm_List,
1835 Make_Assignment_Statement (Loc,
1836 Name => New_Reference_To (An, Loc),
1838 Make_Attribute_Reference (Loc,
1839 Prefix => New_Reference_To (Index_T, Loc),
1840 Attribute_Name => Name_Succ,
1841 Expressions => New_List (New_Reference_To (An, Loc)))));
1843 Append_To (Stm_List,
1844 Make_Assignment_Statement (Loc,
1845 Name => New_Reference_To (Bn, Loc),
1847 Make_Attribute_Reference (Loc,
1848 Prefix => New_Reference_To (Index_T, Loc),
1849 Attribute_Name => Name_Succ,
1850 Expressions => New_List (New_Reference_To (Bn, Loc)))));
1853 -- If separate indexes, we need a declare block for An and Bn, and a
1854 -- loop without an iteration scheme.
1856 if Need_Separate_Indexes then
1858 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1861 Make_Block_Statement (Loc,
1862 Declarations => New_List (
1863 Make_Object_Declaration (Loc,
1864 Defining_Identifier => An,
1865 Object_Definition => New_Reference_To (Index_T, Loc),
1866 Expression => Arr_Attr (A, Name_First, N)),
1868 Make_Object_Declaration (Loc,
1869 Defining_Identifier => Bn,
1870 Object_Definition => New_Reference_To (Index_T, Loc),
1871 Expression => Arr_Attr (B, Name_First, N))),
1873 Handled_Statement_Sequence =>
1874 Make_Handled_Sequence_Of_Statements (Loc,
1875 Statements => New_List (Loop_Stm)));
1877 -- If no separate indexes, return loop statement with explicit
1878 -- iteration scheme on its own
1882 Make_Implicit_Loop_Statement (Nod,
1883 Statements => Stm_List,
1885 Make_Iteration_Scheme (Loc,
1886 Loop_Parameter_Specification =>
1887 Make_Loop_Parameter_Specification (Loc,
1888 Defining_Identifier => An,
1889 Discrete_Subtype_Definition =>
1890 Arr_Attr (A, Name_Range, N))));
1893 end Handle_One_Dimension;
1895 -----------------------
1896 -- Test_Empty_Arrays --
1897 -----------------------
1899 function Test_Empty_Arrays return Node_Id is
1909 for J in 1 .. Number_Dimensions (Ltyp) loop
1912 Left_Opnd => Arr_Attr (A, Name_Length, J),
1913 Right_Opnd => Make_Integer_Literal (Loc, 0));
1917 Left_Opnd => Arr_Attr (B, Name_Length, J),
1918 Right_Opnd => Make_Integer_Literal (Loc, 0));
1927 Left_Opnd => Relocate_Node (Alist),
1928 Right_Opnd => Atest);
1932 Left_Opnd => Relocate_Node (Blist),
1933 Right_Opnd => Btest);
1940 Right_Opnd => Blist);
1941 end Test_Empty_Arrays;
1943 -----------------------------
1944 -- Test_Lengths_Correspond --
1945 -----------------------------
1947 function Test_Lengths_Correspond return Node_Id is
1953 for J in 1 .. Number_Dimensions (Ltyp) loop
1956 Left_Opnd => Arr_Attr (A, Name_Length, J),
1957 Right_Opnd => Arr_Attr (B, Name_Length, J));
1964 Left_Opnd => Relocate_Node (Result),
1965 Right_Opnd => Rtest);
1970 end Test_Lengths_Correspond;
1972 -- Start of processing for Expand_Array_Equality
1975 Ltyp := Get_Arg_Type (Lhs);
1976 Rtyp := Get_Arg_Type (Rhs);
1978 -- For now, if the argument types are not the same, go to the base type,
1979 -- since the code assumes that the formals have the same type. This is
1980 -- fixable in future ???
1982 if Ltyp /= Rtyp then
1983 Ltyp := Base_Type (Ltyp);
1984 Rtyp := Base_Type (Rtyp);
1985 pragma Assert (Ltyp = Rtyp);
1988 -- Build list of formals for function
1990 Formals := New_List (
1991 Make_Parameter_Specification (Loc,
1992 Defining_Identifier => A,
1993 Parameter_Type => New_Reference_To (Ltyp, Loc)),
1995 Make_Parameter_Specification (Loc,
1996 Defining_Identifier => B,
1997 Parameter_Type => New_Reference_To (Rtyp, Loc)));
1999 Func_Name := Make_Temporary (Loc, 'E');
2001 -- Build statement sequence for function
2004 Make_Subprogram_Body (Loc,
2006 Make_Function_Specification (Loc,
2007 Defining_Unit_Name => Func_Name,
2008 Parameter_Specifications => Formals,
2009 Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
2011 Declarations => Decls,
2013 Handled_Statement_Sequence =>
2014 Make_Handled_Sequence_Of_Statements (Loc,
2015 Statements => New_List (
2017 Make_Implicit_If_Statement (Nod,
2018 Condition => Test_Empty_Arrays,
2019 Then_Statements => New_List (
2020 Make_Simple_Return_Statement (Loc,
2022 New_Occurrence_Of (Standard_True, Loc)))),
2024 Make_Implicit_If_Statement (Nod,
2025 Condition => Test_Lengths_Correspond,
2026 Then_Statements => New_List (
2027 Make_Simple_Return_Statement (Loc,
2029 New_Occurrence_Of (Standard_False, Loc)))),
2031 Handle_One_Dimension (1, First_Index (Ltyp)),
2033 Make_Simple_Return_Statement (Loc,
2034 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2036 Set_Has_Completion (Func_Name, True);
2037 Set_Is_Inlined (Func_Name);
2039 -- If the array type is distinct from the type of the arguments, it
2040 -- is the full view of a private type. Apply an unchecked conversion
2041 -- to insure that analysis of the call succeeds.
2051 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
2053 L := OK_Convert_To (Ltyp, Lhs);
2057 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
2059 R := OK_Convert_To (Rtyp, Rhs);
2062 Actuals := New_List (L, R);
2065 Append_To (Bodies, Func_Body);
2068 Make_Function_Call (Loc,
2069 Name => New_Reference_To (Func_Name, Loc),
2070 Parameter_Associations => Actuals);
2071 end Expand_Array_Equality;
2073 -----------------------------
2074 -- Expand_Boolean_Operator --
2075 -----------------------------
2077 -- Note that we first get the actual subtypes of the operands, since we
2078 -- always want to deal with types that have bounds.
2080 procedure Expand_Boolean_Operator (N : Node_Id) is
2081 Typ : constant Entity_Id := Etype (N);
2084 -- Special case of bit packed array where both operands are known to be
2085 -- properly aligned. In this case we use an efficient run time routine
2086 -- to carry out the operation (see System.Bit_Ops).
2088 if Is_Bit_Packed_Array (Typ)
2089 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2090 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2092 Expand_Packed_Boolean_Operator (N);
2096 -- For the normal non-packed case, the general expansion is to build
2097 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2098 -- and then inserting it into the tree. The original operator node is
2099 -- then rewritten as a call to this function. We also use this in the
2100 -- packed case if either operand is a possibly unaligned object.
2103 Loc : constant Source_Ptr := Sloc (N);
2104 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2105 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
2106 Func_Body : Node_Id;
2107 Func_Name : Entity_Id;
2110 Convert_To_Actual_Subtype (L);
2111 Convert_To_Actual_Subtype (R);
2112 Ensure_Defined (Etype (L), N);
2113 Ensure_Defined (Etype (R), N);
2114 Apply_Length_Check (R, Etype (L));
2116 if Nkind (N) = N_Op_Xor then
2117 Silly_Boolean_Array_Xor_Test (N, Etype (L));
2120 if Nkind (Parent (N)) = N_Assignment_Statement
2121 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2123 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2125 elsif Nkind (Parent (N)) = N_Op_Not
2126 and then Nkind (N) = N_Op_And
2128 Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2133 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2134 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2135 Insert_Action (N, Func_Body);
2137 -- Now rewrite the expression with a call
2140 Make_Function_Call (Loc,
2141 Name => New_Reference_To (Func_Name, Loc),
2142 Parameter_Associations =>
2145 Make_Type_Conversion
2146 (Loc, New_Reference_To (Etype (L), Loc), R))));
2148 Analyze_And_Resolve (N, Typ);
2151 end Expand_Boolean_Operator;
2153 -------------------------------
2154 -- Expand_Composite_Equality --
2155 -------------------------------
2157 -- This function is only called for comparing internal fields of composite
2158 -- types when these fields are themselves composites. This is a special
2159 -- case because it is not possible to respect normal Ada visibility rules.
2161 function Expand_Composite_Equality
2166 Bodies : List_Id) return Node_Id
2168 Loc : constant Source_Ptr := Sloc (Nod);
2169 Full_Type : Entity_Id;
2173 function Find_Primitive_Eq return Node_Id;
2174 -- AI05-0123: Locate primitive equality for type if it exists, and
2175 -- build the corresponding call. If operation is abstract, replace
2176 -- call with an explicit raise. Return Empty if there is no primitive.
2178 -----------------------
2179 -- Find_Primitive_Eq --
2180 -----------------------
2182 function Find_Primitive_Eq return Node_Id is
2187 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
2188 while Present (Prim_E) loop
2189 Prim := Node (Prim_E);
2191 -- Locate primitive equality with the right signature
2193 if Chars (Prim) = Name_Op_Eq
2194 and then Etype (First_Formal (Prim)) =
2195 Etype (Next_Formal (First_Formal (Prim)))
2196 and then Etype (Prim) = Standard_Boolean
2198 if Is_Abstract_Subprogram (Prim) then
2200 Make_Raise_Program_Error (Loc,
2201 Reason => PE_Explicit_Raise);
2205 Make_Function_Call (Loc,
2206 Name => New_Reference_To (Prim, Loc),
2207 Parameter_Associations => New_List (Lhs, Rhs));
2214 -- If not found, predefined operation will be used
2217 end Find_Primitive_Eq;
2219 -- Start of processing for Expand_Composite_Equality
2222 if Is_Private_Type (Typ) then
2223 Full_Type := Underlying_Type (Typ);
2228 -- Defense against malformed private types with no completion the error
2229 -- will be diagnosed later by check_completion
2231 if No (Full_Type) then
2232 return New_Reference_To (Standard_False, Loc);
2235 Full_Type := Base_Type (Full_Type);
2237 if Is_Array_Type (Full_Type) then
2239 -- If the operand is an elementary type other than a floating-point
2240 -- type, then we can simply use the built-in block bitwise equality,
2241 -- since the predefined equality operators always apply and bitwise
2242 -- equality is fine for all these cases.
2244 if Is_Elementary_Type (Component_Type (Full_Type))
2245 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2247 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2249 -- For composite component types, and floating-point types, use the
2250 -- expansion. This deals with tagged component types (where we use
2251 -- the applicable equality routine) and floating-point, (where we
2252 -- need to worry about negative zeroes), and also the case of any
2253 -- composite type recursively containing such fields.
2256 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
2259 elsif Is_Tagged_Type (Full_Type) then
2261 -- Call the primitive operation "=" of this type
2263 if Is_Class_Wide_Type (Full_Type) then
2264 Full_Type := Root_Type (Full_Type);
2267 -- If this is derived from an untagged private type completed with a
2268 -- tagged type, it does not have a full view, so we use the primitive
2269 -- operations of the private type. This check should no longer be
2270 -- necessary when these types receive their full views ???
2272 if Is_Private_Type (Typ)
2273 and then not Is_Tagged_Type (Typ)
2274 and then not Is_Controlled (Typ)
2275 and then Is_Derived_Type (Typ)
2276 and then No (Full_View (Typ))
2278 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2280 Prim := First_Elmt (Primitive_Operations (Full_Type));
2284 Eq_Op := Node (Prim);
2285 exit when Chars (Eq_Op) = Name_Op_Eq
2286 and then Etype (First_Formal (Eq_Op)) =
2287 Etype (Next_Formal (First_Formal (Eq_Op)))
2288 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
2290 pragma Assert (Present (Prim));
2293 Eq_Op := Node (Prim);
2296 Make_Function_Call (Loc,
2297 Name => New_Reference_To (Eq_Op, Loc),
2298 Parameter_Associations =>
2300 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2301 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2303 elsif Is_Record_Type (Full_Type) then
2304 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2306 if Present (Eq_Op) then
2307 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2309 -- Inherited equality from parent type. Convert the actuals to
2310 -- match signature of operation.
2313 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2317 Make_Function_Call (Loc,
2318 Name => New_Reference_To (Eq_Op, Loc),
2319 Parameter_Associations => New_List (
2320 OK_Convert_To (T, Lhs),
2321 OK_Convert_To (T, Rhs)));
2325 -- Comparison between Unchecked_Union components
2327 if Is_Unchecked_Union (Full_Type) then
2329 Lhs_Type : Node_Id := Full_Type;
2330 Rhs_Type : Node_Id := Full_Type;
2331 Lhs_Discr_Val : Node_Id;
2332 Rhs_Discr_Val : Node_Id;
2337 if Nkind (Lhs) = N_Selected_Component then
2338 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2343 if Nkind (Rhs) = N_Selected_Component then
2344 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2347 -- Lhs of the composite equality
2349 if Is_Constrained (Lhs_Type) then
2351 -- Since the enclosing record type can never be an
2352 -- Unchecked_Union (this code is executed for records
2353 -- that do not have variants), we may reference its
2356 if Nkind (Lhs) = N_Selected_Component
2357 and then Has_Per_Object_Constraint (
2358 Entity (Selector_Name (Lhs)))
2361 Make_Selected_Component (Loc,
2362 Prefix => Prefix (Lhs),
2365 (Get_Discriminant_Value
2366 (First_Discriminant (Lhs_Type),
2368 Stored_Constraint (Lhs_Type))));
2373 (Get_Discriminant_Value
2374 (First_Discriminant (Lhs_Type),
2376 Stored_Constraint (Lhs_Type)));
2380 -- It is not possible to infer the discriminant since
2381 -- the subtype is not constrained.
2384 Make_Raise_Program_Error (Loc,
2385 Reason => PE_Unchecked_Union_Restriction);
2388 -- Rhs of the composite equality
2390 if Is_Constrained (Rhs_Type) then
2391 if Nkind (Rhs) = N_Selected_Component
2392 and then Has_Per_Object_Constraint
2393 (Entity (Selector_Name (Rhs)))
2396 Make_Selected_Component (Loc,
2397 Prefix => Prefix (Rhs),
2400 (Get_Discriminant_Value
2401 (First_Discriminant (Rhs_Type),
2403 Stored_Constraint (Rhs_Type))));
2408 (Get_Discriminant_Value
2409 (First_Discriminant (Rhs_Type),
2411 Stored_Constraint (Rhs_Type)));
2416 Make_Raise_Program_Error (Loc,
2417 Reason => PE_Unchecked_Union_Restriction);
2420 -- Call the TSS equality function with the inferred
2421 -- discriminant values.
2424 Make_Function_Call (Loc,
2425 Name => New_Reference_To (Eq_Op, Loc),
2426 Parameter_Associations => New_List (
2435 Make_Function_Call (Loc,
2436 Name => New_Reference_To (Eq_Op, Loc),
2437 Parameter_Associations => New_List (Lhs, Rhs));
2441 elsif Ada_Version >= Ada_2012 then
2443 -- if no TSS has been created for the type, check whether there is
2444 -- a primitive equality declared for it.
2447 Ada_2012_Op : constant Node_Id := Find_Primitive_Eq;
2450 if Present (Ada_2012_Op) then
2454 -- Use predefined equality if no user-defined primitive exists
2456 return Make_Op_Eq (Loc, Lhs, Rhs);
2461 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2465 -- If not array or record type, it is predefined equality.
2467 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2469 end Expand_Composite_Equality;
2471 ------------------------
2472 -- Expand_Concatenate --
2473 ------------------------
2475 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2476 Loc : constant Source_Ptr := Sloc (Cnode);
2478 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2479 -- Result type of concatenation
2481 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2482 -- Component type. Elements of this component type can appear as one
2483 -- of the operands of concatenation as well as arrays.
2485 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2488 Ityp : constant Entity_Id := Base_Type (Istyp);
2489 -- Index type. This is the base type of the index subtype, and is used
2490 -- for all computed bounds (which may be out of range of Istyp in the
2491 -- case of null ranges).
2494 -- This is the type we use to do arithmetic to compute the bounds and
2495 -- lengths of operands. The choice of this type is a little subtle and
2496 -- is discussed in a separate section at the start of the body code.
2498 Concatenation_Error : exception;
2499 -- Raised if concatenation is sure to raise a CE
2501 Result_May_Be_Null : Boolean := True;
2502 -- Reset to False if at least one operand is encountered which is known
2503 -- at compile time to be non-null. Used for handling the special case
2504 -- of setting the high bound to the last operand high bound for a null
2505 -- result, thus ensuring a proper high bound in the super-flat case.
2507 N : constant Nat := List_Length (Opnds);
2508 -- Number of concatenation operands including possibly null operands
2511 -- Number of operands excluding any known to be null, except that the
2512 -- last operand is always retained, in case it provides the bounds for
2516 -- Current operand being processed in the loop through operands. After
2517 -- this loop is complete, always contains the last operand (which is not
2518 -- the same as Operands (NN), since null operands are skipped).
2520 -- Arrays describing the operands, only the first NN entries of each
2521 -- array are set (NN < N when we exclude known null operands).
2523 Is_Fixed_Length : array (1 .. N) of Boolean;
2524 -- True if length of corresponding operand known at compile time
2526 Operands : array (1 .. N) of Node_Id;
2527 -- Set to the corresponding entry in the Opnds list (but note that null
2528 -- operands are excluded, so not all entries in the list are stored).
2530 Fixed_Length : array (1 .. N) of Uint;
2531 -- Set to length of operand. Entries in this array are set only if the
2532 -- corresponding entry in Is_Fixed_Length is True.
2534 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2535 -- Set to lower bound of operand. Either an integer literal in the case
2536 -- where the bound is known at compile time, else actual lower bound.
2537 -- The operand low bound is of type Ityp.
2539 Var_Length : array (1 .. N) of Entity_Id;
2540 -- Set to an entity of type Natural that contains the length of an
2541 -- operand whose length is not known at compile time. Entries in this
2542 -- array are set only if the corresponding entry in Is_Fixed_Length
2543 -- is False. The entity is of type Artyp.
2545 Aggr_Length : array (0 .. N) of Node_Id;
2546 -- The J'th entry in an expression node that represents the total length
2547 -- of operands 1 through J. It is either an integer literal node, or a
2548 -- reference to a constant entity with the right value, so it is fine
2549 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2550 -- entry always is set to zero. The length is of type Artyp.
2552 Low_Bound : Node_Id;
2553 -- A tree node representing the low bound of the result (of type Ityp).
2554 -- This is either an integer literal node, or an identifier reference to
2555 -- a constant entity initialized to the appropriate value.
2557 Last_Opnd_High_Bound : Node_Id;
2558 -- A tree node representing the high bound of the last operand. This
2559 -- need only be set if the result could be null. It is used for the
2560 -- special case of setting the right high bound for a null result.
2561 -- This is of type Ityp.
2563 High_Bound : Node_Id;
2564 -- A tree node representing the high bound of the result (of type Ityp)
2567 -- Result of the concatenation (of type Ityp)
2569 Actions : constant List_Id := New_List;
2570 -- Collect actions to be inserted if Save_Space is False
2572 Save_Space : Boolean;
2573 pragma Warnings (Off, Save_Space);
2574 -- Set to True if we are saving generated code space by calling routines
2575 -- in packages System.Concat_n.
2577 Known_Non_Null_Operand_Seen : Boolean;
2578 -- Set True during generation of the assignments of operands into
2579 -- result once an operand known to be non-null has been seen.
2581 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2582 -- This function makes an N_Integer_Literal node that is returned in
2583 -- analyzed form with the type set to Artyp. Importantly this literal
2584 -- is not flagged as static, so that if we do computations with it that
2585 -- result in statically detected out of range conditions, we will not
2586 -- generate error messages but instead warning messages.
2588 function To_Artyp (X : Node_Id) return Node_Id;
2589 -- Given a node of type Ityp, returns the corresponding value of type
2590 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2591 -- For enum types, the Pos of the value is returned.
2593 function To_Ityp (X : Node_Id) return Node_Id;
2594 -- The inverse function (uses Val in the case of enumeration types)
2596 ------------------------
2597 -- Make_Artyp_Literal --
2598 ------------------------
2600 function Make_Artyp_Literal (Val : Nat) return Node_Id is
2601 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2603 Set_Etype (Result, Artyp);
2604 Set_Analyzed (Result, True);
2605 Set_Is_Static_Expression (Result, False);
2607 end Make_Artyp_Literal;
2613 function To_Artyp (X : Node_Id) return Node_Id is
2615 if Ityp = Base_Type (Artyp) then
2618 elsif Is_Enumeration_Type (Ityp) then
2620 Make_Attribute_Reference (Loc,
2621 Prefix => New_Occurrence_Of (Ityp, Loc),
2622 Attribute_Name => Name_Pos,
2623 Expressions => New_List (X));
2626 return Convert_To (Artyp, X);
2634 function To_Ityp (X : Node_Id) return Node_Id is
2636 if Is_Enumeration_Type (Ityp) then
2638 Make_Attribute_Reference (Loc,
2639 Prefix => New_Occurrence_Of (Ityp, Loc),
2640 Attribute_Name => Name_Val,
2641 Expressions => New_List (X));
2643 -- Case where we will do a type conversion
2646 if Ityp = Base_Type (Artyp) then
2649 return Convert_To (Ityp, X);
2654 -- Local Declarations
2656 Opnd_Typ : Entity_Id;
2663 -- Start of processing for Expand_Concatenate
2666 -- Choose an appropriate computational type
2668 -- We will be doing calculations of lengths and bounds in this routine
2669 -- and computing one from the other in some cases, e.g. getting the high
2670 -- bound by adding the length-1 to the low bound.
2672 -- We can't just use the index type, or even its base type for this
2673 -- purpose for two reasons. First it might be an enumeration type which
2674 -- is not suitable for computations of any kind, and second it may
2675 -- simply not have enough range. For example if the index type is
2676 -- -128..+127 then lengths can be up to 256, which is out of range of
2679 -- For enumeration types, we can simply use Standard_Integer, this is
2680 -- sufficient since the actual number of enumeration literals cannot
2681 -- possibly exceed the range of integer (remember we will be doing the
2682 -- arithmetic with POS values, not representation values).
2684 if Is_Enumeration_Type (Ityp) then
2685 Artyp := Standard_Integer;
2687 -- If index type is Positive, we use the standard unsigned type, to give
2688 -- more room on the top of the range, obviating the need for an overflow
2689 -- check when creating the upper bound. This is needed to avoid junk
2690 -- overflow checks in the common case of String types.
2692 -- ??? Disabled for now
2694 -- elsif Istyp = Standard_Positive then
2695 -- Artyp := Standard_Unsigned;
2697 -- For modular types, we use a 32-bit modular type for types whose size
2698 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2699 -- identity type, and for larger unsigned types we use 64-bits.
2701 elsif Is_Modular_Integer_Type (Ityp) then
2702 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
2703 Artyp := Standard_Unsigned;
2704 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
2707 Artyp := RTE (RE_Long_Long_Unsigned);
2710 -- Similar treatment for signed types
2713 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
2714 Artyp := Standard_Integer;
2715 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
2718 Artyp := Standard_Long_Long_Integer;
2722 -- Supply dummy entry at start of length array
2724 Aggr_Length (0) := Make_Artyp_Literal (0);
2726 -- Go through operands setting up the above arrays
2730 Opnd := Remove_Head (Opnds);
2731 Opnd_Typ := Etype (Opnd);
2733 -- The parent got messed up when we put the operands in a list,
2734 -- so now put back the proper parent for the saved operand, that
2735 -- is to say the concatenation node, to make sure that each operand
2736 -- is seen as a subexpression, e.g. if actions must be inserted.
2738 Set_Parent (Opnd, Cnode);
2740 -- Set will be True when we have setup one entry in the array
2744 -- Singleton element (or character literal) case
2746 if Base_Type (Opnd_Typ) = Ctyp then
2748 Operands (NN) := Opnd;
2749 Is_Fixed_Length (NN) := True;
2750 Fixed_Length (NN) := Uint_1;
2751 Result_May_Be_Null := False;
2753 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2754 -- since we know that the result cannot be null).
2756 Opnd_Low_Bound (NN) :=
2757 Make_Attribute_Reference (Loc,
2758 Prefix => New_Reference_To (Istyp, Loc),
2759 Attribute_Name => Name_First);
2763 -- String literal case (can only occur for strings of course)
2765 elsif Nkind (Opnd) = N_String_Literal then
2766 Len := String_Literal_Length (Opnd_Typ);
2769 Result_May_Be_Null := False;
2772 -- Capture last operand high bound if result could be null
2774 if J = N and then Result_May_Be_Null then
2775 Last_Opnd_High_Bound :=
2778 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
2779 Right_Opnd => Make_Integer_Literal (Loc, 1));
2782 -- Skip null string literal
2784 if J < N and then Len = 0 then
2789 Operands (NN) := Opnd;
2790 Is_Fixed_Length (NN) := True;
2792 -- Set length and bounds
2794 Fixed_Length (NN) := Len;
2796 Opnd_Low_Bound (NN) :=
2797 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
2804 -- Check constrained case with known bounds
2806 if Is_Constrained (Opnd_Typ) then
2808 Index : constant Node_Id := First_Index (Opnd_Typ);
2809 Indx_Typ : constant Entity_Id := Etype (Index);
2810 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
2811 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
2814 -- Fixed length constrained array type with known at compile
2815 -- time bounds is last case of fixed length operand.
2817 if Compile_Time_Known_Value (Lo)
2819 Compile_Time_Known_Value (Hi)
2822 Loval : constant Uint := Expr_Value (Lo);
2823 Hival : constant Uint := Expr_Value (Hi);
2824 Len : constant Uint :=
2825 UI_Max (Hival - Loval + 1, Uint_0);
2829 Result_May_Be_Null := False;
2832 -- Capture last operand bound if result could be null
2834 if J = N and then Result_May_Be_Null then
2835 Last_Opnd_High_Bound :=
2837 Make_Integer_Literal (Loc, Expr_Value (Hi)));
2840 -- Exclude null length case unless last operand
2842 if J < N and then Len = 0 then
2847 Operands (NN) := Opnd;
2848 Is_Fixed_Length (NN) := True;
2849 Fixed_Length (NN) := Len;
2851 Opnd_Low_Bound (NN) :=
2853 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
2860 -- All cases where the length is not known at compile time, or the
2861 -- special case of an operand which is known to be null but has a
2862 -- lower bound other than 1 or is other than a string type.
2867 -- Capture operand bounds
2869 Opnd_Low_Bound (NN) :=
2870 Make_Attribute_Reference (Loc,
2872 Duplicate_Subexpr (Opnd, Name_Req => True),
2873 Attribute_Name => Name_First);
2875 if J = N and Result_May_Be_Null then
2876 Last_Opnd_High_Bound :=
2878 Make_Attribute_Reference (Loc,
2880 Duplicate_Subexpr (Opnd, Name_Req => True),
2881 Attribute_Name => Name_Last));
2884 -- Capture length of operand in entity
2886 Operands (NN) := Opnd;
2887 Is_Fixed_Length (NN) := False;
2889 Var_Length (NN) := Make_Temporary (Loc, 'L');
2892 Make_Object_Declaration (Loc,
2893 Defining_Identifier => Var_Length (NN),
2894 Constant_Present => True,
2895 Object_Definition => New_Occurrence_Of (Artyp, Loc),
2897 Make_Attribute_Reference (Loc,
2899 Duplicate_Subexpr (Opnd, Name_Req => True),
2900 Attribute_Name => Name_Length)));
2904 -- Set next entry in aggregate length array
2906 -- For first entry, make either integer literal for fixed length
2907 -- or a reference to the saved length for variable length.
2910 if Is_Fixed_Length (1) then
2911 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
2913 Aggr_Length (1) := New_Reference_To (Var_Length (1), Loc);
2916 -- If entry is fixed length and only fixed lengths so far, make
2917 -- appropriate new integer literal adding new length.
2919 elsif Is_Fixed_Length (NN)
2920 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
2923 Make_Integer_Literal (Loc,
2924 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
2926 -- All other cases, construct an addition node for the length and
2927 -- create an entity initialized to this length.
2930 Ent := Make_Temporary (Loc, 'L');
2932 if Is_Fixed_Length (NN) then
2933 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
2935 Clen := New_Reference_To (Var_Length (NN), Loc);
2939 Make_Object_Declaration (Loc,
2940 Defining_Identifier => Ent,
2941 Constant_Present => True,
2942 Object_Definition => New_Occurrence_Of (Artyp, Loc),
2945 Left_Opnd => New_Copy (Aggr_Length (NN - 1)),
2946 Right_Opnd => Clen)));
2948 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
2955 -- If we have only skipped null operands, return the last operand
2962 -- If we have only one non-null operand, return it and we are done.
2963 -- There is one case in which this cannot be done, and that is when
2964 -- the sole operand is of the element type, in which case it must be
2965 -- converted to an array, and the easiest way of doing that is to go
2966 -- through the normal general circuit.
2969 and then Base_Type (Etype (Operands (1))) /= Ctyp
2971 Result := Operands (1);
2975 -- Cases where we have a real concatenation
2977 -- Next step is to find the low bound for the result array that we
2978 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
2980 -- If the ultimate ancestor of the index subtype is a constrained array
2981 -- definition, then the lower bound is that of the index subtype as
2982 -- specified by (RM 4.5.3(6)).
2984 -- The right test here is to go to the root type, and then the ultimate
2985 -- ancestor is the first subtype of this root type.
2987 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
2989 Make_Attribute_Reference (Loc,
2991 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
2992 Attribute_Name => Name_First);
2994 -- If the first operand in the list has known length we know that
2995 -- the lower bound of the result is the lower bound of this operand.
2997 elsif Is_Fixed_Length (1) then
2998 Low_Bound := Opnd_Low_Bound (1);
3000 -- OK, we don't know the lower bound, we have to build a horrible
3001 -- expression actions node of the form
3003 -- if Cond1'Length /= 0 then
3006 -- if Opnd2'Length /= 0 then
3011 -- The nesting ends either when we hit an operand whose length is known
3012 -- at compile time, or on reaching the last operand, whose low bound we
3013 -- take unconditionally whether or not it is null. It's easiest to do
3014 -- this with a recursive procedure:
3018 function Get_Known_Bound (J : Nat) return Node_Id;
3019 -- Returns the lower bound determined by operands J .. NN
3021 ---------------------
3022 -- Get_Known_Bound --
3023 ---------------------
3025 function Get_Known_Bound (J : Nat) return Node_Id is
3027 if Is_Fixed_Length (J) or else J = NN then
3028 return New_Copy (Opnd_Low_Bound (J));
3032 Make_Conditional_Expression (Loc,
3033 Expressions => New_List (
3036 Left_Opnd => New_Reference_To (Var_Length (J), Loc),
3037 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3039 New_Copy (Opnd_Low_Bound (J)),
3040 Get_Known_Bound (J + 1)));
3042 end Get_Known_Bound;
3045 Ent := Make_Temporary (Loc, 'L');
3048 Make_Object_Declaration (Loc,
3049 Defining_Identifier => Ent,
3050 Constant_Present => True,
3051 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3052 Expression => Get_Known_Bound (1)));
3054 Low_Bound := New_Reference_To (Ent, Loc);
3058 -- Now we can safely compute the upper bound, normally
3059 -- Low_Bound + Length - 1.
3064 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3066 Make_Op_Subtract (Loc,
3067 Left_Opnd => New_Copy (Aggr_Length (NN)),
3068 Right_Opnd => Make_Artyp_Literal (1))));
3070 -- Note that calculation of the high bound may cause overflow in some
3071 -- very weird cases, so in the general case we need an overflow check on
3072 -- the high bound. We can avoid this for the common case of string types
3073 -- and other types whose index is Positive, since we chose a wider range
3074 -- for the arithmetic type.
3076 if Istyp /= Standard_Positive then
3077 Activate_Overflow_Check (High_Bound);
3080 -- Handle the exceptional case where the result is null, in which case
3081 -- case the bounds come from the last operand (so that we get the proper
3082 -- bounds if the last operand is super-flat).
3084 if Result_May_Be_Null then
3086 Make_Conditional_Expression (Loc,
3087 Expressions => New_List (
3089 Left_Opnd => New_Copy (Aggr_Length (NN)),
3090 Right_Opnd => Make_Artyp_Literal (0)),
3091 Last_Opnd_High_Bound,
3095 -- Here is where we insert the saved up actions
3097 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3099 -- Now we construct an array object with appropriate bounds. We mark
3100 -- the target as internal to prevent useless initialization when
3101 -- Initialize_Scalars is enabled. Also since this is the actual result
3102 -- entity, we make sure we have debug information for the result.
3104 Ent := Make_Temporary (Loc, 'S');
3105 Set_Is_Internal (Ent);
3106 Set_Needs_Debug_Info (Ent);
3108 -- If the bound is statically known to be out of range, we do not want
3109 -- to abort, we want a warning and a runtime constraint error. Note that
3110 -- we have arranged that the result will not be treated as a static
3111 -- constant, so we won't get an illegality during this insertion.
3113 Insert_Action (Cnode,
3114 Make_Object_Declaration (Loc,
3115 Defining_Identifier => Ent,
3116 Object_Definition =>
3117 Make_Subtype_Indication (Loc,
3118 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3120 Make_Index_Or_Discriminant_Constraint (Loc,
3121 Constraints => New_List (
3123 Low_Bound => Low_Bound,
3124 High_Bound => High_Bound))))),
3125 Suppress => All_Checks);
3127 -- If the result of the concatenation appears as the initializing
3128 -- expression of an object declaration, we can just rename the
3129 -- result, rather than copying it.
3131 Set_OK_To_Rename (Ent);
3133 -- Catch the static out of range case now
3135 if Raises_Constraint_Error (High_Bound) then
3136 raise Concatenation_Error;
3139 -- Now we will generate the assignments to do the actual concatenation
3141 -- There is one case in which we will not do this, namely when all the
3142 -- following conditions are met:
3144 -- The result type is Standard.String
3146 -- There are nine or fewer retained (non-null) operands
3148 -- The optimization level is -O0
3150 -- The corresponding System.Concat_n.Str_Concat_n routine is
3151 -- available in the run time.
3153 -- The debug flag gnatd.c is not set
3155 -- If all these conditions are met then we generate a call to the
3156 -- relevant concatenation routine. The purpose of this is to avoid
3157 -- undesirable code bloat at -O0.
3159 if Atyp = Standard_String
3160 and then NN in 2 .. 9
3161 and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3162 and then not Debug_Flag_Dot_C
3165 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3176 if RTE_Available (RR (NN)) then
3178 Opnds : constant List_Id :=
3179 New_List (New_Occurrence_Of (Ent, Loc));
3182 for J in 1 .. NN loop
3183 if Is_List_Member (Operands (J)) then
3184 Remove (Operands (J));
3187 if Base_Type (Etype (Operands (J))) = Ctyp then
3189 Make_Aggregate (Loc,
3190 Component_Associations => New_List (
3191 Make_Component_Association (Loc,
3192 Choices => New_List (
3193 Make_Integer_Literal (Loc, 1)),
3194 Expression => Operands (J)))));
3197 Append_To (Opnds, Operands (J));
3201 Insert_Action (Cnode,
3202 Make_Procedure_Call_Statement (Loc,
3203 Name => New_Reference_To (RTE (RR (NN)), Loc),
3204 Parameter_Associations => Opnds));
3206 Result := New_Reference_To (Ent, Loc);
3213 -- Not special case so generate the assignments
3215 Known_Non_Null_Operand_Seen := False;
3217 for J in 1 .. NN loop
3219 Lo : constant Node_Id :=
3221 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3222 Right_Opnd => Aggr_Length (J - 1));
3224 Hi : constant Node_Id :=
3226 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3228 Make_Op_Subtract (Loc,
3229 Left_Opnd => Aggr_Length (J),
3230 Right_Opnd => Make_Artyp_Literal (1)));
3233 -- Singleton case, simple assignment
3235 if Base_Type (Etype (Operands (J))) = Ctyp then
3236 Known_Non_Null_Operand_Seen := True;
3237 Insert_Action (Cnode,
3238 Make_Assignment_Statement (Loc,
3240 Make_Indexed_Component (Loc,
3241 Prefix => New_Occurrence_Of (Ent, Loc),
3242 Expressions => New_List (To_Ityp (Lo))),
3243 Expression => Operands (J)),
3244 Suppress => All_Checks);
3246 -- Array case, slice assignment, skipped when argument is fixed
3247 -- length and known to be null.
3249 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3252 Make_Assignment_Statement (Loc,
3256 New_Occurrence_Of (Ent, Loc),
3259 Low_Bound => To_Ityp (Lo),
3260 High_Bound => To_Ityp (Hi))),
3261 Expression => Operands (J));
3263 if Is_Fixed_Length (J) then
3264 Known_Non_Null_Operand_Seen := True;
3266 elsif not Known_Non_Null_Operand_Seen then
3268 -- Here if operand length is not statically known and no
3269 -- operand known to be non-null has been processed yet.
3270 -- If operand length is 0, we do not need to perform the
3271 -- assignment, and we must avoid the evaluation of the
3272 -- high bound of the slice, since it may underflow if the
3273 -- low bound is Ityp'First.
3276 Make_Implicit_If_Statement (Cnode,
3280 New_Occurrence_Of (Var_Length (J), Loc),
3281 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3282 Then_Statements => New_List (Assign));
3285 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3291 -- Finally we build the result, which is a reference to the array object
3293 Result := New_Reference_To (Ent, Loc);
3296 Rewrite (Cnode, Result);
3297 Analyze_And_Resolve (Cnode, Atyp);
3300 when Concatenation_Error =>
3302 -- Kill warning generated for the declaration of the static out of
3303 -- range high bound, and instead generate a Constraint_Error with
3304 -- an appropriate specific message.
3306 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3307 Apply_Compile_Time_Constraint_Error
3309 Msg => "concatenation result upper bound out of range?",
3310 Reason => CE_Range_Check_Failed);
3311 -- Set_Etype (Cnode, Atyp);
3312 end Expand_Concatenate;
3314 ------------------------
3315 -- Expand_N_Allocator --
3316 ------------------------
3318 procedure Expand_N_Allocator (N : Node_Id) is
3319 PtrT : constant Entity_Id := Etype (N);
3320 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
3321 Etyp : constant Entity_Id := Etype (Expression (N));
3322 Loc : constant Source_Ptr := Sloc (N);
3328 procedure Rewrite_Coextension (N : Node_Id);
3329 -- Static coextensions have the same lifetime as the entity they
3330 -- constrain. Such occurrences can be rewritten as aliased objects
3331 -- and their unrestricted access used instead of the coextension.
3333 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
3334 -- Given a constrained array type E, returns a node representing the
3335 -- code to compute the size in storage elements for the given type.
3336 -- This is done without using the attribute (which malfunctions for
3339 -------------------------
3340 -- Rewrite_Coextension --
3341 -------------------------
3343 procedure Rewrite_Coextension (N : Node_Id) is
3344 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
3345 Temp_Decl : Node_Id;
3346 Insert_Nod : Node_Id;
3350 -- Cnn : aliased Etyp;
3353 Make_Object_Declaration (Loc,
3354 Defining_Identifier => Temp_Id,
3355 Aliased_Present => True,
3356 Object_Definition => New_Occurrence_Of (Etyp, Loc));
3358 if Nkind (Expression (N)) = N_Qualified_Expression then
3359 Set_Expression (Temp_Decl, Expression (Expression (N)));
3362 -- Find the proper insertion node for the declaration
3364 Insert_Nod := Parent (N);
3365 while Present (Insert_Nod) loop
3367 Nkind (Insert_Nod) in N_Statement_Other_Than_Procedure_Call
3368 or else Nkind (Insert_Nod) = N_Procedure_Call_Statement
3369 or else Nkind (Insert_Nod) in N_Declaration;
3371 Insert_Nod := Parent (Insert_Nod);
3374 Insert_Before (Insert_Nod, Temp_Decl);
3375 Analyze (Temp_Decl);
3378 Make_Attribute_Reference (Loc,
3379 Prefix => New_Occurrence_Of (Temp_Id, Loc),
3380 Attribute_Name => Name_Unrestricted_Access));
3382 Analyze_And_Resolve (N, PtrT);
3383 end Rewrite_Coextension;
3385 ------------------------------
3386 -- Size_In_Storage_Elements --
3387 ------------------------------
3389 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
3391 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3392 -- However, the reason for the existence of this function is
3393 -- to construct a test for sizes too large, which means near the
3394 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3395 -- is that we get overflows when sizes are greater than 2**31.
3397 -- So what we end up doing for array types is to use the expression:
3399 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3401 -- which avoids this problem. All this is a bit bogus, but it does
3402 -- mean we catch common cases of trying to allocate arrays that
3403 -- are too large, and which in the absence of a check results in
3404 -- undetected chaos ???
3411 for J in 1 .. Number_Dimensions (E) loop
3413 Make_Attribute_Reference (Loc,
3414 Prefix => New_Occurrence_Of (E, Loc),
3415 Attribute_Name => Name_Length,
3416 Expressions => New_List (Make_Integer_Literal (Loc, J)));
3423 Make_Op_Multiply (Loc,
3430 Make_Op_Multiply (Loc,
3433 Make_Attribute_Reference (Loc,
3434 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
3435 Attribute_Name => Name_Max_Size_In_Storage_Elements));
3437 end Size_In_Storage_Elements;
3439 -- Start of processing for Expand_N_Allocator
3442 -- RM E.2.3(22). We enforce that the expected type of an allocator
3443 -- shall not be a remote access-to-class-wide-limited-private type
3445 -- Why is this being done at expansion time, seems clearly wrong ???
3447 Validate_Remote_Access_To_Class_Wide_Type (N);
3449 -- Processing for anonymous access-to-controlled types. These access
3450 -- types receive a special finalization master which appears in the
3451 -- declarations of the enclosing semantic unit. This expansion is done
3452 -- now to ensure that any additional types generated by this routine
3453 -- or Expand_Allocator_Expression inherit the proper type attributes.
3455 if Ekind (PtrT) = E_Anonymous_Access_Type
3456 and then Needs_Finalization (Dtyp)
3458 -- Anonymous access-to-controlled types allocate on the global pool.
3459 -- Do not set this attribute on .NET/JVM since those targets do not
3462 if No (Associated_Storage_Pool (PtrT))
3463 and then VM_Target = No_VM
3465 Set_Associated_Storage_Pool
3466 (PtrT, Get_Global_Pool_For_Access_Type (PtrT));
3469 -- The finalization master must be inserted and analyzed as part of
3470 -- the current semantic unit.
3472 if No (Finalization_Master (PtrT)) then
3473 Set_Finalization_Master (PtrT, Current_Anonymous_Master);
3477 -- Set the storage pool and find the appropriate version of Allocate to
3480 Pool := Associated_Storage_Pool (Root_Type (PtrT));
3481 Set_Storage_Pool (N, Pool);
3483 if Present (Pool) then
3484 if Is_RTE (Pool, RE_SS_Pool) then
3485 if VM_Target = No_VM then
3486 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
3489 elsif Is_Class_Wide_Type (Etype (Pool)) then
3490 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
3493 Set_Procedure_To_Call (N,
3494 Find_Prim_Op (Etype (Pool), Name_Allocate));
3498 -- Under certain circumstances we can replace an allocator by an access
3499 -- to statically allocated storage. The conditions, as noted in AARM
3500 -- 3.10 (10c) are as follows:
3502 -- Size and initial value is known at compile time
3503 -- Access type is access-to-constant
3505 -- The allocator is not part of a constraint on a record component,
3506 -- because in that case the inserted actions are delayed until the
3507 -- record declaration is fully analyzed, which is too late for the
3508 -- analysis of the rewritten allocator.
3510 if Is_Access_Constant (PtrT)
3511 and then Nkind (Expression (N)) = N_Qualified_Expression
3512 and then Compile_Time_Known_Value (Expression (Expression (N)))
3513 and then Size_Known_At_Compile_Time
3514 (Etype (Expression (Expression (N))))
3515 and then not Is_Record_Type (Current_Scope)
3517 -- Here we can do the optimization. For the allocator
3521 -- We insert an object declaration
3523 -- Tnn : aliased x := y;
3525 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3526 -- marked as requiring static allocation.
3528 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
3529 Desig := Subtype_Mark (Expression (N));
3531 -- If context is constrained, use constrained subtype directly,
3532 -- so that the constant is not labelled as having a nominally
3533 -- unconstrained subtype.
3535 if Entity (Desig) = Base_Type (Dtyp) then
3536 Desig := New_Occurrence_Of (Dtyp, Loc);
3540 Make_Object_Declaration (Loc,
3541 Defining_Identifier => Temp,
3542 Aliased_Present => True,
3543 Constant_Present => Is_Access_Constant (PtrT),
3544 Object_Definition => Desig,
3545 Expression => Expression (Expression (N))));
3548 Make_Attribute_Reference (Loc,
3549 Prefix => New_Occurrence_Of (Temp, Loc),
3550 Attribute_Name => Name_Unrestricted_Access));
3552 Analyze_And_Resolve (N, PtrT);
3554 -- We set the variable as statically allocated, since we don't want
3555 -- it going on the stack of the current procedure!
3557 Set_Is_Statically_Allocated (Temp);
3561 -- Same if the allocator is an access discriminant for a local object:
3562 -- instead of an allocator we create a local value and constrain the
3563 -- enclosing object with the corresponding access attribute.
3565 if Is_Static_Coextension (N) then
3566 Rewrite_Coextension (N);
3570 -- Check for size too large, we do this because the back end misses
3571 -- proper checks here and can generate rubbish allocation calls when
3572 -- we are near the limit. We only do this for the 32-bit address case
3573 -- since that is from a practical point of view where we see a problem.
3575 if System_Address_Size = 32
3576 and then not Storage_Checks_Suppressed (PtrT)
3577 and then not Storage_Checks_Suppressed (Dtyp)
3578 and then not Storage_Checks_Suppressed (Etyp)
3580 -- The check we want to generate should look like
3582 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
3583 -- raise Storage_Error;
3586 -- where 3.5 gigabytes is a constant large enough to accommodate any
3587 -- reasonable request for. But we can't do it this way because at
3588 -- least at the moment we don't compute this attribute right, and
3589 -- can silently give wrong results when the result gets large. Since
3590 -- this is all about large results, that's bad, so instead we only
3591 -- apply the check for constrained arrays, and manually compute the
3592 -- value of the attribute ???
3594 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
3596 Make_Raise_Storage_Error (Loc,
3599 Left_Opnd => Size_In_Storage_Elements (Etyp),
3601 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
3602 Reason => SE_Object_Too_Large));
3606 -- Handle case of qualified expression (other than optimization above)
3607 -- First apply constraint checks, because the bounds or discriminants
3608 -- in the aggregate might not match the subtype mark in the allocator.
3610 if Nkind (Expression (N)) = N_Qualified_Expression then
3611 Apply_Constraint_Check
3612 (Expression (Expression (N)), Etype (Expression (N)));
3614 Expand_Allocator_Expression (N);
3618 -- If the allocator is for a type which requires initialization, and
3619 -- there is no initial value (i.e. operand is a subtype indication
3620 -- rather than a qualified expression), then we must generate a call to
3621 -- the initialization routine using an expressions action node:
3623 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3625 -- Here ptr_T is the pointer type for the allocator, and T is the
3626 -- subtype of the allocator. A special case arises if the designated
3627 -- type of the access type is a task or contains tasks. In this case
3628 -- the call to Init (Temp.all ...) is replaced by code that ensures
3629 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3630 -- for details). In addition, if the type T is a task T, then the
3631 -- first argument to Init must be converted to the task record type.
3634 T : constant Entity_Id := Entity (Expression (N));
3640 Init_Arg1 : Node_Id;
3641 Temp_Decl : Node_Id;
3642 Temp_Type : Entity_Id;
3645 if No_Initialization (N) then
3647 -- Even though this might be a simple allocation, create a custom
3648 -- Allocate if the context requires it. Since .NET/JVM compilers
3649 -- do not support pools, this step is skipped.
3651 if VM_Target = No_VM
3652 and then Present (Finalization_Master (PtrT))
3654 Build_Allocate_Deallocate_Proc
3656 Is_Allocate => True);
3659 -- Case of no initialization procedure present
3661 elsif not Has_Non_Null_Base_Init_Proc (T) then
3663 -- Case of simple initialization required
3665 if Needs_Simple_Initialization (T) then
3666 Check_Restriction (No_Default_Initialization, N);
3667 Rewrite (Expression (N),
3668 Make_Qualified_Expression (Loc,
3669 Subtype_Mark => New_Occurrence_Of (T, Loc),
3670 Expression => Get_Simple_Init_Val (T, N)));
3672 Analyze_And_Resolve (Expression (Expression (N)), T);
3673 Analyze_And_Resolve (Expression (N), T);
3674 Set_Paren_Count (Expression (Expression (N)), 1);
3675 Expand_N_Allocator (N);
3677 -- No initialization required
3683 -- Case of initialization procedure present, must be called
3686 Check_Restriction (No_Default_Initialization, N);
3688 if not Restriction_Active (No_Default_Initialization) then
3689 Init := Base_Init_Proc (T);
3691 Temp := Make_Temporary (Loc, 'P');
3693 -- Construct argument list for the initialization routine call
3696 Make_Explicit_Dereference (Loc,
3698 New_Reference_To (Temp, Loc));
3700 Set_Assignment_OK (Init_Arg1);
3703 -- The initialization procedure expects a specific type. if the
3704 -- context is access to class wide, indicate that the object
3705 -- being allocated has the right specific type.
3707 if Is_Class_Wide_Type (Dtyp) then
3708 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
3711 -- If designated type is a concurrent type or if it is private
3712 -- type whose definition is a concurrent type, the first
3713 -- argument in the Init routine has to be unchecked conversion
3714 -- to the corresponding record type. If the designated type is
3715 -- a derived type, also convert the argument to its root type.
3717 if Is_Concurrent_Type (T) then
3719 Unchecked_Convert_To (
3720 Corresponding_Record_Type (T), Init_Arg1);
3722 elsif Is_Private_Type (T)
3723 and then Present (Full_View (T))
3724 and then Is_Concurrent_Type (Full_View (T))
3727 Unchecked_Convert_To
3728 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
3730 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
3732 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
3735 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
3736 Set_Etype (Init_Arg1, Ftyp);
3740 Args := New_List (Init_Arg1);
3742 -- For the task case, pass the Master_Id of the access type as
3743 -- the value of the _Master parameter, and _Chain as the value
3744 -- of the _Chain parameter (_Chain will be defined as part of
3745 -- the generated code for the allocator).
3747 -- In Ada 2005, the context may be a function that returns an
3748 -- anonymous access type. In that case the Master_Id has been
3749 -- created when expanding the function declaration.
3751 if Has_Task (T) then
3752 if No (Master_Id (Base_Type (PtrT))) then
3754 -- The designated type was an incomplete type, and the
3755 -- access type did not get expanded. Salvage it now.
3757 if not Restriction_Active (No_Task_Hierarchy) then
3758 pragma Assert (Present (Parent (Base_Type (PtrT))));
3759 Expand_N_Full_Type_Declaration
3760 (Parent (Base_Type (PtrT)));
3764 -- If the context of the allocator is a declaration or an
3765 -- assignment, we can generate a meaningful image for it,
3766 -- even though subsequent assignments might remove the
3767 -- connection between task and entity. We build this image
3768 -- when the left-hand side is a simple variable, a simple
3769 -- indexed assignment or a simple selected component.
3771 if Nkind (Parent (N)) = N_Assignment_Statement then
3773 Nam : constant Node_Id := Name (Parent (N));
3776 if Is_Entity_Name (Nam) then
3778 Build_Task_Image_Decls
3781 (Entity (Nam), Sloc (Nam)), T);
3783 elsif Nkind_In (Nam, N_Indexed_Component,
3784 N_Selected_Component)
3785 and then Is_Entity_Name (Prefix (Nam))
3788 Build_Task_Image_Decls
3789 (Loc, Nam, Etype (Prefix (Nam)));
3791 Decls := Build_Task_Image_Decls (Loc, T, T);
3795 elsif Nkind (Parent (N)) = N_Object_Declaration then
3797 Build_Task_Image_Decls
3798 (Loc, Defining_Identifier (Parent (N)), T);
3801 Decls := Build_Task_Image_Decls (Loc, T, T);
3804 if Restriction_Active (No_Task_Hierarchy) then
3806 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
3810 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
3813 Append_To (Args, Make_Identifier (Loc, Name_uChain));
3815 Decl := Last (Decls);
3817 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
3819 -- Has_Task is false, Decls not used
3825 -- Add discriminants if discriminated type
3828 Dis : Boolean := False;
3832 if Has_Discriminants (T) then
3836 elsif Is_Private_Type (T)
3837 and then Present (Full_View (T))
3838 and then Has_Discriminants (Full_View (T))
3841 Typ := Full_View (T);
3846 -- If the allocated object will be constrained by the
3847 -- default values for discriminants, then build a subtype
3848 -- with those defaults, and change the allocated subtype
3849 -- to that. Note that this happens in fewer cases in Ada
3852 if not Is_Constrained (Typ)
3853 and then Present (Discriminant_Default_Value
3854 (First_Discriminant (Typ)))
3855 and then (Ada_Version < Ada_2005
3857 not Has_Constrained_Partial_View (Typ))
3859 Typ := Build_Default_Subtype (Typ, N);
3860 Set_Expression (N, New_Reference_To (Typ, Loc));
3863 Discr := First_Elmt (Discriminant_Constraint (Typ));
3864 while Present (Discr) loop
3865 Nod := Node (Discr);
3866 Append (New_Copy_Tree (Node (Discr)), Args);
3868 -- AI-416: when the discriminant constraint is an
3869 -- anonymous access type make sure an accessibility
3870 -- check is inserted if necessary (3.10.2(22.q/2))
3872 if Ada_Version >= Ada_2005
3874 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
3876 Apply_Accessibility_Check
3877 (Nod, Typ, Insert_Node => Nod);
3885 -- We set the allocator as analyzed so that when we analyze the
3886 -- expression actions node, we do not get an unwanted recursive
3887 -- expansion of the allocator expression.
3889 Set_Analyzed (N, True);
3890 Nod := Relocate_Node (N);
3892 -- Here is the transformation:
3893 -- input: new Ctrl_Typ
3894 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
3895 -- Ctrl_TypIP (Temp.all, ...);
3896 -- [Deep_]Initialize (Temp.all);
3898 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
3899 -- is the subtype of the allocator.
3902 Make_Object_Declaration (Loc,
3903 Defining_Identifier => Temp,
3904 Constant_Present => True,
3905 Object_Definition => New_Reference_To (Temp_Type, Loc),
3908 Set_Assignment_OK (Temp_Decl);
3909 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
3911 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
3913 -- If the designated type is a task type or contains tasks,
3914 -- create block to activate created tasks, and insert
3915 -- declaration for Task_Image variable ahead of call.
3917 if Has_Task (T) then
3919 L : constant List_Id := New_List;
3922 Build_Task_Allocate_Block (L, Nod, Args);
3924 Insert_List_Before (First (Declarations (Blk)), Decls);
3925 Insert_Actions (N, L);
3930 Make_Procedure_Call_Statement (Loc,
3931 Name => New_Reference_To (Init, Loc),
3932 Parameter_Associations => Args));
3935 if Needs_Finalization (T) then
3938 -- [Deep_]Initialize (Init_Arg1);
3942 (Obj_Ref => New_Copy_Tree (Init_Arg1),
3945 if Present (Finalization_Master (PtrT)) then
3947 -- Special processing for .NET/JVM, the allocated object
3948 -- is attached to the finalization master. Generate:
3950 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
3952 -- Types derived from [Limited_]Controlled are the only
3953 -- ones considered since they have fields Prev and Next.
3955 if VM_Target /= No_VM then
3956 if Is_Controlled (T) then
3959 (Obj_Ref => New_Copy_Tree (Init_Arg1),
3963 -- Default case, generate:
3965 -- Set_Finalize_Address
3966 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
3968 -- Do not generate the above for CodePeer compilations
3969 -- because primitive Finalize_Address is never built.
3971 elsif not CodePeer_Mode then
3973 Make_Set_Finalize_Address_Call
3981 Rewrite (N, New_Reference_To (Temp, Loc));
3982 Analyze_And_Resolve (N, PtrT);
3987 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3988 -- object that has been rewritten as a reference, we displace "this"
3989 -- to reference properly its secondary dispatch table.
3991 if Nkind (N) = N_Identifier
3992 and then Is_Interface (Dtyp)
3994 Displace_Allocator_Pointer (N);
3998 when RE_Not_Available =>
4000 end Expand_N_Allocator;
4002 -----------------------
4003 -- Expand_N_And_Then --
4004 -----------------------
4006 procedure Expand_N_And_Then (N : Node_Id)
4007 renames Expand_Short_Circuit_Operator;
4009 ------------------------------
4010 -- Expand_N_Case_Expression --
4011 ------------------------------
4013 procedure Expand_N_Case_Expression (N : Node_Id) is
4014 Loc : constant Source_Ptr := Sloc (N);
4015 Typ : constant Entity_Id := Etype (N);
4027 -- case X is when A => AX, when B => BX ...
4042 -- However, this expansion is wrong for limited types, and also
4043 -- wrong for unconstrained types (since the bounds may not be the
4044 -- same in all branches). Furthermore it involves an extra copy
4045 -- for large objects. So we take care of this by using the following
4046 -- modified expansion for non-scalar types:
4049 -- type Pnn is access all typ;
4053 -- T := AX'Unrestricted_Access;
4055 -- T := BX'Unrestricted_Access;
4061 Make_Case_Statement (Loc,
4062 Expression => Expression (N),
4063 Alternatives => New_List);
4065 Actions := New_List;
4069 if Is_Scalar_Type (Typ) then
4073 Pnn := Make_Temporary (Loc, 'P');
4075 Make_Full_Type_Declaration (Loc,
4076 Defining_Identifier => Pnn,
4078 Make_Access_To_Object_Definition (Loc,
4079 All_Present => True,
4080 Subtype_Indication =>
4081 New_Reference_To (Typ, Loc))));
4085 Tnn := Make_Temporary (Loc, 'T');
4087 Make_Object_Declaration (Loc,
4088 Defining_Identifier => Tnn,
4089 Object_Definition => New_Occurrence_Of (Ttyp, Loc)));
4091 -- Now process the alternatives
4093 Alt := First (Alternatives (N));
4094 while Present (Alt) loop
4096 Aexp : Node_Id := Expression (Alt);
4097 Aloc : constant Source_Ptr := Sloc (Aexp);
4100 -- Propagate declarations inserted in the node by Insert_Actions
4101 -- (for example, temporaries generated to remove side effects).
4103 Append_List_To (Actions, Sinfo.Actions (Alt));
4105 if not Is_Scalar_Type (Typ) then
4107 Make_Attribute_Reference (Aloc,
4108 Prefix => Relocate_Node (Aexp),
4109 Attribute_Name => Name_Unrestricted_Access);
4113 (Alternatives (Cstmt),
4114 Make_Case_Statement_Alternative (Sloc (Alt),
4115 Discrete_Choices => Discrete_Choices (Alt),
4116 Statements => New_List (
4117 Make_Assignment_Statement (Aloc,
4118 Name => New_Occurrence_Of (Tnn, Loc),
4119 Expression => Aexp))));
4125 Append_To (Actions, Cstmt);
4127 -- Construct and return final expression with actions
4129 if Is_Scalar_Type (Typ) then
4130 Fexp := New_Occurrence_Of (Tnn, Loc);
4133 Make_Explicit_Dereference (Loc,
4134 Prefix => New_Occurrence_Of (Tnn, Loc));
4138 Make_Expression_With_Actions (Loc,
4140 Actions => Actions));
4142 Analyze_And_Resolve (N, Typ);
4143 end Expand_N_Case_Expression;
4145 -------------------------------------
4146 -- Expand_N_Conditional_Expression --
4147 -------------------------------------
4149 -- Deal with limited types and expression actions
4151 procedure Expand_N_Conditional_Expression (N : Node_Id) is
4152 Loc : constant Source_Ptr := Sloc (N);
4153 Cond : constant Node_Id := First (Expressions (N));
4154 Thenx : constant Node_Id := Next (Cond);
4155 Elsex : constant Node_Id := Next (Thenx);
4156 Typ : constant Entity_Id := Etype (N);
4167 -- Fold at compile time if condition known. We have already folded
4168 -- static conditional expressions, but it is possible to fold any
4169 -- case in which the condition is known at compile time, even though
4170 -- the result is non-static.
4172 -- Note that we don't do the fold of such cases in Sem_Elab because
4173 -- it can cause infinite loops with the expander adding a conditional
4174 -- expression, and Sem_Elab circuitry removing it repeatedly.
4176 if Compile_Time_Known_Value (Cond) then
4177 if Is_True (Expr_Value (Cond)) then
4179 Actions := Then_Actions (N);
4182 Actions := Else_Actions (N);
4187 if Present (Actions) then
4189 -- If we are not allowed to use Expression_With_Actions, just skip
4190 -- the optimization, it is not critical for correctness.
4192 if not Use_Expression_With_Actions then
4193 goto Skip_Optimization;
4197 Make_Expression_With_Actions (Loc,
4198 Expression => Relocate_Node (Expr),
4199 Actions => Actions));
4200 Analyze_And_Resolve (N, Typ);
4203 Rewrite (N, Relocate_Node (Expr));
4206 -- Note that the result is never static (legitimate cases of static
4207 -- conditional expressions were folded in Sem_Eval).
4209 Set_Is_Static_Expression (N, False);
4213 <<Skip_Optimization>>
4215 -- If the type is limited or unconstrained, we expand as follows to
4216 -- avoid any possibility of improper copies.
4218 -- Note: it may be possible to avoid this special processing if the
4219 -- back end uses its own mechanisms for handling by-reference types ???
4221 -- type Ptr is access all Typ;
4225 -- Cnn := then-expr'Unrestricted_Access;
4228 -- Cnn := else-expr'Unrestricted_Access;
4231 -- and replace the conditional expression by a reference to Cnn.all.
4233 -- This special case can be skipped if the back end handles limited
4234 -- types properly and ensures that no incorrect copies are made.
4236 if Is_By_Reference_Type (Typ)
4237 and then not Back_End_Handles_Limited_Types
4239 Cnn := Make_Temporary (Loc, 'C', N);
4242 Make_Full_Type_Declaration (Loc,
4243 Defining_Identifier =>
4244 Make_Temporary (Loc, 'A'),
4246 Make_Access_To_Object_Definition (Loc,
4247 All_Present => True,
4248 Subtype_Indication => New_Reference_To (Typ, Loc)));
4250 Insert_Action (N, P_Decl);
4253 Make_Object_Declaration (Loc,
4254 Defining_Identifier => Cnn,
4255 Object_Definition =>
4256 New_Occurrence_Of (Defining_Identifier (P_Decl), Loc));
4259 Make_Implicit_If_Statement (N,
4260 Condition => Relocate_Node (Cond),
4262 Then_Statements => New_List (
4263 Make_Assignment_Statement (Sloc (Thenx),
4264 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
4266 Make_Attribute_Reference (Loc,
4267 Attribute_Name => Name_Unrestricted_Access,
4268 Prefix => Relocate_Node (Thenx)))),
4270 Else_Statements => New_List (
4271 Make_Assignment_Statement (Sloc (Elsex),
4272 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
4274 Make_Attribute_Reference (Loc,
4275 Attribute_Name => Name_Unrestricted_Access,
4276 Prefix => Relocate_Node (Elsex)))));
4279 Make_Explicit_Dereference (Loc,
4280 Prefix => New_Occurrence_Of (Cnn, Loc));
4282 -- For other types, we only need to expand if there are other actions
4283 -- associated with either branch.
4285 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
4287 -- We have two approaches to handling this. If we are allowed to use
4288 -- N_Expression_With_Actions, then we can just wrap the actions into
4289 -- the appropriate expression.
4291 if Use_Expression_With_Actions then
4292 if Present (Then_Actions (N)) then
4294 Make_Expression_With_Actions (Sloc (Thenx),
4295 Actions => Then_Actions (N),
4296 Expression => Relocate_Node (Thenx)));
4297 Set_Then_Actions (N, No_List);
4298 Analyze_And_Resolve (Thenx, Typ);
4301 if Present (Else_Actions (N)) then
4303 Make_Expression_With_Actions (Sloc (Elsex),
4304 Actions => Else_Actions (N),
4305 Expression => Relocate_Node (Elsex)));
4306 Set_Else_Actions (N, No_List);
4307 Analyze_And_Resolve (Elsex, Typ);
4312 -- if we can't use N_Expression_With_Actions nodes, then we insert
4313 -- the following sequence of actions (using Insert_Actions):
4318 -- Cnn := then-expr;
4324 -- and replace the conditional expression by a reference to Cnn
4327 Cnn := Make_Temporary (Loc, 'C', N);
4330 Make_Object_Declaration (Loc,
4331 Defining_Identifier => Cnn,
4332 Object_Definition => New_Occurrence_Of (Typ, Loc));
4335 Make_Implicit_If_Statement (N,
4336 Condition => Relocate_Node (Cond),
4338 Then_Statements => New_List (
4339 Make_Assignment_Statement (Sloc (Thenx),
4340 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
4341 Expression => Relocate_Node (Thenx))),
4343 Else_Statements => New_List (
4344 Make_Assignment_Statement (Sloc (Elsex),
4345 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
4346 Expression => Relocate_Node (Elsex))));
4348 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
4349 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
4351 New_N := New_Occurrence_Of (Cnn, Loc);
4354 -- If no actions then no expansion needed, gigi will handle it using
4355 -- the same approach as a C conditional expression.
4361 -- Fall through here for either the limited expansion, or the case of
4362 -- inserting actions for non-limited types. In both these cases, we must
4363 -- move the SLOC of the parent If statement to the newly created one and
4364 -- change it to the SLOC of the expression which, after expansion, will
4365 -- correspond to what is being evaluated.
4367 if Present (Parent (N))
4368 and then Nkind (Parent (N)) = N_If_Statement
4370 Set_Sloc (New_If, Sloc (Parent (N)));
4371 Set_Sloc (Parent (N), Loc);
4374 -- Make sure Then_Actions and Else_Actions are appropriately moved
4375 -- to the new if statement.
4377 if Present (Then_Actions (N)) then
4379 (First (Then_Statements (New_If)), Then_Actions (N));
4382 if Present (Else_Actions (N)) then
4384 (First (Else_Statements (New_If)), Else_Actions (N));
4387 Insert_Action (N, Decl);
4388 Insert_Action (N, New_If);
4390 Analyze_And_Resolve (N, Typ);
4391 end Expand_N_Conditional_Expression;
4393 -----------------------------------
4394 -- Expand_N_Explicit_Dereference --
4395 -----------------------------------
4397 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
4399 -- Insert explicit dereference call for the checked storage pool case
4401 Insert_Dereference_Action (Prefix (N));
4402 end Expand_N_Explicit_Dereference;
4404 --------------------------------------
4405 -- Expand_N_Expression_With_Actions --
4406 --------------------------------------
4408 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
4410 procedure Process_Transient_Object (Decl : Node_Id);
4411 -- Given the declaration of a controlled transient declared inside the
4412 -- Actions list of an Expression_With_Actions, generate all necessary
4413 -- types and hooks in order to properly finalize the transient. This
4414 -- mechanism works in conjunction with Build_Finalizer.
4416 ------------------------------
4417 -- Process_Transient_Object --
4418 ------------------------------
4420 procedure Process_Transient_Object (Decl : Node_Id) is
4422 function Find_Insertion_Node return Node_Id;
4423 -- Complex conditions in if statements may be converted into nested
4424 -- EWAs. In this case, any generated code must be inserted before the
4425 -- if statement to ensure proper visibility of the hook objects. This
4426 -- routine returns the top most short circuit operator or the parent
4427 -- of the EWA if no nesting was detected.
4429 -------------------------
4430 -- Find_Insertion_Node --
4431 -------------------------
4433 function Find_Insertion_Node return Node_Id is
4437 -- Climb up the branches of a complex condition
4440 while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop
4441 Par := Parent (Par);
4445 end Find_Insertion_Node;
4449 Ins_Node : constant Node_Id := Find_Insertion_Node;
4450 Loc : constant Source_Ptr := Sloc (Decl);
4451 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
4452 Obj_Typ : constant Entity_Id := Etype (Obj_Id);
4453 Desig_Typ : Entity_Id;
4457 Temp_Decl : Node_Id;
4460 -- Start of processing for Process_Transient_Object
4463 -- Step 1: Create the access type which provides a reference to the
4464 -- transient object.
4466 if Is_Access_Type (Obj_Typ) then
4467 Desig_Typ := Directly_Designated_Type (Obj_Typ);
4469 Desig_Typ := Obj_Typ;
4473 -- Ann : access [all] <Desig_Typ>;
4475 Ptr_Id := Make_Temporary (Loc, 'A');
4478 Make_Full_Type_Declaration (Loc,
4479 Defining_Identifier => Ptr_Id,
4481 Make_Access_To_Object_Definition (Loc,
4483 Ekind (Obj_Typ) = E_General_Access_Type,
4484 Subtype_Indication => New_Reference_To (Desig_Typ, Loc)));
4486 Insert_Action (Ins_Node, Ptr_Decl);
4489 -- Step 2: Create a temporary which acts as a hook to the transient
4490 -- object. Generate:
4492 -- Temp : Ptr_Id := null;
4494 Temp_Id := Make_Temporary (Loc, 'T');
4497 Make_Object_Declaration (Loc,
4498 Defining_Identifier => Temp_Id,
4499 Object_Definition => New_Reference_To (Ptr_Id, Loc));
4501 Insert_Action (Ins_Node, Temp_Decl);
4502 Analyze (Temp_Decl);
4504 -- Mark this temporary as created for the purposes of exporting the
4505 -- transient declaration out of the Actions list. This signals the
4506 -- machinery in Build_Finalizer to recognize this special case.
4508 Set_Return_Flag_Or_Transient_Decl (Temp_Id, Decl);
4510 -- Step 3: Hook the transient object to the temporary
4512 if Is_Access_Type (Obj_Typ) then
4513 Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
4516 Make_Attribute_Reference (Loc,
4517 Prefix => New_Reference_To (Obj_Id, Loc),
4518 Attribute_Name => Name_Unrestricted_Access);
4522 -- Temp := Ptr_Id (Obj_Id);
4524 -- Temp := Obj_Id'Unrestricted_Access;
4526 Insert_After_And_Analyze (Decl,
4527 Make_Assignment_Statement (Loc,
4528 Name => New_Reference_To (Temp_Id, Loc),
4529 Expression => Expr));
4530 end Process_Transient_Object;
4536 -- Start of processing for Expand_N_Expression_With_Actions
4539 Decl := First (Actions (N));
4540 while Present (Decl) loop
4541 if Nkind (Decl) = N_Object_Declaration
4542 and then Is_Finalizable_Transient (Decl, N)
4544 Process_Transient_Object (Decl);
4549 end Expand_N_Expression_With_Actions;
4555 procedure Expand_N_In (N : Node_Id) is
4556 Loc : constant Source_Ptr := Sloc (N);
4557 Restyp : constant Entity_Id := Etype (N);
4558 Lop : constant Node_Id := Left_Opnd (N);
4559 Rop : constant Node_Id := Right_Opnd (N);
4560 Static : constant Boolean := Is_OK_Static_Expression (N);
4565 procedure Expand_Set_Membership;
4566 -- For each choice we create a simple equality or membership test.
4567 -- The whole membership is rewritten connecting these with OR ELSE.
4569 ---------------------------
4570 -- Expand_Set_Membership --
4571 ---------------------------
4573 procedure Expand_Set_Membership is
4577 function Make_Cond (Alt : Node_Id) return Node_Id;
4578 -- If the alternative is a subtype mark, create a simple membership
4579 -- test. Otherwise create an equality test for it.
4585 function Make_Cond (Alt : Node_Id) return Node_Id is
4587 L : constant Node_Id := New_Copy (Lop);
4588 R : constant Node_Id := Relocate_Node (Alt);
4591 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
4592 or else Nkind (Alt) = N_Range
4595 Make_In (Sloc (Alt),
4600 Make_Op_Eq (Sloc (Alt),
4608 -- Start of processing for Expand_Set_Membership
4611 Alt := Last (Alternatives (N));
4612 Res := Make_Cond (Alt);
4615 while Present (Alt) loop
4617 Make_Or_Else (Sloc (Alt),
4618 Left_Opnd => Make_Cond (Alt),
4624 Analyze_And_Resolve (N, Standard_Boolean);
4625 end Expand_Set_Membership;
4627 procedure Substitute_Valid_Check;
4628 -- Replaces node N by Lop'Valid. This is done when we have an explicit
4629 -- test for the left operand being in range of its subtype.
4631 ----------------------------
4632 -- Substitute_Valid_Check --
4633 ----------------------------
4635 procedure Substitute_Valid_Check is
4638 Make_Attribute_Reference (Loc,
4639 Prefix => Relocate_Node (Lop),
4640 Attribute_Name => Name_Valid));
4642 Analyze_And_Resolve (N, Restyp);
4644 Error_Msg_N ("?explicit membership test may be optimized away", N);
4645 Error_Msg_N -- CODEFIX
4646 ("\?use ''Valid attribute instead", N);
4648 end Substitute_Valid_Check;
4650 -- Start of processing for Expand_N_In
4653 -- If set membership case, expand with separate procedure
4655 if Present (Alternatives (N)) then
4656 Remove_Side_Effects (Lop);
4657 Expand_Set_Membership;
4661 -- Not set membership, proceed with expansion
4663 Ltyp := Etype (Left_Opnd (N));
4664 Rtyp := Etype (Right_Opnd (N));
4666 -- Check case of explicit test for an expression in range of its
4667 -- subtype. This is suspicious usage and we replace it with a 'Valid
4668 -- test and give a warning. For floating point types however, this is a
4669 -- standard way to check for finite numbers, and using 'Valid would
4670 -- typically be a pessimization. Also skip this test for predicated
4671 -- types, since it is perfectly reasonable to check if a value meets
4674 if Is_Scalar_Type (Ltyp)
4675 and then not Is_Floating_Point_Type (Ltyp)
4676 and then Nkind (Rop) in N_Has_Entity
4677 and then Ltyp = Entity (Rop)
4678 and then Comes_From_Source (N)
4679 and then VM_Target = No_VM
4680 and then not (Is_Discrete_Type (Ltyp)
4681 and then Present (Predicate_Function (Ltyp)))
4683 Substitute_Valid_Check;
4687 -- Do validity check on operands
4689 if Validity_Checks_On and Validity_Check_Operands then
4690 Ensure_Valid (Left_Opnd (N));
4691 Validity_Check_Range (Right_Opnd (N));
4694 -- Case of explicit range
4696 if Nkind (Rop) = N_Range then
4698 Lo : constant Node_Id := Low_Bound (Rop);
4699 Hi : constant Node_Id := High_Bound (Rop);
4701 Lo_Orig : constant Node_Id := Original_Node (Lo);
4702 Hi_Orig : constant Node_Id := Original_Node (Hi);
4704 Lcheck : Compare_Result;
4705 Ucheck : Compare_Result;
4707 Warn1 : constant Boolean :=
4708 Constant_Condition_Warnings
4709 and then Comes_From_Source (N)
4710 and then not In_Instance;
4711 -- This must be true for any of the optimization warnings, we
4712 -- clearly want to give them only for source with the flag on. We
4713 -- also skip these warnings in an instance since it may be the
4714 -- case that different instantiations have different ranges.
4716 Warn2 : constant Boolean :=
4718 and then Nkind (Original_Node (Rop)) = N_Range
4719 and then Is_Integer_Type (Etype (Lo));
4720 -- For the case where only one bound warning is elided, we also
4721 -- insist on an explicit range and an integer type. The reason is
4722 -- that the use of enumeration ranges including an end point is
4723 -- common, as is the use of a subtype name, one of whose bounds is
4724 -- the same as the type of the expression.
4727 -- If test is explicit x'First .. x'Last, replace by valid check
4729 -- Could use some individual comments for this complex test ???
4731 if Is_Scalar_Type (Ltyp)
4732 and then Nkind (Lo_Orig) = N_Attribute_Reference
4733 and then Attribute_Name (Lo_Orig) = Name_First
4734 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
4735 and then Entity (Prefix (Lo_Orig)) = Ltyp
4736 and then Nkind (Hi_Orig) = N_Attribute_Reference
4737 and then Attribute_Name (Hi_Orig) = Name_Last
4738 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
4739 and then Entity (Prefix (Hi_Orig)) = Ltyp
4740 and then Comes_From_Source (N)
4741 and then VM_Target = No_VM
4743 Substitute_Valid_Check;
4747 -- If bounds of type are known at compile time, and the end points
4748 -- are known at compile time and identical, this is another case
4749 -- for substituting a valid test. We only do this for discrete
4750 -- types, since it won't arise in practice for float types.
4752 if Comes_From_Source (N)
4753 and then Is_Discrete_Type (Ltyp)
4754 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
4755 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
4756 and then Compile_Time_Known_Value (Lo)
4757 and then Compile_Time_Known_Value (Hi)
4758 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
4759 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
4761 -- Kill warnings in instances, since they may be cases where we
4762 -- have a test in the generic that makes sense with some types
4763 -- and not with other types.
4765 and then not In_Instance
4767 Substitute_Valid_Check;
4771 -- If we have an explicit range, do a bit of optimization based on
4772 -- range analysis (we may be able to kill one or both checks).
4774 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
4775 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
4777 -- If either check is known to fail, replace result by False since
4778 -- the other check does not matter. Preserve the static flag for
4779 -- legality checks, because we are constant-folding beyond RM 4.9.
4781 if Lcheck = LT or else Ucheck = GT then
4783 Error_Msg_N ("?range test optimized away", N);
4784 Error_Msg_N ("\?value is known to be out of range", N);
4787 Rewrite (N, New_Reference_To (Standard_False, Loc));
4788 Analyze_And_Resolve (N, Restyp);
4789 Set_Is_Static_Expression (N, Static);
4792 -- If both checks are known to succeed, replace result by True,
4793 -- since we know we are in range.
4795 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
4797 Error_Msg_N ("?range test optimized away", N);
4798 Error_Msg_N ("\?value is known to be in range", N);
4801 Rewrite (N, New_Reference_To (Standard_True, Loc));
4802 Analyze_And_Resolve (N, Restyp);
4803 Set_Is_Static_Expression (N, Static);
4806 -- If lower bound check succeeds and upper bound check is not
4807 -- known to succeed or fail, then replace the range check with
4808 -- a comparison against the upper bound.
4810 elsif Lcheck in Compare_GE then
4811 if Warn2 and then not In_Instance then
4812 Error_Msg_N ("?lower bound test optimized away", Lo);
4813 Error_Msg_N ("\?value is known to be in range", Lo);
4819 Right_Opnd => High_Bound (Rop)));
4820 Analyze_And_Resolve (N, Restyp);
4823 -- If upper bound check succeeds and lower bound check is not
4824 -- known to succeed or fail, then replace the range check with
4825 -- a comparison against the lower bound.
4827 elsif Ucheck in Compare_LE then
4828 if Warn2 and then not In_Instance then
4829 Error_Msg_N ("?upper bound test optimized away", Hi);
4830 Error_Msg_N ("\?value is known to be in range", Hi);
4836 Right_Opnd => Low_Bound (Rop)));
4837 Analyze_And_Resolve (N, Restyp);
4841 -- We couldn't optimize away the range check, but there is one
4842 -- more issue. If we are checking constant conditionals, then we
4843 -- see if we can determine the outcome assuming everything is
4844 -- valid, and if so give an appropriate warning.
4846 if Warn1 and then not Assume_No_Invalid_Values then
4847 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
4848 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
4850 -- Result is out of range for valid value
4852 if Lcheck = LT or else Ucheck = GT then
4854 ("?value can only be in range if it is invalid", N);
4856 -- Result is in range for valid value
4858 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
4860 ("?value can only be out of range if it is invalid", N);
4862 -- Lower bound check succeeds if value is valid
4864 elsif Warn2 and then Lcheck in Compare_GE then
4866 ("?lower bound check only fails if it is invalid", Lo);
4868 -- Upper bound check succeeds if value is valid
4870 elsif Warn2 and then Ucheck in Compare_LE then
4872 ("?upper bound check only fails for invalid values", Hi);
4877 -- For all other cases of an explicit range, nothing to be done
4881 -- Here right operand is a subtype mark
4885 Typ : Entity_Id := Etype (Rop);
4886 Is_Acc : constant Boolean := Is_Access_Type (Typ);
4887 Cond : Node_Id := Empty;
4889 Obj : Node_Id := Lop;
4890 SCIL_Node : Node_Id;
4893 Remove_Side_Effects (Obj);
4895 -- For tagged type, do tagged membership operation
4897 if Is_Tagged_Type (Typ) then
4899 -- No expansion will be performed when VM_Target, as the VM
4900 -- back-ends will handle the membership tests directly (tags
4901 -- are not explicitly represented in Java objects, so the
4902 -- normal tagged membership expansion is not what we want).
4904 if Tagged_Type_Expansion then
4905 Tagged_Membership (N, SCIL_Node, New_N);
4907 Analyze_And_Resolve (N, Restyp);
4909 -- Update decoration of relocated node referenced by the
4912 if Generate_SCIL and then Present (SCIL_Node) then
4913 Set_SCIL_Node (N, SCIL_Node);
4919 -- If type is scalar type, rewrite as x in t'First .. t'Last.
4920 -- This reason we do this is that the bounds may have the wrong
4921 -- type if they come from the original type definition. Also this
4922 -- way we get all the processing above for an explicit range.
4924 -- Don't do this for predicated types, since in this case we
4925 -- want to check the predicate!
4927 elsif Is_Scalar_Type (Typ) then
4928 if No (Predicate_Function (Typ)) then
4932 Make_Attribute_Reference (Loc,
4933 Attribute_Name => Name_First,
4934 Prefix => New_Reference_To (Typ, Loc)),
4937 Make_Attribute_Reference (Loc,
4938 Attribute_Name => Name_Last,
4939 Prefix => New_Reference_To (Typ, Loc))));
4940 Analyze_And_Resolve (N, Restyp);
4945 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4946 -- a membership test if the subtype mark denotes a constrained
4947 -- Unchecked_Union subtype and the expression lacks inferable
4950 elsif Is_Unchecked_Union (Base_Type (Typ))
4951 and then Is_Constrained (Typ)
4952 and then not Has_Inferable_Discriminants (Lop)
4955 Make_Raise_Program_Error (Loc,
4956 Reason => PE_Unchecked_Union_Restriction));
4958 -- Prevent Gigi from generating incorrect code by rewriting the
4961 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
4965 -- Here we have a non-scalar type
4968 Typ := Designated_Type (Typ);
4971 if not Is_Constrained (Typ) then
4972 Rewrite (N, New_Reference_To (Standard_True, Loc));
4973 Analyze_And_Resolve (N, Restyp);
4975 -- For the constrained array case, we have to check the subscripts
4976 -- for an exact match if the lengths are non-zero (the lengths
4977 -- must match in any case).
4979 elsif Is_Array_Type (Typ) then
4980 Check_Subscripts : declare
4981 function Build_Attribute_Reference
4984 Dim : Nat) return Node_Id;
4985 -- Build attribute reference E'Nam (Dim)
4987 -------------------------------
4988 -- Build_Attribute_Reference --
4989 -------------------------------
4991 function Build_Attribute_Reference
4994 Dim : Nat) return Node_Id
4998 Make_Attribute_Reference (Loc,
5000 Attribute_Name => Nam,
5001 Expressions => New_List (
5002 Make_Integer_Literal (Loc, Dim)));
5003 end Build_Attribute_Reference;
5005 -- Start of processing for Check_Subscripts
5008 for J in 1 .. Number_Dimensions (Typ) loop
5009 Evolve_And_Then (Cond,
5012 Build_Attribute_Reference
5013 (Duplicate_Subexpr_No_Checks (Obj),
5016 Build_Attribute_Reference
5017 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
5019 Evolve_And_Then (Cond,
5022 Build_Attribute_Reference
5023 (Duplicate_Subexpr_No_Checks (Obj),
5026 Build_Attribute_Reference
5027 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
5036 Right_Opnd => Make_Null (Loc)),
5037 Right_Opnd => Cond);
5041 Analyze_And_Resolve (N, Restyp);
5042 end Check_Subscripts;
5044 -- These are the cases where constraint checks may be required,
5045 -- e.g. records with possible discriminants
5048 -- Expand the test into a series of discriminant comparisons.
5049 -- The expression that is built is the negation of the one that
5050 -- is used for checking discriminant constraints.
5052 Obj := Relocate_Node (Left_Opnd (N));
5054 if Has_Discriminants (Typ) then
5055 Cond := Make_Op_Not (Loc,
5056 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
5059 Cond := Make_Or_Else (Loc,
5063 Right_Opnd => Make_Null (Loc)),
5064 Right_Opnd => Cond);
5068 Cond := New_Occurrence_Of (Standard_True, Loc);
5072 Analyze_And_Resolve (N, Restyp);
5075 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5076 -- expression of an anonymous access type. This can involve an
5077 -- accessibility test and a tagged type membership test in the
5078 -- case of tagged designated types.
5080 if Ada_Version >= Ada_2012
5082 and then Ekind (Ltyp) = E_Anonymous_Access_Type
5085 Expr_Entity : Entity_Id := Empty;
5087 Param_Level : Node_Id;
5088 Type_Level : Node_Id;
5091 if Is_Entity_Name (Lop) then
5092 Expr_Entity := Param_Entity (Lop);
5094 if not Present (Expr_Entity) then
5095 Expr_Entity := Entity (Lop);
5099 -- If a conversion of the anonymous access value to the
5100 -- tested type would be illegal, then the result is False.
5102 if not Valid_Conversion
5103 (Lop, Rtyp, Lop, Report_Errs => False)
5105 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5106 Analyze_And_Resolve (N, Restyp);
5108 -- Apply an accessibility check if the access object has an
5109 -- associated access level and when the level of the type is
5110 -- less deep than the level of the access parameter. This
5111 -- only occur for access parameters and stand-alone objects
5112 -- of an anonymous access type.
5115 if Present (Expr_Entity)
5118 (Effective_Extra_Accessibility (Expr_Entity))
5119 and then UI_Gt (Object_Access_Level (Lop),
5120 Type_Access_Level (Rtyp))
5124 (Effective_Extra_Accessibility (Expr_Entity), Loc);
5127 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
5129 -- Return True only if the accessibility level of the
5130 -- expression entity is not deeper than the level of
5131 -- the tested access type.
5135 Left_Opnd => Relocate_Node (N),
5136 Right_Opnd => Make_Op_Le (Loc,
5137 Left_Opnd => Param_Level,
5138 Right_Opnd => Type_Level)));
5140 Analyze_And_Resolve (N);
5143 -- If the designated type is tagged, do tagged membership
5146 -- *** NOTE: we have to check not null before doing the
5147 -- tagged membership test (but maybe that can be done
5148 -- inside Tagged_Membership?).
5150 if Is_Tagged_Type (Typ) then
5153 Left_Opnd => Relocate_Node (N),
5157 Right_Opnd => Make_Null (Loc))));
5159 -- No expansion will be performed when VM_Target, as
5160 -- the VM back-ends will handle the membership tests
5161 -- directly (tags are not explicitly represented in
5162 -- Java objects, so the normal tagged membership
5163 -- expansion is not what we want).
5165 if Tagged_Type_Expansion then
5167 -- Note that we have to pass Original_Node, because
5168 -- the membership test might already have been
5169 -- rewritten by earlier parts of membership test.
5172 (Original_Node (N), SCIL_Node, New_N);
5174 -- Update decoration of relocated node referenced
5175 -- by the SCIL node.
5177 if Generate_SCIL and then Present (SCIL_Node) then
5178 Set_SCIL_Node (New_N, SCIL_Node);
5183 Left_Opnd => Relocate_Node (N),
5184 Right_Opnd => New_N));
5186 Analyze_And_Resolve (N, Restyp);
5195 -- At this point, we have done the processing required for the basic
5196 -- membership test, but not yet dealt with the predicate.
5200 -- If a predicate is present, then we do the predicate test, but we
5201 -- most certainly want to omit this if we are within the predicate
5202 -- function itself, since otherwise we have an infinite recursion!
5205 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
5209 and then Current_Scope /= PFunc
5213 Left_Opnd => Relocate_Node (N),
5214 Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
5216 -- Analyze new expression, mark left operand as analyzed to
5217 -- avoid infinite recursion adding predicate calls.
5219 Set_Analyzed (Left_Opnd (N));
5220 Analyze_And_Resolve (N, Standard_Boolean);
5222 -- All done, skip attempt at compile time determination of result
5229 --------------------------------
5230 -- Expand_N_Indexed_Component --
5231 --------------------------------
5233 procedure Expand_N_Indexed_Component (N : Node_Id) is
5234 Loc : constant Source_Ptr := Sloc (N);
5235 Typ : constant Entity_Id := Etype (N);
5236 P : constant Node_Id := Prefix (N);
5237 T : constant Entity_Id := Etype (P);
5240 -- A special optimization, if we have an indexed component that is
5241 -- selecting from a slice, then we can eliminate the slice, since, for
5242 -- example, x (i .. j)(k) is identical to x(k). The only difference is
5243 -- the range check required by the slice. The range check for the slice
5244 -- itself has already been generated. The range check for the
5245 -- subscripting operation is ensured by converting the subject to
5246 -- the subtype of the slice.
5248 -- This optimization not only generates better code, avoiding slice
5249 -- messing especially in the packed case, but more importantly bypasses
5250 -- some problems in handling this peculiar case, for example, the issue
5251 -- of dealing specially with object renamings.
5253 if Nkind (P) = N_Slice then
5255 Make_Indexed_Component (Loc,
5256 Prefix => Prefix (P),
5257 Expressions => New_List (
5259 (Etype (First_Index (Etype (P))),
5260 First (Expressions (N))))));
5261 Analyze_And_Resolve (N, Typ);
5265 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
5266 -- function, then additional actuals must be passed.
5268 if Ada_Version >= Ada_2005
5269 and then Is_Build_In_Place_Function_Call (P)
5271 Make_Build_In_Place_Call_In_Anonymous_Context (P);
5274 -- If the prefix is an access type, then we unconditionally rewrite if
5275 -- as an explicit dereference. This simplifies processing for several
5276 -- cases, including packed array cases and certain cases in which checks
5277 -- must be generated. We used to try to do this only when it was
5278 -- necessary, but it cleans up the code to do it all the time.
5280 if Is_Access_Type (T) then
5281 Insert_Explicit_Dereference (P);
5282 Analyze_And_Resolve (P, Designated_Type (T));
5285 -- Generate index and validity checks
5287 Generate_Index_Checks (N);
5289 if Validity_Checks_On and then Validity_Check_Subscripts then
5290 Apply_Subscript_Validity_Checks (N);
5293 -- All done for the non-packed case
5295 if not Is_Packed (Etype (Prefix (N))) then
5299 -- For packed arrays that are not bit-packed (i.e. the case of an array
5300 -- with one or more index types with a non-contiguous enumeration type),
5301 -- we can always use the normal packed element get circuit.
5303 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
5304 Expand_Packed_Element_Reference (N);
5308 -- For a reference to a component of a bit packed array, we have to
5309 -- convert it to a reference to the corresponding Packed_Array_Type.
5310 -- We only want to do this for simple references, and not for:
5312 -- Left side of assignment, or prefix of left side of assignment, or
5313 -- prefix of the prefix, to handle packed arrays of packed arrays,
5314 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
5316 -- Renaming objects in renaming associations
5317 -- This case is handled when a use of the renamed variable occurs
5319 -- Actual parameters for a procedure call
5320 -- This case is handled in Exp_Ch6.Expand_Actuals
5322 -- The second expression in a 'Read attribute reference
5324 -- The prefix of an address or bit or size attribute reference
5326 -- The following circuit detects these exceptions
5329 Child : Node_Id := N;
5330 Parnt : Node_Id := Parent (N);
5334 if Nkind (Parnt) = N_Unchecked_Expression then
5337 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
5338 N_Procedure_Call_Statement)
5339 or else (Nkind (Parnt) = N_Parameter_Association
5341 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
5345 elsif Nkind (Parnt) = N_Attribute_Reference
5346 and then (Attribute_Name (Parnt) = Name_Address
5348 Attribute_Name (Parnt) = Name_Bit
5350 Attribute_Name (Parnt) = Name_Size)
5351 and then Prefix (Parnt) = Child
5355 elsif Nkind (Parnt) = N_Assignment_Statement
5356 and then Name (Parnt) = Child
5360 -- If the expression is an index of an indexed component, it must
5361 -- be expanded regardless of context.
5363 elsif Nkind (Parnt) = N_Indexed_Component
5364 and then Child /= Prefix (Parnt)
5366 Expand_Packed_Element_Reference (N);
5369 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
5370 and then Name (Parent (Parnt)) = Parnt
5374 elsif Nkind (Parnt) = N_Attribute_Reference
5375 and then Attribute_Name (Parnt) = Name_Read
5376 and then Next (First (Expressions (Parnt))) = Child
5380 elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
5381 and then Prefix (Parnt) = Child
5386 Expand_Packed_Element_Reference (N);
5390 -- Keep looking up tree for unchecked expression, or if we are the
5391 -- prefix of a possible assignment left side.
5394 Parnt := Parent (Child);
5397 end Expand_N_Indexed_Component;
5399 ---------------------
5400 -- Expand_N_Not_In --
5401 ---------------------
5403 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
5404 -- can be done. This avoids needing to duplicate this expansion code.
5406 procedure Expand_N_Not_In (N : Node_Id) is
5407 Loc : constant Source_Ptr := Sloc (N);
5408 Typ : constant Entity_Id := Etype (N);
5409 Cfs : constant Boolean := Comes_From_Source (N);
5416 Left_Opnd => Left_Opnd (N),
5417 Right_Opnd => Right_Opnd (N))));
5419 -- If this is a set membership, preserve list of alternatives
5421 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
5423 -- We want this to appear as coming from source if original does (see
5424 -- transformations in Expand_N_In).
5426 Set_Comes_From_Source (N, Cfs);
5427 Set_Comes_From_Source (Right_Opnd (N), Cfs);
5429 -- Now analyze transformed node
5431 Analyze_And_Resolve (N, Typ);
5432 end Expand_N_Not_In;
5438 -- The only replacement required is for the case of a null of a type that
5439 -- is an access to protected subprogram, or a subtype thereof. We represent
5440 -- such access values as a record, and so we must replace the occurrence of
5441 -- null by the equivalent record (with a null address and a null pointer in
5442 -- it), so that the backend creates the proper value.
5444 procedure Expand_N_Null (N : Node_Id) is
5445 Loc : constant Source_Ptr := Sloc (N);
5446 Typ : constant Entity_Id := Base_Type (Etype (N));
5450 if Is_Access_Protected_Subprogram_Type (Typ) then
5452 Make_Aggregate (Loc,
5453 Expressions => New_List (
5454 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
5458 Analyze_And_Resolve (N, Equivalent_Type (Typ));
5460 -- For subsequent semantic analysis, the node must retain its type.
5461 -- Gigi in any case replaces this type by the corresponding record
5462 -- type before processing the node.
5468 when RE_Not_Available =>
5472 ---------------------
5473 -- Expand_N_Op_Abs --
5474 ---------------------
5476 procedure Expand_N_Op_Abs (N : Node_Id) is
5477 Loc : constant Source_Ptr := Sloc (N);
5478 Expr : constant Node_Id := Right_Opnd (N);
5481 Unary_Op_Validity_Checks (N);
5483 -- Deal with software overflow checking
5485 if not Backend_Overflow_Checks_On_Target
5486 and then Is_Signed_Integer_Type (Etype (N))
5487 and then Do_Overflow_Check (N)
5489 -- The only case to worry about is when the argument is equal to the
5490 -- largest negative number, so what we do is to insert the check:
5492 -- [constraint_error when Expr = typ'Base'First]
5494 -- with the usual Duplicate_Subexpr use coding for expr
5497 Make_Raise_Constraint_Error (Loc,
5500 Left_Opnd => Duplicate_Subexpr (Expr),
5502 Make_Attribute_Reference (Loc,
5504 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
5505 Attribute_Name => Name_First)),
5506 Reason => CE_Overflow_Check_Failed));
5509 -- Vax floating-point types case
5511 if Vax_Float (Etype (N)) then
5512 Expand_Vax_Arith (N);
5514 end Expand_N_Op_Abs;
5516 ---------------------
5517 -- Expand_N_Op_Add --
5518 ---------------------
5520 procedure Expand_N_Op_Add (N : Node_Id) is
5521 Typ : constant Entity_Id := Etype (N);
5524 Binary_Op_Validity_Checks (N);
5526 -- N + 0 = 0 + N = N for integer types
5528 if Is_Integer_Type (Typ) then
5529 if Compile_Time_Known_Value (Right_Opnd (N))
5530 and then Expr_Value (Right_Opnd (N)) = Uint_0
5532 Rewrite (N, Left_Opnd (N));
5535 elsif Compile_Time_Known_Value (Left_Opnd (N))
5536 and then Expr_Value (Left_Opnd (N)) = Uint_0
5538 Rewrite (N, Right_Opnd (N));
5543 -- Arithmetic overflow checks for signed integer/fixed point types
5545 if Is_Signed_Integer_Type (Typ)
5546 or else Is_Fixed_Point_Type (Typ)
5548 Apply_Arithmetic_Overflow_Check (N);
5551 -- Vax floating-point types case
5553 elsif Vax_Float (Typ) then
5554 Expand_Vax_Arith (N);
5556 end Expand_N_Op_Add;
5558 ---------------------
5559 -- Expand_N_Op_And --
5560 ---------------------
5562 procedure Expand_N_Op_And (N : Node_Id) is
5563 Typ : constant Entity_Id := Etype (N);
5566 Binary_Op_Validity_Checks (N);
5568 if Is_Array_Type (Etype (N)) then
5569 Expand_Boolean_Operator (N);
5571 elsif Is_Boolean_Type (Etype (N)) then
5573 -- Replace AND by AND THEN if Short_Circuit_And_Or active and the
5574 -- type is standard Boolean (do not mess with AND that uses a non-
5575 -- standard Boolean type, because something strange is going on).
5577 if Short_Circuit_And_Or and then Typ = Standard_Boolean then
5579 Make_And_Then (Sloc (N),
5580 Left_Opnd => Relocate_Node (Left_Opnd (N)),
5581 Right_Opnd => Relocate_Node (Right_Opnd (N))));
5582 Analyze_And_Resolve (N, Typ);
5584 -- Otherwise, adjust conditions
5587 Adjust_Condition (Left_Opnd (N));
5588 Adjust_Condition (Right_Opnd (N));
5589 Set_Etype (N, Standard_Boolean);
5590 Adjust_Result_Type (N, Typ);
5593 elsif Is_Intrinsic_Subprogram (Entity (N)) then
5594 Expand_Intrinsic_Call (N, Entity (N));
5597 end Expand_N_Op_And;
5599 ------------------------
5600 -- Expand_N_Op_Concat --
5601 ------------------------
5603 procedure Expand_N_Op_Concat (N : Node_Id) is
5605 -- List of operands to be concatenated
5608 -- Node which is to be replaced by the result of concatenating the nodes
5609 -- in the list Opnds.
5612 -- Ensure validity of both operands
5614 Binary_Op_Validity_Checks (N);
5616 -- If we are the left operand of a concatenation higher up the tree,
5617 -- then do nothing for now, since we want to deal with a series of
5618 -- concatenations as a unit.
5620 if Nkind (Parent (N)) = N_Op_Concat
5621 and then N = Left_Opnd (Parent (N))
5626 -- We get here with a concatenation whose left operand may be a
5627 -- concatenation itself with a consistent type. We need to process
5628 -- these concatenation operands from left to right, which means
5629 -- from the deepest node in the tree to the highest node.
5632 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
5633 Cnode := Left_Opnd (Cnode);
5636 -- Now Cnode is the deepest concatenation, and its parents are the
5637 -- concatenation nodes above, so now we process bottom up, doing the
5638 -- operations. We gather a string that is as long as possible up to five
5641 -- The outer loop runs more than once if more than one concatenation
5642 -- type is involved.
5645 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
5646 Set_Parent (Opnds, N);
5648 -- The inner loop gathers concatenation operands
5650 Inner : while Cnode /= N
5651 and then Base_Type (Etype (Cnode)) =
5652 Base_Type (Etype (Parent (Cnode)))
5654 Cnode := Parent (Cnode);
5655 Append (Right_Opnd (Cnode), Opnds);
5658 Expand_Concatenate (Cnode, Opnds);
5660 exit Outer when Cnode = N;
5661 Cnode := Parent (Cnode);
5663 end Expand_N_Op_Concat;
5665 ------------------------
5666 -- Expand_N_Op_Divide --
5667 ------------------------
5669 procedure Expand_N_Op_Divide (N : Node_Id) is
5670 Loc : constant Source_Ptr := Sloc (N);
5671 Lopnd : constant Node_Id := Left_Opnd (N);
5672 Ropnd : constant Node_Id := Right_Opnd (N);
5673 Ltyp : constant Entity_Id := Etype (Lopnd);
5674 Rtyp : constant Entity_Id := Etype (Ropnd);
5675 Typ : Entity_Id := Etype (N);
5676 Rknow : constant Boolean := Is_Integer_Type (Typ)
5678 Compile_Time_Known_Value (Ropnd);
5682 Binary_Op_Validity_Checks (N);
5685 Rval := Expr_Value (Ropnd);
5688 -- N / 1 = N for integer types
5690 if Rknow and then Rval = Uint_1 then
5695 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
5696 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5697 -- operand is an unsigned integer, as required for this to work.
5699 if Nkind (Ropnd) = N_Op_Expon
5700 and then Is_Power_Of_2_For_Shift (Ropnd)
5702 -- We cannot do this transformation in configurable run time mode if we
5703 -- have 64-bit integers and long shifts are not available.
5707 or else Support_Long_Shifts_On_Target)
5710 Make_Op_Shift_Right (Loc,
5713 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
5714 Analyze_And_Resolve (N, Typ);
5718 -- Do required fixup of universal fixed operation
5720 if Typ = Universal_Fixed then
5721 Fixup_Universal_Fixed_Operation (N);
5725 -- Divisions with fixed-point results
5727 if Is_Fixed_Point_Type (Typ) then
5729 -- No special processing if Treat_Fixed_As_Integer is set, since
5730 -- from a semantic point of view such operations are simply integer
5731 -- operations and will be treated that way.
5733 if not Treat_Fixed_As_Integer (N) then
5734 if Is_Integer_Type (Rtyp) then
5735 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
5737 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
5741 -- Other cases of division of fixed-point operands. Again we exclude the
5742 -- case where Treat_Fixed_As_Integer is set.
5744 elsif (Is_Fixed_Point_Type (Ltyp) or else
5745 Is_Fixed_Point_Type (Rtyp))
5746 and then not Treat_Fixed_As_Integer (N)
5748 if Is_Integer_Type (Typ) then
5749 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
5751 pragma Assert (Is_Floating_Point_Type (Typ));
5752 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
5755 -- Mixed-mode operations can appear in a non-static universal context,
5756 -- in which case the integer argument must be converted explicitly.
5758 elsif Typ = Universal_Real
5759 and then Is_Integer_Type (Rtyp)
5762 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
5764 Analyze_And_Resolve (Ropnd, Universal_Real);
5766 elsif Typ = Universal_Real
5767 and then Is_Integer_Type (Ltyp)
5770 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
5772 Analyze_And_Resolve (Lopnd, Universal_Real);
5774 -- Non-fixed point cases, do integer zero divide and overflow checks
5776 elsif Is_Integer_Type (Typ) then
5777 Apply_Divide_Check (N);
5779 -- Deal with Vax_Float
5781 elsif Vax_Float (Typ) then
5782 Expand_Vax_Arith (N);
5785 end Expand_N_Op_Divide;
5787 --------------------
5788 -- Expand_N_Op_Eq --
5789 --------------------
5791 procedure Expand_N_Op_Eq (N : Node_Id) is
5792 Loc : constant Source_Ptr := Sloc (N);
5793 Typ : constant Entity_Id := Etype (N);
5794 Lhs : constant Node_Id := Left_Opnd (N);
5795 Rhs : constant Node_Id := Right_Opnd (N);
5796 Bodies : constant List_Id := New_List;
5797 A_Typ : constant Entity_Id := Etype (Lhs);
5799 Typl : Entity_Id := A_Typ;
5800 Op_Name : Entity_Id;
5803 procedure Build_Equality_Call (Eq : Entity_Id);
5804 -- If a constructed equality exists for the type or for its parent,
5805 -- build and analyze call, adding conversions if the operation is
5808 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
5809 -- Determines whether a type has a subcomponent of an unconstrained
5810 -- Unchecked_Union subtype. Typ is a record type.
5812 -------------------------
5813 -- Build_Equality_Call --
5814 -------------------------
5816 procedure Build_Equality_Call (Eq : Entity_Id) is
5817 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
5818 L_Exp : Node_Id := Relocate_Node (Lhs);
5819 R_Exp : Node_Id := Relocate_Node (Rhs);
5822 if Base_Type (Op_Type) /= Base_Type (A_Typ)
5823 and then not Is_Class_Wide_Type (A_Typ)
5825 L_Exp := OK_Convert_To (Op_Type, L_Exp);
5826 R_Exp := OK_Convert_To (Op_Type, R_Exp);
5829 -- If we have an Unchecked_Union, we need to add the inferred
5830 -- discriminant values as actuals in the function call. At this
5831 -- point, the expansion has determined that both operands have
5832 -- inferable discriminants.
5834 if Is_Unchecked_Union (Op_Type) then
5836 Lhs_Type : constant Node_Id := Etype (L_Exp);
5837 Rhs_Type : constant Node_Id := Etype (R_Exp);
5838 Lhs_Discr_Val : Node_Id;
5839 Rhs_Discr_Val : Node_Id;
5842 -- Per-object constrained selected components require special
5843 -- attention. If the enclosing scope of the component is an
5844 -- Unchecked_Union, we cannot reference its discriminants
5845 -- directly. This is why we use the two extra parameters of
5846 -- the equality function of the enclosing Unchecked_Union.
5848 -- type UU_Type (Discr : Integer := 0) is
5851 -- pragma Unchecked_Union (UU_Type);
5853 -- 1. Unchecked_Union enclosing record:
5855 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
5857 -- Comp : UU_Type (Discr);
5859 -- end Enclosing_UU_Type;
5860 -- pragma Unchecked_Union (Enclosing_UU_Type);
5862 -- Obj1 : Enclosing_UU_Type;
5863 -- Obj2 : Enclosing_UU_Type (1);
5865 -- [. . .] Obj1 = Obj2 [. . .]
5869 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
5871 -- A and B are the formal parameters of the equality function
5872 -- of Enclosing_UU_Type. The function always has two extra
5873 -- formals to capture the inferred discriminant values.
5875 -- 2. Non-Unchecked_Union enclosing record:
5878 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
5881 -- Comp : UU_Type (Discr);
5883 -- end Enclosing_Non_UU_Type;
5885 -- Obj1 : Enclosing_Non_UU_Type;
5886 -- Obj2 : Enclosing_Non_UU_Type (1);
5888 -- ... Obj1 = Obj2 ...
5892 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
5893 -- obj1.discr, obj2.discr)) then
5895 -- In this case we can directly reference the discriminants of
5896 -- the enclosing record.
5900 if Nkind (Lhs) = N_Selected_Component
5901 and then Has_Per_Object_Constraint
5902 (Entity (Selector_Name (Lhs)))
5904 -- Enclosing record is an Unchecked_Union, use formal A
5906 if Is_Unchecked_Union
5907 (Scope (Entity (Selector_Name (Lhs))))
5909 Lhs_Discr_Val := Make_Identifier (Loc, Name_A);
5911 -- Enclosing record is of a non-Unchecked_Union type, it is
5912 -- possible to reference the discriminant.
5916 Make_Selected_Component (Loc,
5917 Prefix => Prefix (Lhs),
5920 (Get_Discriminant_Value
5921 (First_Discriminant (Lhs_Type),
5923 Stored_Constraint (Lhs_Type))));
5926 -- Comment needed here ???
5929 -- Infer the discriminant value
5933 (Get_Discriminant_Value
5934 (First_Discriminant (Lhs_Type),
5936 Stored_Constraint (Lhs_Type)));
5941 if Nkind (Rhs) = N_Selected_Component
5942 and then Has_Per_Object_Constraint
5943 (Entity (Selector_Name (Rhs)))
5945 if Is_Unchecked_Union
5946 (Scope (Entity (Selector_Name (Rhs))))
5948 Rhs_Discr_Val := Make_Identifier (Loc, Name_B);
5952 Make_Selected_Component (Loc,
5953 Prefix => Prefix (Rhs),
5955 New_Copy (Get_Discriminant_Value (
5956 First_Discriminant (Rhs_Type),
5958 Stored_Constraint (Rhs_Type))));
5963 New_Copy (Get_Discriminant_Value (
5964 First_Discriminant (Rhs_Type),
5966 Stored_Constraint (Rhs_Type)));
5971 Make_Function_Call (Loc,
5972 Name => New_Reference_To (Eq, Loc),
5973 Parameter_Associations => New_List (
5980 -- Normal case, not an unchecked union
5984 Make_Function_Call (Loc,
5985 Name => New_Reference_To (Eq, Loc),
5986 Parameter_Associations => New_List (L_Exp, R_Exp)));
5989 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5990 end Build_Equality_Call;
5992 ------------------------------------
5993 -- Has_Unconstrained_UU_Component --
5994 ------------------------------------
5996 function Has_Unconstrained_UU_Component
5997 (Typ : Node_Id) return Boolean
5999 Tdef : constant Node_Id :=
6000 Type_Definition (Declaration_Node (Base_Type (Typ)));
6004 function Component_Is_Unconstrained_UU
6005 (Comp : Node_Id) return Boolean;
6006 -- Determines whether the subtype of the component is an
6007 -- unconstrained Unchecked_Union.
6009 function Variant_Is_Unconstrained_UU
6010 (Variant : Node_Id) return Boolean;
6011 -- Determines whether a component of the variant has an unconstrained
6012 -- Unchecked_Union subtype.
6014 -----------------------------------
6015 -- Component_Is_Unconstrained_UU --
6016 -----------------------------------
6018 function Component_Is_Unconstrained_UU
6019 (Comp : Node_Id) return Boolean
6022 if Nkind (Comp) /= N_Component_Declaration then
6027 Sindic : constant Node_Id :=
6028 Subtype_Indication (Component_Definition (Comp));
6031 -- Unconstrained nominal type. In the case of a constraint
6032 -- present, the node kind would have been N_Subtype_Indication.
6034 if Nkind (Sindic) = N_Identifier then
6035 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
6040 end Component_Is_Unconstrained_UU;
6042 ---------------------------------
6043 -- Variant_Is_Unconstrained_UU --
6044 ---------------------------------
6046 function Variant_Is_Unconstrained_UU
6047 (Variant : Node_Id) return Boolean
6049 Clist : constant Node_Id := Component_List (Variant);
6052 if Is_Empty_List (Component_Items (Clist)) then
6056 -- We only need to test one component
6059 Comp : Node_Id := First (Component_Items (Clist));
6062 while Present (Comp) loop
6063 if Component_Is_Unconstrained_UU (Comp) then
6071 -- None of the components withing the variant were of
6072 -- unconstrained Unchecked_Union type.
6075 end Variant_Is_Unconstrained_UU;
6077 -- Start of processing for Has_Unconstrained_UU_Component
6080 if Null_Present (Tdef) then
6084 Clist := Component_List (Tdef);
6085 Vpart := Variant_Part (Clist);
6087 -- Inspect available components
6089 if Present (Component_Items (Clist)) then
6091 Comp : Node_Id := First (Component_Items (Clist));
6094 while Present (Comp) loop
6096 -- One component is sufficient
6098 if Component_Is_Unconstrained_UU (Comp) then
6107 -- Inspect available components withing variants
6109 if Present (Vpart) then
6111 Variant : Node_Id := First (Variants (Vpart));
6114 while Present (Variant) loop
6116 -- One component within a variant is sufficient
6118 if Variant_Is_Unconstrained_UU (Variant) then
6127 -- Neither the available components, nor the components inside the
6128 -- variant parts were of an unconstrained Unchecked_Union subtype.
6131 end Has_Unconstrained_UU_Component;
6133 -- Start of processing for Expand_N_Op_Eq
6136 Binary_Op_Validity_Checks (N);
6138 if Ekind (Typl) = E_Private_Type then
6139 Typl := Underlying_Type (Typl);
6140 elsif Ekind (Typl) = E_Private_Subtype then
6141 Typl := Underlying_Type (Base_Type (Typl));
6146 -- It may happen in error situations that the underlying type is not
6147 -- set. The error will be detected later, here we just defend the
6154 Typl := Base_Type (Typl);
6156 -- Boolean types (requiring handling of non-standard case)
6158 if Is_Boolean_Type (Typl) then
6159 Adjust_Condition (Left_Opnd (N));
6160 Adjust_Condition (Right_Opnd (N));
6161 Set_Etype (N, Standard_Boolean);
6162 Adjust_Result_Type (N, Typ);
6166 elsif Is_Array_Type (Typl) then
6168 -- If we are doing full validity checking, and it is possible for the
6169 -- array elements to be invalid then expand out array comparisons to
6170 -- make sure that we check the array elements.
6172 if Validity_Check_Operands
6173 and then not Is_Known_Valid (Component_Type (Typl))
6176 Save_Force_Validity_Checks : constant Boolean :=
6177 Force_Validity_Checks;
6179 Force_Validity_Checks := True;
6181 Expand_Array_Equality
6183 Relocate_Node (Lhs),
6184 Relocate_Node (Rhs),
6187 Insert_Actions (N, Bodies);
6188 Analyze_And_Resolve (N, Standard_Boolean);
6189 Force_Validity_Checks := Save_Force_Validity_Checks;
6192 -- Packed case where both operands are known aligned
6194 elsif Is_Bit_Packed_Array (Typl)
6195 and then not Is_Possibly_Unaligned_Object (Lhs)
6196 and then not Is_Possibly_Unaligned_Object (Rhs)
6198 Expand_Packed_Eq (N);
6200 -- Where the component type is elementary we can use a block bit
6201 -- comparison (if supported on the target) exception in the case
6202 -- of floating-point (negative zero issues require element by
6203 -- element comparison), and atomic types (where we must be sure
6204 -- to load elements independently) and possibly unaligned arrays.
6206 elsif Is_Elementary_Type (Component_Type (Typl))
6207 and then not Is_Floating_Point_Type (Component_Type (Typl))
6208 and then not Is_Atomic (Component_Type (Typl))
6209 and then not Is_Possibly_Unaligned_Object (Lhs)
6210 and then not Is_Possibly_Unaligned_Object (Rhs)
6211 and then Support_Composite_Compare_On_Target
6215 -- For composite and floating-point cases, expand equality loop to
6216 -- make sure of using proper comparisons for tagged types, and
6217 -- correctly handling the floating-point case.
6221 Expand_Array_Equality
6223 Relocate_Node (Lhs),
6224 Relocate_Node (Rhs),
6227 Insert_Actions (N, Bodies, Suppress => All_Checks);
6228 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6233 elsif Is_Record_Type (Typl) then
6235 -- For tagged types, use the primitive "="
6237 if Is_Tagged_Type (Typl) then
6239 -- No need to do anything else compiling under restriction
6240 -- No_Dispatching_Calls. During the semantic analysis we
6241 -- already notified such violation.
6243 if Restriction_Active (No_Dispatching_Calls) then
6247 -- If this is derived from an untagged private type completed with
6248 -- a tagged type, it does not have a full view, so we use the
6249 -- primitive operations of the private type. This check should no
6250 -- longer be necessary when these types get their full views???
6252 if Is_Private_Type (A_Typ)
6253 and then not Is_Tagged_Type (A_Typ)
6254 and then Is_Derived_Type (A_Typ)
6255 and then No (Full_View (A_Typ))
6257 -- Search for equality operation, checking that the operands
6258 -- have the same type. Note that we must find a matching entry,
6259 -- or something is very wrong!
6261 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
6263 while Present (Prim) loop
6264 exit when Chars (Node (Prim)) = Name_Op_Eq
6265 and then Etype (First_Formal (Node (Prim))) =
6266 Etype (Next_Formal (First_Formal (Node (Prim))))
6268 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
6273 pragma Assert (Present (Prim));
6274 Op_Name := Node (Prim);
6276 -- Find the type's predefined equality or an overriding
6277 -- user- defined equality. The reason for not simply calling
6278 -- Find_Prim_Op here is that there may be a user-defined
6279 -- overloaded equality op that precedes the equality that we want,
6280 -- so we have to explicitly search (e.g., there could be an
6281 -- equality with two different parameter types).
6284 if Is_Class_Wide_Type (Typl) then
6285 Typl := Root_Type (Typl);
6288 Prim := First_Elmt (Primitive_Operations (Typl));
6289 while Present (Prim) loop
6290 exit when Chars (Node (Prim)) = Name_Op_Eq
6291 and then Etype (First_Formal (Node (Prim))) =
6292 Etype (Next_Formal (First_Formal (Node (Prim))))
6294 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
6299 pragma Assert (Present (Prim));
6300 Op_Name := Node (Prim);
6303 Build_Equality_Call (Op_Name);
6305 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
6306 -- predefined equality operator for a type which has a subcomponent
6307 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
6309 elsif Has_Unconstrained_UU_Component (Typl) then
6311 Make_Raise_Program_Error (Loc,
6312 Reason => PE_Unchecked_Union_Restriction));
6314 -- Prevent Gigi from generating incorrect code by rewriting the
6315 -- equality as a standard False.
6318 New_Occurrence_Of (Standard_False, Loc));
6320 elsif Is_Unchecked_Union (Typl) then
6322 -- If we can infer the discriminants of the operands, we make a
6323 -- call to the TSS equality function.
6325 if Has_Inferable_Discriminants (Lhs)
6327 Has_Inferable_Discriminants (Rhs)
6330 (TSS (Root_Type (Typl), TSS_Composite_Equality));
6333 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6334 -- the predefined equality operator for an Unchecked_Union type
6335 -- if either of the operands lack inferable discriminants.
6338 Make_Raise_Program_Error (Loc,
6339 Reason => PE_Unchecked_Union_Restriction));
6341 -- Prevent Gigi from generating incorrect code by rewriting
6342 -- the equality as a standard False.
6345 New_Occurrence_Of (Standard_False, Loc));
6349 -- If a type support function is present (for complex cases), use it
6351 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
6353 (TSS (Root_Type (Typl), TSS_Composite_Equality));
6355 -- Otherwise expand the component by component equality. Note that
6356 -- we never use block-bit comparisons for records, because of the
6357 -- problems with gaps. The backend will often be able to recombine
6358 -- the separate comparisons that we generate here.
6361 Remove_Side_Effects (Lhs);
6362 Remove_Side_Effects (Rhs);
6364 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
6366 Insert_Actions (N, Bodies, Suppress => All_Checks);
6367 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6371 -- Test if result is known at compile time
6373 Rewrite_Comparison (N);
6375 -- If we still have comparison for Vax_Float, process it
6377 if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then
6378 Expand_Vax_Comparison (N);
6382 Optimize_Length_Comparison (N);
6385 -----------------------
6386 -- Expand_N_Op_Expon --
6387 -----------------------
6389 procedure Expand_N_Op_Expon (N : Node_Id) is
6390 Loc : constant Source_Ptr := Sloc (N);
6391 Typ : constant Entity_Id := Etype (N);
6392 Rtyp : constant Entity_Id := Root_Type (Typ);
6393 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
6394 Bastyp : constant Node_Id := Etype (Base);
6395 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
6396 Exptyp : constant Entity_Id := Etype (Exp);
6397 Ovflo : constant Boolean := Do_Overflow_Check (N);
6406 Binary_Op_Validity_Checks (N);
6408 -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
6410 if CodePeer_Mode or Alfa_Mode then
6414 -- If either operand is of a private type, then we have the use of an
6415 -- intrinsic operator, and we get rid of the privateness, by using root
6416 -- types of underlying types for the actual operation. Otherwise the
6417 -- private types will cause trouble if we expand multiplications or
6418 -- shifts etc. We also do this transformation if the result type is
6419 -- different from the base type.
6421 if Is_Private_Type (Etype (Base))
6422 or else Is_Private_Type (Typ)
6423 or else Is_Private_Type (Exptyp)
6424 or else Rtyp /= Root_Type (Bastyp)
6427 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
6428 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
6432 Unchecked_Convert_To (Typ,
6434 Left_Opnd => Unchecked_Convert_To (Bt, Base),
6435 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
6436 Analyze_And_Resolve (N, Typ);
6441 -- Test for case of known right argument
6443 if Compile_Time_Known_Value (Exp) then
6444 Expv := Expr_Value (Exp);
6446 -- We only fold small non-negative exponents. You might think we
6447 -- could fold small negative exponents for the real case, but we
6448 -- can't because we are required to raise Constraint_Error for
6449 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
6450 -- See ACVC test C4A012B.
6452 if Expv >= 0 and then Expv <= 4 then
6454 -- X ** 0 = 1 (or 1.0)
6458 -- Call Remove_Side_Effects to ensure that any side effects
6459 -- in the ignored left operand (in particular function calls
6460 -- to user defined functions) are properly executed.
6462 Remove_Side_Effects (Base);
6464 if Ekind (Typ) in Integer_Kind then
6465 Xnode := Make_Integer_Literal (Loc, Intval => 1);
6467 Xnode := Make_Real_Literal (Loc, Ureal_1);
6479 Make_Op_Multiply (Loc,
6480 Left_Opnd => Duplicate_Subexpr (Base),
6481 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
6483 -- X ** 3 = X * X * X
6487 Make_Op_Multiply (Loc,
6489 Make_Op_Multiply (Loc,
6490 Left_Opnd => Duplicate_Subexpr (Base),
6491 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
6492 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
6495 -- En : constant base'type := base * base;
6500 Temp := Make_Temporary (Loc, 'E', Base);
6502 Insert_Actions (N, New_List (
6503 Make_Object_Declaration (Loc,
6504 Defining_Identifier => Temp,
6505 Constant_Present => True,
6506 Object_Definition => New_Reference_To (Typ, Loc),
6508 Make_Op_Multiply (Loc,
6509 Left_Opnd => Duplicate_Subexpr (Base),
6510 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
6513 Make_Op_Multiply (Loc,
6514 Left_Opnd => New_Reference_To (Temp, Loc),
6515 Right_Opnd => New_Reference_To (Temp, Loc));
6519 Analyze_And_Resolve (N, Typ);
6524 -- Case of (2 ** expression) appearing as an argument of an integer
6525 -- multiplication, or as the right argument of a division of a non-
6526 -- negative integer. In such cases we leave the node untouched, setting
6527 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
6528 -- of the higher level node converts it into a shift.
6530 -- Another case is 2 ** N in any other context. We simply convert
6531 -- this to 1 * 2 ** N, and then the above transformation applies.
6533 -- Note: this transformation is not applicable for a modular type with
6534 -- a non-binary modulus in the multiplication case, since we get a wrong
6535 -- result if the shift causes an overflow before the modular reduction.
6537 if Nkind (Base) = N_Integer_Literal
6538 and then Intval (Base) = 2
6539 and then Is_Integer_Type (Root_Type (Exptyp))
6540 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
6541 and then Is_Unsigned_Type (Exptyp)
6544 -- First the multiply and divide cases
6546 if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
6548 P : constant Node_Id := Parent (N);
6549 L : constant Node_Id := Left_Opnd (P);
6550 R : constant Node_Id := Right_Opnd (P);
6553 if (Nkind (P) = N_Op_Multiply
6554 and then not Non_Binary_Modulus (Typ)
6556 ((Is_Integer_Type (Etype (L)) and then R = N)
6558 (Is_Integer_Type (Etype (R)) and then L = N))
6559 and then not Do_Overflow_Check (P))
6561 (Nkind (P) = N_Op_Divide
6562 and then Is_Integer_Type (Etype (L))
6563 and then Is_Unsigned_Type (Etype (L))
6565 and then not Do_Overflow_Check (P))
6567 Set_Is_Power_Of_2_For_Shift (N);
6572 -- Now the other cases
6574 elsif not Non_Binary_Modulus (Typ) then
6576 Make_Op_Multiply (Loc,
6577 Left_Opnd => Make_Integer_Literal (Loc, 1),
6578 Right_Opnd => Relocate_Node (N)));
6579 Analyze_And_Resolve (N, Typ);
6584 -- Fall through if exponentiation must be done using a runtime routine
6586 -- First deal with modular case
6588 if Is_Modular_Integer_Type (Rtyp) then
6590 -- Non-binary case, we call the special exponentiation routine for
6591 -- the non-binary case, converting the argument to Long_Long_Integer
6592 -- and passing the modulus value. Then the result is converted back
6593 -- to the base type.
6595 if Non_Binary_Modulus (Rtyp) then
6598 Make_Function_Call (Loc,
6599 Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
6600 Parameter_Associations => New_List (
6601 Convert_To (Standard_Integer, Base),
6602 Make_Integer_Literal (Loc, Modulus (Rtyp)),
6605 -- Binary case, in this case, we call one of two routines, either the
6606 -- unsigned integer case, or the unsigned long long integer case,
6607 -- with a final "and" operation to do the required mod.
6610 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
6611 Ent := RTE (RE_Exp_Unsigned);
6613 Ent := RTE (RE_Exp_Long_Long_Unsigned);
6620 Make_Function_Call (Loc,
6621 Name => New_Reference_To (Ent, Loc),
6622 Parameter_Associations => New_List (
6623 Convert_To (Etype (First_Formal (Ent)), Base),
6626 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
6630 -- Common exit point for modular type case
6632 Analyze_And_Resolve (N, Typ);
6635 -- Signed integer cases, done using either Integer or Long_Long_Integer.
6636 -- It is not worth having routines for Short_[Short_]Integer, since for
6637 -- most machines it would not help, and it would generate more code that
6638 -- might need certification when a certified run time is required.
6640 -- In the integer cases, we have two routines, one for when overflow
6641 -- checks are required, and one when they are not required, since there
6642 -- is a real gain in omitting checks on many machines.
6644 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
6645 or else (Rtyp = Base_Type (Standard_Long_Integer)
6647 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
6648 or else (Rtyp = Universal_Integer)
6650 Etyp := Standard_Long_Long_Integer;
6653 Rent := RE_Exp_Long_Long_Integer;
6655 Rent := RE_Exn_Long_Long_Integer;
6658 elsif Is_Signed_Integer_Type (Rtyp) then
6659 Etyp := Standard_Integer;
6662 Rent := RE_Exp_Integer;
6664 Rent := RE_Exn_Integer;
6667 -- Floating-point cases, always done using Long_Long_Float. We do not
6668 -- need separate routines for the overflow case here, since in the case
6669 -- of floating-point, we generate infinities anyway as a rule (either
6670 -- that or we automatically trap overflow), and if there is an infinity
6671 -- generated and a range check is required, the check will fail anyway.
6674 pragma Assert (Is_Floating_Point_Type (Rtyp));
6675 Etyp := Standard_Long_Long_Float;
6676 Rent := RE_Exn_Long_Long_Float;
6679 -- Common processing for integer cases and floating-point cases.
6680 -- If we are in the right type, we can call runtime routine directly
6683 and then Rtyp /= Universal_Integer
6684 and then Rtyp /= Universal_Real
6687 Make_Function_Call (Loc,
6688 Name => New_Reference_To (RTE (Rent), Loc),
6689 Parameter_Associations => New_List (Base, Exp)));
6691 -- Otherwise we have to introduce conversions (conversions are also
6692 -- required in the universal cases, since the runtime routine is
6693 -- typed using one of the standard types).
6698 Make_Function_Call (Loc,
6699 Name => New_Reference_To (RTE (Rent), Loc),
6700 Parameter_Associations => New_List (
6701 Convert_To (Etyp, Base),
6705 Analyze_And_Resolve (N, Typ);
6709 when RE_Not_Available =>
6711 end Expand_N_Op_Expon;
6713 --------------------
6714 -- Expand_N_Op_Ge --
6715 --------------------
6717 procedure Expand_N_Op_Ge (N : Node_Id) is
6718 Typ : constant Entity_Id := Etype (N);
6719 Op1 : constant Node_Id := Left_Opnd (N);
6720 Op2 : constant Node_Id := Right_Opnd (N);
6721 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6724 Binary_Op_Validity_Checks (N);
6726 if Is_Array_Type (Typ1) then
6727 Expand_Array_Comparison (N);
6731 if Is_Boolean_Type (Typ1) then
6732 Adjust_Condition (Op1);
6733 Adjust_Condition (Op2);
6734 Set_Etype (N, Standard_Boolean);
6735 Adjust_Result_Type (N, Typ);
6738 Rewrite_Comparison (N);
6740 -- If we still have comparison, and Vax_Float type, process it
6742 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6743 Expand_Vax_Comparison (N);
6747 Optimize_Length_Comparison (N);
6750 --------------------
6751 -- Expand_N_Op_Gt --
6752 --------------------
6754 procedure Expand_N_Op_Gt (N : Node_Id) is
6755 Typ : constant Entity_Id := Etype (N);
6756 Op1 : constant Node_Id := Left_Opnd (N);
6757 Op2 : constant Node_Id := Right_Opnd (N);
6758 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6761 Binary_Op_Validity_Checks (N);
6763 if Is_Array_Type (Typ1) then
6764 Expand_Array_Comparison (N);
6768 if Is_Boolean_Type (Typ1) then
6769 Adjust_Condition (Op1);
6770 Adjust_Condition (Op2);
6771 Set_Etype (N, Standard_Boolean);
6772 Adjust_Result_Type (N, Typ);
6775 Rewrite_Comparison (N);
6777 -- If we still have comparison, and Vax_Float type, process it
6779 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6780 Expand_Vax_Comparison (N);
6784 Optimize_Length_Comparison (N);
6787 --------------------
6788 -- Expand_N_Op_Le --
6789 --------------------
6791 procedure Expand_N_Op_Le (N : Node_Id) is
6792 Typ : constant Entity_Id := Etype (N);
6793 Op1 : constant Node_Id := Left_Opnd (N);
6794 Op2 : constant Node_Id := Right_Opnd (N);
6795 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6798 Binary_Op_Validity_Checks (N);
6800 if Is_Array_Type (Typ1) then
6801 Expand_Array_Comparison (N);
6805 if Is_Boolean_Type (Typ1) then
6806 Adjust_Condition (Op1);
6807 Adjust_Condition (Op2);
6808 Set_Etype (N, Standard_Boolean);
6809 Adjust_Result_Type (N, Typ);
6812 Rewrite_Comparison (N);
6814 -- If we still have comparison, and Vax_Float type, process it
6816 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6817 Expand_Vax_Comparison (N);
6821 Optimize_Length_Comparison (N);
6824 --------------------
6825 -- Expand_N_Op_Lt --
6826 --------------------
6828 procedure Expand_N_Op_Lt (N : Node_Id) is
6829 Typ : constant Entity_Id := Etype (N);
6830 Op1 : constant Node_Id := Left_Opnd (N);
6831 Op2 : constant Node_Id := Right_Opnd (N);
6832 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6835 Binary_Op_Validity_Checks (N);
6837 if Is_Array_Type (Typ1) then
6838 Expand_Array_Comparison (N);
6842 if Is_Boolean_Type (Typ1) then
6843 Adjust_Condition (Op1);
6844 Adjust_Condition (Op2);
6845 Set_Etype (N, Standard_Boolean);
6846 Adjust_Result_Type (N, Typ);
6849 Rewrite_Comparison (N);
6851 -- If we still have comparison, and Vax_Float type, process it
6853 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6854 Expand_Vax_Comparison (N);
6858 Optimize_Length_Comparison (N);
6861 -----------------------
6862 -- Expand_N_Op_Minus --
6863 -----------------------
6865 procedure Expand_N_Op_Minus (N : Node_Id) is
6866 Loc : constant Source_Ptr := Sloc (N);
6867 Typ : constant Entity_Id := Etype (N);
6870 Unary_Op_Validity_Checks (N);
6872 if not Backend_Overflow_Checks_On_Target
6873 and then Is_Signed_Integer_Type (Etype (N))
6874 and then Do_Overflow_Check (N)
6876 -- Software overflow checking expands -expr into (0 - expr)
6879 Make_Op_Subtract (Loc,
6880 Left_Opnd => Make_Integer_Literal (Loc, 0),
6881 Right_Opnd => Right_Opnd (N)));
6883 Analyze_And_Resolve (N, Typ);
6885 -- Vax floating-point types case
6887 elsif Vax_Float (Etype (N)) then
6888 Expand_Vax_Arith (N);
6890 end Expand_N_Op_Minus;
6892 ---------------------
6893 -- Expand_N_Op_Mod --
6894 ---------------------
6896 procedure Expand_N_Op_Mod (N : Node_Id) is
6897 Loc : constant Source_Ptr := Sloc (N);
6898 Typ : constant Entity_Id := Etype (N);
6899 Left : constant Node_Id := Left_Opnd (N);
6900 Right : constant Node_Id := Right_Opnd (N);
6901 DOC : constant Boolean := Do_Overflow_Check (N);
6902 DDC : constant Boolean := Do_Division_Check (N);
6912 pragma Warnings (Off, Lhi);
6915 Binary_Op_Validity_Checks (N);
6917 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
6918 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
6920 -- Convert mod to rem if operands are known non-negative. We do this
6921 -- since it is quite likely that this will improve the quality of code,
6922 -- (the operation now corresponds to the hardware remainder), and it
6923 -- does not seem likely that it could be harmful.
6925 if LOK and then Llo >= 0
6927 ROK and then Rlo >= 0
6930 Make_Op_Rem (Sloc (N),
6931 Left_Opnd => Left_Opnd (N),
6932 Right_Opnd => Right_Opnd (N)));
6934 -- Instead of reanalyzing the node we do the analysis manually. This
6935 -- avoids anomalies when the replacement is done in an instance and
6936 -- is epsilon more efficient.
6938 Set_Entity (N, Standard_Entity (S_Op_Rem));
6940 Set_Do_Overflow_Check (N, DOC);
6941 Set_Do_Division_Check (N, DDC);
6942 Expand_N_Op_Rem (N);
6945 -- Otherwise, normal mod processing
6948 if Is_Integer_Type (Etype (N)) then
6949 Apply_Divide_Check (N);
6952 -- Apply optimization x mod 1 = 0. We don't really need that with
6953 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
6954 -- certainly harmless.
6956 if Is_Integer_Type (Etype (N))
6957 and then Compile_Time_Known_Value (Right)
6958 and then Expr_Value (Right) = Uint_1
6960 -- Call Remove_Side_Effects to ensure that any side effects in
6961 -- the ignored left operand (in particular function calls to
6962 -- user defined functions) are properly executed.
6964 Remove_Side_Effects (Left);
6966 Rewrite (N, Make_Integer_Literal (Loc, 0));
6967 Analyze_And_Resolve (N, Typ);
6971 -- Deal with annoying case of largest negative number remainder
6972 -- minus one. Gigi does not handle this case correctly, because
6973 -- it generates a divide instruction which may trap in this case.
6975 -- In fact the check is quite easy, if the right operand is -1, then
6976 -- the mod value is always 0, and we can just ignore the left operand
6977 -- completely in this case.
6979 -- The operand type may be private (e.g. in the expansion of an
6980 -- intrinsic operation) so we must use the underlying type to get the
6981 -- bounds, and convert the literals explicitly.
6985 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
6987 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
6989 ((not LOK) or else (Llo = LLB))
6992 Make_Conditional_Expression (Loc,
6993 Expressions => New_List (
6995 Left_Opnd => Duplicate_Subexpr (Right),
6997 Unchecked_Convert_To (Typ,
6998 Make_Integer_Literal (Loc, -1))),
6999 Unchecked_Convert_To (Typ,
7000 Make_Integer_Literal (Loc, Uint_0)),
7001 Relocate_Node (N))));
7003 Set_Analyzed (Next (Next (First (Expressions (N)))));
7004 Analyze_And_Resolve (N, Typ);
7007 end Expand_N_Op_Mod;
7009 --------------------------
7010 -- Expand_N_Op_Multiply --
7011 --------------------------
7013 procedure Expand_N_Op_Multiply (N : Node_Id) is
7014 Loc : constant Source_Ptr := Sloc (N);
7015 Lop : constant Node_Id := Left_Opnd (N);
7016 Rop : constant Node_Id := Right_Opnd (N);
7018 Lp2 : constant Boolean :=
7019 Nkind (Lop) = N_Op_Expon
7020 and then Is_Power_Of_2_For_Shift (Lop);
7022 Rp2 : constant Boolean :=
7023 Nkind (Rop) = N_Op_Expon
7024 and then Is_Power_Of_2_For_Shift (Rop);
7026 Ltyp : constant Entity_Id := Etype (Lop);
7027 Rtyp : constant Entity_Id := Etype (Rop);
7028 Typ : Entity_Id := Etype (N);
7031 Binary_Op_Validity_Checks (N);
7033 -- Special optimizations for integer types
7035 if Is_Integer_Type (Typ) then
7037 -- N * 0 = 0 for integer types
7039 if Compile_Time_Known_Value (Rop)
7040 and then Expr_Value (Rop) = Uint_0
7042 -- Call Remove_Side_Effects to ensure that any side effects in
7043 -- the ignored left operand (in particular function calls to
7044 -- user defined functions) are properly executed.
7046 Remove_Side_Effects (Lop);
7048 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
7049 Analyze_And_Resolve (N, Typ);
7053 -- Similar handling for 0 * N = 0
7055 if Compile_Time_Known_Value (Lop)
7056 and then Expr_Value (Lop) = Uint_0
7058 Remove_Side_Effects (Rop);
7059 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
7060 Analyze_And_Resolve (N, Typ);
7064 -- N * 1 = 1 * N = N for integer types
7066 -- This optimisation is not done if we are going to
7067 -- rewrite the product 1 * 2 ** N to a shift.
7069 if Compile_Time_Known_Value (Rop)
7070 and then Expr_Value (Rop) = Uint_1
7076 elsif Compile_Time_Known_Value (Lop)
7077 and then Expr_Value (Lop) = Uint_1
7085 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
7086 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7087 -- operand is an integer, as required for this to work.
7092 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
7096 Left_Opnd => Make_Integer_Literal (Loc, 2),
7099 Left_Opnd => Right_Opnd (Lop),
7100 Right_Opnd => Right_Opnd (Rop))));
7101 Analyze_And_Resolve (N, Typ);
7106 Make_Op_Shift_Left (Loc,
7109 Convert_To (Standard_Natural, Right_Opnd (Rop))));
7110 Analyze_And_Resolve (N, Typ);
7114 -- Same processing for the operands the other way round
7118 Make_Op_Shift_Left (Loc,
7121 Convert_To (Standard_Natural, Right_Opnd (Lop))));
7122 Analyze_And_Resolve (N, Typ);
7126 -- Do required fixup of universal fixed operation
7128 if Typ = Universal_Fixed then
7129 Fixup_Universal_Fixed_Operation (N);
7133 -- Multiplications with fixed-point results
7135 if Is_Fixed_Point_Type (Typ) then
7137 -- No special processing if Treat_Fixed_As_Integer is set, since from
7138 -- a semantic point of view such operations are simply integer
7139 -- operations and will be treated that way.
7141 if not Treat_Fixed_As_Integer (N) then
7143 -- Case of fixed * integer => fixed
7145 if Is_Integer_Type (Rtyp) then
7146 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
7148 -- Case of integer * fixed => fixed
7150 elsif Is_Integer_Type (Ltyp) then
7151 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
7153 -- Case of fixed * fixed => fixed
7156 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
7160 -- Other cases of multiplication of fixed-point operands. Again we
7161 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
7163 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
7164 and then not Treat_Fixed_As_Integer (N)
7166 if Is_Integer_Type (Typ) then
7167 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
7169 pragma Assert (Is_Floating_Point_Type (Typ));
7170 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
7173 -- Mixed-mode operations can appear in a non-static universal context,
7174 -- in which case the integer argument must be converted explicitly.
7176 elsif Typ = Universal_Real
7177 and then Is_Integer_Type (Rtyp)
7179 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
7181 Analyze_And_Resolve (Rop, Universal_Real);
7183 elsif Typ = Universal_Real
7184 and then Is_Integer_Type (Ltyp)
7186 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
7188 Analyze_And_Resolve (Lop, Universal_Real);
7190 -- Non-fixed point cases, check software overflow checking required
7192 elsif Is_Signed_Integer_Type (Etype (N)) then
7193 Apply_Arithmetic_Overflow_Check (N);
7195 -- Deal with VAX float case
7197 elsif Vax_Float (Typ) then
7198 Expand_Vax_Arith (N);
7201 end Expand_N_Op_Multiply;
7203 --------------------
7204 -- Expand_N_Op_Ne --
7205 --------------------
7207 procedure Expand_N_Op_Ne (N : Node_Id) is
7208 Typ : constant Entity_Id := Etype (Left_Opnd (N));
7211 -- Case of elementary type with standard operator
7213 if Is_Elementary_Type (Typ)
7214 and then Sloc (Entity (N)) = Standard_Location
7216 Binary_Op_Validity_Checks (N);
7218 -- Boolean types (requiring handling of non-standard case)
7220 if Is_Boolean_Type (Typ) then
7221 Adjust_Condition (Left_Opnd (N));
7222 Adjust_Condition (Right_Opnd (N));
7223 Set_Etype (N, Standard_Boolean);
7224 Adjust_Result_Type (N, Typ);
7227 Rewrite_Comparison (N);
7229 -- If we still have comparison for Vax_Float, process it
7231 if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then
7232 Expand_Vax_Comparison (N);
7236 -- For all cases other than elementary types, we rewrite node as the
7237 -- negation of an equality operation, and reanalyze. The equality to be
7238 -- used is defined in the same scope and has the same signature. This
7239 -- signature must be set explicitly since in an instance it may not have
7240 -- the same visibility as in the generic unit. This avoids duplicating
7241 -- or factoring the complex code for record/array equality tests etc.
7245 Loc : constant Source_Ptr := Sloc (N);
7247 Ne : constant Entity_Id := Entity (N);
7250 Binary_Op_Validity_Checks (N);
7256 Left_Opnd => Left_Opnd (N),
7257 Right_Opnd => Right_Opnd (N)));
7258 Set_Paren_Count (Right_Opnd (Neg), 1);
7260 if Scope (Ne) /= Standard_Standard then
7261 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
7264 -- For navigation purposes, we want to treat the inequality as an
7265 -- implicit reference to the corresponding equality. Preserve the
7266 -- Comes_From_ source flag to generate proper Xref entries.
7268 Preserve_Comes_From_Source (Neg, N);
7269 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
7271 Analyze_And_Resolve (N, Standard_Boolean);
7275 Optimize_Length_Comparison (N);
7278 ---------------------
7279 -- Expand_N_Op_Not --
7280 ---------------------
7282 -- If the argument is other than a Boolean array type, there is no special
7283 -- expansion required, except for VMS operations on signed integers.
7285 -- For the packed case, we call the special routine in Exp_Pakd, except
7286 -- that if the component size is greater than one, we use the standard
7287 -- routine generating a gruesome loop (it is so peculiar to have packed
7288 -- arrays with non-standard Boolean representations anyway, so it does not
7289 -- matter that we do not handle this case efficiently).
7291 -- For the unpacked case (and for the special packed case where we have non
7292 -- standard Booleans, as discussed above), we generate and insert into the
7293 -- tree the following function definition:
7295 -- function Nnnn (A : arr) is
7298 -- for J in a'range loop
7299 -- B (J) := not A (J);
7304 -- Here arr is the actual subtype of the parameter (and hence always
7305 -- constrained). Then we replace the not with a call to this function.
7307 procedure Expand_N_Op_Not (N : Node_Id) is
7308 Loc : constant Source_Ptr := Sloc (N);
7309 Typ : constant Entity_Id := Etype (N);
7318 Func_Name : Entity_Id;
7319 Loop_Statement : Node_Id;
7322 Unary_Op_Validity_Checks (N);
7324 -- For boolean operand, deal with non-standard booleans
7326 if Is_Boolean_Type (Typ) then
7327 Adjust_Condition (Right_Opnd (N));
7328 Set_Etype (N, Standard_Boolean);
7329 Adjust_Result_Type (N, Typ);
7333 -- For the VMS "not" on signed integer types, use conversion to and from
7334 -- a predefined modular type.
7336 if Is_VMS_Operator (Entity (N)) then
7342 -- If this is a derived type, retrieve original VMS type so that
7343 -- the proper sized type is used for intermediate values.
7345 if Is_Derived_Type (Typ) then
7346 Rtyp := First_Subtype (Etype (Typ));
7351 -- The proper unsigned type must have a size compatible with the
7352 -- operand, to prevent misalignment.
7354 if RM_Size (Rtyp) <= 8 then
7355 Utyp := RTE (RE_Unsigned_8);
7357 elsif RM_Size (Rtyp) <= 16 then
7358 Utyp := RTE (RE_Unsigned_16);
7360 elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
7361 Utyp := RTE (RE_Unsigned_32);
7364 Utyp := RTE (RE_Long_Long_Unsigned);
7368 Unchecked_Convert_To (Typ,
7370 Unchecked_Convert_To (Utyp, Right_Opnd (N)))));
7371 Analyze_And_Resolve (N, Typ);
7376 -- Only array types need any other processing
7378 if not Is_Array_Type (Typ) then
7382 -- Case of array operand. If bit packed with a component size of 1,
7383 -- handle it in Exp_Pakd if the operand is known to be aligned.
7385 if Is_Bit_Packed_Array (Typ)
7386 and then Component_Size (Typ) = 1
7387 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
7389 Expand_Packed_Not (N);
7393 -- Case of array operand which is not bit-packed. If the context is
7394 -- a safe assignment, call in-place operation, If context is a larger
7395 -- boolean expression in the context of a safe assignment, expansion is
7396 -- done by enclosing operation.
7398 Opnd := Relocate_Node (Right_Opnd (N));
7399 Convert_To_Actual_Subtype (Opnd);
7400 Arr := Etype (Opnd);
7401 Ensure_Defined (Arr, N);
7402 Silly_Boolean_Array_Not_Test (N, Arr);
7404 if Nkind (Parent (N)) = N_Assignment_Statement then
7405 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
7406 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
7409 -- Special case the negation of a binary operation
7411 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
7412 and then Safe_In_Place_Array_Op
7413 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
7415 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
7419 elsif Nkind (Parent (N)) in N_Binary_Op
7420 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
7423 Op1 : constant Node_Id := Left_Opnd (Parent (N));
7424 Op2 : constant Node_Id := Right_Opnd (Parent (N));
7425 Lhs : constant Node_Id := Name (Parent (Parent (N)));
7428 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
7430 -- (not A) op (not B) can be reduced to a single call
7432 if N = Op1 and then Nkind (Op2) = N_Op_Not then
7435 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
7438 -- A xor (not B) can also be special-cased
7440 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
7447 A := Make_Defining_Identifier (Loc, Name_uA);
7448 B := Make_Defining_Identifier (Loc, Name_uB);
7449 J := Make_Defining_Identifier (Loc, Name_uJ);
7452 Make_Indexed_Component (Loc,
7453 Prefix => New_Reference_To (A, Loc),
7454 Expressions => New_List (New_Reference_To (J, Loc)));
7457 Make_Indexed_Component (Loc,
7458 Prefix => New_Reference_To (B, Loc),
7459 Expressions => New_List (New_Reference_To (J, Loc)));
7462 Make_Implicit_Loop_Statement (N,
7463 Identifier => Empty,
7466 Make_Iteration_Scheme (Loc,
7467 Loop_Parameter_Specification =>
7468 Make_Loop_Parameter_Specification (Loc,
7469 Defining_Identifier => J,
7470 Discrete_Subtype_Definition =>
7471 Make_Attribute_Reference (Loc,
7472 Prefix => Make_Identifier (Loc, Chars (A)),
7473 Attribute_Name => Name_Range))),
7475 Statements => New_List (
7476 Make_Assignment_Statement (Loc,
7478 Expression => Make_Op_Not (Loc, A_J))));
7480 Func_Name := Make_Temporary (Loc, 'N');
7481 Set_Is_Inlined (Func_Name);
7484 Make_Subprogram_Body (Loc,
7486 Make_Function_Specification (Loc,
7487 Defining_Unit_Name => Func_Name,
7488 Parameter_Specifications => New_List (
7489 Make_Parameter_Specification (Loc,
7490 Defining_Identifier => A,
7491 Parameter_Type => New_Reference_To (Typ, Loc))),
7492 Result_Definition => New_Reference_To (Typ, Loc)),
7494 Declarations => New_List (
7495 Make_Object_Declaration (Loc,
7496 Defining_Identifier => B,
7497 Object_Definition => New_Reference_To (Arr, Loc))),
7499 Handled_Statement_Sequence =>
7500 Make_Handled_Sequence_Of_Statements (Loc,
7501 Statements => New_List (
7503 Make_Simple_Return_Statement (Loc,
7504 Expression => Make_Identifier (Loc, Chars (B)))))));
7507 Make_Function_Call (Loc,
7508 Name => New_Reference_To (Func_Name, Loc),
7509 Parameter_Associations => New_List (Opnd)));
7511 Analyze_And_Resolve (N, Typ);
7512 end Expand_N_Op_Not;
7514 --------------------
7515 -- Expand_N_Op_Or --
7516 --------------------
7518 procedure Expand_N_Op_Or (N : Node_Id) is
7519 Typ : constant Entity_Id := Etype (N);
7522 Binary_Op_Validity_Checks (N);
7524 if Is_Array_Type (Etype (N)) then
7525 Expand_Boolean_Operator (N);
7527 elsif Is_Boolean_Type (Etype (N)) then
7529 -- Replace OR by OR ELSE if Short_Circuit_And_Or active and the type
7530 -- is standard Boolean (do not mess with AND that uses a non-standard
7531 -- Boolean type, because something strange is going on).
7533 if Short_Circuit_And_Or and then Typ = Standard_Boolean then
7535 Make_Or_Else (Sloc (N),
7536 Left_Opnd => Relocate_Node (Left_Opnd (N)),
7537 Right_Opnd => Relocate_Node (Right_Opnd (N))));
7538 Analyze_And_Resolve (N, Typ);
7540 -- Otherwise, adjust conditions
7543 Adjust_Condition (Left_Opnd (N));
7544 Adjust_Condition (Right_Opnd (N));
7545 Set_Etype (N, Standard_Boolean);
7546 Adjust_Result_Type (N, Typ);
7549 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7550 Expand_Intrinsic_Call (N, Entity (N));
7555 ----------------------
7556 -- Expand_N_Op_Plus --
7557 ----------------------
7559 procedure Expand_N_Op_Plus (N : Node_Id) is
7561 Unary_Op_Validity_Checks (N);
7562 end Expand_N_Op_Plus;
7564 ---------------------
7565 -- Expand_N_Op_Rem --
7566 ---------------------
7568 procedure Expand_N_Op_Rem (N : Node_Id) is
7569 Loc : constant Source_Ptr := Sloc (N);
7570 Typ : constant Entity_Id := Etype (N);
7572 Left : constant Node_Id := Left_Opnd (N);
7573 Right : constant Node_Id := Right_Opnd (N);
7581 -- Set if corresponding operand can be negative
7583 pragma Unreferenced (Hi);
7586 Binary_Op_Validity_Checks (N);
7588 if Is_Integer_Type (Etype (N)) then
7589 Apply_Divide_Check (N);
7592 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
7593 -- but it is useful with other back ends (e.g. AAMP), and is certainly
7596 if Is_Integer_Type (Etype (N))
7597 and then Compile_Time_Known_Value (Right)
7598 and then Expr_Value (Right) = Uint_1
7600 -- Call Remove_Side_Effects to ensure that any side effects in the
7601 -- ignored left operand (in particular function calls to user defined
7602 -- functions) are properly executed.
7604 Remove_Side_Effects (Left);
7606 Rewrite (N, Make_Integer_Literal (Loc, 0));
7607 Analyze_And_Resolve (N, Typ);
7611 -- Deal with annoying case of largest negative number remainder minus
7612 -- one. Gigi does not handle this case correctly, because it generates
7613 -- a divide instruction which may trap in this case.
7615 -- In fact the check is quite easy, if the right operand is -1, then
7616 -- the remainder is always 0, and we can just ignore the left operand
7617 -- completely in this case.
7619 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
7620 Lneg := (not OK) or else Lo < 0;
7622 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
7623 Rneg := (not OK) or else Lo < 0;
7625 -- We won't mess with trying to find out if the left operand can really
7626 -- be the largest negative number (that's a pain in the case of private
7627 -- types and this is really marginal). We will just assume that we need
7628 -- the test if the left operand can be negative at all.
7630 if Lneg and Rneg then
7632 Make_Conditional_Expression (Loc,
7633 Expressions => New_List (
7635 Left_Opnd => Duplicate_Subexpr (Right),
7637 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
7639 Unchecked_Convert_To (Typ,
7640 Make_Integer_Literal (Loc, Uint_0)),
7642 Relocate_Node (N))));
7644 Set_Analyzed (Next (Next (First (Expressions (N)))));
7645 Analyze_And_Resolve (N, Typ);
7647 end Expand_N_Op_Rem;
7649 -----------------------------
7650 -- Expand_N_Op_Rotate_Left --
7651 -----------------------------
7653 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
7655 Binary_Op_Validity_Checks (N);
7656 end Expand_N_Op_Rotate_Left;
7658 ------------------------------
7659 -- Expand_N_Op_Rotate_Right --
7660 ------------------------------
7662 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
7664 Binary_Op_Validity_Checks (N);
7665 end Expand_N_Op_Rotate_Right;
7667 ----------------------------
7668 -- Expand_N_Op_Shift_Left --
7669 ----------------------------
7671 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
7673 Binary_Op_Validity_Checks (N);
7674 end Expand_N_Op_Shift_Left;
7676 -----------------------------
7677 -- Expand_N_Op_Shift_Right --
7678 -----------------------------
7680 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
7682 Binary_Op_Validity_Checks (N);
7683 end Expand_N_Op_Shift_Right;
7685 ----------------------------------------
7686 -- Expand_N_Op_Shift_Right_Arithmetic --
7687 ----------------------------------------
7689 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
7691 Binary_Op_Validity_Checks (N);
7692 end Expand_N_Op_Shift_Right_Arithmetic;
7694 --------------------------
7695 -- Expand_N_Op_Subtract --
7696 --------------------------
7698 procedure Expand_N_Op_Subtract (N : Node_Id) is
7699 Typ : constant Entity_Id := Etype (N);
7702 Binary_Op_Validity_Checks (N);
7704 -- N - 0 = N for integer types
7706 if Is_Integer_Type (Typ)
7707 and then Compile_Time_Known_Value (Right_Opnd (N))
7708 and then Expr_Value (Right_Opnd (N)) = 0
7710 Rewrite (N, Left_Opnd (N));
7714 -- Arithmetic overflow checks for signed integer/fixed point types
7716 if Is_Signed_Integer_Type (Typ)
7718 Is_Fixed_Point_Type (Typ)
7720 Apply_Arithmetic_Overflow_Check (N);
7722 -- VAX floating-point types case
7724 elsif Vax_Float (Typ) then
7725 Expand_Vax_Arith (N);
7727 end Expand_N_Op_Subtract;
7729 ---------------------
7730 -- Expand_N_Op_Xor --
7731 ---------------------
7733 procedure Expand_N_Op_Xor (N : Node_Id) is
7734 Typ : constant Entity_Id := Etype (N);
7737 Binary_Op_Validity_Checks (N);
7739 if Is_Array_Type (Etype (N)) then
7740 Expand_Boolean_Operator (N);
7742 elsif Is_Boolean_Type (Etype (N)) then
7743 Adjust_Condition (Left_Opnd (N));
7744 Adjust_Condition (Right_Opnd (N));
7745 Set_Etype (N, Standard_Boolean);
7746 Adjust_Result_Type (N, Typ);
7748 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7749 Expand_Intrinsic_Call (N, Entity (N));
7752 end Expand_N_Op_Xor;
7754 ----------------------
7755 -- Expand_N_Or_Else --
7756 ----------------------
7758 procedure Expand_N_Or_Else (N : Node_Id)
7759 renames Expand_Short_Circuit_Operator;
7761 -----------------------------------
7762 -- Expand_N_Qualified_Expression --
7763 -----------------------------------
7765 procedure Expand_N_Qualified_Expression (N : Node_Id) is
7766 Operand : constant Node_Id := Expression (N);
7767 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
7770 -- Do validity check if validity checking operands
7772 if Validity_Checks_On
7773 and then Validity_Check_Operands
7775 Ensure_Valid (Operand);
7778 -- Apply possible constraint check
7780 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
7782 if Do_Range_Check (Operand) then
7783 Set_Do_Range_Check (Operand, False);
7784 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
7786 end Expand_N_Qualified_Expression;
7788 ------------------------------------
7789 -- Expand_N_Quantified_Expression --
7790 ------------------------------------
7794 -- for all X in range => Cond
7799 -- for X in range loop
7806 -- Conversely, an existentially quantified expression:
7808 -- for some X in range => Cond
7813 -- for X in range loop
7820 -- In both cases, the iteration may be over a container in which case it is
7821 -- given by an iterator specification, not a loop parameter specification.
7823 procedure Expand_N_Quantified_Expression (N : Node_Id) is
7824 Loc : constant Source_Ptr := Sloc (N);
7825 Is_Universal : constant Boolean := All_Present (N);
7826 Actions : constant List_Id := New_List;
7827 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
7835 Make_Object_Declaration (Loc,
7836 Defining_Identifier => Tnn,
7837 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
7839 New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc));
7840 Append_To (Actions, Decl);
7842 Cond := Relocate_Node (Condition (N));
7844 -- Reset flag analyzed in the condition to force its analysis. Required
7845 -- since the previous analysis was done with expansion disabled (see
7846 -- Resolve_Quantified_Expression) and hence checks were not inserted
7847 -- and record comparisons have not been expanded.
7849 Reset_Analyzed_Flags (Cond);
7851 if Is_Universal then
7852 Cond := Make_Op_Not (Loc, Cond);
7856 Make_Implicit_If_Statement (N,
7858 Then_Statements => New_List (
7859 Make_Assignment_Statement (Loc,
7860 Name => New_Occurrence_Of (Tnn, Loc),
7862 New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)),
7863 Make_Exit_Statement (Loc)));
7865 if Present (Loop_Parameter_Specification (N)) then
7867 Make_Iteration_Scheme (Loc,
7868 Loop_Parameter_Specification =>
7869 Loop_Parameter_Specification (N));
7872 Make_Iteration_Scheme (Loc,
7873 Iterator_Specification => Iterator_Specification (N));
7877 Make_Loop_Statement (Loc,
7878 Iteration_Scheme => I_Scheme,
7879 Statements => New_List (Test),
7880 End_Label => Empty));
7883 Make_Expression_With_Actions (Loc,
7884 Expression => New_Occurrence_Of (Tnn, Loc),
7885 Actions => Actions));
7887 Analyze_And_Resolve (N, Standard_Boolean);
7888 end Expand_N_Quantified_Expression;
7890 ---------------------------------
7891 -- Expand_N_Selected_Component --
7892 ---------------------------------
7894 -- If the selector is a discriminant of a concurrent object, rewrite the
7895 -- prefix to denote the corresponding record type.
7897 procedure Expand_N_Selected_Component (N : Node_Id) is
7898 Loc : constant Source_Ptr := Sloc (N);
7899 Par : constant Node_Id := Parent (N);
7900 P : constant Node_Id := Prefix (N);
7901 Ptyp : Entity_Id := Underlying_Type (Etype (P));
7907 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
7908 -- Gigi needs a temporary for prefixes that depend on a discriminant,
7909 -- unless the context of an assignment can provide size information.
7910 -- Don't we have a general routine that does this???
7912 function Is_Subtype_Declaration return Boolean;
7913 -- The replacement of a discriminant reference by its value is required
7914 -- if this is part of the initialization of an temporary generated by a
7915 -- change of representation. This shows up as the construction of a
7916 -- discriminant constraint for a subtype declared at the same point as
7917 -- the entity in the prefix of the selected component. We recognize this
7918 -- case when the context of the reference is:
7919 -- subtype ST is T(Obj.D);
7920 -- where the entity for Obj comes from source, and ST has the same sloc.
7922 -----------------------
7923 -- In_Left_Hand_Side --
7924 -----------------------
7926 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
7928 return (Nkind (Parent (Comp)) = N_Assignment_Statement
7929 and then Comp = Name (Parent (Comp)))
7930 or else (Present (Parent (Comp))
7931 and then Nkind (Parent (Comp)) in N_Subexpr
7932 and then In_Left_Hand_Side (Parent (Comp)));
7933 end In_Left_Hand_Side;
7935 -----------------------------
7936 -- Is_Subtype_Declaration --
7937 -----------------------------
7939 function Is_Subtype_Declaration return Boolean is
7940 Par : constant Node_Id := Parent (N);
7943 Nkind (Par) = N_Index_Or_Discriminant_Constraint
7944 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
7945 and then Comes_From_Source (Entity (Prefix (N)))
7946 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
7947 end Is_Subtype_Declaration;
7949 -- Start of processing for Expand_N_Selected_Component
7952 -- Insert explicit dereference if required
7954 if Is_Access_Type (Ptyp) then
7956 -- First set prefix type to proper access type, in case it currently
7957 -- has a private (non-access) view of this type.
7959 Set_Etype (P, Ptyp);
7961 Insert_Explicit_Dereference (P);
7962 Analyze_And_Resolve (P, Designated_Type (Ptyp));
7964 if Ekind (Etype (P)) = E_Private_Subtype
7965 and then Is_For_Access_Subtype (Etype (P))
7967 Set_Etype (P, Base_Type (Etype (P)));
7973 -- Deal with discriminant check required
7975 if Do_Discriminant_Check (N) then
7977 -- Present the discriminant checking function to the backend, so that
7978 -- it can inline the call to the function.
7981 (Discriminant_Checking_Func
7982 (Original_Record_Component (Entity (Selector_Name (N)))));
7984 -- Now reset the flag and generate the call
7986 Set_Do_Discriminant_Check (N, False);
7987 Generate_Discriminant_Check (N);
7990 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7991 -- function, then additional actuals must be passed.
7993 if Ada_Version >= Ada_2005
7994 and then Is_Build_In_Place_Function_Call (P)
7996 Make_Build_In_Place_Call_In_Anonymous_Context (P);
7999 -- Gigi cannot handle unchecked conversions that are the prefix of a
8000 -- selected component with discriminants. This must be checked during
8001 -- expansion, because during analysis the type of the selector is not
8002 -- known at the point the prefix is analyzed. If the conversion is the
8003 -- target of an assignment, then we cannot force the evaluation.
8005 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
8006 and then Has_Discriminants (Etype (N))
8007 and then not In_Left_Hand_Side (N)
8009 Force_Evaluation (Prefix (N));
8012 -- Remaining processing applies only if selector is a discriminant
8014 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
8016 -- If the selector is a discriminant of a constrained record type,
8017 -- we may be able to rewrite the expression with the actual value
8018 -- of the discriminant, a useful optimization in some cases.
8020 if Is_Record_Type (Ptyp)
8021 and then Has_Discriminants (Ptyp)
8022 and then Is_Constrained (Ptyp)
8024 -- Do this optimization for discrete types only, and not for
8025 -- access types (access discriminants get us into trouble!)
8027 if not Is_Discrete_Type (Etype (N)) then
8030 -- Don't do this on the left hand of an assignment statement.
8031 -- Normally one would think that references like this would not
8032 -- occur, but they do in generated code, and mean that we really
8033 -- do want to assign the discriminant!
8035 elsif Nkind (Par) = N_Assignment_Statement
8036 and then Name (Par) = N
8040 -- Don't do this optimization for the prefix of an attribute or
8041 -- the name of an object renaming declaration since these are
8042 -- contexts where we do not want the value anyway.
8044 elsif (Nkind (Par) = N_Attribute_Reference
8045 and then Prefix (Par) = N)
8046 or else Is_Renamed_Object (N)
8050 -- Don't do this optimization if we are within the code for a
8051 -- discriminant check, since the whole point of such a check may
8052 -- be to verify the condition on which the code below depends!
8054 elsif Is_In_Discriminant_Check (N) then
8057 -- Green light to see if we can do the optimization. There is
8058 -- still one condition that inhibits the optimization below but
8059 -- now is the time to check the particular discriminant.
8062 -- Loop through discriminants to find the matching discriminant
8063 -- constraint to see if we can copy it.
8065 Disc := First_Discriminant (Ptyp);
8066 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
8067 Discr_Loop : while Present (Dcon) loop
8068 Dval := Node (Dcon);
8070 -- Check if this is the matching discriminant and if the
8071 -- discriminant value is simple enough to make sense to
8072 -- copy. We don't want to copy complex expressions, and
8073 -- indeed to do so can cause trouble (before we put in
8074 -- this guard, a discriminant expression containing an
8075 -- AND THEN was copied, causing problems for coverage
8078 -- However, if the reference is part of the initialization
8079 -- code generated for an object declaration, we must use
8080 -- the discriminant value from the subtype constraint,
8081 -- because the selected component may be a reference to the
8082 -- object being initialized, whose discriminant is not yet
8083 -- set. This only happens in complex cases involving changes
8084 -- or representation.
8086 if Disc = Entity (Selector_Name (N))
8087 and then (Is_Entity_Name (Dval)
8088 or else Compile_Time_Known_Value (Dval)
8089 or else Is_Subtype_Declaration)
8091 -- Here we have the matching discriminant. Check for
8092 -- the case of a discriminant of a component that is
8093 -- constrained by an outer discriminant, which cannot
8094 -- be optimized away.
8096 if Denotes_Discriminant
8097 (Dval, Check_Concurrent => True)
8101 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
8103 Denotes_Discriminant
8104 (Selector_Name (Original_Node (Dval)), True)
8108 -- Do not retrieve value if constraint is not static. It
8109 -- is generally not useful, and the constraint may be a
8110 -- rewritten outer discriminant in which case it is in
8113 elsif Is_Entity_Name (Dval)
8114 and then Nkind (Parent (Entity (Dval))) =
8115 N_Object_Declaration
8116 and then Present (Expression (Parent (Entity (Dval))))
8118 not Is_Static_Expression
8119 (Expression (Parent (Entity (Dval))))
8123 -- In the context of a case statement, the expression may
8124 -- have the base type of the discriminant, and we need to
8125 -- preserve the constraint to avoid spurious errors on
8128 elsif Nkind (Parent (N)) = N_Case_Statement
8129 and then Etype (Dval) /= Etype (Disc)
8132 Make_Qualified_Expression (Loc,
8134 New_Occurrence_Of (Etype (Disc), Loc),
8136 New_Copy_Tree (Dval)));
8137 Analyze_And_Resolve (N, Etype (Disc));
8139 -- In case that comes out as a static expression,
8140 -- reset it (a selected component is never static).
8142 Set_Is_Static_Expression (N, False);
8145 -- Otherwise we can just copy the constraint, but the
8146 -- result is certainly not static! In some cases the
8147 -- discriminant constraint has been analyzed in the
8148 -- context of the original subtype indication, but for
8149 -- itypes the constraint might not have been analyzed
8150 -- yet, and this must be done now.
8153 Rewrite (N, New_Copy_Tree (Dval));
8154 Analyze_And_Resolve (N);
8155 Set_Is_Static_Expression (N, False);
8161 Next_Discriminant (Disc);
8162 end loop Discr_Loop;
8164 -- Note: the above loop should always find a matching
8165 -- discriminant, but if it does not, we just missed an
8166 -- optimization due to some glitch (perhaps a previous
8167 -- error), so ignore.
8172 -- The only remaining processing is in the case of a discriminant of
8173 -- a concurrent object, where we rewrite the prefix to denote the
8174 -- corresponding record type. If the type is derived and has renamed
8175 -- discriminants, use corresponding discriminant, which is the one
8176 -- that appears in the corresponding record.
8178 if not Is_Concurrent_Type (Ptyp) then
8182 Disc := Entity (Selector_Name (N));
8184 if Is_Derived_Type (Ptyp)
8185 and then Present (Corresponding_Discriminant (Disc))
8187 Disc := Corresponding_Discriminant (Disc);
8191 Make_Selected_Component (Loc,
8193 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
8195 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
8200 end Expand_N_Selected_Component;
8202 --------------------
8203 -- Expand_N_Slice --
8204 --------------------
8206 procedure Expand_N_Slice (N : Node_Id) is
8207 Loc : constant Source_Ptr := Sloc (N);
8208 Typ : constant Entity_Id := Etype (N);
8209 Pfx : constant Node_Id := Prefix (N);
8210 Ptp : Entity_Id := Etype (Pfx);
8212 function Is_Procedure_Actual (N : Node_Id) return Boolean;
8213 -- Check whether the argument is an actual for a procedure call, in
8214 -- which case the expansion of a bit-packed slice is deferred until the
8215 -- call itself is expanded. The reason this is required is that we might
8216 -- have an IN OUT or OUT parameter, and the copy out is essential, and
8217 -- that copy out would be missed if we created a temporary here in
8218 -- Expand_N_Slice. Note that we don't bother to test specifically for an
8219 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
8220 -- is harmless to defer expansion in the IN case, since the call
8221 -- processing will still generate the appropriate copy in operation,
8222 -- which will take care of the slice.
8224 procedure Make_Temporary_For_Slice;
8225 -- Create a named variable for the value of the slice, in cases where
8226 -- the back-end cannot handle it properly, e.g. when packed types or
8227 -- unaligned slices are involved.
8229 -------------------------
8230 -- Is_Procedure_Actual --
8231 -------------------------
8233 function Is_Procedure_Actual (N : Node_Id) return Boolean is
8234 Par : Node_Id := Parent (N);
8238 -- If our parent is a procedure call we can return
8240 if Nkind (Par) = N_Procedure_Call_Statement then
8243 -- If our parent is a type conversion, keep climbing the tree,
8244 -- since a type conversion can be a procedure actual. Also keep
8245 -- climbing if parameter association or a qualified expression,
8246 -- since these are additional cases that do can appear on
8247 -- procedure actuals.
8249 elsif Nkind_In (Par, N_Type_Conversion,
8250 N_Parameter_Association,
8251 N_Qualified_Expression)
8253 Par := Parent (Par);
8255 -- Any other case is not what we are looking for
8261 end Is_Procedure_Actual;
8263 ------------------------------
8264 -- Make_Temporary_For_Slice --
8265 ------------------------------
8267 procedure Make_Temporary_For_Slice is
8269 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
8273 Make_Object_Declaration (Loc,
8274 Defining_Identifier => Ent,
8275 Object_Definition => New_Occurrence_Of (Typ, Loc));
8277 Set_No_Initialization (Decl);
8279 Insert_Actions (N, New_List (
8281 Make_Assignment_Statement (Loc,
8282 Name => New_Occurrence_Of (Ent, Loc),
8283 Expression => Relocate_Node (N))));
8285 Rewrite (N, New_Occurrence_Of (Ent, Loc));
8286 Analyze_And_Resolve (N, Typ);
8287 end Make_Temporary_For_Slice;
8289 -- Start of processing for Expand_N_Slice
8292 -- Special handling for access types
8294 if Is_Access_Type (Ptp) then
8296 Ptp := Designated_Type (Ptp);
8299 Make_Explicit_Dereference (Sloc (N),
8300 Prefix => Relocate_Node (Pfx)));
8302 Analyze_And_Resolve (Pfx, Ptp);
8305 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
8306 -- function, then additional actuals must be passed.
8308 if Ada_Version >= Ada_2005
8309 and then Is_Build_In_Place_Function_Call (Pfx)
8311 Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
8314 -- The remaining case to be handled is packed slices. We can leave
8315 -- packed slices as they are in the following situations:
8317 -- 1. Right or left side of an assignment (we can handle this
8318 -- situation correctly in the assignment statement expansion).
8320 -- 2. Prefix of indexed component (the slide is optimized away in this
8321 -- case, see the start of Expand_N_Slice.)
8323 -- 3. Object renaming declaration, since we want the name of the
8324 -- slice, not the value.
8326 -- 4. Argument to procedure call, since copy-in/copy-out handling may
8327 -- be required, and this is handled in the expansion of call
8330 -- 5. Prefix of an address attribute (this is an error which is caught
8331 -- elsewhere, and the expansion would interfere with generating the
8334 if not Is_Packed (Typ) then
8336 -- Apply transformation for actuals of a function call, where
8337 -- Expand_Actuals is not used.
8339 if Nkind (Parent (N)) = N_Function_Call
8340 and then Is_Possibly_Unaligned_Slice (N)
8342 Make_Temporary_For_Slice;
8345 elsif Nkind (Parent (N)) = N_Assignment_Statement
8346 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
8347 and then Parent (N) = Name (Parent (Parent (N))))
8351 elsif Nkind (Parent (N)) = N_Indexed_Component
8352 or else Is_Renamed_Object (N)
8353 or else Is_Procedure_Actual (N)
8357 elsif Nkind (Parent (N)) = N_Attribute_Reference
8358 and then Attribute_Name (Parent (N)) = Name_Address
8363 Make_Temporary_For_Slice;
8367 ------------------------------
8368 -- Expand_N_Type_Conversion --
8369 ------------------------------
8371 procedure Expand_N_Type_Conversion (N : Node_Id) is
8372 Loc : constant Source_Ptr := Sloc (N);
8373 Operand : constant Node_Id := Expression (N);
8374 Target_Type : constant Entity_Id := Etype (N);
8375 Operand_Type : Entity_Id := Etype (Operand);
8377 procedure Handle_Changed_Representation;
8378 -- This is called in the case of record and array type conversions to
8379 -- see if there is a change of representation to be handled. Change of
8380 -- representation is actually handled at the assignment statement level,
8381 -- and what this procedure does is rewrite node N conversion as an
8382 -- assignment to temporary. If there is no change of representation,
8383 -- then the conversion node is unchanged.
8385 procedure Raise_Accessibility_Error;
8386 -- Called when we know that an accessibility check will fail. Rewrites
8387 -- node N to an appropriate raise statement and outputs warning msgs.
8388 -- The Etype of the raise node is set to Target_Type.
8390 procedure Real_Range_Check;
8391 -- Handles generation of range check for real target value
8393 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
8394 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
8395 -- evaluates to True.
8397 -----------------------------------
8398 -- Handle_Changed_Representation --
8399 -----------------------------------
8401 procedure Handle_Changed_Representation is
8410 -- Nothing else to do if no change of representation
8412 if Same_Representation (Operand_Type, Target_Type) then
8415 -- The real change of representation work is done by the assignment
8416 -- statement processing. So if this type conversion is appearing as
8417 -- the expression of an assignment statement, nothing needs to be
8418 -- done to the conversion.
8420 elsif Nkind (Parent (N)) = N_Assignment_Statement then
8423 -- Otherwise we need to generate a temporary variable, and do the
8424 -- change of representation assignment into that temporary variable.
8425 -- The conversion is then replaced by a reference to this variable.
8430 -- If type is unconstrained we have to add a constraint, copied
8431 -- from the actual value of the left hand side.
8433 if not Is_Constrained (Target_Type) then
8434 if Has_Discriminants (Operand_Type) then
8435 Disc := First_Discriminant (Operand_Type);
8437 if Disc /= First_Stored_Discriminant (Operand_Type) then
8438 Disc := First_Stored_Discriminant (Operand_Type);
8442 while Present (Disc) loop
8444 Make_Selected_Component (Loc,
8446 Duplicate_Subexpr_Move_Checks (Operand),
8448 Make_Identifier (Loc, Chars (Disc))));
8449 Next_Discriminant (Disc);
8452 elsif Is_Array_Type (Operand_Type) then
8453 N_Ix := First_Index (Target_Type);
8456 for J in 1 .. Number_Dimensions (Operand_Type) loop
8458 -- We convert the bounds explicitly. We use an unchecked
8459 -- conversion because bounds checks are done elsewhere.
8464 Unchecked_Convert_To (Etype (N_Ix),
8465 Make_Attribute_Reference (Loc,
8467 Duplicate_Subexpr_No_Checks
8468 (Operand, Name_Req => True),
8469 Attribute_Name => Name_First,
8470 Expressions => New_List (
8471 Make_Integer_Literal (Loc, J)))),
8474 Unchecked_Convert_To (Etype (N_Ix),
8475 Make_Attribute_Reference (Loc,
8477 Duplicate_Subexpr_No_Checks
8478 (Operand, Name_Req => True),
8479 Attribute_Name => Name_Last,
8480 Expressions => New_List (
8481 Make_Integer_Literal (Loc, J))))));
8488 Odef := New_Occurrence_Of (Target_Type, Loc);
8490 if Present (Cons) then
8492 Make_Subtype_Indication (Loc,
8493 Subtype_Mark => Odef,
8495 Make_Index_Or_Discriminant_Constraint (Loc,
8496 Constraints => Cons));
8499 Temp := Make_Temporary (Loc, 'C');
8501 Make_Object_Declaration (Loc,
8502 Defining_Identifier => Temp,
8503 Object_Definition => Odef);
8505 Set_No_Initialization (Decl, True);
8507 -- Insert required actions. It is essential to suppress checks
8508 -- since we have suppressed default initialization, which means
8509 -- that the variable we create may have no discriminants.
8514 Make_Assignment_Statement (Loc,
8515 Name => New_Occurrence_Of (Temp, Loc),
8516 Expression => Relocate_Node (N))),
8517 Suppress => All_Checks);
8519 Rewrite (N, New_Occurrence_Of (Temp, Loc));
8522 end Handle_Changed_Representation;
8524 -------------------------------
8525 -- Raise_Accessibility_Error --
8526 -------------------------------
8528 procedure Raise_Accessibility_Error is
8531 Make_Raise_Program_Error (Sloc (N),
8532 Reason => PE_Accessibility_Check_Failed));
8533 Set_Etype (N, Target_Type);
8535 Error_Msg_N ("?accessibility check failure", N);
8537 ("\?& will be raised at run time", N, Standard_Program_Error);
8538 end Raise_Accessibility_Error;
8540 ----------------------
8541 -- Real_Range_Check --
8542 ----------------------
8544 -- Case of conversions to floating-point or fixed-point. If range checks
8545 -- are enabled and the target type has a range constraint, we convert:
8551 -- Tnn : typ'Base := typ'Base (x);
8552 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
8555 -- This is necessary when there is a conversion of integer to float or
8556 -- to fixed-point to ensure that the correct checks are made. It is not
8557 -- necessary for float to float where it is enough to simply set the
8558 -- Do_Range_Check flag.
8560 procedure Real_Range_Check is
8561 Btyp : constant Entity_Id := Base_Type (Target_Type);
8562 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
8563 Hi : constant Node_Id := Type_High_Bound (Target_Type);
8564 Xtyp : constant Entity_Id := Etype (Operand);
8569 -- Nothing to do if conversion was rewritten
8571 if Nkind (N) /= N_Type_Conversion then
8575 -- Nothing to do if range checks suppressed, or target has the same
8576 -- range as the base type (or is the base type).
8578 if Range_Checks_Suppressed (Target_Type)
8579 or else (Lo = Type_Low_Bound (Btyp)
8581 Hi = Type_High_Bound (Btyp))
8586 -- Nothing to do if expression is an entity on which checks have been
8589 if Is_Entity_Name (Operand)
8590 and then Range_Checks_Suppressed (Entity (Operand))
8595 -- Nothing to do if bounds are all static and we can tell that the
8596 -- expression is within the bounds of the target. Note that if the
8597 -- operand is of an unconstrained floating-point type, then we do
8598 -- not trust it to be in range (might be infinite)
8601 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
8602 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
8605 if (not Is_Floating_Point_Type (Xtyp)
8606 or else Is_Constrained (Xtyp))
8607 and then Compile_Time_Known_Value (S_Lo)
8608 and then Compile_Time_Known_Value (S_Hi)
8609 and then Compile_Time_Known_Value (Hi)
8610 and then Compile_Time_Known_Value (Lo)
8613 D_Lov : constant Ureal := Expr_Value_R (Lo);
8614 D_Hiv : constant Ureal := Expr_Value_R (Hi);
8619 if Is_Real_Type (Xtyp) then
8620 S_Lov := Expr_Value_R (S_Lo);
8621 S_Hiv := Expr_Value_R (S_Hi);
8623 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
8624 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
8628 and then S_Lov >= D_Lov
8629 and then S_Hiv <= D_Hiv
8631 Set_Do_Range_Check (Operand, False);
8638 -- For float to float conversions, we are done
8640 if Is_Floating_Point_Type (Xtyp)
8642 Is_Floating_Point_Type (Btyp)
8647 -- Otherwise rewrite the conversion as described above
8649 Conv := Relocate_Node (N);
8650 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
8651 Set_Etype (Conv, Btyp);
8653 -- Enable overflow except for case of integer to float conversions,
8654 -- where it is never required, since we can never have overflow in
8657 if not Is_Integer_Type (Etype (Operand)) then
8658 Enable_Overflow_Check (Conv);
8661 Tnn := Make_Temporary (Loc, 'T', Conv);
8663 Insert_Actions (N, New_List (
8664 Make_Object_Declaration (Loc,
8665 Defining_Identifier => Tnn,
8666 Object_Definition => New_Occurrence_Of (Btyp, Loc),
8667 Constant_Present => True,
8668 Expression => Conv),
8670 Make_Raise_Constraint_Error (Loc,
8675 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8677 Make_Attribute_Reference (Loc,
8678 Attribute_Name => Name_First,
8680 New_Occurrence_Of (Target_Type, Loc))),
8684 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8686 Make_Attribute_Reference (Loc,
8687 Attribute_Name => Name_Last,
8689 New_Occurrence_Of (Target_Type, Loc)))),
8690 Reason => CE_Range_Check_Failed)));
8692 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
8693 Analyze_And_Resolve (N, Btyp);
8694 end Real_Range_Check;
8696 -----------------------------
8697 -- Has_Extra_Accessibility --
8698 -----------------------------
8700 -- Returns true for a formal of an anonymous access type or for
8701 -- an Ada 2012-style stand-alone object of an anonymous access type.
8703 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
8705 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
8706 return Present (Effective_Extra_Accessibility (Id));
8710 end Has_Extra_Accessibility;
8712 -- Start of processing for Expand_N_Type_Conversion
8715 -- Nothing at all to do if conversion is to the identical type so remove
8716 -- the conversion completely, it is useless, except that it may carry
8717 -- an Assignment_OK attribute, which must be propagated to the operand.
8719 if Operand_Type = Target_Type then
8720 if Assignment_OK (N) then
8721 Set_Assignment_OK (Operand);
8724 Rewrite (N, Relocate_Node (Operand));
8728 -- Nothing to do if this is the second argument of read. This is a
8729 -- "backwards" conversion that will be handled by the specialized code
8730 -- in attribute processing.
8732 if Nkind (Parent (N)) = N_Attribute_Reference
8733 and then Attribute_Name (Parent (N)) = Name_Read
8734 and then Next (First (Expressions (Parent (N)))) = N
8739 -- Check for case of converting to a type that has an invariant
8740 -- associated with it. This required an invariant check. We convert
8746 -- do invariant_check (typ (expr)) in typ (expr);
8748 -- using Duplicate_Subexpr to avoid multiple side effects
8750 -- Note: the Comes_From_Source check, and then the resetting of this
8751 -- flag prevents what would otherwise be an infinite recursion.
8753 if Has_Invariants (Target_Type)
8754 and then Present (Invariant_Procedure (Target_Type))
8755 and then Comes_From_Source (N)
8757 Set_Comes_From_Source (N, False);
8759 Make_Expression_With_Actions (Loc,
8760 Actions => New_List (
8761 Make_Invariant_Call (Duplicate_Subexpr (N))),
8762 Expression => Duplicate_Subexpr_No_Checks (N)));
8763 Analyze_And_Resolve (N, Target_Type);
8767 -- Here if we may need to expand conversion
8769 -- If the operand of the type conversion is an arithmetic operation on
8770 -- signed integers, and the based type of the signed integer type in
8771 -- question is smaller than Standard.Integer, we promote both of the
8772 -- operands to type Integer.
8774 -- For example, if we have
8776 -- target-type (opnd1 + opnd2)
8778 -- and opnd1 and opnd2 are of type short integer, then we rewrite
8781 -- target-type (integer(opnd1) + integer(opnd2))
8783 -- We do this because we are always allowed to compute in a larger type
8784 -- if we do the right thing with the result, and in this case we are
8785 -- going to do a conversion which will do an appropriate check to make
8786 -- sure that things are in range of the target type in any case. This
8787 -- avoids some unnecessary intermediate overflows.
8789 -- We might consider a similar transformation in the case where the
8790 -- target is a real type or a 64-bit integer type, and the operand
8791 -- is an arithmetic operation using a 32-bit integer type. However,
8792 -- we do not bother with this case, because it could cause significant
8793 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
8794 -- much cheaper, but we don't want different behavior on 32-bit and
8795 -- 64-bit machines. Note that the exclusion of the 64-bit case also
8796 -- handles the configurable run-time cases where 64-bit arithmetic
8797 -- may simply be unavailable.
8799 -- Note: this circuit is partially redundant with respect to the circuit
8800 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
8801 -- the processing here. Also we still need the Checks circuit, since we
8802 -- have to be sure not to generate junk overflow checks in the first
8803 -- place, since it would be trick to remove them here!
8805 if Integer_Promotion_Possible (N) then
8807 -- All conditions met, go ahead with transformation
8815 Make_Type_Conversion (Loc,
8816 Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
8817 Expression => Relocate_Node (Right_Opnd (Operand)));
8819 Opnd := New_Op_Node (Nkind (Operand), Loc);
8820 Set_Right_Opnd (Opnd, R);
8822 if Nkind (Operand) in N_Binary_Op then
8824 Make_Type_Conversion (Loc,
8825 Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
8826 Expression => Relocate_Node (Left_Opnd (Operand)));
8828 Set_Left_Opnd (Opnd, L);
8832 Make_Type_Conversion (Loc,
8833 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
8834 Expression => Opnd));
8836 Analyze_And_Resolve (N, Target_Type);
8841 -- Do validity check if validity checking operands
8843 if Validity_Checks_On
8844 and then Validity_Check_Operands
8846 Ensure_Valid (Operand);
8849 -- Special case of converting from non-standard boolean type
8851 if Is_Boolean_Type (Operand_Type)
8852 and then (Nonzero_Is_True (Operand_Type))
8854 Adjust_Condition (Operand);
8855 Set_Etype (Operand, Standard_Boolean);
8856 Operand_Type := Standard_Boolean;
8859 -- Case of converting to an access type
8861 if Is_Access_Type (Target_Type) then
8863 -- Apply an accessibility check when the conversion operand is an
8864 -- access parameter (or a renaming thereof), unless conversion was
8865 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
8866 -- Note that other checks may still need to be applied below (such
8867 -- as tagged type checks).
8869 if Is_Entity_Name (Operand)
8870 and then Has_Extra_Accessibility (Entity (Operand))
8871 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
8872 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
8873 or else Attribute_Name (Original_Node (N)) = Name_Access)
8875 Apply_Accessibility_Check
8876 (Operand, Target_Type, Insert_Node => Operand);
8878 -- If the level of the operand type is statically deeper than the
8879 -- level of the target type, then force Program_Error. Note that this
8880 -- can only occur for cases where the attribute is within the body of
8881 -- an instantiation (otherwise the conversion will already have been
8882 -- rejected as illegal). Note: warnings are issued by the analyzer
8883 -- for the instance cases.
8885 elsif In_Instance_Body
8886 and then Type_Access_Level (Operand_Type) >
8887 Type_Access_Level (Target_Type)
8889 Raise_Accessibility_Error;
8891 -- When the operand is a selected access discriminant the check needs
8892 -- to be made against the level of the object denoted by the prefix
8893 -- of the selected name. Force Program_Error for this case as well
8894 -- (this accessibility violation can only happen if within the body
8895 -- of an instantiation).
8897 elsif In_Instance_Body
8898 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
8899 and then Nkind (Operand) = N_Selected_Component
8900 and then Object_Access_Level (Operand) >
8901 Type_Access_Level (Target_Type)
8903 Raise_Accessibility_Error;
8908 -- Case of conversions of tagged types and access to tagged types
8910 -- When needed, that is to say when the expression is class-wide, Add
8911 -- runtime a tag check for (strict) downward conversion by using the
8912 -- membership test, generating:
8914 -- [constraint_error when Operand not in Target_Type'Class]
8916 -- or in the access type case
8918 -- [constraint_error
8919 -- when Operand /= null
8920 -- and then Operand.all not in
8921 -- Designated_Type (Target_Type)'Class]
8923 if (Is_Access_Type (Target_Type)
8924 and then Is_Tagged_Type (Designated_Type (Target_Type)))
8925 or else Is_Tagged_Type (Target_Type)
8927 -- Do not do any expansion in the access type case if the parent is a
8928 -- renaming, since this is an error situation which will be caught by
8929 -- Sem_Ch8, and the expansion can interfere with this error check.
8931 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
8935 -- Otherwise, proceed with processing tagged conversion
8937 Tagged_Conversion : declare
8938 Actual_Op_Typ : Entity_Id;
8939 Actual_Targ_Typ : Entity_Id;
8940 Make_Conversion : Boolean := False;
8941 Root_Op_Typ : Entity_Id;
8943 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
8944 -- Create a membership check to test whether Operand is a member
8945 -- of Targ_Typ. If the original Target_Type is an access, include
8946 -- a test for null value. The check is inserted at N.
8948 --------------------
8949 -- Make_Tag_Check --
8950 --------------------
8952 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
8957 -- [Constraint_Error
8958 -- when Operand /= null
8959 -- and then Operand.all not in Targ_Typ]
8961 if Is_Access_Type (Target_Type) then
8966 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
8967 Right_Opnd => Make_Null (Loc)),
8972 Make_Explicit_Dereference (Loc,
8973 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
8974 Right_Opnd => New_Reference_To (Targ_Typ, Loc)));
8977 -- [Constraint_Error when Operand not in Targ_Typ]
8982 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
8983 Right_Opnd => New_Reference_To (Targ_Typ, Loc));
8987 Make_Raise_Constraint_Error (Loc,
8989 Reason => CE_Tag_Check_Failed));
8992 -- Start of processing for Tagged_Conversion
8995 -- Handle entities from the limited view
8997 if Is_Access_Type (Operand_Type) then
8999 Available_View (Designated_Type (Operand_Type));
9001 Actual_Op_Typ := Operand_Type;
9004 if Is_Access_Type (Target_Type) then
9006 Available_View (Designated_Type (Target_Type));
9008 Actual_Targ_Typ := Target_Type;
9011 Root_Op_Typ := Root_Type (Actual_Op_Typ);
9013 -- Ada 2005 (AI-251): Handle interface type conversion
9015 if Is_Interface (Actual_Op_Typ) then
9016 Expand_Interface_Conversion (N, Is_Static => False);
9020 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
9022 -- Create a runtime tag check for a downward class-wide type
9025 if Is_Class_Wide_Type (Actual_Op_Typ)
9026 and then Actual_Op_Typ /= Actual_Targ_Typ
9027 and then Root_Op_Typ /= Actual_Targ_Typ
9028 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
9029 Use_Full_View => True)
9031 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
9032 Make_Conversion := True;
9035 -- AI05-0073: If the result subtype of the function is defined
9036 -- by an access_definition designating a specific tagged type
9037 -- T, a check is made that the result value is null or the tag
9038 -- of the object designated by the result value identifies T.
9039 -- Constraint_Error is raised if this check fails.
9041 if Nkind (Parent (N)) = Sinfo.N_Return_Statement then
9044 Func_Typ : Entity_Id;
9047 -- Climb scope stack looking for the enclosing function
9049 Func := Current_Scope;
9050 while Present (Func)
9051 and then Ekind (Func) /= E_Function
9053 Func := Scope (Func);
9056 -- The function's return subtype must be defined using
9057 -- an access definition.
9059 if Nkind (Result_Definition (Parent (Func))) =
9062 Func_Typ := Directly_Designated_Type (Etype (Func));
9064 -- The return subtype denotes a specific tagged type,
9065 -- in other words, a non class-wide type.
9067 if Is_Tagged_Type (Func_Typ)
9068 and then not Is_Class_Wide_Type (Func_Typ)
9070 Make_Tag_Check (Actual_Targ_Typ);
9071 Make_Conversion := True;
9077 -- We have generated a tag check for either a class-wide type
9078 -- conversion or for AI05-0073.
9080 if Make_Conversion then
9085 Make_Unchecked_Type_Conversion (Loc,
9086 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
9087 Expression => Relocate_Node (Expression (N)));
9089 Analyze_And_Resolve (N, Target_Type);
9093 end Tagged_Conversion;
9095 -- Case of other access type conversions
9097 elsif Is_Access_Type (Target_Type) then
9098 Apply_Constraint_Check (Operand, Target_Type);
9100 -- Case of conversions from a fixed-point type
9102 -- These conversions require special expansion and processing, found in
9103 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
9104 -- since from a semantic point of view, these are simple integer
9105 -- conversions, which do not need further processing.
9107 elsif Is_Fixed_Point_Type (Operand_Type)
9108 and then not Conversion_OK (N)
9110 -- We should never see universal fixed at this case, since the
9111 -- expansion of the constituent divide or multiply should have
9112 -- eliminated the explicit mention of universal fixed.
9114 pragma Assert (Operand_Type /= Universal_Fixed);
9116 -- Check for special case of the conversion to universal real that
9117 -- occurs as a result of the use of a round attribute. In this case,
9118 -- the real type for the conversion is taken from the target type of
9119 -- the Round attribute and the result must be marked as rounded.
9121 if Target_Type = Universal_Real
9122 and then Nkind (Parent (N)) = N_Attribute_Reference
9123 and then Attribute_Name (Parent (N)) = Name_Round
9125 Set_Rounded_Result (N);
9126 Set_Etype (N, Etype (Parent (N)));
9129 -- Otherwise do correct fixed-conversion, but skip these if the
9130 -- Conversion_OK flag is set, because from a semantic point of view
9131 -- these are simple integer conversions needing no further processing
9132 -- (the backend will simply treat them as integers).
9134 if not Conversion_OK (N) then
9135 if Is_Fixed_Point_Type (Etype (N)) then
9136 Expand_Convert_Fixed_To_Fixed (N);
9139 elsif Is_Integer_Type (Etype (N)) then
9140 Expand_Convert_Fixed_To_Integer (N);
9143 pragma Assert (Is_Floating_Point_Type (Etype (N)));
9144 Expand_Convert_Fixed_To_Float (N);
9149 -- Case of conversions to a fixed-point type
9151 -- These conversions require special expansion and processing, found in
9152 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
9153 -- since from a semantic point of view, these are simple integer
9154 -- conversions, which do not need further processing.
9156 elsif Is_Fixed_Point_Type (Target_Type)
9157 and then not Conversion_OK (N)
9159 if Is_Integer_Type (Operand_Type) then
9160 Expand_Convert_Integer_To_Fixed (N);
9163 pragma Assert (Is_Floating_Point_Type (Operand_Type));
9164 Expand_Convert_Float_To_Fixed (N);
9168 -- Case of float-to-integer conversions
9170 -- We also handle float-to-fixed conversions with Conversion_OK set
9171 -- since semantically the fixed-point target is treated as though it
9172 -- were an integer in such cases.
9174 elsif Is_Floating_Point_Type (Operand_Type)
9176 (Is_Integer_Type (Target_Type)
9178 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
9180 -- One more check here, gcc is still not able to do conversions of
9181 -- this type with proper overflow checking, and so gigi is doing an
9182 -- approximation of what is required by doing floating-point compares
9183 -- with the end-point. But that can lose precision in some cases, and
9184 -- give a wrong result. Converting the operand to Universal_Real is
9185 -- helpful, but still does not catch all cases with 64-bit integers
9186 -- on targets with only 64-bit floats.
9188 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
9189 -- Can this code be removed ???
9191 if Do_Range_Check (Operand) then
9193 Make_Type_Conversion (Loc,
9195 New_Occurrence_Of (Universal_Real, Loc),
9197 Relocate_Node (Operand)));
9199 Set_Etype (Operand, Universal_Real);
9200 Enable_Range_Check (Operand);
9201 Set_Do_Range_Check (Expression (Operand), False);
9204 -- Case of array conversions
9206 -- Expansion of array conversions, add required length/range checks but
9207 -- only do this if there is no change of representation. For handling of
9208 -- this case, see Handle_Changed_Representation.
9210 elsif Is_Array_Type (Target_Type) then
9211 if Is_Constrained (Target_Type) then
9212 Apply_Length_Check (Operand, Target_Type);
9214 Apply_Range_Check (Operand, Target_Type);
9217 Handle_Changed_Representation;
9219 -- Case of conversions of discriminated types
9221 -- Add required discriminant checks if target is constrained. Again this
9222 -- change is skipped if we have a change of representation.
9224 elsif Has_Discriminants (Target_Type)
9225 and then Is_Constrained (Target_Type)
9227 Apply_Discriminant_Check (Operand, Target_Type);
9228 Handle_Changed_Representation;
9230 -- Case of all other record conversions. The only processing required
9231 -- is to check for a change of representation requiring the special
9232 -- assignment processing.
9234 elsif Is_Record_Type (Target_Type) then
9236 -- Ada 2005 (AI-216): Program_Error is raised when converting from
9237 -- a derived Unchecked_Union type to an unconstrained type that is
9238 -- not Unchecked_Union if the operand lacks inferable discriminants.
9240 if Is_Derived_Type (Operand_Type)
9241 and then Is_Unchecked_Union (Base_Type (Operand_Type))
9242 and then not Is_Constrained (Target_Type)
9243 and then not Is_Unchecked_Union (Base_Type (Target_Type))
9244 and then not Has_Inferable_Discriminants (Operand)
9246 -- To prevent Gigi from generating illegal code, we generate a
9247 -- Program_Error node, but we give it the target type of the
9251 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
9252 Reason => PE_Unchecked_Union_Restriction);
9255 Set_Etype (PE, Target_Type);
9260 Handle_Changed_Representation;
9263 -- Case of conversions of enumeration types
9265 elsif Is_Enumeration_Type (Target_Type) then
9267 -- Special processing is required if there is a change of
9268 -- representation (from enumeration representation clauses).
9270 if not Same_Representation (Target_Type, Operand_Type) then
9272 -- Convert: x(y) to x'val (ytyp'val (y))
9275 Make_Attribute_Reference (Loc,
9276 Prefix => New_Occurrence_Of (Target_Type, Loc),
9277 Attribute_Name => Name_Val,
9278 Expressions => New_List (
9279 Make_Attribute_Reference (Loc,
9280 Prefix => New_Occurrence_Of (Operand_Type, Loc),
9281 Attribute_Name => Name_Pos,
9282 Expressions => New_List (Operand)))));
9284 Analyze_And_Resolve (N, Target_Type);
9287 -- Case of conversions to floating-point
9289 elsif Is_Floating_Point_Type (Target_Type) then
9293 -- At this stage, either the conversion node has been transformed into
9294 -- some other equivalent expression, or left as a conversion that can be
9295 -- handled by Gigi, in the following cases:
9297 -- Conversions with no change of representation or type
9299 -- Numeric conversions involving integer, floating- and fixed-point
9300 -- values. Fixed-point values are allowed only if Conversion_OK is
9301 -- set, i.e. if the fixed-point values are to be treated as integers.
9303 -- No other conversions should be passed to Gigi
9305 -- Check: are these rules stated in sinfo??? if so, why restate here???
9307 -- The only remaining step is to generate a range check if we still have
9308 -- a type conversion at this stage and Do_Range_Check is set. For now we
9309 -- do this only for conversions of discrete types.
9311 if Nkind (N) = N_Type_Conversion
9312 and then Is_Discrete_Type (Etype (N))
9315 Expr : constant Node_Id := Expression (N);
9320 if Do_Range_Check (Expr)
9321 and then Is_Discrete_Type (Etype (Expr))
9323 Set_Do_Range_Check (Expr, False);
9325 -- Before we do a range check, we have to deal with treating a
9326 -- fixed-point operand as an integer. The way we do this is
9327 -- simply to do an unchecked conversion to an appropriate
9328 -- integer type large enough to hold the result.
9330 -- This code is not active yet, because we are only dealing
9331 -- with discrete types so far ???
9333 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
9334 and then Treat_Fixed_As_Integer (Expr)
9336 Ftyp := Base_Type (Etype (Expr));
9338 if Esize (Ftyp) >= Esize (Standard_Integer) then
9339 Ityp := Standard_Long_Long_Integer;
9341 Ityp := Standard_Integer;
9344 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
9347 -- Reset overflow flag, since the range check will include
9348 -- dealing with possible overflow, and generate the check. If
9349 -- Address is either a source type or target type, suppress
9350 -- range check to avoid typing anomalies when it is a visible
9353 Set_Do_Overflow_Check (N, False);
9354 if not Is_Descendent_Of_Address (Etype (Expr))
9355 and then not Is_Descendent_Of_Address (Target_Type)
9357 Generate_Range_Check
9358 (Expr, Target_Type, CE_Range_Check_Failed);
9364 -- Final step, if the result is a type conversion involving Vax_Float
9365 -- types, then it is subject for further special processing.
9367 if Nkind (N) = N_Type_Conversion
9368 and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
9370 Expand_Vax_Conversion (N);
9374 -- Here at end of processing
9377 -- Apply predicate check if required. Note that we can't just call
9378 -- Apply_Predicate_Check here, because the type looks right after
9379 -- the conversion and it would omit the check. The Comes_From_Source
9380 -- guard is necessary to prevent infinite recursions when we generate
9381 -- internal conversions for the purpose of checking predicates.
9383 if Present (Predicate_Function (Target_Type))
9384 and then Target_Type /= Operand_Type
9385 and then Comes_From_Source (N)
9388 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
9391 -- Avoid infinite recursion on the subsequent expansion of
9392 -- of the copy of the original type conversion.
9394 Set_Comes_From_Source (New_Expr, False);
9395 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr));
9398 end Expand_N_Type_Conversion;
9400 -----------------------------------
9401 -- Expand_N_Unchecked_Expression --
9402 -----------------------------------
9404 -- Remove the unchecked expression node from the tree. Its job was simply
9405 -- to make sure that its constituent expression was handled with checks
9406 -- off, and now that that is done, we can remove it from the tree, and
9407 -- indeed must, since Gigi does not expect to see these nodes.
9409 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
9410 Exp : constant Node_Id := Expression (N);
9412 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
9414 end Expand_N_Unchecked_Expression;
9416 ----------------------------------------
9417 -- Expand_N_Unchecked_Type_Conversion --
9418 ----------------------------------------
9420 -- If this cannot be handled by Gigi and we haven't already made a
9421 -- temporary for it, do it now.
9423 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
9424 Target_Type : constant Entity_Id := Etype (N);
9425 Operand : constant Node_Id := Expression (N);
9426 Operand_Type : constant Entity_Id := Etype (Operand);
9429 -- Nothing at all to do if conversion is to the identical type so remove
9430 -- the conversion completely, it is useless, except that it may carry
9431 -- an Assignment_OK indication which must be propagated to the operand.
9433 if Operand_Type = Target_Type then
9435 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
9437 if Assignment_OK (N) then
9438 Set_Assignment_OK (Operand);
9441 Rewrite (N, Relocate_Node (Operand));
9445 -- If we have a conversion of a compile time known value to a target
9446 -- type and the value is in range of the target type, then we can simply
9447 -- replace the construct by an integer literal of the correct type. We
9448 -- only apply this to integer types being converted. Possibly it may
9449 -- apply in other cases, but it is too much trouble to worry about.
9451 -- Note that we do not do this transformation if the Kill_Range_Check
9452 -- flag is set, since then the value may be outside the expected range.
9453 -- This happens in the Normalize_Scalars case.
9455 -- We also skip this if either the target or operand type is biased
9456 -- because in this case, the unchecked conversion is supposed to
9457 -- preserve the bit pattern, not the integer value.
9459 if Is_Integer_Type (Target_Type)
9460 and then not Has_Biased_Representation (Target_Type)
9461 and then Is_Integer_Type (Operand_Type)
9462 and then not Has_Biased_Representation (Operand_Type)
9463 and then Compile_Time_Known_Value (Operand)
9464 and then not Kill_Range_Check (N)
9467 Val : constant Uint := Expr_Value (Operand);
9470 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
9472 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
9474 Val >= Expr_Value (Type_Low_Bound (Target_Type))
9476 Val <= Expr_Value (Type_High_Bound (Target_Type))
9478 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
9480 -- If Address is the target type, just set the type to avoid a
9481 -- spurious type error on the literal when Address is a visible
9484 if Is_Descendent_Of_Address (Target_Type) then
9485 Set_Etype (N, Target_Type);
9487 Analyze_And_Resolve (N, Target_Type);
9495 -- Nothing to do if conversion is safe
9497 if Safe_Unchecked_Type_Conversion (N) then
9501 -- Otherwise force evaluation unless Assignment_OK flag is set (this
9502 -- flag indicates ??? -- more comments needed here)
9504 if Assignment_OK (N) then
9507 Force_Evaluation (N);
9509 end Expand_N_Unchecked_Type_Conversion;
9511 ----------------------------
9512 -- Expand_Record_Equality --
9513 ----------------------------
9515 -- For non-variant records, Equality is expanded when needed into:
9517 -- and then Lhs.Discr1 = Rhs.Discr1
9519 -- and then Lhs.Discrn = Rhs.Discrn
9520 -- and then Lhs.Cmp1 = Rhs.Cmp1
9522 -- and then Lhs.Cmpn = Rhs.Cmpn
9524 -- The expression is folded by the back-end for adjacent fields. This
9525 -- function is called for tagged record in only one occasion: for imple-
9526 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
9527 -- otherwise the primitive "=" is used directly.
9529 function Expand_Record_Equality
9534 Bodies : List_Id) return Node_Id
9536 Loc : constant Source_Ptr := Sloc (Nod);
9541 First_Time : Boolean := True;
9543 function Suitable_Element (C : Entity_Id) return Entity_Id;
9544 -- Return the first field to compare beginning with C, skipping the
9545 -- inherited components.
9547 ----------------------
9548 -- Suitable_Element --
9549 ----------------------
9551 function Suitable_Element (C : Entity_Id) return Entity_Id is
9556 elsif Ekind (C) /= E_Discriminant
9557 and then Ekind (C) /= E_Component
9559 return Suitable_Element (Next_Entity (C));
9561 elsif Is_Tagged_Type (Typ)
9562 and then C /= Original_Record_Component (C)
9564 return Suitable_Element (Next_Entity (C));
9566 elsif Chars (C) = Name_uTag then
9567 return Suitable_Element (Next_Entity (C));
9569 -- The .NET/JVM version of type Root_Controlled contains two fields
9570 -- which should not be considered part of the object. To achieve
9571 -- proper equiality between two controlled objects on .NET/JVM, skip
9572 -- field _parent whenever it is of type Root_Controlled.
9574 elsif Chars (C) = Name_uParent
9575 and then VM_Target /= No_VM
9576 and then Etype (C) = RTE (RE_Root_Controlled)
9578 return Suitable_Element (Next_Entity (C));
9580 elsif Is_Interface (Etype (C)) then
9581 return Suitable_Element (Next_Entity (C));
9586 end Suitable_Element;
9588 -- Start of processing for Expand_Record_Equality
9591 -- Generates the following code: (assuming that Typ has one Discr and
9592 -- component C2 is also a record)
9595 -- and then Lhs.Discr1 = Rhs.Discr1
9596 -- and then Lhs.C1 = Rhs.C1
9597 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
9599 -- and then Lhs.Cmpn = Rhs.Cmpn
9601 Result := New_Reference_To (Standard_True, Loc);
9602 C := Suitable_Element (First_Entity (Typ));
9603 while Present (C) loop
9611 First_Time := False;
9615 New_Lhs := New_Copy_Tree (Lhs);
9616 New_Rhs := New_Copy_Tree (Rhs);
9620 Expand_Composite_Equality (Nod, Etype (C),
9622 Make_Selected_Component (Loc,
9624 Selector_Name => New_Reference_To (C, Loc)),
9626 Make_Selected_Component (Loc,
9628 Selector_Name => New_Reference_To (C, Loc)),
9631 -- If some (sub)component is an unchecked_union, the whole
9632 -- operation will raise program error.
9634 if Nkind (Check) = N_Raise_Program_Error then
9636 Set_Etype (Result, Standard_Boolean);
9641 Left_Opnd => Result,
9642 Right_Opnd => Check);
9646 C := Suitable_Element (Next_Entity (C));
9650 end Expand_Record_Equality;
9652 -----------------------------------
9653 -- Expand_Short_Circuit_Operator --
9654 -----------------------------------
9656 -- Deal with special expansion if actions are present for the right operand
9657 -- and deal with optimizing case of arguments being True or False. We also
9658 -- deal with the special case of non-standard boolean values.
9660 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
9661 Loc : constant Source_Ptr := Sloc (N);
9662 Typ : constant Entity_Id := Etype (N);
9663 Left : constant Node_Id := Left_Opnd (N);
9664 Right : constant Node_Id := Right_Opnd (N);
9665 LocR : constant Source_Ptr := Sloc (Right);
9668 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
9669 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
9670 -- If Left = Shortcut_Value then Right need not be evaluated
9672 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
9673 -- For Opnd a boolean expression, return a Boolean expression equivalent
9674 -- to Opnd /= Shortcut_Value.
9676 --------------------
9677 -- Make_Test_Expr --
9678 --------------------
9680 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
9682 if Shortcut_Value then
9683 return Make_Op_Not (Sloc (Opnd), Opnd);
9690 -- Entity for a temporary variable holding the value of the operator,
9691 -- used for expansion in the case where actions are present.
9693 -- Start of processing for Expand_Short_Circuit_Operator
9696 -- Deal with non-standard booleans
9698 if Is_Boolean_Type (Typ) then
9699 Adjust_Condition (Left);
9700 Adjust_Condition (Right);
9701 Set_Etype (N, Standard_Boolean);
9704 -- Check for cases where left argument is known to be True or False
9706 if Compile_Time_Known_Value (Left) then
9708 -- Mark SCO for left condition as compile time known
9710 if Generate_SCO and then Comes_From_Source (Left) then
9711 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
9714 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
9715 -- Any actions associated with Right will be executed unconditionally
9716 -- and can thus be inserted into the tree unconditionally.
9718 if Expr_Value_E (Left) /= Shortcut_Ent then
9719 if Present (Actions (N)) then
9720 Insert_Actions (N, Actions (N));
9725 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
9726 -- In this case we can forget the actions associated with Right,
9727 -- since they will never be executed.
9730 Kill_Dead_Code (Right);
9731 Kill_Dead_Code (Actions (N));
9732 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
9735 Adjust_Result_Type (N, Typ);
9739 -- If Actions are present for the right operand, we have to do some
9740 -- special processing. We can't just let these actions filter back into
9741 -- code preceding the short circuit (which is what would have happened
9742 -- if we had not trapped them in the short-circuit form), since they
9743 -- must only be executed if the right operand of the short circuit is
9744 -- executed and not otherwise.
9746 -- the temporary variable C.
9748 if Present (Actions (N)) then
9749 Actlist := Actions (N);
9751 -- The old approach is to expand:
9753 -- left AND THEN right
9757 -- C : Boolean := False;
9765 -- and finally rewrite the operator into a reference to C. Similarly
9766 -- for left OR ELSE right, with negated values. Note that this
9767 -- rewrite causes some difficulties for coverage analysis because
9768 -- of the introduction of the new variable C, which obscures the
9769 -- structure of the test.
9771 -- We use this "old approach" if use of N_Expression_With_Actions
9772 -- is False (see description in Opt of when this is or is not set).
9774 if not Use_Expression_With_Actions then
9775 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
9778 Make_Object_Declaration (Loc,
9779 Defining_Identifier =>
9781 Object_Definition =>
9782 New_Occurrence_Of (Standard_Boolean, Loc),
9784 New_Occurrence_Of (Shortcut_Ent, Loc)));
9787 Make_Implicit_If_Statement (Right,
9788 Condition => Make_Test_Expr (Right),
9789 Then_Statements => New_List (
9790 Make_Assignment_Statement (LocR,
9791 Name => New_Occurrence_Of (Op_Var, LocR),
9794 (Boolean_Literals (not Shortcut_Value), LocR)))));
9797 Make_Implicit_If_Statement (Left,
9798 Condition => Make_Test_Expr (Left),
9799 Then_Statements => Actlist));
9801 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
9802 Analyze_And_Resolve (N, Standard_Boolean);
9804 -- The new approach, activated for now by the use of debug flag
9805 -- -gnatd.X is to use the new Expression_With_Actions node for the
9806 -- right operand of the short-circuit form. This should solve the
9807 -- traceability problems for coverage analysis.
9811 Make_Expression_With_Actions (LocR,
9812 Expression => Relocate_Node (Right),
9813 Actions => Actlist));
9814 Set_Actions (N, No_List);
9815 Analyze_And_Resolve (Right, Standard_Boolean);
9818 Adjust_Result_Type (N, Typ);
9822 -- No actions present, check for cases of right argument True/False
9824 if Compile_Time_Known_Value (Right) then
9826 -- Mark SCO for left condition as compile time known
9828 if Generate_SCO and then Comes_From_Source (Right) then
9829 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
9832 -- Change (Left and then True), (Left or else False) to Left.
9833 -- Note that we know there are no actions associated with the right
9834 -- operand, since we just checked for this case above.
9836 if Expr_Value_E (Right) /= Shortcut_Ent then
9839 -- Change (Left and then False), (Left or else True) to Right,
9840 -- making sure to preserve any side effects associated with the Left
9844 Remove_Side_Effects (Left);
9845 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
9849 Adjust_Result_Type (N, Typ);
9850 end Expand_Short_Circuit_Operator;
9852 -------------------------------------
9853 -- Fixup_Universal_Fixed_Operation --
9854 -------------------------------------
9856 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
9857 Conv : constant Node_Id := Parent (N);
9860 -- We must have a type conversion immediately above us
9862 pragma Assert (Nkind (Conv) = N_Type_Conversion);
9864 -- Normally the type conversion gives our target type. The exception
9865 -- occurs in the case of the Round attribute, where the conversion
9866 -- will be to universal real, and our real type comes from the Round
9867 -- attribute (as well as an indication that we must round the result)
9869 if Nkind (Parent (Conv)) = N_Attribute_Reference
9870 and then Attribute_Name (Parent (Conv)) = Name_Round
9872 Set_Etype (N, Etype (Parent (Conv)));
9873 Set_Rounded_Result (N);
9875 -- Normal case where type comes from conversion above us
9878 Set_Etype (N, Etype (Conv));
9880 end Fixup_Universal_Fixed_Operation;
9882 ---------------------------------
9883 -- Has_Inferable_Discriminants --
9884 ---------------------------------
9886 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
9888 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
9889 -- Determines whether the left-most prefix of a selected component is a
9890 -- formal parameter in a subprogram. Assumes N is a selected component.
9892 --------------------------------
9893 -- Prefix_Is_Formal_Parameter --
9894 --------------------------------
9896 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
9897 Sel_Comp : Node_Id := N;
9900 -- Move to the left-most prefix by climbing up the tree
9902 while Present (Parent (Sel_Comp))
9903 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
9905 Sel_Comp := Parent (Sel_Comp);
9908 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
9909 end Prefix_Is_Formal_Parameter;
9911 -- Start of processing for Has_Inferable_Discriminants
9914 -- For identifiers and indexed components, it is sufficient to have a
9915 -- constrained Unchecked_Union nominal subtype.
9917 if Nkind_In (N, N_Identifier, N_Indexed_Component) then
9918 return Is_Unchecked_Union (Base_Type (Etype (N)))
9920 Is_Constrained (Etype (N));
9922 -- For selected components, the subtype of the selector must be a
9923 -- constrained Unchecked_Union. If the component is subject to a
9924 -- per-object constraint, then the enclosing object must have inferable
9927 elsif Nkind (N) = N_Selected_Component then
9928 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
9930 -- A small hack. If we have a per-object constrained selected
9931 -- component of a formal parameter, return True since we do not
9932 -- know the actual parameter association yet.
9934 if Prefix_Is_Formal_Parameter (N) then
9938 -- Otherwise, check the enclosing object and the selector
9940 return Has_Inferable_Discriminants (Prefix (N))
9942 Has_Inferable_Discriminants (Selector_Name (N));
9945 -- The call to Has_Inferable_Discriminants will determine whether
9946 -- the selector has a constrained Unchecked_Union nominal type.
9948 return Has_Inferable_Discriminants (Selector_Name (N));
9950 -- A qualified expression has inferable discriminants if its subtype
9951 -- mark is a constrained Unchecked_Union subtype.
9953 elsif Nkind (N) = N_Qualified_Expression then
9954 return Is_Unchecked_Union (Subtype_Mark (N))
9956 Is_Constrained (Subtype_Mark (N));
9961 end Has_Inferable_Discriminants;
9963 -------------------------------
9964 -- Insert_Dereference_Action --
9965 -------------------------------
9967 procedure Insert_Dereference_Action (N : Node_Id) is
9968 Loc : constant Source_Ptr := Sloc (N);
9969 Typ : constant Entity_Id := Etype (N);
9970 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
9971 Pnod : constant Node_Id := Parent (N);
9973 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
9974 -- Return true if type of P is derived from Checked_Pool;
9976 -----------------------------
9977 -- Is_Checked_Storage_Pool --
9978 -----------------------------
9980 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
9989 while T /= Etype (T) loop
9990 if Is_RTE (T, RE_Checked_Pool) then
9998 end Is_Checked_Storage_Pool;
10000 -- Start of processing for Insert_Dereference_Action
10003 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
10005 if not (Is_Checked_Storage_Pool (Pool)
10006 and then Comes_From_Source (Original_Node (Pnod)))
10012 Make_Procedure_Call_Statement (Loc,
10013 Name => New_Reference_To (
10014 Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
10016 Parameter_Associations => New_List (
10020 New_Reference_To (Pool, Loc),
10022 -- Storage_Address. We use the attribute Pool_Address, which uses
10023 -- the pointer itself to find the address of the object, and which
10024 -- handles unconstrained arrays properly by computing the address
10025 -- of the template. i.e. the correct address of the corresponding
10028 Make_Attribute_Reference (Loc,
10029 Prefix => Duplicate_Subexpr_Move_Checks (N),
10030 Attribute_Name => Name_Pool_Address),
10032 -- Size_In_Storage_Elements
10034 Make_Op_Divide (Loc,
10036 Make_Attribute_Reference (Loc,
10038 Make_Explicit_Dereference (Loc,
10039 Duplicate_Subexpr_Move_Checks (N)),
10040 Attribute_Name => Name_Size),
10042 Make_Integer_Literal (Loc, System_Storage_Unit)),
10046 Make_Attribute_Reference (Loc,
10048 Make_Explicit_Dereference (Loc,
10049 Duplicate_Subexpr_Move_Checks (N)),
10050 Attribute_Name => Name_Alignment))));
10053 when RE_Not_Available =>
10055 end Insert_Dereference_Action;
10057 --------------------------------
10058 -- Integer_Promotion_Possible --
10059 --------------------------------
10061 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
10062 Operand : constant Node_Id := Expression (N);
10063 Operand_Type : constant Entity_Id := Etype (Operand);
10064 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
10067 pragma Assert (Nkind (N) = N_Type_Conversion);
10071 -- We only do the transformation for source constructs. We assume
10072 -- that the expander knows what it is doing when it generates code.
10074 Comes_From_Source (N)
10076 -- If the operand type is Short_Integer or Short_Short_Integer,
10077 -- then we will promote to Integer, which is available on all
10078 -- targets, and is sufficient to ensure no intermediate overflow.
10079 -- Furthermore it is likely to be as efficient or more efficient
10080 -- than using the smaller type for the computation so we do this
10081 -- unconditionally.
10084 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
10086 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
10088 -- Test for interesting operation, which includes addition,
10089 -- division, exponentiation, multiplication, subtraction, absolute
10090 -- value and unary negation. Unary "+" is omitted since it is a
10091 -- no-op and thus can't overflow.
10093 and then Nkind_In (Operand, N_Op_Abs,
10100 end Integer_Promotion_Possible;
10102 ------------------------------
10103 -- Make_Array_Comparison_Op --
10104 ------------------------------
10106 -- This is a hand-coded expansion of the following generic function:
10109 -- type elem is (<>);
10110 -- type index is (<>);
10111 -- type a is array (index range <>) of elem;
10113 -- function Gnnn (X : a; Y: a) return boolean is
10114 -- J : index := Y'first;
10117 -- if X'length = 0 then
10120 -- elsif Y'length = 0 then
10124 -- for I in X'range loop
10125 -- if X (I) = Y (J) then
10126 -- if J = Y'last then
10129 -- J := index'succ (J);
10133 -- return X (I) > Y (J);
10137 -- return X'length > Y'length;
10141 -- Note that since we are essentially doing this expansion by hand, we
10142 -- do not need to generate an actual or formal generic part, just the
10143 -- instantiated function itself.
10145 function Make_Array_Comparison_Op
10147 Nod : Node_Id) return Node_Id
10149 Loc : constant Source_Ptr := Sloc (Nod);
10151 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
10152 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
10153 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
10154 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
10156 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
10158 Loop_Statement : Node_Id;
10159 Loop_Body : Node_Id;
10161 Inner_If : Node_Id;
10162 Final_Expr : Node_Id;
10163 Func_Body : Node_Id;
10164 Func_Name : Entity_Id;
10170 -- if J = Y'last then
10173 -- J := index'succ (J);
10177 Make_Implicit_If_Statement (Nod,
10180 Left_Opnd => New_Reference_To (J, Loc),
10182 Make_Attribute_Reference (Loc,
10183 Prefix => New_Reference_To (Y, Loc),
10184 Attribute_Name => Name_Last)),
10186 Then_Statements => New_List (
10187 Make_Exit_Statement (Loc)),
10191 Make_Assignment_Statement (Loc,
10192 Name => New_Reference_To (J, Loc),
10194 Make_Attribute_Reference (Loc,
10195 Prefix => New_Reference_To (Index, Loc),
10196 Attribute_Name => Name_Succ,
10197 Expressions => New_List (New_Reference_To (J, Loc))))));
10199 -- if X (I) = Y (J) then
10202 -- return X (I) > Y (J);
10206 Make_Implicit_If_Statement (Nod,
10210 Make_Indexed_Component (Loc,
10211 Prefix => New_Reference_To (X, Loc),
10212 Expressions => New_List (New_Reference_To (I, Loc))),
10215 Make_Indexed_Component (Loc,
10216 Prefix => New_Reference_To (Y, Loc),
10217 Expressions => New_List (New_Reference_To (J, Loc)))),
10219 Then_Statements => New_List (Inner_If),
10221 Else_Statements => New_List (
10222 Make_Simple_Return_Statement (Loc,
10226 Make_Indexed_Component (Loc,
10227 Prefix => New_Reference_To (X, Loc),
10228 Expressions => New_List (New_Reference_To (I, Loc))),
10231 Make_Indexed_Component (Loc,
10232 Prefix => New_Reference_To (Y, Loc),
10233 Expressions => New_List (
10234 New_Reference_To (J, Loc)))))));
10236 -- for I in X'range loop
10241 Make_Implicit_Loop_Statement (Nod,
10242 Identifier => Empty,
10244 Iteration_Scheme =>
10245 Make_Iteration_Scheme (Loc,
10246 Loop_Parameter_Specification =>
10247 Make_Loop_Parameter_Specification (Loc,
10248 Defining_Identifier => I,
10249 Discrete_Subtype_Definition =>
10250 Make_Attribute_Reference (Loc,
10251 Prefix => New_Reference_To (X, Loc),
10252 Attribute_Name => Name_Range))),
10254 Statements => New_List (Loop_Body));
10256 -- if X'length = 0 then
10258 -- elsif Y'length = 0 then
10261 -- for ... loop ... end loop;
10262 -- return X'length > Y'length;
10266 Make_Attribute_Reference (Loc,
10267 Prefix => New_Reference_To (X, Loc),
10268 Attribute_Name => Name_Length);
10271 Make_Attribute_Reference (Loc,
10272 Prefix => New_Reference_To (Y, Loc),
10273 Attribute_Name => Name_Length);
10277 Left_Opnd => Length1,
10278 Right_Opnd => Length2);
10281 Make_Implicit_If_Statement (Nod,
10285 Make_Attribute_Reference (Loc,
10286 Prefix => New_Reference_To (X, Loc),
10287 Attribute_Name => Name_Length),
10289 Make_Integer_Literal (Loc, 0)),
10293 Make_Simple_Return_Statement (Loc,
10294 Expression => New_Reference_To (Standard_False, Loc))),
10296 Elsif_Parts => New_List (
10297 Make_Elsif_Part (Loc,
10301 Make_Attribute_Reference (Loc,
10302 Prefix => New_Reference_To (Y, Loc),
10303 Attribute_Name => Name_Length),
10305 Make_Integer_Literal (Loc, 0)),
10309 Make_Simple_Return_Statement (Loc,
10310 Expression => New_Reference_To (Standard_True, Loc))))),
10312 Else_Statements => New_List (
10314 Make_Simple_Return_Statement (Loc,
10315 Expression => Final_Expr)));
10319 Formals := New_List (
10320 Make_Parameter_Specification (Loc,
10321 Defining_Identifier => X,
10322 Parameter_Type => New_Reference_To (Typ, Loc)),
10324 Make_Parameter_Specification (Loc,
10325 Defining_Identifier => Y,
10326 Parameter_Type => New_Reference_To (Typ, Loc)));
10328 -- function Gnnn (...) return boolean is
10329 -- J : index := Y'first;
10334 Func_Name := Make_Temporary (Loc, 'G');
10337 Make_Subprogram_Body (Loc,
10339 Make_Function_Specification (Loc,
10340 Defining_Unit_Name => Func_Name,
10341 Parameter_Specifications => Formals,
10342 Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
10344 Declarations => New_List (
10345 Make_Object_Declaration (Loc,
10346 Defining_Identifier => J,
10347 Object_Definition => New_Reference_To (Index, Loc),
10349 Make_Attribute_Reference (Loc,
10350 Prefix => New_Reference_To (Y, Loc),
10351 Attribute_Name => Name_First))),
10353 Handled_Statement_Sequence =>
10354 Make_Handled_Sequence_Of_Statements (Loc,
10355 Statements => New_List (If_Stat)));
10358 end Make_Array_Comparison_Op;
10360 ---------------------------
10361 -- Make_Boolean_Array_Op --
10362 ---------------------------
10364 -- For logical operations on boolean arrays, expand in line the following,
10365 -- replacing 'and' with 'or' or 'xor' where needed:
10367 -- function Annn (A : typ; B: typ) return typ is
10370 -- for J in A'range loop
10371 -- C (J) := A (J) op B (J);
10376 -- Here typ is the boolean array type
10378 function Make_Boolean_Array_Op
10380 N : Node_Id) return Node_Id
10382 Loc : constant Source_Ptr := Sloc (N);
10384 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
10385 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
10386 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
10387 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
10395 Func_Name : Entity_Id;
10396 Func_Body : Node_Id;
10397 Loop_Statement : Node_Id;
10401 Make_Indexed_Component (Loc,
10402 Prefix => New_Reference_To (A, Loc),
10403 Expressions => New_List (New_Reference_To (J, Loc)));
10406 Make_Indexed_Component (Loc,
10407 Prefix => New_Reference_To (B, Loc),
10408 Expressions => New_List (New_Reference_To (J, Loc)));
10411 Make_Indexed_Component (Loc,
10412 Prefix => New_Reference_To (C, Loc),
10413 Expressions => New_List (New_Reference_To (J, Loc)));
10415 if Nkind (N) = N_Op_And then
10419 Right_Opnd => B_J);
10421 elsif Nkind (N) = N_Op_Or then
10425 Right_Opnd => B_J);
10431 Right_Opnd => B_J);
10435 Make_Implicit_Loop_Statement (N,
10436 Identifier => Empty,
10438 Iteration_Scheme =>
10439 Make_Iteration_Scheme (Loc,
10440 Loop_Parameter_Specification =>
10441 Make_Loop_Parameter_Specification (Loc,
10442 Defining_Identifier => J,
10443 Discrete_Subtype_Definition =>
10444 Make_Attribute_Reference (Loc,
10445 Prefix => New_Reference_To (A, Loc),
10446 Attribute_Name => Name_Range))),
10448 Statements => New_List (
10449 Make_Assignment_Statement (Loc,
10451 Expression => Op)));
10453 Formals := New_List (
10454 Make_Parameter_Specification (Loc,
10455 Defining_Identifier => A,
10456 Parameter_Type => New_Reference_To (Typ, Loc)),
10458 Make_Parameter_Specification (Loc,
10459 Defining_Identifier => B,
10460 Parameter_Type => New_Reference_To (Typ, Loc)));
10462 Func_Name := Make_Temporary (Loc, 'A');
10463 Set_Is_Inlined (Func_Name);
10466 Make_Subprogram_Body (Loc,
10468 Make_Function_Specification (Loc,
10469 Defining_Unit_Name => Func_Name,
10470 Parameter_Specifications => Formals,
10471 Result_Definition => New_Reference_To (Typ, Loc)),
10473 Declarations => New_List (
10474 Make_Object_Declaration (Loc,
10475 Defining_Identifier => C,
10476 Object_Definition => New_Reference_To (Typ, Loc))),
10478 Handled_Statement_Sequence =>
10479 Make_Handled_Sequence_Of_Statements (Loc,
10480 Statements => New_List (
10482 Make_Simple_Return_Statement (Loc,
10483 Expression => New_Reference_To (C, Loc)))));
10486 end Make_Boolean_Array_Op;
10488 --------------------------------
10489 -- Optimize_Length_Comparison --
10490 --------------------------------
10492 procedure Optimize_Length_Comparison (N : Node_Id) is
10493 Loc : constant Source_Ptr := Sloc (N);
10494 Typ : constant Entity_Id := Etype (N);
10499 -- First and Last attribute reference nodes, which end up as left and
10500 -- right operands of the optimized result.
10503 -- True for comparison operand of zero
10506 -- Comparison operand, set only if Is_Zero is false
10509 -- Entity whose length is being compared
10512 -- Integer_Literal node for length attribute expression, or Empty
10513 -- if there is no such expression present.
10516 -- Type of array index to which 'Length is applied
10518 Op : Node_Kind := Nkind (N);
10519 -- Kind of comparison operator, gets flipped if operands backwards
10521 function Is_Optimizable (N : Node_Id) return Boolean;
10522 -- Tests N to see if it is an optimizable comparison value (defined as
10523 -- constant zero or one, or something else where the value is known to
10524 -- be positive and in the range of 32-bits, and where the corresponding
10525 -- Length value is also known to be 32-bits. If result is true, sets
10526 -- Is_Zero, Ityp, and Comp accordingly.
10528 function Is_Entity_Length (N : Node_Id) return Boolean;
10529 -- Tests if N is a length attribute applied to a simple entity. If so,
10530 -- returns True, and sets Ent to the entity, and Index to the integer
10531 -- literal provided as an attribute expression, or to Empty if none.
10532 -- Also returns True if the expression is a generated type conversion
10533 -- whose expression is of the desired form. This latter case arises
10534 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
10535 -- to check for being in range, which is not needed in this context.
10536 -- Returns False if neither condition holds.
10538 function Prepare_64 (N : Node_Id) return Node_Id;
10539 -- Given a discrete expression, returns a Long_Long_Integer typed
10540 -- expression representing the underlying value of the expression.
10541 -- This is done with an unchecked conversion to the result type. We
10542 -- use unchecked conversion to handle the enumeration type case.
10544 ----------------------
10545 -- Is_Entity_Length --
10546 ----------------------
10548 function Is_Entity_Length (N : Node_Id) return Boolean is
10550 if Nkind (N) = N_Attribute_Reference
10551 and then Attribute_Name (N) = Name_Length
10552 and then Is_Entity_Name (Prefix (N))
10554 Ent := Entity (Prefix (N));
10556 if Present (Expressions (N)) then
10557 Index := First (Expressions (N));
10564 elsif Nkind (N) = N_Type_Conversion
10565 and then not Comes_From_Source (N)
10567 return Is_Entity_Length (Expression (N));
10572 end Is_Entity_Length;
10574 --------------------
10575 -- Is_Optimizable --
10576 --------------------
10578 function Is_Optimizable (N : Node_Id) return Boolean is
10586 if Compile_Time_Known_Value (N) then
10587 Val := Expr_Value (N);
10589 if Val = Uint_0 then
10594 elsif Val = Uint_1 then
10601 -- Here we have to make sure of being within 32-bits
10603 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
10606 or else Lo < Uint_1
10607 or else Hi > UI_From_Int (Int'Last)
10612 -- Comparison value was within range, so now we must check the index
10613 -- value to make sure it is also within 32-bits.
10615 Indx := First_Index (Etype (Ent));
10617 if Present (Index) then
10618 for J in 2 .. UI_To_Int (Intval (Index)) loop
10623 Ityp := Etype (Indx);
10625 if Esize (Ityp) > 32 then
10632 end Is_Optimizable;
10638 function Prepare_64 (N : Node_Id) return Node_Id is
10640 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
10643 -- Start of processing for Optimize_Length_Comparison
10646 -- Nothing to do if not a comparison
10648 if Op not in N_Op_Compare then
10652 -- Nothing to do if special -gnatd.P debug flag set
10654 if Debug_Flag_Dot_PP then
10658 -- Ent'Length op 0/1
10660 if Is_Entity_Length (Left_Opnd (N))
10661 and then Is_Optimizable (Right_Opnd (N))
10665 -- 0/1 op Ent'Length
10667 elsif Is_Entity_Length (Right_Opnd (N))
10668 and then Is_Optimizable (Left_Opnd (N))
10670 -- Flip comparison to opposite sense
10673 when N_Op_Lt => Op := N_Op_Gt;
10674 when N_Op_Le => Op := N_Op_Ge;
10675 when N_Op_Gt => Op := N_Op_Lt;
10676 when N_Op_Ge => Op := N_Op_Le;
10677 when others => null;
10680 -- Else optimization not possible
10686 -- Fall through if we will do the optimization
10688 -- Cases to handle:
10690 -- X'Length = 0 => X'First > X'Last
10691 -- X'Length = 1 => X'First = X'Last
10692 -- X'Length = n => X'First + (n - 1) = X'Last
10694 -- X'Length /= 0 => X'First <= X'Last
10695 -- X'Length /= 1 => X'First /= X'Last
10696 -- X'Length /= n => X'First + (n - 1) /= X'Last
10698 -- X'Length >= 0 => always true, warn
10699 -- X'Length >= 1 => X'First <= X'Last
10700 -- X'Length >= n => X'First + (n - 1) <= X'Last
10702 -- X'Length > 0 => X'First <= X'Last
10703 -- X'Length > 1 => X'First < X'Last
10704 -- X'Length > n => X'First + (n - 1) < X'Last
10706 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
10707 -- X'Length <= 1 => X'First >= X'Last
10708 -- X'Length <= n => X'First + (n - 1) >= X'Last
10710 -- X'Length < 0 => always false (warn)
10711 -- X'Length < 1 => X'First > X'Last
10712 -- X'Length < n => X'First + (n - 1) > X'Last
10714 -- Note: for the cases of n (not constant 0,1), we require that the
10715 -- corresponding index type be integer or shorter (i.e. not 64-bit),
10716 -- and the same for the comparison value. Then we do the comparison
10717 -- using 64-bit arithmetic (actually long long integer), so that we
10718 -- cannot have overflow intefering with the result.
10720 -- First deal with warning cases
10729 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
10730 Analyze_And_Resolve (N, Typ);
10731 Warn_On_Known_Condition (N);
10738 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
10739 Analyze_And_Resolve (N, Typ);
10740 Warn_On_Known_Condition (N);
10744 if Constant_Condition_Warnings
10745 and then Comes_From_Source (Original_Node (N))
10747 Error_Msg_N ("could replace by ""'=""?", N);
10757 -- Build the First reference we will use
10760 Make_Attribute_Reference (Loc,
10761 Prefix => New_Occurrence_Of (Ent, Loc),
10762 Attribute_Name => Name_First);
10764 if Present (Index) then
10765 Set_Expressions (Left, New_List (New_Copy (Index)));
10768 -- If general value case, then do the addition of (n - 1), and
10769 -- also add the needed conversions to type Long_Long_Integer.
10771 if Present (Comp) then
10774 Left_Opnd => Prepare_64 (Left),
10776 Make_Op_Subtract (Loc,
10777 Left_Opnd => Prepare_64 (Comp),
10778 Right_Opnd => Make_Integer_Literal (Loc, 1)));
10781 -- Build the Last reference we will use
10784 Make_Attribute_Reference (Loc,
10785 Prefix => New_Occurrence_Of (Ent, Loc),
10786 Attribute_Name => Name_Last);
10788 if Present (Index) then
10789 Set_Expressions (Right, New_List (New_Copy (Index)));
10792 -- If general operand, convert Last reference to Long_Long_Integer
10794 if Present (Comp) then
10795 Right := Prepare_64 (Right);
10798 -- Check for cases to optimize
10800 -- X'Length = 0 => X'First > X'Last
10801 -- X'Length < 1 => X'First > X'Last
10802 -- X'Length < n => X'First + (n - 1) > X'Last
10804 if (Is_Zero and then Op = N_Op_Eq)
10805 or else (not Is_Zero and then Op = N_Op_Lt)
10810 Right_Opnd => Right);
10812 -- X'Length = 1 => X'First = X'Last
10813 -- X'Length = n => X'First + (n - 1) = X'Last
10815 elsif not Is_Zero and then Op = N_Op_Eq then
10819 Right_Opnd => Right);
10821 -- X'Length /= 0 => X'First <= X'Last
10822 -- X'Length > 0 => X'First <= X'Last
10824 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
10828 Right_Opnd => Right);
10830 -- X'Length /= 1 => X'First /= X'Last
10831 -- X'Length /= n => X'First + (n - 1) /= X'Last
10833 elsif not Is_Zero and then Op = N_Op_Ne then
10837 Right_Opnd => Right);
10839 -- X'Length >= 1 => X'First <= X'Last
10840 -- X'Length >= n => X'First + (n - 1) <= X'Last
10842 elsif not Is_Zero and then Op = N_Op_Ge then
10846 Right_Opnd => Right);
10848 -- X'Length > 1 => X'First < X'Last
10849 -- X'Length > n => X'First + (n = 1) < X'Last
10851 elsif not Is_Zero and then Op = N_Op_Gt then
10855 Right_Opnd => Right);
10857 -- X'Length <= 1 => X'First >= X'Last
10858 -- X'Length <= n => X'First + (n - 1) >= X'Last
10860 elsif not Is_Zero and then Op = N_Op_Le then
10864 Right_Opnd => Right);
10866 -- Should not happen at this stage
10869 raise Program_Error;
10872 -- Rewrite and finish up
10874 Rewrite (N, Result);
10875 Analyze_And_Resolve (N, Typ);
10877 end Optimize_Length_Comparison;
10879 ------------------------
10880 -- Rewrite_Comparison --
10881 ------------------------
10883 procedure Rewrite_Comparison (N : Node_Id) is
10884 Warning_Generated : Boolean := False;
10885 -- Set to True if first pass with Assume_Valid generates a warning in
10886 -- which case we skip the second pass to avoid warning overloaded.
10889 -- Set to Standard_True or Standard_False
10892 if Nkind (N) = N_Type_Conversion then
10893 Rewrite_Comparison (Expression (N));
10896 elsif Nkind (N) not in N_Op_Compare then
10900 -- Now start looking at the comparison in detail. We potentially go
10901 -- through this loop twice. The first time, Assume_Valid is set False
10902 -- in the call to Compile_Time_Compare. If this call results in a
10903 -- clear result of always True or Always False, that's decisive and
10904 -- we are done. Otherwise we repeat the processing with Assume_Valid
10905 -- set to True to generate additional warnings. We can skip that step
10906 -- if Constant_Condition_Warnings is False.
10908 for AV in False .. True loop
10910 Typ : constant Entity_Id := Etype (N);
10911 Op1 : constant Node_Id := Left_Opnd (N);
10912 Op2 : constant Node_Id := Right_Opnd (N);
10914 Res : constant Compare_Result :=
10915 Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
10916 -- Res indicates if compare outcome can be compile time determined
10918 True_Result : Boolean;
10919 False_Result : Boolean;
10922 case N_Op_Compare (Nkind (N)) is
10924 True_Result := Res = EQ;
10925 False_Result := Res = LT or else Res = GT or else Res = NE;
10928 True_Result := Res in Compare_GE;
10929 False_Result := Res = LT;
10932 and then Constant_Condition_Warnings
10933 and then Comes_From_Source (Original_Node (N))
10934 and then Nkind (Original_Node (N)) = N_Op_Ge
10935 and then not In_Instance
10936 and then Is_Integer_Type (Etype (Left_Opnd (N)))
10937 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
10940 ("can never be greater than, could replace by ""'=""?", N);
10941 Warning_Generated := True;
10945 True_Result := Res = GT;
10946 False_Result := Res in Compare_LE;
10949 True_Result := Res = LT;
10950 False_Result := Res in Compare_GE;
10953 True_Result := Res in Compare_LE;
10954 False_Result := Res = GT;
10957 and then Constant_Condition_Warnings
10958 and then Comes_From_Source (Original_Node (N))
10959 and then Nkind (Original_Node (N)) = N_Op_Le
10960 and then not In_Instance
10961 and then Is_Integer_Type (Etype (Left_Opnd (N)))
10962 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
10965 ("can never be less than, could replace by ""'=""?", N);
10966 Warning_Generated := True;
10970 True_Result := Res = NE or else Res = GT or else Res = LT;
10971 False_Result := Res = EQ;
10974 -- If this is the first iteration, then we actually convert the
10975 -- comparison into True or False, if the result is certain.
10978 if True_Result or False_Result then
10979 if True_Result then
10980 Result := Standard_True;
10982 Result := Standard_False;
10987 New_Occurrence_Of (Result, Sloc (N))));
10988 Analyze_And_Resolve (N, Typ);
10989 Warn_On_Known_Condition (N);
10993 -- If this is the second iteration (AV = True), and the original
10994 -- node comes from source and we are not in an instance, then give
10995 -- a warning if we know result would be True or False. Note: we
10996 -- know Constant_Condition_Warnings is set if we get here.
10998 elsif Comes_From_Source (Original_Node (N))
10999 and then not In_Instance
11001 if True_Result then
11003 ("condition can only be False if invalid values present?",
11005 elsif False_Result then
11007 ("condition can only be True if invalid values present?",
11013 -- Skip second iteration if not warning on constant conditions or
11014 -- if the first iteration already generated a warning of some kind or
11015 -- if we are in any case assuming all values are valid (so that the
11016 -- first iteration took care of the valid case).
11018 exit when not Constant_Condition_Warnings;
11019 exit when Warning_Generated;
11020 exit when Assume_No_Invalid_Values;
11022 end Rewrite_Comparison;
11024 ----------------------------
11025 -- Safe_In_Place_Array_Op --
11026 ----------------------------
11028 function Safe_In_Place_Array_Op
11031 Op2 : Node_Id) return Boolean
11033 Target : Entity_Id;
11035 function Is_Safe_Operand (Op : Node_Id) return Boolean;
11036 -- Operand is safe if it cannot overlap part of the target of the
11037 -- operation. If the operand and the target are identical, the operand
11038 -- is safe. The operand can be empty in the case of negation.
11040 function Is_Unaliased (N : Node_Id) return Boolean;
11041 -- Check that N is a stand-alone entity
11047 function Is_Unaliased (N : Node_Id) return Boolean is
11051 and then No (Address_Clause (Entity (N)))
11052 and then No (Renamed_Object (Entity (N)));
11055 ---------------------
11056 -- Is_Safe_Operand --
11057 ---------------------
11059 function Is_Safe_Operand (Op : Node_Id) return Boolean is
11064 elsif Is_Entity_Name (Op) then
11065 return Is_Unaliased (Op);
11067 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
11068 return Is_Unaliased (Prefix (Op));
11070 elsif Nkind (Op) = N_Slice then
11072 Is_Unaliased (Prefix (Op))
11073 and then Entity (Prefix (Op)) /= Target;
11075 elsif Nkind (Op) = N_Op_Not then
11076 return Is_Safe_Operand (Right_Opnd (Op));
11081 end Is_Safe_Operand;
11083 -- Start of processing for Is_Safe_In_Place_Array_Op
11086 -- Skip this processing if the component size is different from system
11087 -- storage unit (since at least for NOT this would cause problems).
11089 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
11092 -- Cannot do in place stuff on VM_Target since cannot pass addresses
11094 elsif VM_Target /= No_VM then
11097 -- Cannot do in place stuff if non-standard Boolean representation
11099 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
11102 elsif not Is_Unaliased (Lhs) then
11106 Target := Entity (Lhs);
11107 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
11109 end Safe_In_Place_Array_Op;
11111 -----------------------
11112 -- Tagged_Membership --
11113 -----------------------
11115 -- There are two different cases to consider depending on whether the right
11116 -- operand is a class-wide type or not. If not we just compare the actual
11117 -- tag of the left expr to the target type tag:
11119 -- Left_Expr.Tag = Right_Type'Tag;
11121 -- If it is a class-wide type we use the RT function CW_Membership which is
11122 -- usually implemented by looking in the ancestor tables contained in the
11123 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
11125 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
11126 -- function IW_Membership which is usually implemented by looking in the
11127 -- table of abstract interface types plus the ancestor table contained in
11128 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
11130 procedure Tagged_Membership
11132 SCIL_Node : out Node_Id;
11133 Result : out Node_Id)
11135 Left : constant Node_Id := Left_Opnd (N);
11136 Right : constant Node_Id := Right_Opnd (N);
11137 Loc : constant Source_Ptr := Sloc (N);
11139 Full_R_Typ : Entity_Id;
11140 Left_Type : Entity_Id;
11141 New_Node : Node_Id;
11142 Right_Type : Entity_Id;
11146 SCIL_Node := Empty;
11148 -- Handle entities from the limited view
11150 Left_Type := Available_View (Etype (Left));
11151 Right_Type := Available_View (Etype (Right));
11153 -- In the case where the type is an access type, the test is applied
11154 -- using the designated types (needed in Ada 2012 for implicit anonymous
11155 -- access conversions, for AI05-0149).
11157 if Is_Access_Type (Right_Type) then
11158 Left_Type := Designated_Type (Left_Type);
11159 Right_Type := Designated_Type (Right_Type);
11162 if Is_Class_Wide_Type (Left_Type) then
11163 Left_Type := Root_Type (Left_Type);
11166 if Is_Class_Wide_Type (Right_Type) then
11167 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
11169 Full_R_Typ := Underlying_Type (Right_Type);
11173 Make_Selected_Component (Loc,
11174 Prefix => Relocate_Node (Left),
11176 New_Reference_To (First_Tag_Component (Left_Type), Loc));
11178 if Is_Class_Wide_Type (Right_Type) then
11180 -- No need to issue a run-time check if we statically know that the
11181 -- result of this membership test is always true. For example,
11182 -- considering the following declarations:
11184 -- type Iface is interface;
11185 -- type T is tagged null record;
11186 -- type DT is new T and Iface with null record;
11191 -- These membership tests are always true:
11194 -- Obj2 in T'Class;
11195 -- Obj2 in Iface'Class;
11197 -- We do not need to handle cases where the membership is illegal.
11200 -- Obj1 in DT'Class; -- Compile time error
11201 -- Obj1 in Iface'Class; -- Compile time error
11203 if not Is_Class_Wide_Type (Left_Type)
11204 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
11205 Use_Full_View => True)
11206 or else (Is_Interface (Etype (Right_Type))
11207 and then Interface_Present_In_Ancestor
11209 Iface => Etype (Right_Type))))
11211 Result := New_Reference_To (Standard_True, Loc);
11215 -- Ada 2005 (AI-251): Class-wide applied to interfaces
11217 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
11219 -- Support to: "Iface_CW_Typ in Typ'Class"
11221 or else Is_Interface (Left_Type)
11223 -- Issue error if IW_Membership operation not available in a
11224 -- configurable run time setting.
11226 if not RTE_Available (RE_IW_Membership) then
11228 ("dynamic membership test on interface types", N);
11234 Make_Function_Call (Loc,
11235 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
11236 Parameter_Associations => New_List (
11237 Make_Attribute_Reference (Loc,
11239 Attribute_Name => Name_Address),
11241 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
11244 -- Ada 95: Normal case
11247 Build_CW_Membership (Loc,
11248 Obj_Tag_Node => Obj_Tag,
11251 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
11253 New_Node => New_Node);
11255 -- Generate the SCIL node for this class-wide membership test.
11256 -- Done here because the previous call to Build_CW_Membership
11257 -- relocates Obj_Tag.
11259 if Generate_SCIL then
11260 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
11261 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
11262 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
11265 Result := New_Node;
11268 -- Right_Type is not a class-wide type
11271 -- No need to check the tag of the object if Right_Typ is abstract
11273 if Is_Abstract_Type (Right_Type) then
11274 Result := New_Reference_To (Standard_False, Loc);
11279 Left_Opnd => Obj_Tag,
11282 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
11285 end Tagged_Membership;
11287 ------------------------------
11288 -- Unary_Op_Validity_Checks --
11289 ------------------------------
11291 procedure Unary_Op_Validity_Checks (N : Node_Id) is
11293 if Validity_Checks_On and Validity_Check_Operands then
11294 Ensure_Valid (Right_Opnd (N));
11296 end Unary_Op_Validity_Checks;