File : exp_ch4.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 4 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_Ch2; use Exp_Ch2;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Disp; use Exp_Disp;
40 with Exp_Fixd; use Exp_Fixd;
41 with Exp_Intr; use Exp_Intr;
42 with Exp_Pakd; use Exp_Pakd;
43 with Exp_Tss; use Exp_Tss;
44 with Exp_Util; use Exp_Util;
45 with Freeze; use Freeze;
46 with Inline; use Inline;
47 with Namet; use Namet;
48 with Nlists; use Nlists;
49 with Nmake; use Nmake;
50 with Opt; use Opt;
51 with Par_SCO; use Par_SCO;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
55 with Sem; use Sem;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Cat; use Sem_Cat;
58 with Sem_Ch3; use Sem_Ch3;
59 with Sem_Ch13; use Sem_Ch13;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Res; use Sem_Res;
62 with Sem_Type; use Sem_Type;
63 with Sem_Util; use Sem_Util;
64 with Sem_Warn; use Sem_Warn;
65 with Sinfo; use Sinfo;
66 with Snames; use Snames;
67 with Stand; use Stand;
68 with SCIL_LL; use SCIL_LL;
69 with Targparm; use Targparm;
70 with Tbuild; use Tbuild;
71 with Ttypes; use Ttypes;
72 with Uintp; use Uintp;
73 with Urealp; use Urealp;
74 with Validsw; use Validsw;
75
76 package body Exp_Ch4 is
77
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
81
82 procedure Binary_Op_Validity_Checks (N : Node_Id);
83 pragma Inline (Binary_Op_Validity_Checks);
84 -- Performs validity checks for a binary operator
85
86 procedure Build_Boolean_Array_Proc_Call
87 (N : Node_Id;
88 Op1 : Node_Id;
89 Op2 : Node_Id);
90 -- If a boolean array assignment can be done in place, build call to
91 -- corresponding library procedure.
92
93 procedure Displace_Allocator_Pointer (N : Node_Id);
94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
95 -- Expand_Allocator_Expression. Allocating class-wide interface objects
96 -- this routine displaces the pointer to the allocated object to reference
97 -- the component referencing the corresponding secondary dispatch table.
98
99 procedure Expand_Allocator_Expression (N : Node_Id);
100 -- Subsidiary to Expand_N_Allocator, for the case when the expression
101 -- is a qualified expression or an aggregate.
102
103 procedure Expand_Array_Comparison (N : Node_Id);
104 -- This routine handles expansion of the comparison operators (N_Op_Lt,
105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
106 -- code for these operators is similar, differing only in the details of
107 -- the actual comparison call that is made. Special processing (call a
108 -- run-time routine)
109
110 function Expand_Array_Equality
111 (Nod : Node_Id;
112 Lhs : Node_Id;
113 Rhs : Node_Id;
114 Bodies : List_Id;
115 Typ : Entity_Id) return Node_Id;
116 -- Expand an array equality into a call to a function implementing this
117 -- equality, and a call to it. Loc is the location for the generated nodes.
118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
119 -- on which to attach bodies of local functions that are created in the
120 -- process. It is the responsibility of the caller to insert those bodies
121 -- at the right place. Nod provides the Sloc value for the generated code.
122 -- Normally the types used for the generated equality routine are taken
123 -- from Lhs and Rhs. However, in some situations of generated code, the
124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
125 -- the type to be used for the formal parameters.
126
127 procedure Expand_Boolean_Operator (N : Node_Id);
128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
129 -- case of array type arguments.
130
131 procedure Expand_Short_Circuit_Operator (N : Node_Id);
132 -- Common expansion processing for short-circuit boolean operators
133
134 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
135 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
136 -- where we allow comparison of "out of range" values.
137
138 function Expand_Composite_Equality
139 (Nod : Node_Id;
140 Typ : Entity_Id;
141 Lhs : Node_Id;
142 Rhs : Node_Id;
143 Bodies : List_Id) return Node_Id;
144 -- Local recursive function used to expand equality for nested composite
145 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
146 -- to attach bodies of local functions that are created in the process. It
147 -- is the responsibility of the caller to insert those bodies at the right
148 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
149 -- the left and right sides for the comparison, and Typ is the type of the
150 -- objects to compare.
151
152 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
153 -- Routine to expand concatenation of a sequence of two or more operands
154 -- (in the list Operands) and replace node Cnode with the result of the
155 -- concatenation. The operands can be of any appropriate type, and can
156 -- include both arrays and singleton elements.
157
158 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
159 -- N is an N_In membership test mode, with the overflow check mode set to
160 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
161 -- integer type. This is a case where top level processing is required to
162 -- handle overflow checks in subtrees.
163
164 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
165 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
166 -- fixed. We do not have such a type at runtime, so the purpose of this
167 -- routine is to find the real type by looking up the tree. We also
168 -- determine if the operation must be rounded.
169
170 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
171 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
172 -- discriminants if it has a constrained nominal type, unless the object
173 -- is a component of an enclosing Unchecked_Union object that is subject
174 -- to a per-object constraint and the enclosing object lacks inferable
175 -- discriminants.
176 --
177 -- An expression of an Unchecked_Union type has inferable discriminants
178 -- if it is either a name of an object with inferable discriminants or a
179 -- qualified expression whose subtype mark denotes a constrained subtype.
180
181 procedure Insert_Dereference_Action (N : Node_Id);
182 -- N is an expression whose type is an access. When the type of the
183 -- associated storage pool is derived from Checked_Pool, generate a
184 -- call to the 'Dereference' primitive operation.
185
186 function Make_Array_Comparison_Op
187 (Typ : Entity_Id;
188 Nod : Node_Id) return Node_Id;
189 -- Comparisons between arrays are expanded in line. This function produces
190 -- the body of the implementation of (a > b), where a and b are one-
191 -- dimensional arrays of some discrete type. The original node is then
192 -- expanded into the appropriate call to this function. Nod provides the
193 -- Sloc value for the generated code.
194
195 function Make_Boolean_Array_Op
196 (Typ : Entity_Id;
197 N : Node_Id) return Node_Id;
198 -- Boolean operations on boolean arrays are expanded in line. This function
199 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
200 -- b). It is used only the normal case and not the packed case. The type
201 -- involved, Typ, is the Boolean array type, and the logical operations in
202 -- the body are simple boolean operations. Note that Typ is always a
203 -- constrained type (the caller has ensured this by using
204 -- Convert_To_Actual_Subtype if necessary).
205
206 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
207 -- For signed arithmetic operations when the current overflow mode is
208 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
209 -- as the first thing we do. We then return. We count on the recursive
210 -- apparatus for overflow checks to call us back with an equivalent
211 -- operation that is in CHECKED mode, avoiding a recursive entry into this
212 -- routine, and that is when we will proceed with the expansion of the
213 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
214 -- these optimizations without first making this check, since there may be
215 -- operands further down the tree that are relying on the recursive calls
216 -- triggered by the top level nodes to properly process overflow checking
217 -- and remaining expansion on these nodes. Note that this call back may be
218 -- skipped if the operation is done in Bignum mode but that's fine, since
219 -- the Bignum call takes care of everything.
220
221 procedure Optimize_Length_Comparison (N : Node_Id);
222 -- Given an expression, if it is of the form X'Length op N (or the other
223 -- way round), where N is known at compile time to be 0 or 1, and X is a
224 -- simple entity, and op is a comparison operator, optimizes it into a
225 -- comparison of First and Last.
226
227 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
228 -- Inspect and process statement list Stmt of if or case expression N for
229 -- transient controlled objects. If such objects are found, the routine
230 -- generates code to clean them up when the context of the expression is
231 -- evaluated or elaborated.
232
233 procedure Process_Transient_Object
234 (Decl : Node_Id;
235 N : Node_Id;
236 Stmts : List_Id);
237 -- Subsidiary routine to the expansion of expression_with_actions, if and
238 -- case expressions. Generate all necessary code to finalize a transient
239 -- controlled object when the enclosing context is elaborated or evaluated.
240 -- Decl denotes the declaration of the transient controlled object which is
241 -- usually the result of a controlled function call. N denotes the related
242 -- expression_with_actions, if expression, or case expression node. Stmts
243 -- denotes the statement list which contains Decl, either at the top level
244 -- or within a nested construct.
245
246 procedure Rewrite_Comparison (N : Node_Id);
247 -- If N is the node for a comparison whose outcome can be determined at
248 -- compile time, then the node N can be rewritten with True or False. If
249 -- the outcome cannot be determined at compile time, the call has no
250 -- effect. If N is a type conversion, then this processing is applied to
251 -- its expression. If N is neither comparison nor a type conversion, the
252 -- call has no effect.
253
254 procedure Tagged_Membership
255 (N : Node_Id;
256 SCIL_Node : out Node_Id;
257 Result : out Node_Id);
258 -- Construct the expression corresponding to the tagged membership test.
259 -- Deals with a second operand being (or not) a class-wide type.
260
261 function Safe_In_Place_Array_Op
262 (Lhs : Node_Id;
263 Op1 : Node_Id;
264 Op2 : Node_Id) return Boolean;
265 -- In the context of an assignment, where the right-hand side is a boolean
266 -- operation on arrays, check whether operation can be performed in place.
267
268 procedure Unary_Op_Validity_Checks (N : Node_Id);
269 pragma Inline (Unary_Op_Validity_Checks);
270 -- Performs validity checks for a unary operator
271
272 -------------------------------
273 -- Binary_Op_Validity_Checks --
274 -------------------------------
275
276 procedure Binary_Op_Validity_Checks (N : Node_Id) is
277 begin
278 if Validity_Checks_On and Validity_Check_Operands then
279 Ensure_Valid (Left_Opnd (N));
280 Ensure_Valid (Right_Opnd (N));
281 end if;
282 end Binary_Op_Validity_Checks;
283
284 ------------------------------------
285 -- Build_Boolean_Array_Proc_Call --
286 ------------------------------------
287
288 procedure Build_Boolean_Array_Proc_Call
289 (N : Node_Id;
290 Op1 : Node_Id;
291 Op2 : Node_Id)
292 is
293 Loc : constant Source_Ptr := Sloc (N);
294 Kind : constant Node_Kind := Nkind (Expression (N));
295 Target : constant Node_Id :=
296 Make_Attribute_Reference (Loc,
297 Prefix => Name (N),
298 Attribute_Name => Name_Address);
299
300 Arg1 : Node_Id := Op1;
301 Arg2 : Node_Id := Op2;
302 Call_Node : Node_Id;
303 Proc_Name : Entity_Id;
304
305 begin
306 if Kind = N_Op_Not then
307 if Nkind (Op1) in N_Binary_Op then
308
309 -- Use negated version of the binary operators
310
311 if Nkind (Op1) = N_Op_And then
312 Proc_Name := RTE (RE_Vector_Nand);
313
314 elsif Nkind (Op1) = N_Op_Or then
315 Proc_Name := RTE (RE_Vector_Nor);
316
317 else pragma Assert (Nkind (Op1) = N_Op_Xor);
318 Proc_Name := RTE (RE_Vector_Xor);
319 end if;
320
321 Call_Node :=
322 Make_Procedure_Call_Statement (Loc,
323 Name => New_Occurrence_Of (Proc_Name, Loc),
324
325 Parameter_Associations => New_List (
326 Target,
327 Make_Attribute_Reference (Loc,
328 Prefix => Left_Opnd (Op1),
329 Attribute_Name => Name_Address),
330
331 Make_Attribute_Reference (Loc,
332 Prefix => Right_Opnd (Op1),
333 Attribute_Name => Name_Address),
334
335 Make_Attribute_Reference (Loc,
336 Prefix => Left_Opnd (Op1),
337 Attribute_Name => Name_Length)));
338
339 else
340 Proc_Name := RTE (RE_Vector_Not);
341
342 Call_Node :=
343 Make_Procedure_Call_Statement (Loc,
344 Name => New_Occurrence_Of (Proc_Name, Loc),
345 Parameter_Associations => New_List (
346 Target,
347
348 Make_Attribute_Reference (Loc,
349 Prefix => Op1,
350 Attribute_Name => Name_Address),
351
352 Make_Attribute_Reference (Loc,
353 Prefix => Op1,
354 Attribute_Name => Name_Length)));
355 end if;
356
357 else
358 -- We use the following equivalences:
359
360 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
361 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
362 -- (not X) xor (not Y) = X xor Y
363 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
364
365 if Nkind (Op1) = N_Op_Not then
366 Arg1 := Right_Opnd (Op1);
367 Arg2 := Right_Opnd (Op2);
368
369 if Kind = N_Op_And then
370 Proc_Name := RTE (RE_Vector_Nor);
371 elsif Kind = N_Op_Or then
372 Proc_Name := RTE (RE_Vector_Nand);
373 else
374 Proc_Name := RTE (RE_Vector_Xor);
375 end if;
376
377 else
378 if Kind = N_Op_And then
379 Proc_Name := RTE (RE_Vector_And);
380 elsif Kind = N_Op_Or then
381 Proc_Name := RTE (RE_Vector_Or);
382 elsif Nkind (Op2) = N_Op_Not then
383 Proc_Name := RTE (RE_Vector_Nxor);
384 Arg2 := Right_Opnd (Op2);
385 else
386 Proc_Name := RTE (RE_Vector_Xor);
387 end if;
388 end if;
389
390 Call_Node :=
391 Make_Procedure_Call_Statement (Loc,
392 Name => New_Occurrence_Of (Proc_Name, Loc),
393 Parameter_Associations => New_List (
394 Target,
395 Make_Attribute_Reference (Loc,
396 Prefix => Arg1,
397 Attribute_Name => Name_Address),
398 Make_Attribute_Reference (Loc,
399 Prefix => Arg2,
400 Attribute_Name => Name_Address),
401 Make_Attribute_Reference (Loc,
402 Prefix => Arg1,
403 Attribute_Name => Name_Length)));
404 end if;
405
406 Rewrite (N, Call_Node);
407 Analyze (N);
408
409 exception
410 when RE_Not_Available =>
411 return;
412 end Build_Boolean_Array_Proc_Call;
413
414 --------------------------------
415 -- Displace_Allocator_Pointer --
416 --------------------------------
417
418 procedure Displace_Allocator_Pointer (N : Node_Id) is
419 Loc : constant Source_Ptr := Sloc (N);
420 Orig_Node : constant Node_Id := Original_Node (N);
421 Dtyp : Entity_Id;
422 Etyp : Entity_Id;
423 PtrT : Entity_Id;
424
425 begin
426 -- Do nothing in case of VM targets: the virtual machine will handle
427 -- interfaces directly.
428
429 if not Tagged_Type_Expansion then
430 return;
431 end if;
432
433 pragma Assert (Nkind (N) = N_Identifier
434 and then Nkind (Orig_Node) = N_Allocator);
435
436 PtrT := Etype (Orig_Node);
437 Dtyp := Available_View (Designated_Type (PtrT));
438 Etyp := Etype (Expression (Orig_Node));
439
440 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
441
442 -- If the type of the allocator expression is not an interface type
443 -- we can generate code to reference the record component containing
444 -- the pointer to the secondary dispatch table.
445
446 if not Is_Interface (Etyp) then
447 declare
448 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
449
450 begin
451 -- 1) Get access to the allocated object
452
453 Rewrite (N,
454 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
455 Set_Etype (N, Etyp);
456 Set_Analyzed (N);
457
458 -- 2) Add the conversion to displace the pointer to reference
459 -- the secondary dispatch table.
460
461 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
462 Analyze_And_Resolve (N, Dtyp);
463
464 -- 3) The 'access to the secondary dispatch table will be used
465 -- as the value returned by the allocator.
466
467 Rewrite (N,
468 Make_Attribute_Reference (Loc,
469 Prefix => Relocate_Node (N),
470 Attribute_Name => Name_Access));
471 Set_Etype (N, Saved_Typ);
472 Set_Analyzed (N);
473 end;
474
475 -- If the type of the allocator expression is an interface type we
476 -- generate a run-time call to displace "this" to reference the
477 -- component containing the pointer to the secondary dispatch table
478 -- or else raise Constraint_Error if the actual object does not
479 -- implement the target interface. This case corresponds to the
480 -- following example:
481
482 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
483 -- begin
484 -- return new Iface_2'Class'(Obj);
485 -- end Op;
486
487 else
488 Rewrite (N,
489 Unchecked_Convert_To (PtrT,
490 Make_Function_Call (Loc,
491 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
492 Parameter_Associations => New_List (
493 Unchecked_Convert_To (RTE (RE_Address),
494 Relocate_Node (N)),
495
496 New_Occurrence_Of
497 (Elists.Node
498 (First_Elmt
499 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
500 Loc)))));
501 Analyze_And_Resolve (N, PtrT);
502 end if;
503 end if;
504 end Displace_Allocator_Pointer;
505
506 ---------------------------------
507 -- Expand_Allocator_Expression --
508 ---------------------------------
509
510 procedure Expand_Allocator_Expression (N : Node_Id) is
511 Loc : constant Source_Ptr := Sloc (N);
512 Exp : constant Node_Id := Expression (Expression (N));
513 PtrT : constant Entity_Id := Etype (N);
514 DesigT : constant Entity_Id := Designated_Type (PtrT);
515
516 procedure Apply_Accessibility_Check
517 (Ref : Node_Id;
518 Built_In_Place : Boolean := False);
519 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
520 -- type, generate an accessibility check to verify that the level of the
521 -- type of the created object is not deeper than the level of the access
522 -- type. If the type of the qualified expression is class-wide, then
523 -- always generate the check (except in the case where it is known to be
524 -- unnecessary, see comment below). Otherwise, only generate the check
525 -- if the level of the qualified expression type is statically deeper
526 -- than the access type.
527 --
528 -- Although the static accessibility will generally have been performed
529 -- as a legality check, it won't have been done in cases where the
530 -- allocator appears in generic body, so a run-time check is needed in
531 -- general. One special case is when the access type is declared in the
532 -- same scope as the class-wide allocator, in which case the check can
533 -- never fail, so it need not be generated.
534 --
535 -- As an open issue, there seem to be cases where the static level
536 -- associated with the class-wide object's underlying type is not
537 -- sufficient to perform the proper accessibility check, such as for
538 -- allocators in nested subprograms or accept statements initialized by
539 -- class-wide formals when the actual originates outside at a deeper
540 -- static level. The nested subprogram case might require passing
541 -- accessibility levels along with class-wide parameters, and the task
542 -- case seems to be an actual gap in the language rules that needs to
543 -- be fixed by the ARG. ???
544
545 -------------------------------
546 -- Apply_Accessibility_Check --
547 -------------------------------
548
549 procedure Apply_Accessibility_Check
550 (Ref : Node_Id;
551 Built_In_Place : Boolean := False)
552 is
553 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
554 Cond : Node_Id;
555 Fin_Call : Node_Id;
556 Free_Stmt : Node_Id;
557 Obj_Ref : Node_Id;
558 Stmts : List_Id;
559
560 begin
561 if Ada_Version >= Ada_2005
562 and then Is_Class_Wide_Type (DesigT)
563 and then Tagged_Type_Expansion
564 and then not Scope_Suppress.Suppress (Accessibility_Check)
565 and then
566 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
567 or else
568 (Is_Class_Wide_Type (Etype (Exp))
569 and then Scope (PtrT) /= Current_Scope))
570 then
571 -- If the allocator was built in place, Ref is already a reference
572 -- to the access object initialized to the result of the allocator
573 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
574 -- Remove_Side_Effects for cases where the build-in-place call may
575 -- still be the prefix of the reference (to avoid generating
576 -- duplicate calls). Otherwise, it is the entity associated with
577 -- the object containing the address of the allocated object.
578
579 if Built_In_Place then
580 Remove_Side_Effects (Ref);
581 Obj_Ref := New_Copy_Tree (Ref);
582 else
583 Obj_Ref := New_Occurrence_Of (Ref, Loc);
584 end if;
585
586 -- For access to interface types we must generate code to displace
587 -- the pointer to the base of the object since the subsequent code
588 -- references components located in the TSD of the object (which
589 -- is associated with the primary dispatch table --see a-tags.ads)
590 -- and also generates code invoking Free, which requires also a
591 -- reference to the base of the unallocated object.
592
593 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
594 Obj_Ref :=
595 Unchecked_Convert_To (Etype (Obj_Ref),
596 Make_Function_Call (Loc,
597 Name =>
598 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
599 Parameter_Associations => New_List (
600 Unchecked_Convert_To (RTE (RE_Address),
601 New_Copy_Tree (Obj_Ref)))));
602 end if;
603
604 -- Step 1: Create the object clean up code
605
606 Stmts := New_List;
607
608 -- Deallocate the object if the accessibility check fails. This
609 -- is done only on targets or profiles that support deallocation.
610
611 -- Free (Obj_Ref);
612
613 if RTE_Available (RE_Free) then
614 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
615 Set_Storage_Pool (Free_Stmt, Pool_Id);
616
617 Append_To (Stmts, Free_Stmt);
618
619 -- The target or profile cannot deallocate objects
620
621 else
622 Free_Stmt := Empty;
623 end if;
624
625 -- Finalize the object if applicable. Generate:
626
627 -- [Deep_]Finalize (Obj_Ref.all);
628
629 if Needs_Finalization (DesigT) then
630 Fin_Call :=
631 Make_Final_Call
632 (Obj_Ref =>
633 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
634 Typ => DesigT);
635
636 -- When the target or profile supports deallocation, wrap the
637 -- finalization call in a block to ensure proper deallocation
638 -- even if finalization fails. Generate:
639
640 -- begin
641 -- <Fin_Call>
642 -- exception
643 -- when others =>
644 -- <Free_Stmt>
645 -- raise;
646 -- end;
647
648 if Present (Free_Stmt) then
649 Fin_Call :=
650 Make_Block_Statement (Loc,
651 Handled_Statement_Sequence =>
652 Make_Handled_Sequence_Of_Statements (Loc,
653 Statements => New_List (Fin_Call),
654
655 Exception_Handlers => New_List (
656 Make_Exception_Handler (Loc,
657 Exception_Choices => New_List (
658 Make_Others_Choice (Loc)),
659 Statements => New_List (
660 New_Copy_Tree (Free_Stmt),
661 Make_Raise_Statement (Loc))))));
662 end if;
663
664 Prepend_To (Stmts, Fin_Call);
665 end if;
666
667 -- Signal the accessibility failure through a Program_Error
668
669 Append_To (Stmts,
670 Make_Raise_Program_Error (Loc,
671 Condition => New_Occurrence_Of (Standard_True, Loc),
672 Reason => PE_Accessibility_Check_Failed));
673
674 -- Step 2: Create the accessibility comparison
675
676 -- Generate:
677 -- Ref'Tag
678
679 Obj_Ref :=
680 Make_Attribute_Reference (Loc,
681 Prefix => Obj_Ref,
682 Attribute_Name => Name_Tag);
683
684 -- For tagged types, determine the accessibility level by looking
685 -- at the type specific data of the dispatch table. Generate:
686
687 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
688
689 if Tagged_Type_Expansion then
690 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
691
692 -- Use a runtime call to determine the accessibility level when
693 -- compiling on virtual machine targets. Generate:
694
695 -- Get_Access_Level (Ref'Tag)
696
697 else
698 Cond :=
699 Make_Function_Call (Loc,
700 Name =>
701 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
702 Parameter_Associations => New_List (Obj_Ref));
703 end if;
704
705 Cond :=
706 Make_Op_Gt (Loc,
707 Left_Opnd => Cond,
708 Right_Opnd =>
709 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
710
711 -- Due to the complexity and side effects of the check, utilize an
712 -- if statement instead of the regular Program_Error circuitry.
713
714 Insert_Action (N,
715 Make_Implicit_If_Statement (N,
716 Condition => Cond,
717 Then_Statements => Stmts));
718 end if;
719 end Apply_Accessibility_Check;
720
721 -- Local variables
722
723 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
724 Indic : constant Node_Id := Subtype_Mark (Expression (N));
725 T : constant Entity_Id := Entity (Indic);
726 Node : Node_Id;
727 Tag_Assign : Node_Id;
728 Temp : Entity_Id;
729 Temp_Decl : Node_Id;
730
731 TagT : Entity_Id := Empty;
732 -- Type used as source for tag assignment
733
734 TagR : Node_Id := Empty;
735 -- Target reference for tag assignment
736
737 -- Start of processing for Expand_Allocator_Expression
738
739 begin
740 -- Handle call to C++ constructor
741
742 if Is_CPP_Constructor_Call (Exp) then
743 Make_CPP_Constructor_Call_In_Allocator
744 (Allocator => N,
745 Function_Call => Exp);
746 return;
747 end if;
748
749 -- In the case of an Ada 2012 allocator whose initial value comes from a
750 -- function call, pass "the accessibility level determined by the point
751 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
752 -- Expand_Call but it couldn't be done there (because the Etype of the
753 -- allocator wasn't set then) so we generate the parameter here. See
754 -- the Boolean variable Defer in (a block within) Expand_Call.
755
756 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
757 declare
758 Subp : Entity_Id;
759
760 begin
761 if Nkind (Name (Exp)) = N_Explicit_Dereference then
762 Subp := Designated_Type (Etype (Prefix (Name (Exp))));
763 else
764 Subp := Entity (Name (Exp));
765 end if;
766
767 Subp := Ultimate_Alias (Subp);
768
769 if Present (Extra_Accessibility_Of_Result (Subp)) then
770 Add_Extra_Actual_To_Call
771 (Subprogram_Call => Exp,
772 Extra_Formal => Extra_Accessibility_Of_Result (Subp),
773 Extra_Actual => Dynamic_Accessibility_Level (PtrT));
774 end if;
775 end;
776 end if;
777
778 -- Case of tagged type or type requiring finalization
779
780 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
781
782 -- Ada 2005 (AI-318-02): If the initialization expression is a call
783 -- to a build-in-place function, then access to the allocated object
784 -- must be passed to the function. Currently we limit such functions
785 -- to those with constrained limited result subtypes, but eventually
786 -- we plan to expand the allowed forms of functions that are treated
787 -- as build-in-place.
788
789 if Ada_Version >= Ada_2005
790 and then Is_Build_In_Place_Function_Call (Exp)
791 then
792 Make_Build_In_Place_Call_In_Allocator (N, Exp);
793 Apply_Accessibility_Check (N, Built_In_Place => True);
794 return;
795 end if;
796
797 -- Actions inserted before:
798 -- Temp : constant ptr_T := new T'(Expression);
799 -- Temp._tag = T'tag; -- when not class-wide
800 -- [Deep_]Adjust (Temp.all);
801
802 -- We analyze by hand the new internal allocator to avoid any
803 -- recursion and inappropriate call to Initialize.
804
805 -- We don't want to remove side effects when the expression must be
806 -- built in place. In the case of a build-in-place function call,
807 -- that could lead to a duplication of the call, which was already
808 -- substituted for the allocator.
809
810 if not Aggr_In_Place then
811 Remove_Side_Effects (Exp);
812 end if;
813
814 Temp := Make_Temporary (Loc, 'P', N);
815
816 -- For a class wide allocation generate the following code:
817
818 -- type Equiv_Record is record ... end record;
819 -- implicit subtype CW is <Class_Wide_Subytpe>;
820 -- temp : PtrT := new CW'(CW!(expr));
821
822 if Is_Class_Wide_Type (T) then
823 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
824
825 -- Ada 2005 (AI-251): If the expression is a class-wide interface
826 -- object we generate code to move up "this" to reference the
827 -- base of the object before allocating the new object.
828
829 -- Note that Exp'Address is recursively expanded into a call
830 -- to Base_Address (Exp.Tag)
831
832 if Is_Class_Wide_Type (Etype (Exp))
833 and then Is_Interface (Etype (Exp))
834 and then Tagged_Type_Expansion
835 then
836 Set_Expression
837 (Expression (N),
838 Unchecked_Convert_To (Entity (Indic),
839 Make_Explicit_Dereference (Loc,
840 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
841 Make_Attribute_Reference (Loc,
842 Prefix => Exp,
843 Attribute_Name => Name_Address)))));
844 else
845 Set_Expression
846 (Expression (N),
847 Unchecked_Convert_To (Entity (Indic), Exp));
848 end if;
849
850 Analyze_And_Resolve (Expression (N), Entity (Indic));
851 end if;
852
853 -- Processing for allocators returning non-interface types
854
855 if not Is_Interface (Directly_Designated_Type (PtrT)) then
856 if Aggr_In_Place then
857 Temp_Decl :=
858 Make_Object_Declaration (Loc,
859 Defining_Identifier => Temp,
860 Object_Definition => New_Occurrence_Of (PtrT, Loc),
861 Expression =>
862 Make_Allocator (Loc,
863 Expression =>
864 New_Occurrence_Of (Etype (Exp), Loc)));
865
866 -- Copy the Comes_From_Source flag for the allocator we just
867 -- built, since logically this allocator is a replacement of
868 -- the original allocator node. This is for proper handling of
869 -- restriction No_Implicit_Heap_Allocations.
870
871 Set_Comes_From_Source
872 (Expression (Temp_Decl), Comes_From_Source (N));
873
874 Set_No_Initialization (Expression (Temp_Decl));
875 Insert_Action (N, Temp_Decl);
876
877 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
878 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
879
880 else
881 Node := Relocate_Node (N);
882 Set_Analyzed (Node);
883
884 Temp_Decl :=
885 Make_Object_Declaration (Loc,
886 Defining_Identifier => Temp,
887 Constant_Present => True,
888 Object_Definition => New_Occurrence_Of (PtrT, Loc),
889 Expression => Node);
890
891 Insert_Action (N, Temp_Decl);
892 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
893 end if;
894
895 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
896 -- interface type. In this case we use the type of the qualified
897 -- expression to allocate the object.
898
899 else
900 declare
901 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
902 New_Decl : Node_Id;
903
904 begin
905 New_Decl :=
906 Make_Full_Type_Declaration (Loc,
907 Defining_Identifier => Def_Id,
908 Type_Definition =>
909 Make_Access_To_Object_Definition (Loc,
910 All_Present => True,
911 Null_Exclusion_Present => False,
912 Constant_Present =>
913 Is_Access_Constant (Etype (N)),
914 Subtype_Indication =>
915 New_Occurrence_Of (Etype (Exp), Loc)));
916
917 Insert_Action (N, New_Decl);
918
919 -- Inherit the allocation-related attributes from the original
920 -- access type.
921
922 Set_Finalization_Master
923 (Def_Id, Finalization_Master (PtrT));
924
925 Set_Associated_Storage_Pool
926 (Def_Id, Associated_Storage_Pool (PtrT));
927
928 -- Declare the object using the previous type declaration
929
930 if Aggr_In_Place then
931 Temp_Decl :=
932 Make_Object_Declaration (Loc,
933 Defining_Identifier => Temp,
934 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
935 Expression =>
936 Make_Allocator (Loc,
937 New_Occurrence_Of (Etype (Exp), Loc)));
938
939 -- Copy the Comes_From_Source flag for the allocator we just
940 -- built, since logically this allocator is a replacement of
941 -- the original allocator node. This is for proper handling
942 -- of restriction No_Implicit_Heap_Allocations.
943
944 Set_Comes_From_Source
945 (Expression (Temp_Decl), Comes_From_Source (N));
946
947 Set_No_Initialization (Expression (Temp_Decl));
948 Insert_Action (N, Temp_Decl);
949
950 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
951 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
952
953 else
954 Node := Relocate_Node (N);
955 Set_Analyzed (Node);
956
957 Temp_Decl :=
958 Make_Object_Declaration (Loc,
959 Defining_Identifier => Temp,
960 Constant_Present => True,
961 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
962 Expression => Node);
963
964 Insert_Action (N, Temp_Decl);
965 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
966 end if;
967
968 -- Generate an additional object containing the address of the
969 -- returned object. The type of this second object declaration
970 -- is the correct type required for the common processing that
971 -- is still performed by this subprogram. The displacement of
972 -- this pointer to reference the component associated with the
973 -- interface type will be done at the end of common processing.
974
975 New_Decl :=
976 Make_Object_Declaration (Loc,
977 Defining_Identifier => Make_Temporary (Loc, 'P'),
978 Object_Definition => New_Occurrence_Of (PtrT, Loc),
979 Expression =>
980 Unchecked_Convert_To (PtrT,
981 New_Occurrence_Of (Temp, Loc)));
982
983 Insert_Action (N, New_Decl);
984
985 Temp_Decl := New_Decl;
986 Temp := Defining_Identifier (New_Decl);
987 end;
988 end if;
989
990 -- Generate the tag assignment
991
992 -- Suppress the tag assignment for VM targets because VM tags are
993 -- represented implicitly in objects.
994
995 if not Tagged_Type_Expansion then
996 null;
997
998 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
999 -- interface objects because in this case the tag does not change.
1000
1001 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1002 pragma Assert (Is_Class_Wide_Type
1003 (Directly_Designated_Type (Etype (N))));
1004 null;
1005
1006 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1007 TagT := T;
1008 TagR := New_Occurrence_Of (Temp, Loc);
1009
1010 elsif Is_Private_Type (T)
1011 and then Is_Tagged_Type (Underlying_Type (T))
1012 then
1013 TagT := Underlying_Type (T);
1014 TagR :=
1015 Unchecked_Convert_To (Underlying_Type (T),
1016 Make_Explicit_Dereference (Loc,
1017 Prefix => New_Occurrence_Of (Temp, Loc)));
1018 end if;
1019
1020 if Present (TagT) then
1021 declare
1022 Full_T : constant Entity_Id := Underlying_Type (TagT);
1023
1024 begin
1025 Tag_Assign :=
1026 Make_Assignment_Statement (Loc,
1027 Name =>
1028 Make_Selected_Component (Loc,
1029 Prefix => TagR,
1030 Selector_Name =>
1031 New_Occurrence_Of
1032 (First_Tag_Component (Full_T), Loc)),
1033
1034 Expression =>
1035 Unchecked_Convert_To (RTE (RE_Tag),
1036 New_Occurrence_Of
1037 (Elists.Node
1038 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1039 end;
1040
1041 -- The previous assignment has to be done in any case
1042
1043 Set_Assignment_OK (Name (Tag_Assign));
1044 Insert_Action (N, Tag_Assign);
1045 end if;
1046
1047 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1048 -- the object may be inherently limited, in which case there is no
1049 -- Adjust procedure, and the object is built in place. In Ada 95, the
1050 -- object can be limited but not inherently limited if this allocator
1051 -- came from a return statement (we're allocating the result on the
1052 -- secondary stack). In that case, the object will be moved, so we do
1053 -- want to Adjust.
1054
1055 if Needs_Finalization (DesigT)
1056 and then Needs_Finalization (T)
1057 and then not Aggr_In_Place
1058 and then not Is_Limited_View (T)
1059 then
1060 -- An unchecked conversion is needed in the classwide case because
1061 -- the designated type can be an ancestor of the subtype mark of
1062 -- the allocator.
1063
1064 Insert_Action (N,
1065 Make_Adjust_Call
1066 (Obj_Ref =>
1067 Unchecked_Convert_To (T,
1068 Make_Explicit_Dereference (Loc,
1069 Prefix => New_Occurrence_Of (Temp, Loc))),
1070 Typ => T));
1071 end if;
1072
1073 -- Note: the accessibility check must be inserted after the call to
1074 -- [Deep_]Adjust to ensure proper completion of the assignment.
1075
1076 Apply_Accessibility_Check (Temp);
1077
1078 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1079 Analyze_And_Resolve (N, PtrT);
1080
1081 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1082 -- component containing the secondary dispatch table of the interface
1083 -- type.
1084
1085 if Is_Interface (Directly_Designated_Type (PtrT)) then
1086 Displace_Allocator_Pointer (N);
1087 end if;
1088
1089 -- Always force the generation of a temporary for aggregates when
1090 -- generating C code, to simplify the work in the code generator.
1091
1092 elsif Aggr_In_Place
1093 or else (Generate_C_Code and then Nkind (Exp) = N_Aggregate)
1094 then
1095 Temp := Make_Temporary (Loc, 'P', N);
1096 Temp_Decl :=
1097 Make_Object_Declaration (Loc,
1098 Defining_Identifier => Temp,
1099 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1100 Expression =>
1101 Make_Allocator (Loc,
1102 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1103
1104 -- Copy the Comes_From_Source flag for the allocator we just built,
1105 -- since logically this allocator is a replacement of the original
1106 -- allocator node. This is for proper handling of restriction
1107 -- No_Implicit_Heap_Allocations.
1108
1109 Set_Comes_From_Source
1110 (Expression (Temp_Decl), Comes_From_Source (N));
1111
1112 Set_No_Initialization (Expression (Temp_Decl));
1113 Insert_Action (N, Temp_Decl);
1114
1115 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1116 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1117
1118 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1119 Analyze_And_Resolve (N, PtrT);
1120
1121 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1122 Install_Null_Excluding_Check (Exp);
1123
1124 elsif Is_Access_Type (DesigT)
1125 and then Nkind (Exp) = N_Allocator
1126 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1127 then
1128 -- Apply constraint to designated subtype indication
1129
1130 Apply_Constraint_Check
1131 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
1132
1133 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1134
1135 -- Propagate constraint_error to enclosing allocator
1136
1137 Rewrite (Exp, New_Copy (Expression (Exp)));
1138 end if;
1139
1140 else
1141 Build_Allocate_Deallocate_Proc (N, True);
1142
1143 -- If we have:
1144 -- type A is access T1;
1145 -- X : A := new T2'(...);
1146 -- T1 and T2 can be different subtypes, and we might need to check
1147 -- both constraints. First check against the type of the qualified
1148 -- expression.
1149
1150 Apply_Constraint_Check (Exp, T, No_Sliding => True);
1151
1152 if Do_Range_Check (Exp) then
1153 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1154 end if;
1155
1156 -- A check is also needed in cases where the designated subtype is
1157 -- constrained and differs from the subtype given in the qualified
1158 -- expression. Note that the check on the qualified expression does
1159 -- not allow sliding, but this check does (a relaxation from Ada 83).
1160
1161 if Is_Constrained (DesigT)
1162 and then not Subtypes_Statically_Match (T, DesigT)
1163 then
1164 Apply_Constraint_Check
1165 (Exp, DesigT, No_Sliding => False);
1166
1167 if Do_Range_Check (Exp) then
1168 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1169 end if;
1170 end if;
1171
1172 -- For an access to unconstrained packed array, GIGI needs to see an
1173 -- expression with a constrained subtype in order to compute the
1174 -- proper size for the allocator.
1175
1176 if Is_Array_Type (T)
1177 and then not Is_Constrained (T)
1178 and then Is_Packed (T)
1179 then
1180 declare
1181 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1182 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1183 begin
1184 Insert_Action (Exp,
1185 Make_Subtype_Declaration (Loc,
1186 Defining_Identifier => ConstrT,
1187 Subtype_Indication =>
1188 Make_Subtype_From_Expr (Internal_Exp, T)));
1189 Freeze_Itype (ConstrT, Exp);
1190 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1191 end;
1192 end if;
1193
1194 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1195 -- to a build-in-place function, then access to the allocated object
1196 -- must be passed to the function. Currently we limit such functions
1197 -- to those with constrained limited result subtypes, but eventually
1198 -- we plan to expand the allowed forms of functions that are treated
1199 -- as build-in-place.
1200
1201 if Ada_Version >= Ada_2005
1202 and then Is_Build_In_Place_Function_Call (Exp)
1203 then
1204 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1205 end if;
1206 end if;
1207
1208 exception
1209 when RE_Not_Available =>
1210 return;
1211 end Expand_Allocator_Expression;
1212
1213 -----------------------------
1214 -- Expand_Array_Comparison --
1215 -----------------------------
1216
1217 -- Expansion is only required in the case of array types. For the unpacked
1218 -- case, an appropriate runtime routine is called. For packed cases, and
1219 -- also in some other cases where a runtime routine cannot be called, the
1220 -- form of the expansion is:
1221
1222 -- [body for greater_nn; boolean_expression]
1223
1224 -- The body is built by Make_Array_Comparison_Op, and the form of the
1225 -- Boolean expression depends on the operator involved.
1226
1227 procedure Expand_Array_Comparison (N : Node_Id) is
1228 Loc : constant Source_Ptr := Sloc (N);
1229 Op1 : Node_Id := Left_Opnd (N);
1230 Op2 : Node_Id := Right_Opnd (N);
1231 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1232 Ctyp : constant Entity_Id := Component_Type (Typ1);
1233
1234 Expr : Node_Id;
1235 Func_Body : Node_Id;
1236 Func_Name : Entity_Id;
1237
1238 Comp : RE_Id;
1239
1240 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1241 -- True for byte addressable target
1242
1243 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1244 -- Returns True if the length of the given operand is known to be less
1245 -- than 4. Returns False if this length is known to be four or greater
1246 -- or is not known at compile time.
1247
1248 ------------------------
1249 -- Length_Less_Than_4 --
1250 ------------------------
1251
1252 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1253 Otyp : constant Entity_Id := Etype (Opnd);
1254
1255 begin
1256 if Ekind (Otyp) = E_String_Literal_Subtype then
1257 return String_Literal_Length (Otyp) < 4;
1258
1259 else
1260 declare
1261 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1262 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1263 Hi : constant Node_Id := Type_High_Bound (Ityp);
1264 Lov : Uint;
1265 Hiv : Uint;
1266
1267 begin
1268 if Compile_Time_Known_Value (Lo) then
1269 Lov := Expr_Value (Lo);
1270 else
1271 return False;
1272 end if;
1273
1274 if Compile_Time_Known_Value (Hi) then
1275 Hiv := Expr_Value (Hi);
1276 else
1277 return False;
1278 end if;
1279
1280 return Hiv < Lov + 3;
1281 end;
1282 end if;
1283 end Length_Less_Than_4;
1284
1285 -- Start of processing for Expand_Array_Comparison
1286
1287 begin
1288 -- Deal first with unpacked case, where we can call a runtime routine
1289 -- except that we avoid this for targets for which are not addressable
1290 -- by bytes.
1291
1292 if not Is_Bit_Packed_Array (Typ1)
1293 and then Byte_Addressable
1294 then
1295 -- The call we generate is:
1296
1297 -- Compare_Array_xn[_Unaligned]
1298 -- (left'address, right'address, left'length, right'length) <op> 0
1299
1300 -- x = U for unsigned, S for signed
1301 -- n = 8,16,32,64 for component size
1302 -- Add _Unaligned if length < 4 and component size is 8.
1303 -- <op> is the standard comparison operator
1304
1305 if Component_Size (Typ1) = 8 then
1306 if Length_Less_Than_4 (Op1)
1307 or else
1308 Length_Less_Than_4 (Op2)
1309 then
1310 if Is_Unsigned_Type (Ctyp) then
1311 Comp := RE_Compare_Array_U8_Unaligned;
1312 else
1313 Comp := RE_Compare_Array_S8_Unaligned;
1314 end if;
1315
1316 else
1317 if Is_Unsigned_Type (Ctyp) then
1318 Comp := RE_Compare_Array_U8;
1319 else
1320 Comp := RE_Compare_Array_S8;
1321 end if;
1322 end if;
1323
1324 elsif Component_Size (Typ1) = 16 then
1325 if Is_Unsigned_Type (Ctyp) then
1326 Comp := RE_Compare_Array_U16;
1327 else
1328 Comp := RE_Compare_Array_S16;
1329 end if;
1330
1331 elsif Component_Size (Typ1) = 32 then
1332 if Is_Unsigned_Type (Ctyp) then
1333 Comp := RE_Compare_Array_U32;
1334 else
1335 Comp := RE_Compare_Array_S32;
1336 end if;
1337
1338 else pragma Assert (Component_Size (Typ1) = 64);
1339 if Is_Unsigned_Type (Ctyp) then
1340 Comp := RE_Compare_Array_U64;
1341 else
1342 Comp := RE_Compare_Array_S64;
1343 end if;
1344 end if;
1345
1346 if RTE_Available (Comp) then
1347
1348 -- Expand to a call only if the runtime function is available,
1349 -- otherwise fall back to inline code.
1350
1351 Remove_Side_Effects (Op1, Name_Req => True);
1352 Remove_Side_Effects (Op2, Name_Req => True);
1353
1354 Rewrite (Op1,
1355 Make_Function_Call (Sloc (Op1),
1356 Name => New_Occurrence_Of (RTE (Comp), Loc),
1357
1358 Parameter_Associations => New_List (
1359 Make_Attribute_Reference (Loc,
1360 Prefix => Relocate_Node (Op1),
1361 Attribute_Name => Name_Address),
1362
1363 Make_Attribute_Reference (Loc,
1364 Prefix => Relocate_Node (Op2),
1365 Attribute_Name => Name_Address),
1366
1367 Make_Attribute_Reference (Loc,
1368 Prefix => Relocate_Node (Op1),
1369 Attribute_Name => Name_Length),
1370
1371 Make_Attribute_Reference (Loc,
1372 Prefix => Relocate_Node (Op2),
1373 Attribute_Name => Name_Length))));
1374
1375 Rewrite (Op2,
1376 Make_Integer_Literal (Sloc (Op2),
1377 Intval => Uint_0));
1378
1379 Analyze_And_Resolve (Op1, Standard_Integer);
1380 Analyze_And_Resolve (Op2, Standard_Integer);
1381 return;
1382 end if;
1383 end if;
1384
1385 -- Cases where we cannot make runtime call
1386
1387 -- For (a <= b) we convert to not (a > b)
1388
1389 if Chars (N) = Name_Op_Le then
1390 Rewrite (N,
1391 Make_Op_Not (Loc,
1392 Right_Opnd =>
1393 Make_Op_Gt (Loc,
1394 Left_Opnd => Op1,
1395 Right_Opnd => Op2)));
1396 Analyze_And_Resolve (N, Standard_Boolean);
1397 return;
1398
1399 -- For < the Boolean expression is
1400 -- greater__nn (op2, op1)
1401
1402 elsif Chars (N) = Name_Op_Lt then
1403 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1404
1405 -- Switch operands
1406
1407 Op1 := Right_Opnd (N);
1408 Op2 := Left_Opnd (N);
1409
1410 -- For (a >= b) we convert to not (a < b)
1411
1412 elsif Chars (N) = Name_Op_Ge then
1413 Rewrite (N,
1414 Make_Op_Not (Loc,
1415 Right_Opnd =>
1416 Make_Op_Lt (Loc,
1417 Left_Opnd => Op1,
1418 Right_Opnd => Op2)));
1419 Analyze_And_Resolve (N, Standard_Boolean);
1420 return;
1421
1422 -- For > the Boolean expression is
1423 -- greater__nn (op1, op2)
1424
1425 else
1426 pragma Assert (Chars (N) = Name_Op_Gt);
1427 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1428 end if;
1429
1430 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1431 Expr :=
1432 Make_Function_Call (Loc,
1433 Name => New_Occurrence_Of (Func_Name, Loc),
1434 Parameter_Associations => New_List (Op1, Op2));
1435
1436 Insert_Action (N, Func_Body);
1437 Rewrite (N, Expr);
1438 Analyze_And_Resolve (N, Standard_Boolean);
1439 end Expand_Array_Comparison;
1440
1441 ---------------------------
1442 -- Expand_Array_Equality --
1443 ---------------------------
1444
1445 -- Expand an equality function for multi-dimensional arrays. Here is an
1446 -- example of such a function for Nb_Dimension = 2
1447
1448 -- function Enn (A : atyp; B : btyp) return boolean is
1449 -- begin
1450 -- if (A'length (1) = 0 or else A'length (2) = 0)
1451 -- and then
1452 -- (B'length (1) = 0 or else B'length (2) = 0)
1453 -- then
1454 -- return True; -- RM 4.5.2(22)
1455 -- end if;
1456
1457 -- if A'length (1) /= B'length (1)
1458 -- or else
1459 -- A'length (2) /= B'length (2)
1460 -- then
1461 -- return False; -- RM 4.5.2(23)
1462 -- end if;
1463
1464 -- declare
1465 -- A1 : Index_T1 := A'first (1);
1466 -- B1 : Index_T1 := B'first (1);
1467 -- begin
1468 -- loop
1469 -- declare
1470 -- A2 : Index_T2 := A'first (2);
1471 -- B2 : Index_T2 := B'first (2);
1472 -- begin
1473 -- loop
1474 -- if A (A1, A2) /= B (B1, B2) then
1475 -- return False;
1476 -- end if;
1477
1478 -- exit when A2 = A'last (2);
1479 -- A2 := Index_T2'succ (A2);
1480 -- B2 := Index_T2'succ (B2);
1481 -- end loop;
1482 -- end;
1483
1484 -- exit when A1 = A'last (1);
1485 -- A1 := Index_T1'succ (A1);
1486 -- B1 := Index_T1'succ (B1);
1487 -- end loop;
1488 -- end;
1489
1490 -- return true;
1491 -- end Enn;
1492
1493 -- Note on the formal types used (atyp and btyp). If either of the arrays
1494 -- is of a private type, we use the underlying type, and do an unchecked
1495 -- conversion of the actual. If either of the arrays has a bound depending
1496 -- on a discriminant, then we use the base type since otherwise we have an
1497 -- escaped discriminant in the function.
1498
1499 -- If both arrays are constrained and have the same bounds, we can generate
1500 -- a loop with an explicit iteration scheme using a 'Range attribute over
1501 -- the first array.
1502
1503 function Expand_Array_Equality
1504 (Nod : Node_Id;
1505 Lhs : Node_Id;
1506 Rhs : Node_Id;
1507 Bodies : List_Id;
1508 Typ : Entity_Id) return Node_Id
1509 is
1510 Loc : constant Source_Ptr := Sloc (Nod);
1511 Decls : constant List_Id := New_List;
1512 Index_List1 : constant List_Id := New_List;
1513 Index_List2 : constant List_Id := New_List;
1514
1515 Actuals : List_Id;
1516 Formals : List_Id;
1517 Func_Name : Entity_Id;
1518 Func_Body : Node_Id;
1519
1520 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1521 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1522
1523 Ltyp : Entity_Id;
1524 Rtyp : Entity_Id;
1525 -- The parameter types to be used for the formals
1526
1527 function Arr_Attr
1528 (Arr : Entity_Id;
1529 Nam : Name_Id;
1530 Num : Int) return Node_Id;
1531 -- This builds the attribute reference Arr'Nam (Expr)
1532
1533 function Component_Equality (Typ : Entity_Id) return Node_Id;
1534 -- Create one statement to compare corresponding components, designated
1535 -- by a full set of indexes.
1536
1537 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1538 -- Given one of the arguments, computes the appropriate type to be used
1539 -- for that argument in the corresponding function formal
1540
1541 function Handle_One_Dimension
1542 (N : Int;
1543 Index : Node_Id) return Node_Id;
1544 -- This procedure returns the following code
1545 --
1546 -- declare
1547 -- Bn : Index_T := B'First (N);
1548 -- begin
1549 -- loop
1550 -- xxx
1551 -- exit when An = A'Last (N);
1552 -- An := Index_T'Succ (An)
1553 -- Bn := Index_T'Succ (Bn)
1554 -- end loop;
1555 -- end;
1556 --
1557 -- If both indexes are constrained and identical, the procedure
1558 -- returns a simpler loop:
1559 --
1560 -- for An in A'Range (N) loop
1561 -- xxx
1562 -- end loop
1563 --
1564 -- N is the dimension for which we are generating a loop. Index is the
1565 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1566 -- xxx statement is either the loop or declare for the next dimension
1567 -- or if this is the last dimension the comparison of corresponding
1568 -- components of the arrays.
1569 --
1570 -- The actual way the code works is to return the comparison of
1571 -- corresponding components for the N+1 call. That's neater.
1572
1573 function Test_Empty_Arrays return Node_Id;
1574 -- This function constructs the test for both arrays being empty
1575 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1576 -- and then
1577 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1578
1579 function Test_Lengths_Correspond return Node_Id;
1580 -- This function constructs the test for arrays having different lengths
1581 -- in at least one index position, in which case the resulting code is:
1582
1583 -- A'length (1) /= B'length (1)
1584 -- or else
1585 -- A'length (2) /= B'length (2)
1586 -- or else
1587 -- ...
1588
1589 --------------
1590 -- Arr_Attr --
1591 --------------
1592
1593 function Arr_Attr
1594 (Arr : Entity_Id;
1595 Nam : Name_Id;
1596 Num : Int) return Node_Id
1597 is
1598 begin
1599 return
1600 Make_Attribute_Reference (Loc,
1601 Attribute_Name => Nam,
1602 Prefix => New_Occurrence_Of (Arr, Loc),
1603 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1604 end Arr_Attr;
1605
1606 ------------------------
1607 -- Component_Equality --
1608 ------------------------
1609
1610 function Component_Equality (Typ : Entity_Id) return Node_Id is
1611 Test : Node_Id;
1612 L, R : Node_Id;
1613
1614 begin
1615 -- if a(i1...) /= b(j1...) then return false; end if;
1616
1617 L :=
1618 Make_Indexed_Component (Loc,
1619 Prefix => Make_Identifier (Loc, Chars (A)),
1620 Expressions => Index_List1);
1621
1622 R :=
1623 Make_Indexed_Component (Loc,
1624 Prefix => Make_Identifier (Loc, Chars (B)),
1625 Expressions => Index_List2);
1626
1627 Test := Expand_Composite_Equality
1628 (Nod, Component_Type (Typ), L, R, Decls);
1629
1630 -- If some (sub)component is an unchecked_union, the whole operation
1631 -- will raise program error.
1632
1633 if Nkind (Test) = N_Raise_Program_Error then
1634
1635 -- This node is going to be inserted at a location where a
1636 -- statement is expected: clear its Etype so analysis will set
1637 -- it to the expected Standard_Void_Type.
1638
1639 Set_Etype (Test, Empty);
1640 return Test;
1641
1642 else
1643 return
1644 Make_Implicit_If_Statement (Nod,
1645 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1646 Then_Statements => New_List (
1647 Make_Simple_Return_Statement (Loc,
1648 Expression => New_Occurrence_Of (Standard_False, Loc))));
1649 end if;
1650 end Component_Equality;
1651
1652 ------------------
1653 -- Get_Arg_Type --
1654 ------------------
1655
1656 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1657 T : Entity_Id;
1658 X : Node_Id;
1659
1660 begin
1661 T := Etype (N);
1662
1663 if No (T) then
1664 return Typ;
1665
1666 else
1667 T := Underlying_Type (T);
1668
1669 X := First_Index (T);
1670 while Present (X) loop
1671 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1672 or else
1673 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1674 then
1675 T := Base_Type (T);
1676 exit;
1677 end if;
1678
1679 Next_Index (X);
1680 end loop;
1681
1682 return T;
1683 end if;
1684 end Get_Arg_Type;
1685
1686 --------------------------
1687 -- Handle_One_Dimension --
1688 ---------------------------
1689
1690 function Handle_One_Dimension
1691 (N : Int;
1692 Index : Node_Id) return Node_Id
1693 is
1694 Need_Separate_Indexes : constant Boolean :=
1695 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1696 -- If the index types are identical, and we are working with
1697 -- constrained types, then we can use the same index for both
1698 -- of the arrays.
1699
1700 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1701
1702 Bn : Entity_Id;
1703 Index_T : Entity_Id;
1704 Stm_List : List_Id;
1705 Loop_Stm : Node_Id;
1706
1707 begin
1708 if N > Number_Dimensions (Ltyp) then
1709 return Component_Equality (Ltyp);
1710 end if;
1711
1712 -- Case where we generate a loop
1713
1714 Index_T := Base_Type (Etype (Index));
1715
1716 if Need_Separate_Indexes then
1717 Bn := Make_Temporary (Loc, 'B');
1718 else
1719 Bn := An;
1720 end if;
1721
1722 Append (New_Occurrence_Of (An, Loc), Index_List1);
1723 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1724
1725 Stm_List := New_List (
1726 Handle_One_Dimension (N + 1, Next_Index (Index)));
1727
1728 if Need_Separate_Indexes then
1729
1730 -- Generate guard for loop, followed by increments of indexes
1731
1732 Append_To (Stm_List,
1733 Make_Exit_Statement (Loc,
1734 Condition =>
1735 Make_Op_Eq (Loc,
1736 Left_Opnd => New_Occurrence_Of (An, Loc),
1737 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1738
1739 Append_To (Stm_List,
1740 Make_Assignment_Statement (Loc,
1741 Name => New_Occurrence_Of (An, Loc),
1742 Expression =>
1743 Make_Attribute_Reference (Loc,
1744 Prefix => New_Occurrence_Of (Index_T, Loc),
1745 Attribute_Name => Name_Succ,
1746 Expressions => New_List (
1747 New_Occurrence_Of (An, Loc)))));
1748
1749 Append_To (Stm_List,
1750 Make_Assignment_Statement (Loc,
1751 Name => New_Occurrence_Of (Bn, Loc),
1752 Expression =>
1753 Make_Attribute_Reference (Loc,
1754 Prefix => New_Occurrence_Of (Index_T, Loc),
1755 Attribute_Name => Name_Succ,
1756 Expressions => New_List (
1757 New_Occurrence_Of (Bn, Loc)))));
1758 end if;
1759
1760 -- If separate indexes, we need a declare block for An and Bn, and a
1761 -- loop without an iteration scheme.
1762
1763 if Need_Separate_Indexes then
1764 Loop_Stm :=
1765 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1766
1767 return
1768 Make_Block_Statement (Loc,
1769 Declarations => New_List (
1770 Make_Object_Declaration (Loc,
1771 Defining_Identifier => An,
1772 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1773 Expression => Arr_Attr (A, Name_First, N)),
1774
1775 Make_Object_Declaration (Loc,
1776 Defining_Identifier => Bn,
1777 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1778 Expression => Arr_Attr (B, Name_First, N))),
1779
1780 Handled_Statement_Sequence =>
1781 Make_Handled_Sequence_Of_Statements (Loc,
1782 Statements => New_List (Loop_Stm)));
1783
1784 -- If no separate indexes, return loop statement with explicit
1785 -- iteration scheme on its own
1786
1787 else
1788 Loop_Stm :=
1789 Make_Implicit_Loop_Statement (Nod,
1790 Statements => Stm_List,
1791 Iteration_Scheme =>
1792 Make_Iteration_Scheme (Loc,
1793 Loop_Parameter_Specification =>
1794 Make_Loop_Parameter_Specification (Loc,
1795 Defining_Identifier => An,
1796 Discrete_Subtype_Definition =>
1797 Arr_Attr (A, Name_Range, N))));
1798 return Loop_Stm;
1799 end if;
1800 end Handle_One_Dimension;
1801
1802 -----------------------
1803 -- Test_Empty_Arrays --
1804 -----------------------
1805
1806 function Test_Empty_Arrays return Node_Id is
1807 Alist : Node_Id;
1808 Blist : Node_Id;
1809
1810 Atest : Node_Id;
1811 Btest : Node_Id;
1812
1813 begin
1814 Alist := Empty;
1815 Blist := Empty;
1816 for J in 1 .. Number_Dimensions (Ltyp) loop
1817 Atest :=
1818 Make_Op_Eq (Loc,
1819 Left_Opnd => Arr_Attr (A, Name_Length, J),
1820 Right_Opnd => Make_Integer_Literal (Loc, 0));
1821
1822 Btest :=
1823 Make_Op_Eq (Loc,
1824 Left_Opnd => Arr_Attr (B, Name_Length, J),
1825 Right_Opnd => Make_Integer_Literal (Loc, 0));
1826
1827 if No (Alist) then
1828 Alist := Atest;
1829 Blist := Btest;
1830
1831 else
1832 Alist :=
1833 Make_Or_Else (Loc,
1834 Left_Opnd => Relocate_Node (Alist),
1835 Right_Opnd => Atest);
1836
1837 Blist :=
1838 Make_Or_Else (Loc,
1839 Left_Opnd => Relocate_Node (Blist),
1840 Right_Opnd => Btest);
1841 end if;
1842 end loop;
1843
1844 return
1845 Make_And_Then (Loc,
1846 Left_Opnd => Alist,
1847 Right_Opnd => Blist);
1848 end Test_Empty_Arrays;
1849
1850 -----------------------------
1851 -- Test_Lengths_Correspond --
1852 -----------------------------
1853
1854 function Test_Lengths_Correspond return Node_Id is
1855 Result : Node_Id;
1856 Rtest : Node_Id;
1857
1858 begin
1859 Result := Empty;
1860 for J in 1 .. Number_Dimensions (Ltyp) loop
1861 Rtest :=
1862 Make_Op_Ne (Loc,
1863 Left_Opnd => Arr_Attr (A, Name_Length, J),
1864 Right_Opnd => Arr_Attr (B, Name_Length, J));
1865
1866 if No (Result) then
1867 Result := Rtest;
1868 else
1869 Result :=
1870 Make_Or_Else (Loc,
1871 Left_Opnd => Relocate_Node (Result),
1872 Right_Opnd => Rtest);
1873 end if;
1874 end loop;
1875
1876 return Result;
1877 end Test_Lengths_Correspond;
1878
1879 -- Start of processing for Expand_Array_Equality
1880
1881 begin
1882 Ltyp := Get_Arg_Type (Lhs);
1883 Rtyp := Get_Arg_Type (Rhs);
1884
1885 -- For now, if the argument types are not the same, go to the base type,
1886 -- since the code assumes that the formals have the same type. This is
1887 -- fixable in future ???
1888
1889 if Ltyp /= Rtyp then
1890 Ltyp := Base_Type (Ltyp);
1891 Rtyp := Base_Type (Rtyp);
1892 pragma Assert (Ltyp = Rtyp);
1893 end if;
1894
1895 -- Build list of formals for function
1896
1897 Formals := New_List (
1898 Make_Parameter_Specification (Loc,
1899 Defining_Identifier => A,
1900 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
1901
1902 Make_Parameter_Specification (Loc,
1903 Defining_Identifier => B,
1904 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
1905
1906 Func_Name := Make_Temporary (Loc, 'E');
1907
1908 -- Build statement sequence for function
1909
1910 Func_Body :=
1911 Make_Subprogram_Body (Loc,
1912 Specification =>
1913 Make_Function_Specification (Loc,
1914 Defining_Unit_Name => Func_Name,
1915 Parameter_Specifications => Formals,
1916 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
1917
1918 Declarations => Decls,
1919
1920 Handled_Statement_Sequence =>
1921 Make_Handled_Sequence_Of_Statements (Loc,
1922 Statements => New_List (
1923
1924 Make_Implicit_If_Statement (Nod,
1925 Condition => Test_Empty_Arrays,
1926 Then_Statements => New_List (
1927 Make_Simple_Return_Statement (Loc,
1928 Expression =>
1929 New_Occurrence_Of (Standard_True, Loc)))),
1930
1931 Make_Implicit_If_Statement (Nod,
1932 Condition => Test_Lengths_Correspond,
1933 Then_Statements => New_List (
1934 Make_Simple_Return_Statement (Loc,
1935 Expression => New_Occurrence_Of (Standard_False, Loc)))),
1936
1937 Handle_One_Dimension (1, First_Index (Ltyp)),
1938
1939 Make_Simple_Return_Statement (Loc,
1940 Expression => New_Occurrence_Of (Standard_True, Loc)))));
1941
1942 Set_Has_Completion (Func_Name, True);
1943 Set_Is_Inlined (Func_Name);
1944
1945 -- If the array type is distinct from the type of the arguments, it
1946 -- is the full view of a private type. Apply an unchecked conversion
1947 -- to insure that analysis of the call succeeds.
1948
1949 declare
1950 L, R : Node_Id;
1951
1952 begin
1953 L := Lhs;
1954 R := Rhs;
1955
1956 if No (Etype (Lhs))
1957 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1958 then
1959 L := OK_Convert_To (Ltyp, Lhs);
1960 end if;
1961
1962 if No (Etype (Rhs))
1963 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1964 then
1965 R := OK_Convert_To (Rtyp, Rhs);
1966 end if;
1967
1968 Actuals := New_List (L, R);
1969 end;
1970
1971 Append_To (Bodies, Func_Body);
1972
1973 return
1974 Make_Function_Call (Loc,
1975 Name => New_Occurrence_Of (Func_Name, Loc),
1976 Parameter_Associations => Actuals);
1977 end Expand_Array_Equality;
1978
1979 -----------------------------
1980 -- Expand_Boolean_Operator --
1981 -----------------------------
1982
1983 -- Note that we first get the actual subtypes of the operands, since we
1984 -- always want to deal with types that have bounds.
1985
1986 procedure Expand_Boolean_Operator (N : Node_Id) is
1987 Typ : constant Entity_Id := Etype (N);
1988
1989 begin
1990 -- Special case of bit packed array where both operands are known to be
1991 -- properly aligned. In this case we use an efficient run time routine
1992 -- to carry out the operation (see System.Bit_Ops).
1993
1994 if Is_Bit_Packed_Array (Typ)
1995 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
1996 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
1997 then
1998 Expand_Packed_Boolean_Operator (N);
1999 return;
2000 end if;
2001
2002 -- For the normal non-packed case, the general expansion is to build
2003 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2004 -- and then inserting it into the tree. The original operator node is
2005 -- then rewritten as a call to this function. We also use this in the
2006 -- packed case if either operand is a possibly unaligned object.
2007
2008 declare
2009 Loc : constant Source_Ptr := Sloc (N);
2010 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2011 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
2012 Func_Body : Node_Id;
2013 Func_Name : Entity_Id;
2014
2015 begin
2016 Convert_To_Actual_Subtype (L);
2017 Convert_To_Actual_Subtype (R);
2018 Ensure_Defined (Etype (L), N);
2019 Ensure_Defined (Etype (R), N);
2020 Apply_Length_Check (R, Etype (L));
2021
2022 if Nkind (N) = N_Op_Xor then
2023 Silly_Boolean_Array_Xor_Test (N, Etype (L));
2024 end if;
2025
2026 if Nkind (Parent (N)) = N_Assignment_Statement
2027 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2028 then
2029 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2030
2031 elsif Nkind (Parent (N)) = N_Op_Not
2032 and then Nkind (N) = N_Op_And
2033 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2034 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2035 then
2036 return;
2037 else
2038
2039 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2040 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2041 Insert_Action (N, Func_Body);
2042
2043 -- Now rewrite the expression with a call
2044
2045 Rewrite (N,
2046 Make_Function_Call (Loc,
2047 Name => New_Occurrence_Of (Func_Name, Loc),
2048 Parameter_Associations =>
2049 New_List (
2050 L,
2051 Make_Type_Conversion
2052 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
2053
2054 Analyze_And_Resolve (N, Typ);
2055 end if;
2056 end;
2057 end Expand_Boolean_Operator;
2058
2059 ------------------------------------------------
2060 -- Expand_Compare_Minimize_Eliminate_Overflow --
2061 ------------------------------------------------
2062
2063 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2064 Loc : constant Source_Ptr := Sloc (N);
2065
2066 Result_Type : constant Entity_Id := Etype (N);
2067 -- Capture result type (could be a derived boolean type)
2068
2069 Llo, Lhi : Uint;
2070 Rlo, Rhi : Uint;
2071
2072 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2073 -- Entity for Long_Long_Integer'Base
2074
2075 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2076 -- Current overflow checking mode
2077
2078 procedure Set_True;
2079 procedure Set_False;
2080 -- These procedures rewrite N with an occurrence of Standard_True or
2081 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2082
2083 ---------------
2084 -- Set_False --
2085 ---------------
2086
2087 procedure Set_False is
2088 begin
2089 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2090 Warn_On_Known_Condition (N);
2091 end Set_False;
2092
2093 --------------
2094 -- Set_True --
2095 --------------
2096
2097 procedure Set_True is
2098 begin
2099 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2100 Warn_On_Known_Condition (N);
2101 end Set_True;
2102
2103 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2104
2105 begin
2106 -- Nothing to do unless we have a comparison operator with operands
2107 -- that are signed integer types, and we are operating in either
2108 -- MINIMIZED or ELIMINATED overflow checking mode.
2109
2110 if Nkind (N) not in N_Op_Compare
2111 or else Check not in Minimized_Or_Eliminated
2112 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2113 then
2114 return;
2115 end if;
2116
2117 -- OK, this is the case we are interested in. First step is to process
2118 -- our operands using the Minimize_Eliminate circuitry which applies
2119 -- this processing to the two operand subtrees.
2120
2121 Minimize_Eliminate_Overflows
2122 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2123 Minimize_Eliminate_Overflows
2124 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2125
2126 -- See if the range information decides the result of the comparison.
2127 -- We can only do this if we in fact have full range information (which
2128 -- won't be the case if either operand is bignum at this stage).
2129
2130 if Llo /= No_Uint and then Rlo /= No_Uint then
2131 case N_Op_Compare (Nkind (N)) is
2132 when N_Op_Eq =>
2133 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2134 Set_True;
2135 elsif Llo > Rhi or else Lhi < Rlo then
2136 Set_False;
2137 end if;
2138
2139 when N_Op_Ge =>
2140 if Llo >= Rhi then
2141 Set_True;
2142 elsif Lhi < Rlo then
2143 Set_False;
2144 end if;
2145
2146 when N_Op_Gt =>
2147 if Llo > Rhi then
2148 Set_True;
2149 elsif Lhi <= Rlo then
2150 Set_False;
2151 end if;
2152
2153 when N_Op_Le =>
2154 if Llo > Rhi then
2155 Set_False;
2156 elsif Lhi <= Rlo then
2157 Set_True;
2158 end if;
2159
2160 when N_Op_Lt =>
2161 if Llo >= Rhi then
2162 Set_False;
2163 elsif Lhi < Rlo then
2164 Set_True;
2165 end if;
2166
2167 when N_Op_Ne =>
2168 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2169 Set_False;
2170 elsif Llo > Rhi or else Lhi < Rlo then
2171 Set_True;
2172 end if;
2173 end case;
2174
2175 -- All done if we did the rewrite
2176
2177 if Nkind (N) not in N_Op_Compare then
2178 return;
2179 end if;
2180 end if;
2181
2182 -- Otherwise, time to do the comparison
2183
2184 declare
2185 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2186 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2187
2188 begin
2189 -- If the two operands have the same signed integer type we are
2190 -- all set, nothing more to do. This is the case where either
2191 -- both operands were unchanged, or we rewrote both of them to
2192 -- be Long_Long_Integer.
2193
2194 -- Note: Entity for the comparison may be wrong, but it's not worth
2195 -- the effort to change it, since the back end does not use it.
2196
2197 if Is_Signed_Integer_Type (Ltype)
2198 and then Base_Type (Ltype) = Base_Type (Rtype)
2199 then
2200 return;
2201
2202 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2203
2204 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2205 declare
2206 Left : Node_Id := Left_Opnd (N);
2207 Right : Node_Id := Right_Opnd (N);
2208 -- Bignum references for left and right operands
2209
2210 begin
2211 if not Is_RTE (Ltype, RE_Bignum) then
2212 Left := Convert_To_Bignum (Left);
2213 elsif not Is_RTE (Rtype, RE_Bignum) then
2214 Right := Convert_To_Bignum (Right);
2215 end if;
2216
2217 -- We rewrite our node with:
2218
2219 -- do
2220 -- Bnn : Result_Type;
2221 -- declare
2222 -- M : Mark_Id := SS_Mark;
2223 -- begin
2224 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2225 -- SS_Release (M);
2226 -- end;
2227 -- in
2228 -- Bnn
2229 -- end
2230
2231 declare
2232 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2233 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2234 Ent : RE_Id;
2235
2236 begin
2237 case N_Op_Compare (Nkind (N)) is
2238 when N_Op_Eq => Ent := RE_Big_EQ;
2239 when N_Op_Ge => Ent := RE_Big_GE;
2240 when N_Op_Gt => Ent := RE_Big_GT;
2241 when N_Op_Le => Ent := RE_Big_LE;
2242 when N_Op_Lt => Ent := RE_Big_LT;
2243 when N_Op_Ne => Ent := RE_Big_NE;
2244 end case;
2245
2246 -- Insert assignment to Bnn into the bignum block
2247
2248 Insert_Before
2249 (First (Statements (Handled_Statement_Sequence (Blk))),
2250 Make_Assignment_Statement (Loc,
2251 Name => New_Occurrence_Of (Bnn, Loc),
2252 Expression =>
2253 Make_Function_Call (Loc,
2254 Name =>
2255 New_Occurrence_Of (RTE (Ent), Loc),
2256 Parameter_Associations => New_List (Left, Right))));
2257
2258 -- Now do the rewrite with expression actions
2259
2260 Rewrite (N,
2261 Make_Expression_With_Actions (Loc,
2262 Actions => New_List (
2263 Make_Object_Declaration (Loc,
2264 Defining_Identifier => Bnn,
2265 Object_Definition =>
2266 New_Occurrence_Of (Result_Type, Loc)),
2267 Blk),
2268 Expression => New_Occurrence_Of (Bnn, Loc)));
2269 Analyze_And_Resolve (N, Result_Type);
2270 end;
2271 end;
2272
2273 -- No bignums involved, but types are different, so we must have
2274 -- rewritten one of the operands as a Long_Long_Integer but not
2275 -- the other one.
2276
2277 -- If left operand is Long_Long_Integer, convert right operand
2278 -- and we are done (with a comparison of two Long_Long_Integers).
2279
2280 elsif Ltype = LLIB then
2281 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2282 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2283 return;
2284
2285 -- If right operand is Long_Long_Integer, convert left operand
2286 -- and we are done (with a comparison of two Long_Long_Integers).
2287
2288 -- This is the only remaining possibility
2289
2290 else pragma Assert (Rtype = LLIB);
2291 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2292 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2293 return;
2294 end if;
2295 end;
2296 end Expand_Compare_Minimize_Eliminate_Overflow;
2297
2298 -------------------------------
2299 -- Expand_Composite_Equality --
2300 -------------------------------
2301
2302 -- This function is only called for comparing internal fields of composite
2303 -- types when these fields are themselves composites. This is a special
2304 -- case because it is not possible to respect normal Ada visibility rules.
2305
2306 function Expand_Composite_Equality
2307 (Nod : Node_Id;
2308 Typ : Entity_Id;
2309 Lhs : Node_Id;
2310 Rhs : Node_Id;
2311 Bodies : List_Id) return Node_Id
2312 is
2313 Loc : constant Source_Ptr := Sloc (Nod);
2314 Full_Type : Entity_Id;
2315 Prim : Elmt_Id;
2316 Eq_Op : Entity_Id;
2317
2318 function Find_Primitive_Eq return Node_Id;
2319 -- AI05-0123: Locate primitive equality for type if it exists, and
2320 -- build the corresponding call. If operation is abstract, replace
2321 -- call with an explicit raise. Return Empty if there is no primitive.
2322
2323 -----------------------
2324 -- Find_Primitive_Eq --
2325 -----------------------
2326
2327 function Find_Primitive_Eq return Node_Id is
2328 Prim_E : Elmt_Id;
2329 Prim : Node_Id;
2330
2331 begin
2332 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
2333 while Present (Prim_E) loop
2334 Prim := Node (Prim_E);
2335
2336 -- Locate primitive equality with the right signature
2337
2338 if Chars (Prim) = Name_Op_Eq
2339 and then Etype (First_Formal (Prim)) =
2340 Etype (Next_Formal (First_Formal (Prim)))
2341 and then Etype (Prim) = Standard_Boolean
2342 then
2343 if Is_Abstract_Subprogram (Prim) then
2344 return
2345 Make_Raise_Program_Error (Loc,
2346 Reason => PE_Explicit_Raise);
2347
2348 else
2349 return
2350 Make_Function_Call (Loc,
2351 Name => New_Occurrence_Of (Prim, Loc),
2352 Parameter_Associations => New_List (Lhs, Rhs));
2353 end if;
2354 end if;
2355
2356 Next_Elmt (Prim_E);
2357 end loop;
2358
2359 -- If not found, predefined operation will be used
2360
2361 return Empty;
2362 end Find_Primitive_Eq;
2363
2364 -- Start of processing for Expand_Composite_Equality
2365
2366 begin
2367 if Is_Private_Type (Typ) then
2368 Full_Type := Underlying_Type (Typ);
2369 else
2370 Full_Type := Typ;
2371 end if;
2372
2373 -- If the private type has no completion the context may be the
2374 -- expansion of a composite equality for a composite type with some
2375 -- still incomplete components. The expression will not be analyzed
2376 -- until the enclosing type is completed, at which point this will be
2377 -- properly expanded, unless there is a bona fide completion error.
2378
2379 if No (Full_Type) then
2380 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2381 end if;
2382
2383 Full_Type := Base_Type (Full_Type);
2384
2385 -- When the base type itself is private, use the full view to expand
2386 -- the composite equality.
2387
2388 if Is_Private_Type (Full_Type) then
2389 Full_Type := Underlying_Type (Full_Type);
2390 end if;
2391
2392 -- Case of array types
2393
2394 if Is_Array_Type (Full_Type) then
2395
2396 -- If the operand is an elementary type other than a floating-point
2397 -- type, then we can simply use the built-in block bitwise equality,
2398 -- since the predefined equality operators always apply and bitwise
2399 -- equality is fine for all these cases.
2400
2401 if Is_Elementary_Type (Component_Type (Full_Type))
2402 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2403 then
2404 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2405
2406 -- For composite component types, and floating-point types, use the
2407 -- expansion. This deals with tagged component types (where we use
2408 -- the applicable equality routine) and floating-point, (where we
2409 -- need to worry about negative zeroes), and also the case of any
2410 -- composite type recursively containing such fields.
2411
2412 else
2413 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
2414 end if;
2415
2416 -- Case of tagged record types
2417
2418 elsif Is_Tagged_Type (Full_Type) then
2419
2420 -- Call the primitive operation "=" of this type
2421
2422 if Is_Class_Wide_Type (Full_Type) then
2423 Full_Type := Root_Type (Full_Type);
2424 end if;
2425
2426 -- If this is derived from an untagged private type completed with a
2427 -- tagged type, it does not have a full view, so we use the primitive
2428 -- operations of the private type. This check should no longer be
2429 -- necessary when these types receive their full views ???
2430
2431 if Is_Private_Type (Typ)
2432 and then not Is_Tagged_Type (Typ)
2433 and then not Is_Controlled (Typ)
2434 and then Is_Derived_Type (Typ)
2435 and then No (Full_View (Typ))
2436 then
2437 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2438 else
2439 Prim := First_Elmt (Primitive_Operations (Full_Type));
2440 end if;
2441
2442 loop
2443 Eq_Op := Node (Prim);
2444 exit when Chars (Eq_Op) = Name_Op_Eq
2445 and then Etype (First_Formal (Eq_Op)) =
2446 Etype (Next_Formal (First_Formal (Eq_Op)))
2447 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
2448 Next_Elmt (Prim);
2449 pragma Assert (Present (Prim));
2450 end loop;
2451
2452 Eq_Op := Node (Prim);
2453
2454 return
2455 Make_Function_Call (Loc,
2456 Name => New_Occurrence_Of (Eq_Op, Loc),
2457 Parameter_Associations =>
2458 New_List
2459 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2460 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2461
2462 -- Case of untagged record types
2463
2464 elsif Is_Record_Type (Full_Type) then
2465 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2466
2467 if Present (Eq_Op) then
2468 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2469
2470 -- Inherited equality from parent type. Convert the actuals to
2471 -- match signature of operation.
2472
2473 declare
2474 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2475
2476 begin
2477 return
2478 Make_Function_Call (Loc,
2479 Name => New_Occurrence_Of (Eq_Op, Loc),
2480 Parameter_Associations => New_List (
2481 OK_Convert_To (T, Lhs),
2482 OK_Convert_To (T, Rhs)));
2483 end;
2484
2485 else
2486 -- Comparison between Unchecked_Union components
2487
2488 if Is_Unchecked_Union (Full_Type) then
2489 declare
2490 Lhs_Type : Node_Id := Full_Type;
2491 Rhs_Type : Node_Id := Full_Type;
2492 Lhs_Discr_Val : Node_Id;
2493 Rhs_Discr_Val : Node_Id;
2494
2495 begin
2496 -- Lhs subtype
2497
2498 if Nkind (Lhs) = N_Selected_Component then
2499 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2500 end if;
2501
2502 -- Rhs subtype
2503
2504 if Nkind (Rhs) = N_Selected_Component then
2505 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2506 end if;
2507
2508 -- Lhs of the composite equality
2509
2510 if Is_Constrained (Lhs_Type) then
2511
2512 -- Since the enclosing record type can never be an
2513 -- Unchecked_Union (this code is executed for records
2514 -- that do not have variants), we may reference its
2515 -- discriminant(s).
2516
2517 if Nkind (Lhs) = N_Selected_Component
2518 and then Has_Per_Object_Constraint
2519 (Entity (Selector_Name (Lhs)))
2520 then
2521 Lhs_Discr_Val :=
2522 Make_Selected_Component (Loc,
2523 Prefix => Prefix (Lhs),
2524 Selector_Name =>
2525 New_Copy
2526 (Get_Discriminant_Value
2527 (First_Discriminant (Lhs_Type),
2528 Lhs_Type,
2529 Stored_Constraint (Lhs_Type))));
2530
2531 else
2532 Lhs_Discr_Val :=
2533 New_Copy
2534 (Get_Discriminant_Value
2535 (First_Discriminant (Lhs_Type),
2536 Lhs_Type,
2537 Stored_Constraint (Lhs_Type)));
2538
2539 end if;
2540 else
2541 -- It is not possible to infer the discriminant since
2542 -- the subtype is not constrained.
2543
2544 return
2545 Make_Raise_Program_Error (Loc,
2546 Reason => PE_Unchecked_Union_Restriction);
2547 end if;
2548
2549 -- Rhs of the composite equality
2550
2551 if Is_Constrained (Rhs_Type) then
2552 if Nkind (Rhs) = N_Selected_Component
2553 and then Has_Per_Object_Constraint
2554 (Entity (Selector_Name (Rhs)))
2555 then
2556 Rhs_Discr_Val :=
2557 Make_Selected_Component (Loc,
2558 Prefix => Prefix (Rhs),
2559 Selector_Name =>
2560 New_Copy
2561 (Get_Discriminant_Value
2562 (First_Discriminant (Rhs_Type),
2563 Rhs_Type,
2564 Stored_Constraint (Rhs_Type))));
2565
2566 else
2567 Rhs_Discr_Val :=
2568 New_Copy
2569 (Get_Discriminant_Value
2570 (First_Discriminant (Rhs_Type),
2571 Rhs_Type,
2572 Stored_Constraint (Rhs_Type)));
2573
2574 end if;
2575 else
2576 return
2577 Make_Raise_Program_Error (Loc,
2578 Reason => PE_Unchecked_Union_Restriction);
2579 end if;
2580
2581 -- Call the TSS equality function with the inferred
2582 -- discriminant values.
2583
2584 return
2585 Make_Function_Call (Loc,
2586 Name => New_Occurrence_Of (Eq_Op, Loc),
2587 Parameter_Associations => New_List (
2588 Lhs,
2589 Rhs,
2590 Lhs_Discr_Val,
2591 Rhs_Discr_Val));
2592 end;
2593
2594 -- All cases other than comparing Unchecked_Union types
2595
2596 else
2597 declare
2598 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2599 begin
2600 return
2601 Make_Function_Call (Loc,
2602 Name =>
2603 New_Occurrence_Of (Eq_Op, Loc),
2604 Parameter_Associations => New_List (
2605 OK_Convert_To (T, Lhs),
2606 OK_Convert_To (T, Rhs)));
2607 end;
2608 end if;
2609 end if;
2610
2611 -- Equality composes in Ada 2012 for untagged record types. It also
2612 -- composes for bounded strings, because they are part of the
2613 -- predefined environment. We could make it compose for bounded
2614 -- strings by making them tagged, or by making sure all subcomponents
2615 -- are set to the same value, even when not used. Instead, we have
2616 -- this special case in the compiler, because it's more efficient.
2617
2618 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2619
2620 -- If no TSS has been created for the type, check whether there is
2621 -- a primitive equality declared for it.
2622
2623 declare
2624 Op : constant Node_Id := Find_Primitive_Eq;
2625
2626 begin
2627 -- Use user-defined primitive if it exists, otherwise use
2628 -- predefined equality.
2629
2630 if Present (Op) then
2631 return Op;
2632 else
2633 return Make_Op_Eq (Loc, Lhs, Rhs);
2634 end if;
2635 end;
2636
2637 else
2638 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2639 end if;
2640
2641 -- Non-composite types (always use predefined equality)
2642
2643 else
2644 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2645 end if;
2646 end Expand_Composite_Equality;
2647
2648 ------------------------
2649 -- Expand_Concatenate --
2650 ------------------------
2651
2652 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2653 Loc : constant Source_Ptr := Sloc (Cnode);
2654
2655 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2656 -- Result type of concatenation
2657
2658 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2659 -- Component type. Elements of this component type can appear as one
2660 -- of the operands of concatenation as well as arrays.
2661
2662 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2663 -- Index subtype
2664
2665 Ityp : constant Entity_Id := Base_Type (Istyp);
2666 -- Index type. This is the base type of the index subtype, and is used
2667 -- for all computed bounds (which may be out of range of Istyp in the
2668 -- case of null ranges).
2669
2670 Artyp : Entity_Id;
2671 -- This is the type we use to do arithmetic to compute the bounds and
2672 -- lengths of operands. The choice of this type is a little subtle and
2673 -- is discussed in a separate section at the start of the body code.
2674
2675 Concatenation_Error : exception;
2676 -- Raised if concatenation is sure to raise a CE
2677
2678 Result_May_Be_Null : Boolean := True;
2679 -- Reset to False if at least one operand is encountered which is known
2680 -- at compile time to be non-null. Used for handling the special case
2681 -- of setting the high bound to the last operand high bound for a null
2682 -- result, thus ensuring a proper high bound in the super-flat case.
2683
2684 N : constant Nat := List_Length (Opnds);
2685 -- Number of concatenation operands including possibly null operands
2686
2687 NN : Nat := 0;
2688 -- Number of operands excluding any known to be null, except that the
2689 -- last operand is always retained, in case it provides the bounds for
2690 -- a null result.
2691
2692 Opnd : Node_Id;
2693 -- Current operand being processed in the loop through operands. After
2694 -- this loop is complete, always contains the last operand (which is not
2695 -- the same as Operands (NN), since null operands are skipped).
2696
2697 -- Arrays describing the operands, only the first NN entries of each
2698 -- array are set (NN < N when we exclude known null operands).
2699
2700 Is_Fixed_Length : array (1 .. N) of Boolean;
2701 -- True if length of corresponding operand known at compile time
2702
2703 Operands : array (1 .. N) of Node_Id;
2704 -- Set to the corresponding entry in the Opnds list (but note that null
2705 -- operands are excluded, so not all entries in the list are stored).
2706
2707 Fixed_Length : array (1 .. N) of Uint;
2708 -- Set to length of operand. Entries in this array are set only if the
2709 -- corresponding entry in Is_Fixed_Length is True.
2710
2711 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2712 -- Set to lower bound of operand. Either an integer literal in the case
2713 -- where the bound is known at compile time, else actual lower bound.
2714 -- The operand low bound is of type Ityp.
2715
2716 Var_Length : array (1 .. N) of Entity_Id;
2717 -- Set to an entity of type Natural that contains the length of an
2718 -- operand whose length is not known at compile time. Entries in this
2719 -- array are set only if the corresponding entry in Is_Fixed_Length
2720 -- is False. The entity is of type Artyp.
2721
2722 Aggr_Length : array (0 .. N) of Node_Id;
2723 -- The J'th entry in an expression node that represents the total length
2724 -- of operands 1 through J. It is either an integer literal node, or a
2725 -- reference to a constant entity with the right value, so it is fine
2726 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2727 -- entry always is set to zero. The length is of type Artyp.
2728
2729 Low_Bound : Node_Id;
2730 -- A tree node representing the low bound of the result (of type Ityp).
2731 -- This is either an integer literal node, or an identifier reference to
2732 -- a constant entity initialized to the appropriate value.
2733
2734 Last_Opnd_Low_Bound : Node_Id;
2735 -- A tree node representing the low bound of the last operand. This
2736 -- need only be set if the result could be null. It is used for the
2737 -- special case of setting the right low bound for a null result.
2738 -- This is of type Ityp.
2739
2740 Last_Opnd_High_Bound : Node_Id;
2741 -- A tree node representing the high bound of the last operand. This
2742 -- need only be set if the result could be null. It is used for the
2743 -- special case of setting the right high bound for a null result.
2744 -- This is of type Ityp.
2745
2746 High_Bound : Node_Id;
2747 -- A tree node representing the high bound of the result (of type Ityp)
2748
2749 Result : Node_Id;
2750 -- Result of the concatenation (of type Ityp)
2751
2752 Actions : constant List_Id := New_List;
2753 -- Collect actions to be inserted
2754
2755 Known_Non_Null_Operand_Seen : Boolean;
2756 -- Set True during generation of the assignments of operands into
2757 -- result once an operand known to be non-null has been seen.
2758
2759 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2760 -- This function makes an N_Integer_Literal node that is returned in
2761 -- analyzed form with the type set to Artyp. Importantly this literal
2762 -- is not flagged as static, so that if we do computations with it that
2763 -- result in statically detected out of range conditions, we will not
2764 -- generate error messages but instead warning messages.
2765
2766 function To_Artyp (X : Node_Id) return Node_Id;
2767 -- Given a node of type Ityp, returns the corresponding value of type
2768 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2769 -- For enum types, the Pos of the value is returned.
2770
2771 function To_Ityp (X : Node_Id) return Node_Id;
2772 -- The inverse function (uses Val in the case of enumeration types)
2773
2774 ------------------------
2775 -- Make_Artyp_Literal --
2776 ------------------------
2777
2778 function Make_Artyp_Literal (Val : Nat) return Node_Id is
2779 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2780 begin
2781 Set_Etype (Result, Artyp);
2782 Set_Analyzed (Result, True);
2783 Set_Is_Static_Expression (Result, False);
2784 return Result;
2785 end Make_Artyp_Literal;
2786
2787 --------------
2788 -- To_Artyp --
2789 --------------
2790
2791 function To_Artyp (X : Node_Id) return Node_Id is
2792 begin
2793 if Ityp = Base_Type (Artyp) then
2794 return X;
2795
2796 elsif Is_Enumeration_Type (Ityp) then
2797 return
2798 Make_Attribute_Reference (Loc,
2799 Prefix => New_Occurrence_Of (Ityp, Loc),
2800 Attribute_Name => Name_Pos,
2801 Expressions => New_List (X));
2802
2803 else
2804 return Convert_To (Artyp, X);
2805 end if;
2806 end To_Artyp;
2807
2808 -------------
2809 -- To_Ityp --
2810 -------------
2811
2812 function To_Ityp (X : Node_Id) return Node_Id is
2813 begin
2814 if Is_Enumeration_Type (Ityp) then
2815 return
2816 Make_Attribute_Reference (Loc,
2817 Prefix => New_Occurrence_Of (Ityp, Loc),
2818 Attribute_Name => Name_Val,
2819 Expressions => New_List (X));
2820
2821 -- Case where we will do a type conversion
2822
2823 else
2824 if Ityp = Base_Type (Artyp) then
2825 return X;
2826 else
2827 return Convert_To (Ityp, X);
2828 end if;
2829 end if;
2830 end To_Ityp;
2831
2832 -- Local Declarations
2833
2834 Lib_Level_Target : constant Boolean :=
2835 Nkind (Parent (Cnode)) = N_Object_Declaration
2836 and then
2837 Is_Library_Level_Entity (Defining_Identifier (Parent (Cnode)));
2838
2839 -- If the concatenation declares a library level entity, we call the
2840 -- built-in concatenation routines to prevent code bloat, regardless
2841 -- of optimization level. This is space-efficient, and prevent linking
2842 -- problems when units are compiled with different optimizations.
2843
2844 Opnd_Typ : Entity_Id;
2845 Ent : Entity_Id;
2846 Len : Uint;
2847 J : Nat;
2848 Clen : Node_Id;
2849 Set : Boolean;
2850
2851 -- Start of processing for Expand_Concatenate
2852
2853 begin
2854 -- Choose an appropriate computational type
2855
2856 -- We will be doing calculations of lengths and bounds in this routine
2857 -- and computing one from the other in some cases, e.g. getting the high
2858 -- bound by adding the length-1 to the low bound.
2859
2860 -- We can't just use the index type, or even its base type for this
2861 -- purpose for two reasons. First it might be an enumeration type which
2862 -- is not suitable for computations of any kind, and second it may
2863 -- simply not have enough range. For example if the index type is
2864 -- -128..+127 then lengths can be up to 256, which is out of range of
2865 -- the type.
2866
2867 -- For enumeration types, we can simply use Standard_Integer, this is
2868 -- sufficient since the actual number of enumeration literals cannot
2869 -- possibly exceed the range of integer (remember we will be doing the
2870 -- arithmetic with POS values, not representation values).
2871
2872 if Is_Enumeration_Type (Ityp) then
2873 Artyp := Standard_Integer;
2874
2875 -- If index type is Positive, we use the standard unsigned type, to give
2876 -- more room on the top of the range, obviating the need for an overflow
2877 -- check when creating the upper bound. This is needed to avoid junk
2878 -- overflow checks in the common case of String types.
2879
2880 -- ??? Disabled for now
2881
2882 -- elsif Istyp = Standard_Positive then
2883 -- Artyp := Standard_Unsigned;
2884
2885 -- For modular types, we use a 32-bit modular type for types whose size
2886 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2887 -- identity type, and for larger unsigned types we use 64-bits.
2888
2889 elsif Is_Modular_Integer_Type (Ityp) then
2890 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
2891 Artyp := Standard_Unsigned;
2892 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
2893 Artyp := Ityp;
2894 else
2895 Artyp := RTE (RE_Long_Long_Unsigned);
2896 end if;
2897
2898 -- Similar treatment for signed types
2899
2900 else
2901 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
2902 Artyp := Standard_Integer;
2903 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
2904 Artyp := Ityp;
2905 else
2906 Artyp := Standard_Long_Long_Integer;
2907 end if;
2908 end if;
2909
2910 -- Supply dummy entry at start of length array
2911
2912 Aggr_Length (0) := Make_Artyp_Literal (0);
2913
2914 -- Go through operands setting up the above arrays
2915
2916 J := 1;
2917 while J <= N loop
2918 Opnd := Remove_Head (Opnds);
2919 Opnd_Typ := Etype (Opnd);
2920
2921 -- The parent got messed up when we put the operands in a list,
2922 -- so now put back the proper parent for the saved operand, that
2923 -- is to say the concatenation node, to make sure that each operand
2924 -- is seen as a subexpression, e.g. if actions must be inserted.
2925
2926 Set_Parent (Opnd, Cnode);
2927
2928 -- Set will be True when we have setup one entry in the array
2929
2930 Set := False;
2931
2932 -- Singleton element (or character literal) case
2933
2934 if Base_Type (Opnd_Typ) = Ctyp then
2935 NN := NN + 1;
2936 Operands (NN) := Opnd;
2937 Is_Fixed_Length (NN) := True;
2938 Fixed_Length (NN) := Uint_1;
2939 Result_May_Be_Null := False;
2940
2941 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2942 -- since we know that the result cannot be null).
2943
2944 Opnd_Low_Bound (NN) :=
2945 Make_Attribute_Reference (Loc,
2946 Prefix => New_Occurrence_Of (Istyp, Loc),
2947 Attribute_Name => Name_First);
2948
2949 Set := True;
2950
2951 -- String literal case (can only occur for strings of course)
2952
2953 elsif Nkind (Opnd) = N_String_Literal then
2954 Len := String_Literal_Length (Opnd_Typ);
2955
2956 if Len /= 0 then
2957 Result_May_Be_Null := False;
2958 end if;
2959
2960 -- Capture last operand low and high bound if result could be null
2961
2962 if J = N and then Result_May_Be_Null then
2963 Last_Opnd_Low_Bound :=
2964 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
2965
2966 Last_Opnd_High_Bound :=
2967 Make_Op_Subtract (Loc,
2968 Left_Opnd =>
2969 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
2970 Right_Opnd => Make_Integer_Literal (Loc, 1));
2971 end if;
2972
2973 -- Skip null string literal
2974
2975 if J < N and then Len = 0 then
2976 goto Continue;
2977 end if;
2978
2979 NN := NN + 1;
2980 Operands (NN) := Opnd;
2981 Is_Fixed_Length (NN) := True;
2982
2983 -- Set length and bounds
2984
2985 Fixed_Length (NN) := Len;
2986
2987 Opnd_Low_Bound (NN) :=
2988 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
2989
2990 Set := True;
2991
2992 -- All other cases
2993
2994 else
2995 -- Check constrained case with known bounds
2996
2997 if Is_Constrained (Opnd_Typ) then
2998 declare
2999 Index : constant Node_Id := First_Index (Opnd_Typ);
3000 Indx_Typ : constant Entity_Id := Etype (Index);
3001 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3002 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3003
3004 begin
3005 -- Fixed length constrained array type with known at compile
3006 -- time bounds is last case of fixed length operand.
3007
3008 if Compile_Time_Known_Value (Lo)
3009 and then
3010 Compile_Time_Known_Value (Hi)
3011 then
3012 declare
3013 Loval : constant Uint := Expr_Value (Lo);
3014 Hival : constant Uint := Expr_Value (Hi);
3015 Len : constant Uint :=
3016 UI_Max (Hival - Loval + 1, Uint_0);
3017
3018 begin
3019 if Len > 0 then
3020 Result_May_Be_Null := False;
3021 end if;
3022
3023 -- Capture last operand bounds if result could be null
3024
3025 if J = N and then Result_May_Be_Null then
3026 Last_Opnd_Low_Bound :=
3027 Convert_To (Ityp,
3028 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3029
3030 Last_Opnd_High_Bound :=
3031 Convert_To (Ityp,
3032 Make_Integer_Literal (Loc, Expr_Value (Hi)));
3033 end if;
3034
3035 -- Exclude null length case unless last operand
3036
3037 if J < N and then Len = 0 then
3038 goto Continue;
3039 end if;
3040
3041 NN := NN + 1;
3042 Operands (NN) := Opnd;
3043 Is_Fixed_Length (NN) := True;
3044 Fixed_Length (NN) := Len;
3045
3046 Opnd_Low_Bound (NN) :=
3047 To_Ityp
3048 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3049 Set := True;
3050 end;
3051 end if;
3052 end;
3053 end if;
3054
3055 -- All cases where the length is not known at compile time, or the
3056 -- special case of an operand which is known to be null but has a
3057 -- lower bound other than 1 or is other than a string type.
3058
3059 if not Set then
3060 NN := NN + 1;
3061
3062 -- Capture operand bounds
3063
3064 Opnd_Low_Bound (NN) :=
3065 Make_Attribute_Reference (Loc,
3066 Prefix =>
3067 Duplicate_Subexpr (Opnd, Name_Req => True),
3068 Attribute_Name => Name_First);
3069
3070 -- Capture last operand bounds if result could be null
3071
3072 if J = N and Result_May_Be_Null then
3073 Last_Opnd_Low_Bound :=
3074 Convert_To (Ityp,
3075 Make_Attribute_Reference (Loc,
3076 Prefix =>
3077 Duplicate_Subexpr (Opnd, Name_Req => True),
3078 Attribute_Name => Name_First));
3079
3080 Last_Opnd_High_Bound :=
3081 Convert_To (Ityp,
3082 Make_Attribute_Reference (Loc,
3083 Prefix =>
3084 Duplicate_Subexpr (Opnd, Name_Req => True),
3085 Attribute_Name => Name_Last));
3086 end if;
3087
3088 -- Capture length of operand in entity
3089
3090 Operands (NN) := Opnd;
3091 Is_Fixed_Length (NN) := False;
3092
3093 Var_Length (NN) := Make_Temporary (Loc, 'L');
3094
3095 Append_To (Actions,
3096 Make_Object_Declaration (Loc,
3097 Defining_Identifier => Var_Length (NN),
3098 Constant_Present => True,
3099 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3100 Expression =>
3101 Make_Attribute_Reference (Loc,
3102 Prefix =>
3103 Duplicate_Subexpr (Opnd, Name_Req => True),
3104 Attribute_Name => Name_Length)));
3105 end if;
3106 end if;
3107
3108 -- Set next entry in aggregate length array
3109
3110 -- For first entry, make either integer literal for fixed length
3111 -- or a reference to the saved length for variable length.
3112
3113 if NN = 1 then
3114 if Is_Fixed_Length (1) then
3115 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3116 else
3117 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3118 end if;
3119
3120 -- If entry is fixed length and only fixed lengths so far, make
3121 -- appropriate new integer literal adding new length.
3122
3123 elsif Is_Fixed_Length (NN)
3124 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3125 then
3126 Aggr_Length (NN) :=
3127 Make_Integer_Literal (Loc,
3128 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3129
3130 -- All other cases, construct an addition node for the length and
3131 -- create an entity initialized to this length.
3132
3133 else
3134 Ent := Make_Temporary (Loc, 'L');
3135
3136 if Is_Fixed_Length (NN) then
3137 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3138 else
3139 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3140 end if;
3141
3142 Append_To (Actions,
3143 Make_Object_Declaration (Loc,
3144 Defining_Identifier => Ent,
3145 Constant_Present => True,
3146 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3147 Expression =>
3148 Make_Op_Add (Loc,
3149 Left_Opnd => New_Copy (Aggr_Length (NN - 1)),
3150 Right_Opnd => Clen)));
3151
3152 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3153 end if;
3154
3155 <<Continue>>
3156 J := J + 1;
3157 end loop;
3158
3159 -- If we have only skipped null operands, return the last operand
3160
3161 if NN = 0 then
3162 Result := Opnd;
3163 goto Done;
3164 end if;
3165
3166 -- If we have only one non-null operand, return it and we are done.
3167 -- There is one case in which this cannot be done, and that is when
3168 -- the sole operand is of the element type, in which case it must be
3169 -- converted to an array, and the easiest way of doing that is to go
3170 -- through the normal general circuit.
3171
3172 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3173 Result := Operands (1);
3174 goto Done;
3175 end if;
3176
3177 -- Cases where we have a real concatenation
3178
3179 -- Next step is to find the low bound for the result array that we
3180 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3181
3182 -- If the ultimate ancestor of the index subtype is a constrained array
3183 -- definition, then the lower bound is that of the index subtype as
3184 -- specified by (RM 4.5.3(6)).
3185
3186 -- The right test here is to go to the root type, and then the ultimate
3187 -- ancestor is the first subtype of this root type.
3188
3189 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3190 Low_Bound :=
3191 Make_Attribute_Reference (Loc,
3192 Prefix =>
3193 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3194 Attribute_Name => Name_First);
3195
3196 -- If the first operand in the list has known length we know that
3197 -- the lower bound of the result is the lower bound of this operand.
3198
3199 elsif Is_Fixed_Length (1) then
3200 Low_Bound := Opnd_Low_Bound (1);
3201
3202 -- OK, we don't know the lower bound, we have to build a horrible
3203 -- if expression node of the form
3204
3205 -- if Cond1'Length /= 0 then
3206 -- Opnd1 low bound
3207 -- else
3208 -- if Opnd2'Length /= 0 then
3209 -- Opnd2 low bound
3210 -- else
3211 -- ...
3212
3213 -- The nesting ends either when we hit an operand whose length is known
3214 -- at compile time, or on reaching the last operand, whose low bound we
3215 -- take unconditionally whether or not it is null. It's easiest to do
3216 -- this with a recursive procedure:
3217
3218 else
3219 declare
3220 function Get_Known_Bound (J : Nat) return Node_Id;
3221 -- Returns the lower bound determined by operands J .. NN
3222
3223 ---------------------
3224 -- Get_Known_Bound --
3225 ---------------------
3226
3227 function Get_Known_Bound (J : Nat) return Node_Id is
3228 begin
3229 if Is_Fixed_Length (J) or else J = NN then
3230 return New_Copy (Opnd_Low_Bound (J));
3231
3232 else
3233 return
3234 Make_If_Expression (Loc,
3235 Expressions => New_List (
3236
3237 Make_Op_Ne (Loc,
3238 Left_Opnd =>
3239 New_Occurrence_Of (Var_Length (J), Loc),
3240 Right_Opnd =>
3241 Make_Integer_Literal (Loc, 0)),
3242
3243 New_Copy (Opnd_Low_Bound (J)),
3244 Get_Known_Bound (J + 1)));
3245 end if;
3246 end Get_Known_Bound;
3247
3248 begin
3249 Ent := Make_Temporary (Loc, 'L');
3250
3251 Append_To (Actions,
3252 Make_Object_Declaration (Loc,
3253 Defining_Identifier => Ent,
3254 Constant_Present => True,
3255 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3256 Expression => Get_Known_Bound (1)));
3257
3258 Low_Bound := New_Occurrence_Of (Ent, Loc);
3259 end;
3260 end if;
3261
3262 -- Now we can safely compute the upper bound, normally
3263 -- Low_Bound + Length - 1.
3264
3265 High_Bound :=
3266 To_Ityp
3267 (Make_Op_Add (Loc,
3268 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3269 Right_Opnd =>
3270 Make_Op_Subtract (Loc,
3271 Left_Opnd => New_Copy (Aggr_Length (NN)),
3272 Right_Opnd => Make_Artyp_Literal (1))));
3273
3274 -- Note that calculation of the high bound may cause overflow in some
3275 -- very weird cases, so in the general case we need an overflow check on
3276 -- the high bound. We can avoid this for the common case of string types
3277 -- and other types whose index is Positive, since we chose a wider range
3278 -- for the arithmetic type.
3279
3280 if Istyp /= Standard_Positive then
3281 Activate_Overflow_Check (High_Bound);
3282 end if;
3283
3284 -- Handle the exceptional case where the result is null, in which case
3285 -- case the bounds come from the last operand (so that we get the proper
3286 -- bounds if the last operand is super-flat).
3287
3288 if Result_May_Be_Null then
3289 Low_Bound :=
3290 Make_If_Expression (Loc,
3291 Expressions => New_List (
3292 Make_Op_Eq (Loc,
3293 Left_Opnd => New_Copy (Aggr_Length (NN)),
3294 Right_Opnd => Make_Artyp_Literal (0)),
3295 Last_Opnd_Low_Bound,
3296 Low_Bound));
3297
3298 High_Bound :=
3299 Make_If_Expression (Loc,
3300 Expressions => New_List (
3301 Make_Op_Eq (Loc,
3302 Left_Opnd => New_Copy (Aggr_Length (NN)),
3303 Right_Opnd => Make_Artyp_Literal (0)),
3304 Last_Opnd_High_Bound,
3305 High_Bound));
3306 end if;
3307
3308 -- Here is where we insert the saved up actions
3309
3310 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3311
3312 -- Now we construct an array object with appropriate bounds. We mark
3313 -- the target as internal to prevent useless initialization when
3314 -- Initialize_Scalars is enabled. Also since this is the actual result
3315 -- entity, we make sure we have debug information for the result.
3316
3317 Ent := Make_Temporary (Loc, 'S');
3318 Set_Is_Internal (Ent);
3319 Set_Needs_Debug_Info (Ent);
3320
3321 -- If the bound is statically known to be out of range, we do not want
3322 -- to abort, we want a warning and a runtime constraint error. Note that
3323 -- we have arranged that the result will not be treated as a static
3324 -- constant, so we won't get an illegality during this insertion.
3325
3326 Insert_Action (Cnode,
3327 Make_Object_Declaration (Loc,
3328 Defining_Identifier => Ent,
3329 Object_Definition =>
3330 Make_Subtype_Indication (Loc,
3331 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3332 Constraint =>
3333 Make_Index_Or_Discriminant_Constraint (Loc,
3334 Constraints => New_List (
3335 Make_Range (Loc,
3336 Low_Bound => Low_Bound,
3337 High_Bound => High_Bound))))),
3338 Suppress => All_Checks);
3339
3340 -- If the result of the concatenation appears as the initializing
3341 -- expression of an object declaration, we can just rename the
3342 -- result, rather than copying it.
3343
3344 Set_OK_To_Rename (Ent);
3345
3346 -- Catch the static out of range case now
3347
3348 if Raises_Constraint_Error (High_Bound) then
3349 raise Concatenation_Error;
3350 end if;
3351
3352 -- Now we will generate the assignments to do the actual concatenation
3353
3354 -- There is one case in which we will not do this, namely when all the
3355 -- following conditions are met:
3356
3357 -- The result type is Standard.String
3358
3359 -- There are nine or fewer retained (non-null) operands
3360
3361 -- The optimization level is -O0
3362
3363 -- The corresponding System.Concat_n.Str_Concat_n routine is
3364 -- available in the run time.
3365
3366 -- The debug flag gnatd.c is not set
3367
3368 -- If all these conditions are met then we generate a call to the
3369 -- relevant concatenation routine. The purpose of this is to avoid
3370 -- undesirable code bloat at -O0.
3371
3372 if Atyp = Standard_String
3373 and then NN in 2 .. 9
3374 and then (Lib_Level_Target
3375 or else ((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3376 and then not Debug_Flag_Dot_C))
3377 then
3378 declare
3379 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3380 (RE_Str_Concat_2,
3381 RE_Str_Concat_3,
3382 RE_Str_Concat_4,
3383 RE_Str_Concat_5,
3384 RE_Str_Concat_6,
3385 RE_Str_Concat_7,
3386 RE_Str_Concat_8,
3387 RE_Str_Concat_9);
3388
3389 begin
3390 if RTE_Available (RR (NN)) then
3391 declare
3392 Opnds : constant List_Id :=
3393 New_List (New_Occurrence_Of (Ent, Loc));
3394
3395 begin
3396 for J in 1 .. NN loop
3397 if Is_List_Member (Operands (J)) then
3398 Remove (Operands (J));
3399 end if;
3400
3401 if Base_Type (Etype (Operands (J))) = Ctyp then
3402 Append_To (Opnds,
3403 Make_Aggregate (Loc,
3404 Component_Associations => New_List (
3405 Make_Component_Association (Loc,
3406 Choices => New_List (
3407 Make_Integer_Literal (Loc, 1)),
3408 Expression => Operands (J)))));
3409
3410 else
3411 Append_To (Opnds, Operands (J));
3412 end if;
3413 end loop;
3414
3415 Insert_Action (Cnode,
3416 Make_Procedure_Call_Statement (Loc,
3417 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3418 Parameter_Associations => Opnds));
3419
3420 Result := New_Occurrence_Of (Ent, Loc);
3421 goto Done;
3422 end;
3423 end if;
3424 end;
3425 end if;
3426
3427 -- Not special case so generate the assignments
3428
3429 Known_Non_Null_Operand_Seen := False;
3430
3431 for J in 1 .. NN loop
3432 declare
3433 Lo : constant Node_Id :=
3434 Make_Op_Add (Loc,
3435 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3436 Right_Opnd => Aggr_Length (J - 1));
3437
3438 Hi : constant Node_Id :=
3439 Make_Op_Add (Loc,
3440 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3441 Right_Opnd =>
3442 Make_Op_Subtract (Loc,
3443 Left_Opnd => Aggr_Length (J),
3444 Right_Opnd => Make_Artyp_Literal (1)));
3445
3446 begin
3447 -- Singleton case, simple assignment
3448
3449 if Base_Type (Etype (Operands (J))) = Ctyp then
3450 Known_Non_Null_Operand_Seen := True;
3451 Insert_Action (Cnode,
3452 Make_Assignment_Statement (Loc,
3453 Name =>
3454 Make_Indexed_Component (Loc,
3455 Prefix => New_Occurrence_Of (Ent, Loc),
3456 Expressions => New_List (To_Ityp (Lo))),
3457 Expression => Operands (J)),
3458 Suppress => All_Checks);
3459
3460 -- Array case, slice assignment, skipped when argument is fixed
3461 -- length and known to be null.
3462
3463 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3464 declare
3465 Assign : Node_Id :=
3466 Make_Assignment_Statement (Loc,
3467 Name =>
3468 Make_Slice (Loc,
3469 Prefix =>
3470 New_Occurrence_Of (Ent, Loc),
3471 Discrete_Range =>
3472 Make_Range (Loc,
3473 Low_Bound => To_Ityp (Lo),
3474 High_Bound => To_Ityp (Hi))),
3475 Expression => Operands (J));
3476 begin
3477 if Is_Fixed_Length (J) then
3478 Known_Non_Null_Operand_Seen := True;
3479
3480 elsif not Known_Non_Null_Operand_Seen then
3481
3482 -- Here if operand length is not statically known and no
3483 -- operand known to be non-null has been processed yet.
3484 -- If operand length is 0, we do not need to perform the
3485 -- assignment, and we must avoid the evaluation of the
3486 -- high bound of the slice, since it may underflow if the
3487 -- low bound is Ityp'First.
3488
3489 Assign :=
3490 Make_Implicit_If_Statement (Cnode,
3491 Condition =>
3492 Make_Op_Ne (Loc,
3493 Left_Opnd =>
3494 New_Occurrence_Of (Var_Length (J), Loc),
3495 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3496 Then_Statements => New_List (Assign));
3497 end if;
3498
3499 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3500 end;
3501 end if;
3502 end;
3503 end loop;
3504
3505 -- Finally we build the result, which is a reference to the array object
3506
3507 Result := New_Occurrence_Of (Ent, Loc);
3508
3509 <<Done>>
3510 Rewrite (Cnode, Result);
3511 Analyze_And_Resolve (Cnode, Atyp);
3512
3513 exception
3514 when Concatenation_Error =>
3515
3516 -- Kill warning generated for the declaration of the static out of
3517 -- range high bound, and instead generate a Constraint_Error with
3518 -- an appropriate specific message.
3519
3520 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3521 Apply_Compile_Time_Constraint_Error
3522 (N => Cnode,
3523 Msg => "concatenation result upper bound out of range??",
3524 Reason => CE_Range_Check_Failed);
3525 end Expand_Concatenate;
3526
3527 ---------------------------------------------------
3528 -- Expand_Membership_Minimize_Eliminate_Overflow --
3529 ---------------------------------------------------
3530
3531 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3532 pragma Assert (Nkind (N) = N_In);
3533 -- Despite the name, this routine applies only to N_In, not to
3534 -- N_Not_In. The latter is always rewritten as not (X in Y).
3535
3536 Result_Type : constant Entity_Id := Etype (N);
3537 -- Capture result type, may be a derived boolean type
3538
3539 Loc : constant Source_Ptr := Sloc (N);
3540 Lop : constant Node_Id := Left_Opnd (N);
3541 Rop : constant Node_Id := Right_Opnd (N);
3542
3543 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3544 -- is thus tempting to capture these values, but due to the rewrites
3545 -- that occur as a result of overflow checking, these values change
3546 -- as we go along, and it is safe just to always use Etype explicitly.
3547
3548 Restype : constant Entity_Id := Etype (N);
3549 -- Save result type
3550
3551 Lo, Hi : Uint;
3552 -- Bounds in Minimize calls, not used currently
3553
3554 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3555 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3556
3557 begin
3558 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3559
3560 -- If right operand is a subtype name, and the subtype name has no
3561 -- predicate, then we can just replace the right operand with an
3562 -- explicit range T'First .. T'Last, and use the explicit range code.
3563
3564 if Nkind (Rop) /= N_Range
3565 and then No (Predicate_Function (Etype (Rop)))
3566 then
3567 declare
3568 Rtyp : constant Entity_Id := Etype (Rop);
3569 begin
3570 Rewrite (Rop,
3571 Make_Range (Loc,
3572 Low_Bound =>
3573 Make_Attribute_Reference (Loc,
3574 Attribute_Name => Name_First,
3575 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3576 High_Bound =>
3577 Make_Attribute_Reference (Loc,
3578 Attribute_Name => Name_Last,
3579 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3580 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3581 end;
3582 end if;
3583
3584 -- Here for the explicit range case. Note that the bounds of the range
3585 -- have not been processed for minimized or eliminated checks.
3586
3587 if Nkind (Rop) = N_Range then
3588 Minimize_Eliminate_Overflows
3589 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3590 Minimize_Eliminate_Overflows
3591 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3592
3593 -- We have A in B .. C, treated as A >= B and then A <= C
3594
3595 -- Bignum case
3596
3597 if Is_RTE (Etype (Lop), RE_Bignum)
3598 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3599 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3600 then
3601 declare
3602 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3603 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3604 L : constant Entity_Id :=
3605 Make_Defining_Identifier (Loc, Name_uL);
3606 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3607 Lbound : constant Node_Id :=
3608 Convert_To_Bignum (Low_Bound (Rop));
3609 Hbound : constant Node_Id :=
3610 Convert_To_Bignum (High_Bound (Rop));
3611
3612 -- Now we rewrite the membership test node to look like
3613
3614 -- do
3615 -- Bnn : Result_Type;
3616 -- declare
3617 -- M : Mark_Id := SS_Mark;
3618 -- L : Bignum := Lopnd;
3619 -- begin
3620 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3621 -- SS_Release (M);
3622 -- end;
3623 -- in
3624 -- Bnn
3625 -- end
3626
3627 begin
3628 -- Insert declaration of L into declarations of bignum block
3629
3630 Insert_After
3631 (Last (Declarations (Blk)),
3632 Make_Object_Declaration (Loc,
3633 Defining_Identifier => L,
3634 Object_Definition =>
3635 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3636 Expression => Lopnd));
3637
3638 -- Insert assignment to Bnn into expressions of bignum block
3639
3640 Insert_Before
3641 (First (Statements (Handled_Statement_Sequence (Blk))),
3642 Make_Assignment_Statement (Loc,
3643 Name => New_Occurrence_Of (Bnn, Loc),
3644 Expression =>
3645 Make_And_Then (Loc,
3646 Left_Opnd =>
3647 Make_Function_Call (Loc,
3648 Name =>
3649 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3650 Parameter_Associations => New_List (
3651 New_Occurrence_Of (L, Loc),
3652 Lbound)),
3653
3654 Right_Opnd =>
3655 Make_Function_Call (Loc,
3656 Name =>
3657 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3658 Parameter_Associations => New_List (
3659 New_Occurrence_Of (L, Loc),
3660 Hbound)))));
3661
3662 -- Now rewrite the node
3663
3664 Rewrite (N,
3665 Make_Expression_With_Actions (Loc,
3666 Actions => New_List (
3667 Make_Object_Declaration (Loc,
3668 Defining_Identifier => Bnn,
3669 Object_Definition =>
3670 New_Occurrence_Of (Result_Type, Loc)),
3671 Blk),
3672 Expression => New_Occurrence_Of (Bnn, Loc)));
3673 Analyze_And_Resolve (N, Result_Type);
3674 return;
3675 end;
3676
3677 -- Here if no bignums around
3678
3679 else
3680 -- Case where types are all the same
3681
3682 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3683 and then
3684 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3685 then
3686 null;
3687
3688 -- If types are not all the same, it means that we have rewritten
3689 -- at least one of them to be of type Long_Long_Integer, and we
3690 -- will convert the other operands to Long_Long_Integer.
3691
3692 else
3693 Convert_To_And_Rewrite (LLIB, Lop);
3694 Set_Analyzed (Lop, False);
3695 Analyze_And_Resolve (Lop, LLIB);
3696
3697 -- For the right operand, avoid unnecessary recursion into
3698 -- this routine, we know that overflow is not possible.
3699
3700 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3701 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3702 Set_Analyzed (Rop, False);
3703 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3704 end if;
3705
3706 -- Now the three operands are of the same signed integer type,
3707 -- so we can use the normal expansion routine for membership,
3708 -- setting the flag to prevent recursion into this procedure.
3709
3710 Set_No_Minimize_Eliminate (N);
3711 Expand_N_In (N);
3712 end if;
3713
3714 -- Right operand is a subtype name and the subtype has a predicate. We
3715 -- have to make sure the predicate is checked, and for that we need to
3716 -- use the standard N_In circuitry with appropriate types.
3717
3718 else
3719 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3720
3721 -- If types are "right", just call Expand_N_In preventing recursion
3722
3723 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3724 Set_No_Minimize_Eliminate (N);
3725 Expand_N_In (N);
3726
3727 -- Bignum case
3728
3729 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3730
3731 -- For X in T, we want to rewrite our node as
3732
3733 -- do
3734 -- Bnn : Result_Type;
3735
3736 -- declare
3737 -- M : Mark_Id := SS_Mark;
3738 -- Lnn : Long_Long_Integer'Base
3739 -- Nnn : Bignum;
3740
3741 -- begin
3742 -- Nnn := X;
3743
3744 -- if not Bignum_In_LLI_Range (Nnn) then
3745 -- Bnn := False;
3746 -- else
3747 -- Lnn := From_Bignum (Nnn);
3748 -- Bnn :=
3749 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3750 -- and then T'Base (Lnn) in T;
3751 -- end if;
3752
3753 -- SS_Release (M);
3754 -- end
3755 -- in
3756 -- Bnn
3757 -- end
3758
3759 -- A bit gruesome, but there doesn't seem to be a simpler way
3760
3761 declare
3762 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3763 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3764 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3765 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3766 T : constant Entity_Id := Etype (Rop);
3767 TB : constant Entity_Id := Base_Type (T);
3768 Nin : Node_Id;
3769
3770 begin
3771 -- Mark the last membership operation to prevent recursion
3772
3773 Nin :=
3774 Make_In (Loc,
3775 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3776 Right_Opnd => New_Occurrence_Of (T, Loc));
3777 Set_No_Minimize_Eliminate (Nin);
3778
3779 -- Now decorate the block
3780
3781 Insert_After
3782 (Last (Declarations (Blk)),
3783 Make_Object_Declaration (Loc,
3784 Defining_Identifier => Lnn,
3785 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
3786
3787 Insert_After
3788 (Last (Declarations (Blk)),
3789 Make_Object_Declaration (Loc,
3790 Defining_Identifier => Nnn,
3791 Object_Definition =>
3792 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3793
3794 Insert_List_Before
3795 (First (Statements (Handled_Statement_Sequence (Blk))),
3796 New_List (
3797 Make_Assignment_Statement (Loc,
3798 Name => New_Occurrence_Of (Nnn, Loc),
3799 Expression => Relocate_Node (Lop)),
3800
3801 Make_Implicit_If_Statement (N,
3802 Condition =>
3803 Make_Op_Not (Loc,
3804 Right_Opnd =>
3805 Make_Function_Call (Loc,
3806 Name =>
3807 New_Occurrence_Of
3808 (RTE (RE_Bignum_In_LLI_Range), Loc),
3809 Parameter_Associations => New_List (
3810 New_Occurrence_Of (Nnn, Loc)))),
3811
3812 Then_Statements => New_List (
3813 Make_Assignment_Statement (Loc,
3814 Name => New_Occurrence_Of (Bnn, Loc),
3815 Expression =>
3816 New_Occurrence_Of (Standard_False, Loc))),
3817
3818 Else_Statements => New_List (
3819 Make_Assignment_Statement (Loc,
3820 Name => New_Occurrence_Of (Lnn, Loc),
3821 Expression =>
3822 Make_Function_Call (Loc,
3823 Name =>
3824 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3825 Parameter_Associations => New_List (
3826 New_Occurrence_Of (Nnn, Loc)))),
3827
3828 Make_Assignment_Statement (Loc,
3829 Name => New_Occurrence_Of (Bnn, Loc),
3830 Expression =>
3831 Make_And_Then (Loc,
3832 Left_Opnd =>
3833 Make_In (Loc,
3834 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3835 Right_Opnd =>
3836 Make_Range (Loc,
3837 Low_Bound =>
3838 Convert_To (LLIB,
3839 Make_Attribute_Reference (Loc,
3840 Attribute_Name => Name_First,
3841 Prefix =>
3842 New_Occurrence_Of (TB, Loc))),
3843
3844 High_Bound =>
3845 Convert_To (LLIB,
3846 Make_Attribute_Reference (Loc,
3847 Attribute_Name => Name_Last,
3848 Prefix =>
3849 New_Occurrence_Of (TB, Loc))))),
3850
3851 Right_Opnd => Nin))))));
3852
3853 -- Now we can do the rewrite
3854
3855 Rewrite (N,
3856 Make_Expression_With_Actions (Loc,
3857 Actions => New_List (
3858 Make_Object_Declaration (Loc,
3859 Defining_Identifier => Bnn,
3860 Object_Definition =>
3861 New_Occurrence_Of (Result_Type, Loc)),
3862 Blk),
3863 Expression => New_Occurrence_Of (Bnn, Loc)));
3864 Analyze_And_Resolve (N, Result_Type);
3865 return;
3866 end;
3867
3868 -- Not bignum case, but types don't match (this means we rewrote the
3869 -- left operand to be Long_Long_Integer).
3870
3871 else
3872 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
3873
3874 -- We rewrite the membership test as (where T is the type with
3875 -- the predicate, i.e. the type of the right operand)
3876
3877 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3878 -- and then T'Base (Lop) in T
3879
3880 declare
3881 T : constant Entity_Id := Etype (Rop);
3882 TB : constant Entity_Id := Base_Type (T);
3883 Nin : Node_Id;
3884
3885 begin
3886 -- The last membership test is marked to prevent recursion
3887
3888 Nin :=
3889 Make_In (Loc,
3890 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
3891 Right_Opnd => New_Occurrence_Of (T, Loc));
3892 Set_No_Minimize_Eliminate (Nin);
3893
3894 -- Now do the rewrite
3895
3896 Rewrite (N,
3897 Make_And_Then (Loc,
3898 Left_Opnd =>
3899 Make_In (Loc,
3900 Left_Opnd => Lop,
3901 Right_Opnd =>
3902 Make_Range (Loc,
3903 Low_Bound =>
3904 Convert_To (LLIB,
3905 Make_Attribute_Reference (Loc,
3906 Attribute_Name => Name_First,
3907 Prefix =>
3908 New_Occurrence_Of (TB, Loc))),
3909 High_Bound =>
3910 Convert_To (LLIB,
3911 Make_Attribute_Reference (Loc,
3912 Attribute_Name => Name_Last,
3913 Prefix =>
3914 New_Occurrence_Of (TB, Loc))))),
3915 Right_Opnd => Nin));
3916 Set_Analyzed (N, False);
3917 Analyze_And_Resolve (N, Restype);
3918 end;
3919 end if;
3920 end if;
3921 end Expand_Membership_Minimize_Eliminate_Overflow;
3922
3923 ------------------------
3924 -- Expand_N_Allocator --
3925 ------------------------
3926
3927 procedure Expand_N_Allocator (N : Node_Id) is
3928 Etyp : constant Entity_Id := Etype (Expression (N));
3929 Loc : constant Source_Ptr := Sloc (N);
3930 PtrT : constant Entity_Id := Etype (N);
3931
3932 procedure Rewrite_Coextension (N : Node_Id);
3933 -- Static coextensions have the same lifetime as the entity they
3934 -- constrain. Such occurrences can be rewritten as aliased objects
3935 -- and their unrestricted access used instead of the coextension.
3936
3937 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
3938 -- Given a constrained array type E, returns a node representing the
3939 -- code to compute the size in storage elements for the given type.
3940 -- This is done without using the attribute (which malfunctions for
3941 -- large sizes ???)
3942
3943 -------------------------
3944 -- Rewrite_Coextension --
3945 -------------------------
3946
3947 procedure Rewrite_Coextension (N : Node_Id) is
3948 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
3949 Temp_Decl : Node_Id;
3950
3951 begin
3952 -- Generate:
3953 -- Cnn : aliased Etyp;
3954
3955 Temp_Decl :=
3956 Make_Object_Declaration (Loc,
3957 Defining_Identifier => Temp_Id,
3958 Aliased_Present => True,
3959 Object_Definition => New_Occurrence_Of (Etyp, Loc));
3960
3961 if Nkind (Expression (N)) = N_Qualified_Expression then
3962 Set_Expression (Temp_Decl, Expression (Expression (N)));
3963 end if;
3964
3965 Insert_Action (N, Temp_Decl);
3966 Rewrite (N,
3967 Make_Attribute_Reference (Loc,
3968 Prefix => New_Occurrence_Of (Temp_Id, Loc),
3969 Attribute_Name => Name_Unrestricted_Access));
3970
3971 Analyze_And_Resolve (N, PtrT);
3972 end Rewrite_Coextension;
3973
3974 ------------------------------
3975 -- Size_In_Storage_Elements --
3976 ------------------------------
3977
3978 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
3979 begin
3980 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3981 -- However, the reason for the existence of this function is
3982 -- to construct a test for sizes too large, which means near the
3983 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3984 -- is that we get overflows when sizes are greater than 2**31.
3985
3986 -- So what we end up doing for array types is to use the expression:
3987
3988 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3989
3990 -- which avoids this problem. All this is a bit bogus, but it does
3991 -- mean we catch common cases of trying to allocate arrays that
3992 -- are too large, and which in the absence of a check results in
3993 -- undetected chaos ???
3994
3995 -- Note in particular that this is a pessimistic estimate in the
3996 -- case of packed array types, where an array element might occupy
3997 -- just a fraction of a storage element???
3998
3999 declare
4000 Len : Node_Id;
4001 Res : Node_Id;
4002
4003 begin
4004 for J in 1 .. Number_Dimensions (E) loop
4005 Len :=
4006 Make_Attribute_Reference (Loc,
4007 Prefix => New_Occurrence_Of (E, Loc),
4008 Attribute_Name => Name_Length,
4009 Expressions => New_List (Make_Integer_Literal (Loc, J)));
4010
4011 if J = 1 then
4012 Res := Len;
4013
4014 else
4015 Res :=
4016 Make_Op_Multiply (Loc,
4017 Left_Opnd => Res,
4018 Right_Opnd => Len);
4019 end if;
4020 end loop;
4021
4022 return
4023 Make_Op_Multiply (Loc,
4024 Left_Opnd => Len,
4025 Right_Opnd =>
4026 Make_Attribute_Reference (Loc,
4027 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4028 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4029 end;
4030 end Size_In_Storage_Elements;
4031
4032 -- Local variables
4033
4034 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4035 Desig : Entity_Id;
4036 Nod : Node_Id;
4037 Pool : Entity_Id;
4038 Rel_Typ : Entity_Id;
4039 Temp : Entity_Id;
4040
4041 -- Start of processing for Expand_N_Allocator
4042
4043 begin
4044 -- RM E.2.3(22). We enforce that the expected type of an allocator
4045 -- shall not be a remote access-to-class-wide-limited-private type
4046
4047 -- Why is this being done at expansion time, seems clearly wrong ???
4048
4049 Validate_Remote_Access_To_Class_Wide_Type (N);
4050
4051 -- Processing for anonymous access-to-controlled types. These access
4052 -- types receive a special finalization master which appears in the
4053 -- declarations of the enclosing semantic unit. This expansion is done
4054 -- now to ensure that any additional types generated by this routine or
4055 -- Expand_Allocator_Expression inherit the proper type attributes.
4056
4057 if (Ekind (PtrT) = E_Anonymous_Access_Type
4058 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4059 and then Needs_Finalization (Dtyp)
4060 then
4061 -- Detect the allocation of an anonymous controlled object where the
4062 -- type of the context is named. For example:
4063
4064 -- procedure Proc (Ptr : Named_Access_Typ);
4065 -- Proc (new Designated_Typ);
4066
4067 -- Regardless of the anonymous-to-named access type conversion, the
4068 -- lifetime of the object must be associated with the named access
4069 -- type. Use the finalization-related attributes of this type.
4070
4071 if Nkind_In (Parent (N), N_Type_Conversion,
4072 N_Unchecked_Type_Conversion)
4073 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4074 E_Access_Type,
4075 E_General_Access_Type)
4076 then
4077 Rel_Typ := Etype (Parent (N));
4078 else
4079 Rel_Typ := Empty;
4080 end if;
4081
4082 -- Anonymous access-to-controlled types allocate on the global pool.
4083 -- Note that this is a "root type only" attribute.
4084
4085 if No (Associated_Storage_Pool (PtrT)) then
4086 if Present (Rel_Typ) then
4087 Set_Associated_Storage_Pool
4088 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4089 else
4090 Set_Associated_Storage_Pool
4091 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4092 end if;
4093 end if;
4094
4095 -- The finalization master must be inserted and analyzed as part of
4096 -- the current semantic unit. Note that the master is updated when
4097 -- analysis changes current units. Note that this is a "root type
4098 -- only" attribute.
4099
4100 if Present (Rel_Typ) then
4101 Set_Finalization_Master
4102 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4103 else
4104 Build_Anonymous_Master (Root_Type (PtrT));
4105 end if;
4106 end if;
4107
4108 -- Set the storage pool and find the appropriate version of Allocate to
4109 -- call. Do not overwrite the storage pool if it is already set, which
4110 -- can happen for build-in-place function returns (see
4111 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4112
4113 if No (Storage_Pool (N)) then
4114 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4115
4116 if Present (Pool) then
4117 Set_Storage_Pool (N, Pool);
4118
4119 if Is_RTE (Pool, RE_SS_Pool) then
4120 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4121
4122 -- In the case of an allocator for a simple storage pool, locate
4123 -- and save a reference to the pool type's Allocate routine.
4124
4125 elsif Present (Get_Rep_Pragma
4126 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4127 then
4128 declare
4129 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4130 Alloc_Op : Entity_Id;
4131 begin
4132 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4133 while Present (Alloc_Op) loop
4134 if Scope (Alloc_Op) = Scope (Pool_Type)
4135 and then Present (First_Formal (Alloc_Op))
4136 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4137 then
4138 Set_Procedure_To_Call (N, Alloc_Op);
4139 exit;
4140 else
4141 Alloc_Op := Homonym (Alloc_Op);
4142 end if;
4143 end loop;
4144 end;
4145
4146 elsif Is_Class_Wide_Type (Etype (Pool)) then
4147 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4148
4149 else
4150 Set_Procedure_To_Call (N,
4151 Find_Prim_Op (Etype (Pool), Name_Allocate));
4152 end if;
4153 end if;
4154 end if;
4155
4156 -- Under certain circumstances we can replace an allocator by an access
4157 -- to statically allocated storage. The conditions, as noted in AARM
4158 -- 3.10 (10c) are as follows:
4159
4160 -- Size and initial value is known at compile time
4161 -- Access type is access-to-constant
4162
4163 -- The allocator is not part of a constraint on a record component,
4164 -- because in that case the inserted actions are delayed until the
4165 -- record declaration is fully analyzed, which is too late for the
4166 -- analysis of the rewritten allocator.
4167
4168 if Is_Access_Constant (PtrT)
4169 and then Nkind (Expression (N)) = N_Qualified_Expression
4170 and then Compile_Time_Known_Value (Expression (Expression (N)))
4171 and then Size_Known_At_Compile_Time
4172 (Etype (Expression (Expression (N))))
4173 and then not Is_Record_Type (Current_Scope)
4174 then
4175 -- Here we can do the optimization. For the allocator
4176
4177 -- new x'(y)
4178
4179 -- We insert an object declaration
4180
4181 -- Tnn : aliased x := y;
4182
4183 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4184 -- marked as requiring static allocation.
4185
4186 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4187 Desig := Subtype_Mark (Expression (N));
4188
4189 -- If context is constrained, use constrained subtype directly,
4190 -- so that the constant is not labelled as having a nominally
4191 -- unconstrained subtype.
4192
4193 if Entity (Desig) = Base_Type (Dtyp) then
4194 Desig := New_Occurrence_Of (Dtyp, Loc);
4195 end if;
4196
4197 Insert_Action (N,
4198 Make_Object_Declaration (Loc,
4199 Defining_Identifier => Temp,
4200 Aliased_Present => True,
4201 Constant_Present => Is_Access_Constant (PtrT),
4202 Object_Definition => Desig,
4203 Expression => Expression (Expression (N))));
4204
4205 Rewrite (N,
4206 Make_Attribute_Reference (Loc,
4207 Prefix => New_Occurrence_Of (Temp, Loc),
4208 Attribute_Name => Name_Unrestricted_Access));
4209
4210 Analyze_And_Resolve (N, PtrT);
4211
4212 -- We set the variable as statically allocated, since we don't want
4213 -- it going on the stack of the current procedure.
4214
4215 Set_Is_Statically_Allocated (Temp);
4216 return;
4217 end if;
4218
4219 -- Same if the allocator is an access discriminant for a local object:
4220 -- instead of an allocator we create a local value and constrain the
4221 -- enclosing object with the corresponding access attribute.
4222
4223 if Is_Static_Coextension (N) then
4224 Rewrite_Coextension (N);
4225 return;
4226 end if;
4227
4228 -- Check for size too large, we do this because the back end misses
4229 -- proper checks here and can generate rubbish allocation calls when
4230 -- we are near the limit. We only do this for the 32-bit address case
4231 -- since that is from a practical point of view where we see a problem.
4232
4233 if System_Address_Size = 32
4234 and then not Storage_Checks_Suppressed (PtrT)
4235 and then not Storage_Checks_Suppressed (Dtyp)
4236 and then not Storage_Checks_Suppressed (Etyp)
4237 then
4238 -- The check we want to generate should look like
4239
4240 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4241 -- raise Storage_Error;
4242 -- end if;
4243
4244 -- where 3.5 gigabytes is a constant large enough to accommodate any
4245 -- reasonable request for. But we can't do it this way because at
4246 -- least at the moment we don't compute this attribute right, and
4247 -- can silently give wrong results when the result gets large. Since
4248 -- this is all about large results, that's bad, so instead we only
4249 -- apply the check for constrained arrays, and manually compute the
4250 -- value of the attribute ???
4251
4252 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
4253 Insert_Action (N,
4254 Make_Raise_Storage_Error (Loc,
4255 Condition =>
4256 Make_Op_Gt (Loc,
4257 Left_Opnd => Size_In_Storage_Elements (Etyp),
4258 Right_Opnd =>
4259 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
4260 Reason => SE_Object_Too_Large));
4261 end if;
4262 end if;
4263
4264 -- If no storage pool has been specified and we have the restriction
4265 -- No_Standard_Allocators_After_Elaboration is present, then generate
4266 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4267
4268 if Nkind (N) = N_Allocator
4269 and then No (Storage_Pool (N))
4270 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4271 then
4272 Insert_Action (N,
4273 Make_Procedure_Call_Statement (Loc,
4274 Name =>
4275 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4276 end if;
4277
4278 -- Handle case of qualified expression (other than optimization above)
4279 -- First apply constraint checks, because the bounds or discriminants
4280 -- in the aggregate might not match the subtype mark in the allocator.
4281
4282 if Nkind (Expression (N)) = N_Qualified_Expression then
4283 Apply_Constraint_Check
4284 (Expression (Expression (N)), Etype (Expression (N)));
4285
4286 Expand_Allocator_Expression (N);
4287 return;
4288 end if;
4289
4290 -- If the allocator is for a type which requires initialization, and
4291 -- there is no initial value (i.e. operand is a subtype indication
4292 -- rather than a qualified expression), then we must generate a call to
4293 -- the initialization routine using an expressions action node:
4294
4295 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4296
4297 -- Here ptr_T is the pointer type for the allocator, and T is the
4298 -- subtype of the allocator. A special case arises if the designated
4299 -- type of the access type is a task or contains tasks. In this case
4300 -- the call to Init (Temp.all ...) is replaced by code that ensures
4301 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4302 -- for details). In addition, if the type T is a task type, then the
4303 -- first argument to Init must be converted to the task record type.
4304
4305 declare
4306 T : constant Entity_Id := Entity (Expression (N));
4307 Args : List_Id;
4308 Decls : List_Id;
4309 Decl : Node_Id;
4310 Discr : Elmt_Id;
4311 Init : Entity_Id;
4312 Init_Arg1 : Node_Id;
4313 Temp_Decl : Node_Id;
4314 Temp_Type : Entity_Id;
4315
4316 begin
4317 if No_Initialization (N) then
4318
4319 -- Even though this might be a simple allocation, create a custom
4320 -- Allocate if the context requires it.
4321
4322 if Present (Finalization_Master (PtrT)) then
4323 Build_Allocate_Deallocate_Proc
4324 (N => N,
4325 Is_Allocate => True);
4326 end if;
4327
4328 -- Case of no initialization procedure present
4329
4330 elsif not Has_Non_Null_Base_Init_Proc (T) then
4331
4332 -- Case of simple initialization required
4333
4334 if Needs_Simple_Initialization (T) then
4335 Check_Restriction (No_Default_Initialization, N);
4336 Rewrite (Expression (N),
4337 Make_Qualified_Expression (Loc,
4338 Subtype_Mark => New_Occurrence_Of (T, Loc),
4339 Expression => Get_Simple_Init_Val (T, N)));
4340
4341 Analyze_And_Resolve (Expression (Expression (N)), T);
4342 Analyze_And_Resolve (Expression (N), T);
4343 Set_Paren_Count (Expression (Expression (N)), 1);
4344 Expand_N_Allocator (N);
4345
4346 -- No initialization required
4347
4348 else
4349 null;
4350 end if;
4351
4352 -- Case of initialization procedure present, must be called
4353
4354 else
4355 Check_Restriction (No_Default_Initialization, N);
4356
4357 if not Restriction_Active (No_Default_Initialization) then
4358 Init := Base_Init_Proc (T);
4359 Nod := N;
4360 Temp := Make_Temporary (Loc, 'P');
4361
4362 -- Construct argument list for the initialization routine call
4363
4364 Init_Arg1 :=
4365 Make_Explicit_Dereference (Loc,
4366 Prefix =>
4367 New_Occurrence_Of (Temp, Loc));
4368
4369 Set_Assignment_OK (Init_Arg1);
4370 Temp_Type := PtrT;
4371
4372 -- The initialization procedure expects a specific type. if the
4373 -- context is access to class wide, indicate that the object
4374 -- being allocated has the right specific type.
4375
4376 if Is_Class_Wide_Type (Dtyp) then
4377 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4378 end if;
4379
4380 -- If designated type is a concurrent type or if it is private
4381 -- type whose definition is a concurrent type, the first
4382 -- argument in the Init routine has to be unchecked conversion
4383 -- to the corresponding record type. If the designated type is
4384 -- a derived type, also convert the argument to its root type.
4385
4386 if Is_Concurrent_Type (T) then
4387 Init_Arg1 :=
4388 Unchecked_Convert_To (
4389 Corresponding_Record_Type (T), Init_Arg1);
4390
4391 elsif Is_Private_Type (T)
4392 and then Present (Full_View (T))
4393 and then Is_Concurrent_Type (Full_View (T))
4394 then
4395 Init_Arg1 :=
4396 Unchecked_Convert_To
4397 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
4398
4399 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
4400 declare
4401 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
4402
4403 begin
4404 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
4405 Set_Etype (Init_Arg1, Ftyp);
4406 end;
4407 end if;
4408
4409 Args := New_List (Init_Arg1);
4410
4411 -- For the task case, pass the Master_Id of the access type as
4412 -- the value of the _Master parameter, and _Chain as the value
4413 -- of the _Chain parameter (_Chain will be defined as part of
4414 -- the generated code for the allocator).
4415
4416 -- In Ada 2005, the context may be a function that returns an
4417 -- anonymous access type. In that case the Master_Id has been
4418 -- created when expanding the function declaration.
4419
4420 if Has_Task (T) then
4421 if No (Master_Id (Base_Type (PtrT))) then
4422
4423 -- The designated type was an incomplete type, and the
4424 -- access type did not get expanded. Salvage it now.
4425
4426 if not Restriction_Active (No_Task_Hierarchy) then
4427 if Present (Parent (Base_Type (PtrT))) then
4428 Expand_N_Full_Type_Declaration
4429 (Parent (Base_Type (PtrT)));
4430
4431 -- The only other possibility is an itype. For this
4432 -- case, the master must exist in the context. This is
4433 -- the case when the allocator initializes an access
4434 -- component in an init-proc.
4435
4436 else
4437 pragma Assert (Is_Itype (PtrT));
4438 Build_Master_Renaming (PtrT, N);
4439 end if;
4440 end if;
4441 end if;
4442
4443 -- If the context of the allocator is a declaration or an
4444 -- assignment, we can generate a meaningful image for it,
4445 -- even though subsequent assignments might remove the
4446 -- connection between task and entity. We build this image
4447 -- when the left-hand side is a simple variable, a simple
4448 -- indexed assignment or a simple selected component.
4449
4450 if Nkind (Parent (N)) = N_Assignment_Statement then
4451 declare
4452 Nam : constant Node_Id := Name (Parent (N));
4453
4454 begin
4455 if Is_Entity_Name (Nam) then
4456 Decls :=
4457 Build_Task_Image_Decls
4458 (Loc,
4459 New_Occurrence_Of
4460 (Entity (Nam), Sloc (Nam)), T);
4461
4462 elsif Nkind_In (Nam, N_Indexed_Component,
4463 N_Selected_Component)
4464 and then Is_Entity_Name (Prefix (Nam))
4465 then
4466 Decls :=
4467 Build_Task_Image_Decls
4468 (Loc, Nam, Etype (Prefix (Nam)));
4469 else
4470 Decls := Build_Task_Image_Decls (Loc, T, T);
4471 end if;
4472 end;
4473
4474 elsif Nkind (Parent (N)) = N_Object_Declaration then
4475 Decls :=
4476 Build_Task_Image_Decls
4477 (Loc, Defining_Identifier (Parent (N)), T);
4478
4479 else
4480 Decls := Build_Task_Image_Decls (Loc, T, T);
4481 end if;
4482
4483 if Restriction_Active (No_Task_Hierarchy) then
4484 Append_To (Args,
4485 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
4486 else
4487 Append_To (Args,
4488 New_Occurrence_Of
4489 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
4490 end if;
4491
4492 Append_To (Args, Make_Identifier (Loc, Name_uChain));
4493
4494 Decl := Last (Decls);
4495 Append_To (Args,
4496 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
4497
4498 -- Has_Task is false, Decls not used
4499
4500 else
4501 Decls := No_List;
4502 end if;
4503
4504 -- Add discriminants if discriminated type
4505
4506 declare
4507 Dis : Boolean := False;
4508 Typ : Entity_Id;
4509
4510 begin
4511 if Has_Discriminants (T) then
4512 Dis := True;
4513 Typ := T;
4514
4515 -- Type may be a private type with no visible discriminants
4516 -- in which case check full view if in scope, or the
4517 -- underlying_full_view if dealing with a type whose full
4518 -- view may be derived from a private type whose own full
4519 -- view has discriminants.
4520
4521 elsif Is_Private_Type (T) then
4522 if Present (Full_View (T))
4523 and then Has_Discriminants (Full_View (T))
4524 then
4525 Dis := True;
4526 Typ := Full_View (T);
4527
4528 elsif Present (Underlying_Full_View (T))
4529 and then Has_Discriminants (Underlying_Full_View (T))
4530 then
4531 Dis := True;
4532 Typ := Underlying_Full_View (T);
4533 end if;
4534 end if;
4535
4536 if Dis then
4537
4538 -- If the allocated object will be constrained by the
4539 -- default values for discriminants, then build a subtype
4540 -- with those defaults, and change the allocated subtype
4541 -- to that. Note that this happens in fewer cases in Ada
4542 -- 2005 (AI-363).
4543
4544 if not Is_Constrained (Typ)
4545 and then Present (Discriminant_Default_Value
4546 (First_Discriminant (Typ)))
4547 and then (Ada_Version < Ada_2005
4548 or else not
4549 Object_Type_Has_Constrained_Partial_View
4550 (Typ, Current_Scope))
4551 then
4552 Typ := Build_Default_Subtype (Typ, N);
4553 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
4554 end if;
4555
4556 Discr := First_Elmt (Discriminant_Constraint (Typ));
4557 while Present (Discr) loop
4558 Nod := Node (Discr);
4559 Append (New_Copy_Tree (Node (Discr)), Args);
4560
4561 -- AI-416: when the discriminant constraint is an
4562 -- anonymous access type make sure an accessibility
4563 -- check is inserted if necessary (3.10.2(22.q/2))
4564
4565 if Ada_Version >= Ada_2005
4566 and then
4567 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
4568 then
4569 Apply_Accessibility_Check
4570 (Nod, Typ, Insert_Node => Nod);
4571 end if;
4572
4573 Next_Elmt (Discr);
4574 end loop;
4575 end if;
4576 end;
4577
4578 -- We set the allocator as analyzed so that when we analyze
4579 -- the if expression node, we do not get an unwanted recursive
4580 -- expansion of the allocator expression.
4581
4582 Set_Analyzed (N, True);
4583 Nod := Relocate_Node (N);
4584
4585 -- Here is the transformation:
4586 -- input: new Ctrl_Typ
4587 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4588 -- Ctrl_TypIP (Temp.all, ...);
4589 -- [Deep_]Initialize (Temp.all);
4590
4591 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4592 -- is the subtype of the allocator.
4593
4594 Temp_Decl :=
4595 Make_Object_Declaration (Loc,
4596 Defining_Identifier => Temp,
4597 Constant_Present => True,
4598 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
4599 Expression => Nod);
4600
4601 Set_Assignment_OK (Temp_Decl);
4602 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
4603
4604 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
4605
4606 -- If the designated type is a task type or contains tasks,
4607 -- create block to activate created tasks, and insert
4608 -- declaration for Task_Image variable ahead of call.
4609
4610 if Has_Task (T) then
4611 declare
4612 L : constant List_Id := New_List;
4613 Blk : Node_Id;
4614 begin
4615 Build_Task_Allocate_Block (L, Nod, Args);
4616 Blk := Last (L);
4617 Insert_List_Before (First (Declarations (Blk)), Decls);
4618 Insert_Actions (N, L);
4619 end;
4620
4621 else
4622 Insert_Action (N,
4623 Make_Procedure_Call_Statement (Loc,
4624 Name => New_Occurrence_Of (Init, Loc),
4625 Parameter_Associations => Args));
4626 end if;
4627
4628 if Needs_Finalization (T) then
4629
4630 -- Generate:
4631 -- [Deep_]Initialize (Init_Arg1);
4632
4633 Insert_Action (N,
4634 Make_Init_Call
4635 (Obj_Ref => New_Copy_Tree (Init_Arg1),
4636 Typ => T));
4637 end if;
4638
4639 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4640 Analyze_And_Resolve (N, PtrT);
4641 end if;
4642 end if;
4643 end;
4644
4645 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4646 -- object that has been rewritten as a reference, we displace "this"
4647 -- to reference properly its secondary dispatch table.
4648
4649 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
4650 Displace_Allocator_Pointer (N);
4651 end if;
4652
4653 exception
4654 when RE_Not_Available =>
4655 return;
4656 end Expand_N_Allocator;
4657
4658 -----------------------
4659 -- Expand_N_And_Then --
4660 -----------------------
4661
4662 procedure Expand_N_And_Then (N : Node_Id)
4663 renames Expand_Short_Circuit_Operator;
4664
4665 ------------------------------
4666 -- Expand_N_Case_Expression --
4667 ------------------------------
4668
4669 procedure Expand_N_Case_Expression (N : Node_Id) is
4670 Loc : constant Source_Ptr := Sloc (N);
4671 Par : constant Node_Id := Parent (N);
4672 Typ : constant Entity_Id := Etype (N);
4673 Acts : List_Id;
4674 Alt : Node_Id;
4675 Case_Stmt : Node_Id;
4676 Decl : Node_Id;
4677 Expr : Node_Id;
4678 Target : Entity_Id;
4679 Target_Typ : Entity_Id;
4680
4681 In_Predicate : Boolean := False;
4682 -- Flag set when the case expression appears within a predicate
4683
4684 Optimize_Return_Stmt : Boolean := False;
4685 -- Flag set when the case expression can be optimized in the context of
4686 -- a simple return statement.
4687
4688 begin
4689 -- Check for MINIMIZED/ELIMINATED overflow mode
4690
4691 if Minimized_Eliminated_Overflow_Check (N) then
4692 Apply_Arithmetic_Overflow_Check (N);
4693 return;
4694 end if;
4695
4696 -- If the case expression is a predicate specification, and the type
4697 -- to which it applies has a static predicate aspect, do not expand,
4698 -- because it will be converted to the proper predicate form later.
4699
4700 if Ekind_In (Current_Scope, E_Function, E_Procedure)
4701 and then Is_Predicate_Function (Current_Scope)
4702 then
4703 In_Predicate := True;
4704
4705 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
4706 then
4707 return;
4708 end if;
4709 end if;
4710
4711 -- When the type of the case expression is elementary, expand
4712
4713 -- (case X is when A => AX, when B => BX ...)
4714
4715 -- into
4716
4717 -- do
4718 -- Target : Typ;
4719 -- case X is
4720 -- when A =>
4721 -- Target := AX;
4722 -- when B =>
4723 -- Target := BX;
4724 -- ...
4725 -- end case;
4726 -- in Target end;
4727
4728 -- In all other cases expand into
4729
4730 -- do
4731 -- type Ptr_Typ is access all Typ;
4732 -- Target : Ptr_Typ;
4733 -- case X is
4734 -- when A =>
4735 -- Target := AX'Unrestricted_Access;
4736 -- when B =>
4737 -- Target := BX'Unrestricted_Access;
4738 -- ...
4739 -- end case;
4740 -- in Target.all end;
4741
4742 -- This approach avoids extra copies of potentially large objects. It
4743 -- also allows handling of values of limited or unconstrained types.
4744
4745 -- Small optimization: when the case expression appears in the context
4746 -- of a simple return statement, expand into
4747
4748 -- case X is
4749 -- when A =>
4750 -- return AX;
4751 -- when B =>
4752 -- return BX;
4753 -- ...
4754 -- end case;
4755
4756 Case_Stmt :=
4757 Make_Case_Statement (Loc,
4758 Expression => Expression (N),
4759 Alternatives => New_List);
4760
4761 -- Preserve the original context for which the case statement is being
4762 -- generated. This is needed by the finalization machinery to prevent
4763 -- the premature finalization of controlled objects found within the
4764 -- case statement.
4765
4766 Set_From_Conditional_Expression (Case_Stmt);
4767 Acts := New_List;
4768
4769 -- Scalar case
4770
4771 if Is_Elementary_Type (Typ) then
4772 Target_Typ := Typ;
4773
4774 -- ??? Do not perform the optimization when the return statement is
4775 -- within a predicate function as this causes supurious errors. Could
4776 -- this be a possible mismatch in handling this case somewhere else
4777 -- in semantic analysis?
4778
4779 Optimize_Return_Stmt :=
4780 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
4781
4782 -- Otherwise create an access type to handle the general case using
4783 -- 'Unrestricted_Access.
4784
4785 -- Generate:
4786 -- type Ptr_Typ is access all Typ;
4787
4788 else
4789 Target_Typ := Make_Temporary (Loc, 'P');
4790
4791 Append_To (Acts,
4792 Make_Full_Type_Declaration (Loc,
4793 Defining_Identifier => Target_Typ,
4794 Type_Definition =>
4795 Make_Access_To_Object_Definition (Loc,
4796 All_Present => True,
4797 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
4798 end if;
4799
4800 -- Create the declaration of the target which captures the value of the
4801 -- expression.
4802
4803 -- Generate:
4804 -- Target : [Ptr_]Typ;
4805
4806 if not Optimize_Return_Stmt then
4807 Target := Make_Temporary (Loc, 'T');
4808
4809 Decl :=
4810 Make_Object_Declaration (Loc,
4811 Defining_Identifier => Target,
4812 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
4813 Set_No_Initialization (Decl);
4814
4815 Append_To (Acts, Decl);
4816 end if;
4817
4818 -- Process the alternatives
4819
4820 Alt := First (Alternatives (N));
4821 while Present (Alt) loop
4822 declare
4823 Alt_Expr : Node_Id := Expression (Alt);
4824 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
4825 Stmts : List_Id;
4826
4827 begin
4828 -- Take the unrestricted access of the expression value for non-
4829 -- scalar types. This approach avoids big copies and covers the
4830 -- limited and unconstrained cases.
4831
4832 -- Generate:
4833 -- AX'Unrestricted_Access
4834
4835 if not Is_Elementary_Type (Typ) then
4836 Alt_Expr :=
4837 Make_Attribute_Reference (Alt_Loc,
4838 Prefix => Relocate_Node (Alt_Expr),
4839 Attribute_Name => Name_Unrestricted_Access);
4840 end if;
4841
4842 -- Generate:
4843 -- return AX['Unrestricted_Access];
4844
4845 if Optimize_Return_Stmt then
4846 Stmts := New_List (
4847 Make_Simple_Return_Statement (Alt_Loc,
4848 Expression => Alt_Expr));
4849
4850 -- Generate:
4851 -- Target := AX['Unrestricted_Access];
4852
4853 else
4854 Stmts := New_List (
4855 Make_Assignment_Statement (Alt_Loc,
4856 Name => New_Occurrence_Of (Target, Loc),
4857 Expression => Alt_Expr));
4858 end if;
4859
4860 -- Propagate declarations inserted in the node by Insert_Actions
4861 -- (for example, temporaries generated to remove side effects).
4862 -- These actions must remain attached to the alternative, given
4863 -- that they are generated by the corresponding expression.
4864
4865 if Present (Actions (Alt)) then
4866 Prepend_List (Actions (Alt), Stmts);
4867 end if;
4868
4869 -- Finalize any transient controlled objects on exit from the
4870 -- alternative. This is done only in the return optimization case
4871 -- because otherwise the case expression is converted into an
4872 -- expression with actions which already contains this form of
4873 -- processing.
4874
4875 if Optimize_Return_Stmt then
4876 Process_If_Case_Statements (N, Stmts);
4877 end if;
4878
4879 Append_To
4880 (Alternatives (Case_Stmt),
4881 Make_Case_Statement_Alternative (Sloc (Alt),
4882 Discrete_Choices => Discrete_Choices (Alt),
4883 Statements => Stmts));
4884 end;
4885
4886 Next (Alt);
4887 end loop;
4888
4889 -- Rewrite the parent return statement as a case statement
4890
4891 if Optimize_Return_Stmt then
4892 Rewrite (Par, Case_Stmt);
4893 Analyze (Par);
4894
4895 -- Otherwise convert the case expression into an expression with actions
4896
4897 else
4898 Append_To (Acts, Case_Stmt);
4899
4900 if Is_Elementary_Type (Typ) then
4901 Expr := New_Occurrence_Of (Target, Loc);
4902
4903 else
4904 Expr :=
4905 Make_Explicit_Dereference (Loc,
4906 Prefix => New_Occurrence_Of (Target, Loc));
4907 end if;
4908
4909 -- Generate:
4910 -- do
4911 -- ...
4912 -- in Target[.all] end;
4913
4914 Rewrite (N,
4915 Make_Expression_With_Actions (Loc,
4916 Expression => Expr,
4917 Actions => Acts));
4918
4919 Analyze_And_Resolve (N, Typ);
4920 end if;
4921 end Expand_N_Case_Expression;
4922
4923 -----------------------------------
4924 -- Expand_N_Explicit_Dereference --
4925 -----------------------------------
4926
4927 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
4928 begin
4929 -- Insert explicit dereference call for the checked storage pool case
4930
4931 Insert_Dereference_Action (Prefix (N));
4932
4933 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
4934 -- we set the atomic sync flag.
4935
4936 if Is_Atomic (Etype (N))
4937 and then not Atomic_Synchronization_Disabled (Etype (N))
4938 then
4939 Activate_Atomic_Synchronization (N);
4940 end if;
4941 end Expand_N_Explicit_Dereference;
4942
4943 --------------------------------------
4944 -- Expand_N_Expression_With_Actions --
4945 --------------------------------------
4946
4947 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
4948 Acts : constant List_Id := Actions (N);
4949
4950 procedure Force_Boolean_Evaluation (Expr : Node_Id);
4951 -- Force the evaluation of Boolean expression Expr
4952
4953 function Process_Action (Act : Node_Id) return Traverse_Result;
4954 -- Inspect and process a single action of an expression_with_actions for
4955 -- transient controlled objects. If such objects are found, the routine
4956 -- generates code to clean them up when the context of the expression is
4957 -- evaluated or elaborated.
4958
4959 ------------------------------
4960 -- Force_Boolean_Evaluation --
4961 ------------------------------
4962
4963 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
4964 Loc : constant Source_Ptr := Sloc (N);
4965 Flag_Decl : Node_Id;
4966 Flag_Id : Entity_Id;
4967
4968 begin
4969 -- Relocate the expression to the actions list by capturing its value
4970 -- in a Boolean flag. Generate:
4971 -- Flag : constant Boolean := Expr;
4972
4973 Flag_Id := Make_Temporary (Loc, 'F');
4974
4975 Flag_Decl :=
4976 Make_Object_Declaration (Loc,
4977 Defining_Identifier => Flag_Id,
4978 Constant_Present => True,
4979 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
4980 Expression => Relocate_Node (Expr));
4981
4982 Append (Flag_Decl, Acts);
4983 Analyze (Flag_Decl);
4984
4985 -- Replace the expression with a reference to the flag
4986
4987 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
4988 Analyze (Expression (N));
4989 end Force_Boolean_Evaluation;
4990
4991 --------------------
4992 -- Process_Action --
4993 --------------------
4994
4995 function Process_Action (Act : Node_Id) return Traverse_Result is
4996 begin
4997 if Nkind (Act) = N_Object_Declaration
4998 and then Is_Finalizable_Transient (Act, N)
4999 then
5000 Process_Transient_Object (Act, N, Acts);
5001 return Abandon;
5002
5003 -- Avoid processing temporary function results multiple times when
5004 -- dealing with nested expression_with_actions.
5005
5006 elsif Nkind (Act) = N_Expression_With_Actions then
5007 return Abandon;
5008
5009 -- Do not process temporary function results in loops. This is done
5010 -- by Expand_N_Loop_Statement and Build_Finalizer.
5011
5012 elsif Nkind (Act) = N_Loop_Statement then
5013 return Abandon;
5014 end if;
5015
5016 return OK;
5017 end Process_Action;
5018
5019 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5020
5021 -- Local variables
5022
5023 Act : Node_Id;
5024
5025 -- Start of processing for Expand_N_Expression_With_Actions
5026
5027 begin
5028 -- Do not evaluate the expression when it denotes an entity because the
5029 -- expression_with_actions node will be replaced by the reference.
5030
5031 if Is_Entity_Name (Expression (N)) then
5032 null;
5033
5034 -- Do not evaluate the expression when there are no actions because the
5035 -- expression_with_actions node will be replaced by the expression.
5036
5037 elsif No (Acts) or else Is_Empty_List (Acts) then
5038 null;
5039
5040 -- Force the evaluation of the expression by capturing its value in a
5041 -- temporary. This ensures that aliases of transient controlled objects
5042 -- do not leak to the expression of the expression_with_actions node:
5043
5044 -- do
5045 -- Trans_Id : Ctrl_Typ := ...;
5046 -- Alias : ... := Trans_Id;
5047 -- in ... Alias ... end;
5048
5049 -- In the example above, Trans_Id cannot be finalized at the end of the
5050 -- actions list because this may affect the alias and the final value of
5051 -- the expression_with_actions. Forcing the evaluation encapsulates the
5052 -- reference to the Alias within the actions list:
5053
5054 -- do
5055 -- Trans_Id : Ctrl_Typ := ...;
5056 -- Alias : ... := Trans_Id;
5057 -- Val : constant Boolean := ... Alias ...;
5058 -- <finalize Trans_Id>
5059 -- in Val end;
5060
5061 -- Once this transformation is performed, it is safe to finalize the
5062 -- transient controlled object at the end of the actions list.
5063
5064 -- Note that Force_Evaluation does not remove side effects in operators
5065 -- because it assumes that all operands are evaluated and side effect
5066 -- free. This is not the case when an operand depends implicitly on the
5067 -- transient controlled object through the use of access types.
5068
5069 elsif Is_Boolean_Type (Etype (Expression (N))) then
5070 Force_Boolean_Evaluation (Expression (N));
5071
5072 -- The expression of an expression_with_actions node may not necessarily
5073 -- be Boolean when the node appears in an if expression. In this case do
5074 -- the usual forced evaluation to encapsulate potential aliasing.
5075
5076 else
5077 Force_Evaluation (Expression (N));
5078 end if;
5079
5080 -- Process all transient controlled objects found within the actions of
5081 -- the EWA node.
5082
5083 Act := First (Acts);
5084 while Present (Act) loop
5085 Process_Single_Action (Act);
5086 Next (Act);
5087 end loop;
5088
5089 -- Deal with case where there are no actions. In this case we simply
5090 -- rewrite the node with its expression since we don't need the actions
5091 -- and the specification of this node does not allow a null action list.
5092
5093 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5094 -- the expanded tree and relying on being able to retrieve the original
5095 -- tree in cases like this. This raises a whole lot of issues of whether
5096 -- we have problems elsewhere, which will be addressed in the future???
5097
5098 if Is_Empty_List (Acts) then
5099 Rewrite (N, Relocate_Node (Expression (N)));
5100 end if;
5101 end Expand_N_Expression_With_Actions;
5102
5103 ----------------------------
5104 -- Expand_N_If_Expression --
5105 ----------------------------
5106
5107 -- Deal with limited types and condition actions
5108
5109 procedure Expand_N_If_Expression (N : Node_Id) is
5110 Cond : constant Node_Id := First (Expressions (N));
5111 Loc : constant Source_Ptr := Sloc (N);
5112 Thenx : constant Node_Id := Next (Cond);
5113 Elsex : constant Node_Id := Next (Thenx);
5114 Typ : constant Entity_Id := Etype (N);
5115
5116 Actions : List_Id;
5117 Cnn : Entity_Id;
5118 Decl : Node_Id;
5119 Expr : Node_Id;
5120 New_If : Node_Id;
5121 New_N : Node_Id;
5122 Ptr_Typ : Entity_Id;
5123
5124 begin
5125 -- Check for MINIMIZED/ELIMINATED overflow mode
5126
5127 if Minimized_Eliminated_Overflow_Check (N) then
5128 Apply_Arithmetic_Overflow_Check (N);
5129 return;
5130 end if;
5131
5132 -- Fold at compile time if condition known. We have already folded
5133 -- static if expressions, but it is possible to fold any case in which
5134 -- the condition is known at compile time, even though the result is
5135 -- non-static.
5136
5137 -- Note that we don't do the fold of such cases in Sem_Elab because
5138 -- it can cause infinite loops with the expander adding a conditional
5139 -- expression, and Sem_Elab circuitry removing it repeatedly.
5140
5141 if Compile_Time_Known_Value (Cond) then
5142 declare
5143 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5144 -- Fold at compile time. Assumes condition known. Return True if
5145 -- folding occurred, meaning we're done.
5146
5147 ----------------------
5148 -- Fold_Known_Value --
5149 ----------------------
5150
5151 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5152 begin
5153 if Is_True (Expr_Value (Cond)) then
5154 Expr := Thenx;
5155 Actions := Then_Actions (N);
5156 else
5157 Expr := Elsex;
5158 Actions := Else_Actions (N);
5159 end if;
5160
5161 Remove (Expr);
5162
5163 if Present (Actions) then
5164
5165 -- To minimize the use of Expression_With_Actions, just skip
5166 -- the optimization as it is not critical for correctness.
5167
5168 if Minimize_Expression_With_Actions then
5169 return False;
5170 end if;
5171
5172 Rewrite (N,
5173 Make_Expression_With_Actions (Loc,
5174 Expression => Relocate_Node (Expr),
5175 Actions => Actions));
5176 Analyze_And_Resolve (N, Typ);
5177
5178 else
5179 Rewrite (N, Relocate_Node (Expr));
5180 end if;
5181
5182 -- Note that the result is never static (legitimate cases of
5183 -- static if expressions were folded in Sem_Eval).
5184
5185 Set_Is_Static_Expression (N, False);
5186 return True;
5187 end Fold_Known_Value;
5188
5189 begin
5190 if Fold_Known_Value (Cond) then
5191 return;
5192 end if;
5193 end;
5194 end if;
5195
5196 -- If the type is limited, and the back end does not handle limited
5197 -- types, then we expand as follows to avoid the possibility of
5198 -- improper copying.
5199
5200 -- type Ptr is access all Typ;
5201 -- Cnn : Ptr;
5202 -- if cond then
5203 -- <<then actions>>
5204 -- Cnn := then-expr'Unrestricted_Access;
5205 -- else
5206 -- <<else actions>>
5207 -- Cnn := else-expr'Unrestricted_Access;
5208 -- end if;
5209
5210 -- and replace the if expression by a reference to Cnn.all.
5211
5212 -- This special case can be skipped if the back end handles limited
5213 -- types properly and ensures that no incorrect copies are made.
5214
5215 if Is_By_Reference_Type (Typ)
5216 and then not Back_End_Handles_Limited_Types
5217 then
5218 -- When the "then" or "else" expressions involve controlled function
5219 -- calls, generated temporaries are chained on the corresponding list
5220 -- of actions. These temporaries need to be finalized after the if
5221 -- expression is evaluated.
5222
5223 Process_If_Case_Statements (N, Then_Actions (N));
5224 Process_If_Case_Statements (N, Else_Actions (N));
5225
5226 -- Generate:
5227 -- type Ann is access all Typ;
5228
5229 Ptr_Typ := Make_Temporary (Loc, 'A');
5230
5231 Insert_Action (N,
5232 Make_Full_Type_Declaration (Loc,
5233 Defining_Identifier => Ptr_Typ,
5234 Type_Definition =>
5235 Make_Access_To_Object_Definition (Loc,
5236 All_Present => True,
5237 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5238
5239 -- Generate:
5240 -- Cnn : Ann;
5241
5242 Cnn := Make_Temporary (Loc, 'C', N);
5243
5244 Decl :=
5245 Make_Object_Declaration (Loc,
5246 Defining_Identifier => Cnn,
5247 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
5248
5249 -- Generate:
5250 -- if Cond then
5251 -- Cnn := <Thenx>'Unrestricted_Access;
5252 -- else
5253 -- Cnn := <Elsex>'Unrestricted_Access;
5254 -- end if;
5255
5256 New_If :=
5257 Make_Implicit_If_Statement (N,
5258 Condition => Relocate_Node (Cond),
5259 Then_Statements => New_List (
5260 Make_Assignment_Statement (Sloc (Thenx),
5261 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5262 Expression =>
5263 Make_Attribute_Reference (Loc,
5264 Prefix => Relocate_Node (Thenx),
5265 Attribute_Name => Name_Unrestricted_Access))),
5266
5267 Else_Statements => New_List (
5268 Make_Assignment_Statement (Sloc (Elsex),
5269 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5270 Expression =>
5271 Make_Attribute_Reference (Loc,
5272 Prefix => Relocate_Node (Elsex),
5273 Attribute_Name => Name_Unrestricted_Access))));
5274
5275 -- Preserve the original context for which the if statement is being
5276 -- generated. This is needed by the finalization machinery to prevent
5277 -- the premature finalization of controlled objects found within the
5278 -- if statement.
5279
5280 Set_From_Conditional_Expression (New_If);
5281
5282 New_N :=
5283 Make_Explicit_Dereference (Loc,
5284 Prefix => New_Occurrence_Of (Cnn, Loc));
5285
5286 -- If the result is an unconstrained array and the if expression is in a
5287 -- context other than the initializing expression of the declaration of
5288 -- an object, then we pull out the if expression as follows:
5289
5290 -- Cnn : constant typ := if-expression
5291
5292 -- and then replace the if expression with an occurrence of Cnn. This
5293 -- avoids the need in the back end to create on-the-fly variable length
5294 -- temporaries (which it cannot do!)
5295
5296 -- Note that the test for being in an object declaration avoids doing an
5297 -- unnecessary expansion, and also avoids infinite recursion.
5298
5299 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
5300 and then (Nkind (Parent (N)) /= N_Object_Declaration
5301 or else Expression (Parent (N)) /= N)
5302 then
5303 declare
5304 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5305 begin
5306 Insert_Action (N,
5307 Make_Object_Declaration (Loc,
5308 Defining_Identifier => Cnn,
5309 Constant_Present => True,
5310 Object_Definition => New_Occurrence_Of (Typ, Loc),
5311 Expression => Relocate_Node (N),
5312 Has_Init_Expression => True));
5313
5314 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
5315 return;
5316 end;
5317
5318 -- For other types, we only need to expand if there are other actions
5319 -- associated with either branch.
5320
5321 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5322
5323 -- We now wrap the actions into the appropriate expression
5324
5325 if Minimize_Expression_With_Actions
5326 and then (Is_Elementary_Type (Underlying_Type (Typ))
5327 or else Is_Constrained (Underlying_Type (Typ)))
5328 then
5329 -- If we can't use N_Expression_With_Actions nodes, then we insert
5330 -- the following sequence of actions (using Insert_Actions):
5331
5332 -- Cnn : typ;
5333 -- if cond then
5334 -- <<then actions>>
5335 -- Cnn := then-expr;
5336 -- else
5337 -- <<else actions>>
5338 -- Cnn := else-expr
5339 -- end if;
5340
5341 -- and replace the if expression by a reference to Cnn
5342
5343 Cnn := Make_Temporary (Loc, 'C', N);
5344
5345 Decl :=
5346 Make_Object_Declaration (Loc,
5347 Defining_Identifier => Cnn,
5348 Object_Definition => New_Occurrence_Of (Typ, Loc));
5349
5350 New_If :=
5351 Make_Implicit_If_Statement (N,
5352 Condition => Relocate_Node (Cond),
5353
5354 Then_Statements => New_List (
5355 Make_Assignment_Statement (Sloc (Thenx),
5356 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5357 Expression => Relocate_Node (Thenx))),
5358
5359 Else_Statements => New_List (
5360 Make_Assignment_Statement (Sloc (Elsex),
5361 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5362 Expression => Relocate_Node (Elsex))));
5363
5364 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
5365 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
5366
5367 New_N := New_Occurrence_Of (Cnn, Loc);
5368
5369 -- Regular path using Expression_With_Actions
5370
5371 else
5372 if Present (Then_Actions (N)) then
5373 Rewrite (Thenx,
5374 Make_Expression_With_Actions (Sloc (Thenx),
5375 Actions => Then_Actions (N),
5376 Expression => Relocate_Node (Thenx)));
5377
5378 Set_Then_Actions (N, No_List);
5379 Analyze_And_Resolve (Thenx, Typ);
5380 end if;
5381
5382 if Present (Else_Actions (N)) then
5383 Rewrite (Elsex,
5384 Make_Expression_With_Actions (Sloc (Elsex),
5385 Actions => Else_Actions (N),
5386 Expression => Relocate_Node (Elsex)));
5387
5388 Set_Else_Actions (N, No_List);
5389 Analyze_And_Resolve (Elsex, Typ);
5390 end if;
5391
5392 return;
5393 end if;
5394
5395 -- If no actions then no expansion needed, gigi will handle it using the
5396 -- same approach as a C conditional expression.
5397
5398 else
5399 return;
5400 end if;
5401
5402 -- Fall through here for either the limited expansion, or the case of
5403 -- inserting actions for non-limited types. In both these cases, we must
5404 -- move the SLOC of the parent If statement to the newly created one and
5405 -- change it to the SLOC of the expression which, after expansion, will
5406 -- correspond to what is being evaluated.
5407
5408 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
5409 Set_Sloc (New_If, Sloc (Parent (N)));
5410 Set_Sloc (Parent (N), Loc);
5411 end if;
5412
5413 -- Make sure Then_Actions and Else_Actions are appropriately moved
5414 -- to the new if statement.
5415
5416 if Present (Then_Actions (N)) then
5417 Insert_List_Before
5418 (First (Then_Statements (New_If)), Then_Actions (N));
5419 end if;
5420
5421 if Present (Else_Actions (N)) then
5422 Insert_List_Before
5423 (First (Else_Statements (New_If)), Else_Actions (N));
5424 end if;
5425
5426 Insert_Action (N, Decl);
5427 Insert_Action (N, New_If);
5428 Rewrite (N, New_N);
5429 Analyze_And_Resolve (N, Typ);
5430 end Expand_N_If_Expression;
5431
5432 -----------------
5433 -- Expand_N_In --
5434 -----------------
5435
5436 procedure Expand_N_In (N : Node_Id) is
5437 Loc : constant Source_Ptr := Sloc (N);
5438 Restyp : constant Entity_Id := Etype (N);
5439 Lop : constant Node_Id := Left_Opnd (N);
5440 Rop : constant Node_Id := Right_Opnd (N);
5441 Static : constant Boolean := Is_OK_Static_Expression (N);
5442
5443 procedure Substitute_Valid_Check;
5444 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5445 -- test for the left operand being in range of its subtype.
5446
5447 ----------------------------
5448 -- Substitute_Valid_Check --
5449 ----------------------------
5450
5451 procedure Substitute_Valid_Check is
5452 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
5453 -- Determine whether arbitrary node Nod denotes a source object that
5454 -- may safely act as prefix of attribute 'Valid.
5455
5456 ----------------------------
5457 -- Is_OK_Object_Reference --
5458 ----------------------------
5459
5460 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
5461 Obj_Ref : Node_Id;
5462
5463 begin
5464 -- Inspect the original operand
5465
5466 Obj_Ref := Original_Node (Nod);
5467
5468 -- The object reference must be a source construct, otherwise the
5469 -- codefix suggestion may refer to nonexistent code from a user
5470 -- perspective.
5471
5472 if Comes_From_Source (Obj_Ref) then
5473
5474 -- Recover the actual object reference. There may be more cases
5475 -- to consider???
5476
5477 loop
5478 if Nkind_In (Obj_Ref, N_Type_Conversion,
5479 N_Unchecked_Type_Conversion)
5480 then
5481 Obj_Ref := Expression (Obj_Ref);
5482 else
5483 exit;
5484 end if;
5485 end loop;
5486
5487 return Is_Object_Reference (Obj_Ref);
5488 end if;
5489
5490 return False;
5491 end Is_OK_Object_Reference;
5492
5493 -- Start of processing for Substitute_Valid_Check
5494
5495 begin
5496 Rewrite (N,
5497 Make_Attribute_Reference (Loc,
5498 Prefix => Relocate_Node (Lop),
5499 Attribute_Name => Name_Valid));
5500
5501 Analyze_And_Resolve (N, Restyp);
5502
5503 -- Emit a warning when the left-hand operand of the membership test
5504 -- is a source object, otherwise the use of attribute 'Valid would be
5505 -- illegal. The warning is not given when overflow checking is either
5506 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
5507 -- eliminated above.
5508
5509 if Is_OK_Object_Reference (Lop)
5510 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
5511 then
5512 Error_Msg_N
5513 ("??explicit membership test may be optimized away", N);
5514 Error_Msg_N -- CODEFIX
5515 ("\??use ''Valid attribute instead", N);
5516 end if;
5517 end Substitute_Valid_Check;
5518
5519 -- Local variables
5520
5521 Ltyp : Entity_Id;
5522 Rtyp : Entity_Id;
5523
5524 -- Start of processing for Expand_N_In
5525
5526 begin
5527 -- If set membership case, expand with separate procedure
5528
5529 if Present (Alternatives (N)) then
5530 Expand_Set_Membership (N);
5531 return;
5532 end if;
5533
5534 -- Not set membership, proceed with expansion
5535
5536 Ltyp := Etype (Left_Opnd (N));
5537 Rtyp := Etype (Right_Opnd (N));
5538
5539 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5540 -- type, then expand with a separate procedure. Note the use of the
5541 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5542
5543 if Overflow_Check_Mode in Minimized_Or_Eliminated
5544 and then Is_Signed_Integer_Type (Ltyp)
5545 and then not No_Minimize_Eliminate (N)
5546 then
5547 Expand_Membership_Minimize_Eliminate_Overflow (N);
5548 return;
5549 end if;
5550
5551 -- Check case of explicit test for an expression in range of its
5552 -- subtype. This is suspicious usage and we replace it with a 'Valid
5553 -- test and give a warning for scalar types.
5554
5555 if Is_Scalar_Type (Ltyp)
5556
5557 -- Only relevant for source comparisons
5558
5559 and then Comes_From_Source (N)
5560
5561 -- In floating-point this is a standard way to check for finite values
5562 -- and using 'Valid would typically be a pessimization.
5563
5564 and then not Is_Floating_Point_Type (Ltyp)
5565
5566 -- Don't give the message unless right operand is a type entity and
5567 -- the type of the left operand matches this type. Note that this
5568 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5569 -- checks have changed the type of the left operand.
5570
5571 and then Nkind (Rop) in N_Has_Entity
5572 and then Ltyp = Entity (Rop)
5573
5574 -- Skip this for predicated types, where such expressions are a
5575 -- reasonable way of testing if something meets the predicate.
5576
5577 and then not Present (Predicate_Function (Ltyp))
5578 then
5579 Substitute_Valid_Check;
5580 return;
5581 end if;
5582
5583 -- Do validity check on operands
5584
5585 if Validity_Checks_On and Validity_Check_Operands then
5586 Ensure_Valid (Left_Opnd (N));
5587 Validity_Check_Range (Right_Opnd (N));
5588 end if;
5589
5590 -- Case of explicit range
5591
5592 if Nkind (Rop) = N_Range then
5593 declare
5594 Lo : constant Node_Id := Low_Bound (Rop);
5595 Hi : constant Node_Id := High_Bound (Rop);
5596
5597 Lo_Orig : constant Node_Id := Original_Node (Lo);
5598 Hi_Orig : constant Node_Id := Original_Node (Hi);
5599
5600 Lcheck : Compare_Result;
5601 Ucheck : Compare_Result;
5602
5603 Warn1 : constant Boolean :=
5604 Constant_Condition_Warnings
5605 and then Comes_From_Source (N)
5606 and then not In_Instance;
5607 -- This must be true for any of the optimization warnings, we
5608 -- clearly want to give them only for source with the flag on. We
5609 -- also skip these warnings in an instance since it may be the
5610 -- case that different instantiations have different ranges.
5611
5612 Warn2 : constant Boolean :=
5613 Warn1
5614 and then Nkind (Original_Node (Rop)) = N_Range
5615 and then Is_Integer_Type (Etype (Lo));
5616 -- For the case where only one bound warning is elided, we also
5617 -- insist on an explicit range and an integer type. The reason is
5618 -- that the use of enumeration ranges including an end point is
5619 -- common, as is the use of a subtype name, one of whose bounds is
5620 -- the same as the type of the expression.
5621
5622 begin
5623 -- If test is explicit x'First .. x'Last, replace by valid check
5624
5625 -- Could use some individual comments for this complex test ???
5626
5627 if Is_Scalar_Type (Ltyp)
5628
5629 -- And left operand is X'First where X matches left operand
5630 -- type (this eliminates cases of type mismatch, including
5631 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5632 -- type of the left operand.
5633
5634 and then Nkind (Lo_Orig) = N_Attribute_Reference
5635 and then Attribute_Name (Lo_Orig) = Name_First
5636 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
5637 and then Entity (Prefix (Lo_Orig)) = Ltyp
5638
5639 -- Same tests for right operand
5640
5641 and then Nkind (Hi_Orig) = N_Attribute_Reference
5642 and then Attribute_Name (Hi_Orig) = Name_Last
5643 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
5644 and then Entity (Prefix (Hi_Orig)) = Ltyp
5645
5646 -- Relevant only for source cases
5647
5648 and then Comes_From_Source (N)
5649 then
5650 Substitute_Valid_Check;
5651 goto Leave;
5652 end if;
5653
5654 -- If bounds of type are known at compile time, and the end points
5655 -- are known at compile time and identical, this is another case
5656 -- for substituting a valid test. We only do this for discrete
5657 -- types, since it won't arise in practice for float types.
5658
5659 if Comes_From_Source (N)
5660 and then Is_Discrete_Type (Ltyp)
5661 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
5662 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
5663 and then Compile_Time_Known_Value (Lo)
5664 and then Compile_Time_Known_Value (Hi)
5665 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
5666 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
5667
5668 -- Kill warnings in instances, since they may be cases where we
5669 -- have a test in the generic that makes sense with some types
5670 -- and not with other types.
5671
5672 and then not In_Instance
5673 then
5674 Substitute_Valid_Check;
5675 goto Leave;
5676 end if;
5677
5678 -- If we have an explicit range, do a bit of optimization based on
5679 -- range analysis (we may be able to kill one or both checks).
5680
5681 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
5682 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
5683
5684 -- If either check is known to fail, replace result by False since
5685 -- the other check does not matter. Preserve the static flag for
5686 -- legality checks, because we are constant-folding beyond RM 4.9.
5687
5688 if Lcheck = LT or else Ucheck = GT then
5689 if Warn1 then
5690 Error_Msg_N ("?c?range test optimized away", N);
5691 Error_Msg_N ("\?c?value is known to be out of range", N);
5692 end if;
5693
5694 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5695 Analyze_And_Resolve (N, Restyp);
5696 Set_Is_Static_Expression (N, Static);
5697 goto Leave;
5698
5699 -- If both checks are known to succeed, replace result by True,
5700 -- since we know we are in range.
5701
5702 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5703 if Warn1 then
5704 Error_Msg_N ("?c?range test optimized away", N);
5705 Error_Msg_N ("\?c?value is known to be in range", N);
5706 end if;
5707
5708 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5709 Analyze_And_Resolve (N, Restyp);
5710 Set_Is_Static_Expression (N, Static);
5711 goto Leave;
5712
5713 -- If lower bound check succeeds and upper bound check is not
5714 -- known to succeed or fail, then replace the range check with
5715 -- a comparison against the upper bound.
5716
5717 elsif Lcheck in Compare_GE then
5718 if Warn2 and then not In_Instance then
5719 Error_Msg_N ("??lower bound test optimized away", Lo);
5720 Error_Msg_N ("\??value is known to be in range", Lo);
5721 end if;
5722
5723 Rewrite (N,
5724 Make_Op_Le (Loc,
5725 Left_Opnd => Lop,
5726 Right_Opnd => High_Bound (Rop)));
5727 Analyze_And_Resolve (N, Restyp);
5728 goto Leave;
5729
5730 -- If upper bound check succeeds and lower bound check is not
5731 -- known to succeed or fail, then replace the range check with
5732 -- a comparison against the lower bound.
5733
5734 elsif Ucheck in Compare_LE then
5735 if Warn2 and then not In_Instance then
5736 Error_Msg_N ("??upper bound test optimized away", Hi);
5737 Error_Msg_N ("\??value is known to be in range", Hi);
5738 end if;
5739
5740 Rewrite (N,
5741 Make_Op_Ge (Loc,
5742 Left_Opnd => Lop,
5743 Right_Opnd => Low_Bound (Rop)));
5744 Analyze_And_Resolve (N, Restyp);
5745 goto Leave;
5746 end if;
5747
5748 -- We couldn't optimize away the range check, but there is one
5749 -- more issue. If we are checking constant conditionals, then we
5750 -- see if we can determine the outcome assuming everything is
5751 -- valid, and if so give an appropriate warning.
5752
5753 if Warn1 and then not Assume_No_Invalid_Values then
5754 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
5755 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
5756
5757 -- Result is out of range for valid value
5758
5759 if Lcheck = LT or else Ucheck = GT then
5760 Error_Msg_N
5761 ("?c?value can only be in range if it is invalid", N);
5762
5763 -- Result is in range for valid value
5764
5765 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5766 Error_Msg_N
5767 ("?c?value can only be out of range if it is invalid", N);
5768
5769 -- Lower bound check succeeds if value is valid
5770
5771 elsif Warn2 and then Lcheck in Compare_GE then
5772 Error_Msg_N
5773 ("?c?lower bound check only fails if it is invalid", Lo);
5774
5775 -- Upper bound check succeeds if value is valid
5776
5777 elsif Warn2 and then Ucheck in Compare_LE then
5778 Error_Msg_N
5779 ("?c?upper bound check only fails for invalid values", Hi);
5780 end if;
5781 end if;
5782 end;
5783
5784 -- For all other cases of an explicit range, nothing to be done
5785
5786 goto Leave;
5787
5788 -- Here right operand is a subtype mark
5789
5790 else
5791 declare
5792 Typ : Entity_Id := Etype (Rop);
5793 Is_Acc : constant Boolean := Is_Access_Type (Typ);
5794 Cond : Node_Id := Empty;
5795 New_N : Node_Id;
5796 Obj : Node_Id := Lop;
5797 SCIL_Node : Node_Id;
5798
5799 begin
5800 Remove_Side_Effects (Obj);
5801
5802 -- For tagged type, do tagged membership operation
5803
5804 if Is_Tagged_Type (Typ) then
5805
5806 -- No expansion will be performed for VM targets, as the VM
5807 -- back-ends will handle the membership tests directly.
5808
5809 if Tagged_Type_Expansion then
5810 Tagged_Membership (N, SCIL_Node, New_N);
5811 Rewrite (N, New_N);
5812 Analyze_And_Resolve (N, Restyp);
5813
5814 -- Update decoration of relocated node referenced by the
5815 -- SCIL node.
5816
5817 if Generate_SCIL and then Present (SCIL_Node) then
5818 Set_SCIL_Node (N, SCIL_Node);
5819 end if;
5820 end if;
5821
5822 goto Leave;
5823
5824 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5825 -- This reason we do this is that the bounds may have the wrong
5826 -- type if they come from the original type definition. Also this
5827 -- way we get all the processing above for an explicit range.
5828
5829 -- Don't do this for predicated types, since in this case we
5830 -- want to check the predicate.
5831
5832 elsif Is_Scalar_Type (Typ) then
5833 if No (Predicate_Function (Typ)) then
5834 Rewrite (Rop,
5835 Make_Range (Loc,
5836 Low_Bound =>
5837 Make_Attribute_Reference (Loc,
5838 Attribute_Name => Name_First,
5839 Prefix => New_Occurrence_Of (Typ, Loc)),
5840
5841 High_Bound =>
5842 Make_Attribute_Reference (Loc,
5843 Attribute_Name => Name_Last,
5844 Prefix => New_Occurrence_Of (Typ, Loc))));
5845 Analyze_And_Resolve (N, Restyp);
5846 end if;
5847
5848 goto Leave;
5849
5850 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5851 -- a membership test if the subtype mark denotes a constrained
5852 -- Unchecked_Union subtype and the expression lacks inferable
5853 -- discriminants.
5854
5855 elsif Is_Unchecked_Union (Base_Type (Typ))
5856 and then Is_Constrained (Typ)
5857 and then not Has_Inferable_Discriminants (Lop)
5858 then
5859 Insert_Action (N,
5860 Make_Raise_Program_Error (Loc,
5861 Reason => PE_Unchecked_Union_Restriction));
5862
5863 -- Prevent Gigi from generating incorrect code by rewriting the
5864 -- test as False. What is this undocumented thing about ???
5865
5866 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5867 goto Leave;
5868 end if;
5869
5870 -- Here we have a non-scalar type
5871
5872 if Is_Acc then
5873 Typ := Designated_Type (Typ);
5874 end if;
5875
5876 if not Is_Constrained (Typ) then
5877 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5878 Analyze_And_Resolve (N, Restyp);
5879
5880 -- For the constrained array case, we have to check the subscripts
5881 -- for an exact match if the lengths are non-zero (the lengths
5882 -- must match in any case).
5883
5884 elsif Is_Array_Type (Typ) then
5885 Check_Subscripts : declare
5886 function Build_Attribute_Reference
5887 (E : Node_Id;
5888 Nam : Name_Id;
5889 Dim : Nat) return Node_Id;
5890 -- Build attribute reference E'Nam (Dim)
5891
5892 -------------------------------
5893 -- Build_Attribute_Reference --
5894 -------------------------------
5895
5896 function Build_Attribute_Reference
5897 (E : Node_Id;
5898 Nam : Name_Id;
5899 Dim : Nat) return Node_Id
5900 is
5901 begin
5902 return
5903 Make_Attribute_Reference (Loc,
5904 Prefix => E,
5905 Attribute_Name => Nam,
5906 Expressions => New_List (
5907 Make_Integer_Literal (Loc, Dim)));
5908 end Build_Attribute_Reference;
5909
5910 -- Start of processing for Check_Subscripts
5911
5912 begin
5913 for J in 1 .. Number_Dimensions (Typ) loop
5914 Evolve_And_Then (Cond,
5915 Make_Op_Eq (Loc,
5916 Left_Opnd =>
5917 Build_Attribute_Reference
5918 (Duplicate_Subexpr_No_Checks (Obj),
5919 Name_First, J),
5920 Right_Opnd =>
5921 Build_Attribute_Reference
5922 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
5923
5924 Evolve_And_Then (Cond,
5925 Make_Op_Eq (Loc,
5926 Left_Opnd =>
5927 Build_Attribute_Reference
5928 (Duplicate_Subexpr_No_Checks (Obj),
5929 Name_Last, J),
5930 Right_Opnd =>
5931 Build_Attribute_Reference
5932 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
5933 end loop;
5934
5935 if Is_Acc then
5936 Cond :=
5937 Make_Or_Else (Loc,
5938 Left_Opnd =>
5939 Make_Op_Eq (Loc,
5940 Left_Opnd => Obj,
5941 Right_Opnd => Make_Null (Loc)),
5942 Right_Opnd => Cond);
5943 end if;
5944
5945 Rewrite (N, Cond);
5946 Analyze_And_Resolve (N, Restyp);
5947 end Check_Subscripts;
5948
5949 -- These are the cases where constraint checks may be required,
5950 -- e.g. records with possible discriminants
5951
5952 else
5953 -- Expand the test into a series of discriminant comparisons.
5954 -- The expression that is built is the negation of the one that
5955 -- is used for checking discriminant constraints.
5956
5957 Obj := Relocate_Node (Left_Opnd (N));
5958
5959 if Has_Discriminants (Typ) then
5960 Cond := Make_Op_Not (Loc,
5961 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
5962
5963 if Is_Acc then
5964 Cond := Make_Or_Else (Loc,
5965 Left_Opnd =>
5966 Make_Op_Eq (Loc,
5967 Left_Opnd => Obj,
5968 Right_Opnd => Make_Null (Loc)),
5969 Right_Opnd => Cond);
5970 end if;
5971
5972 else
5973 Cond := New_Occurrence_Of (Standard_True, Loc);
5974 end if;
5975
5976 Rewrite (N, Cond);
5977 Analyze_And_Resolve (N, Restyp);
5978 end if;
5979
5980 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5981 -- expression of an anonymous access type. This can involve an
5982 -- accessibility test and a tagged type membership test in the
5983 -- case of tagged designated types.
5984
5985 if Ada_Version >= Ada_2012
5986 and then Is_Acc
5987 and then Ekind (Ltyp) = E_Anonymous_Access_Type
5988 then
5989 declare
5990 Expr_Entity : Entity_Id := Empty;
5991 New_N : Node_Id;
5992 Param_Level : Node_Id;
5993 Type_Level : Node_Id;
5994
5995 begin
5996 if Is_Entity_Name (Lop) then
5997 Expr_Entity := Param_Entity (Lop);
5998
5999 if not Present (Expr_Entity) then
6000 Expr_Entity := Entity (Lop);
6001 end if;
6002 end if;
6003
6004 -- If a conversion of the anonymous access value to the
6005 -- tested type would be illegal, then the result is False.
6006
6007 if not Valid_Conversion
6008 (Lop, Rtyp, Lop, Report_Errs => False)
6009 then
6010 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6011 Analyze_And_Resolve (N, Restyp);
6012
6013 -- Apply an accessibility check if the access object has an
6014 -- associated access level and when the level of the type is
6015 -- less deep than the level of the access parameter. This
6016 -- only occur for access parameters and stand-alone objects
6017 -- of an anonymous access type.
6018
6019 else
6020 if Present (Expr_Entity)
6021 and then
6022 Present
6023 (Effective_Extra_Accessibility (Expr_Entity))
6024 and then UI_Gt (Object_Access_Level (Lop),
6025 Type_Access_Level (Rtyp))
6026 then
6027 Param_Level :=
6028 New_Occurrence_Of
6029 (Effective_Extra_Accessibility (Expr_Entity), Loc);
6030
6031 Type_Level :=
6032 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6033
6034 -- Return True only if the accessibility level of the
6035 -- expression entity is not deeper than the level of
6036 -- the tested access type.
6037
6038 Rewrite (N,
6039 Make_And_Then (Loc,
6040 Left_Opnd => Relocate_Node (N),
6041 Right_Opnd => Make_Op_Le (Loc,
6042 Left_Opnd => Param_Level,
6043 Right_Opnd => Type_Level)));
6044
6045 Analyze_And_Resolve (N);
6046 end if;
6047
6048 -- If the designated type is tagged, do tagged membership
6049 -- operation.
6050
6051 -- *** NOTE: we have to check not null before doing the
6052 -- tagged membership test (but maybe that can be done
6053 -- inside Tagged_Membership?).
6054
6055 if Is_Tagged_Type (Typ) then
6056 Rewrite (N,
6057 Make_And_Then (Loc,
6058 Left_Opnd => Relocate_Node (N),
6059 Right_Opnd =>
6060 Make_Op_Ne (Loc,
6061 Left_Opnd => Obj,
6062 Right_Opnd => Make_Null (Loc))));
6063
6064 -- No expansion will be performed for VM targets, as
6065 -- the VM back-ends will handle the membership tests
6066 -- directly.
6067
6068 if Tagged_Type_Expansion then
6069
6070 -- Note that we have to pass Original_Node, because
6071 -- the membership test might already have been
6072 -- rewritten by earlier parts of membership test.
6073
6074 Tagged_Membership
6075 (Original_Node (N), SCIL_Node, New_N);
6076
6077 -- Update decoration of relocated node referenced
6078 -- by the SCIL node.
6079
6080 if Generate_SCIL and then Present (SCIL_Node) then
6081 Set_SCIL_Node (New_N, SCIL_Node);
6082 end if;
6083
6084 Rewrite (N,
6085 Make_And_Then (Loc,
6086 Left_Opnd => Relocate_Node (N),
6087 Right_Opnd => New_N));
6088
6089 Analyze_And_Resolve (N, Restyp);
6090 end if;
6091 end if;
6092 end if;
6093 end;
6094 end if;
6095 end;
6096 end if;
6097
6098 -- At this point, we have done the processing required for the basic
6099 -- membership test, but not yet dealt with the predicate.
6100
6101 <<Leave>>
6102
6103 -- If a predicate is present, then we do the predicate test, but we
6104 -- most certainly want to omit this if we are within the predicate
6105 -- function itself, since otherwise we have an infinite recursion.
6106 -- The check should also not be emitted when testing against a range
6107 -- (the check is only done when the right operand is a subtype; see
6108 -- RM12-4.5.2 (28.1/3-30/3)).
6109
6110 Predicate_Check : declare
6111 function In_Range_Check return Boolean;
6112 -- Within an expanded range check that may raise Constraint_Error do
6113 -- not generate a predicate check as well. It is redundant because
6114 -- the context will add an explicit predicate check, and it will
6115 -- raise the wrong exception if it fails.
6116
6117 --------------------
6118 -- In_Range_Check --
6119 --------------------
6120
6121 function In_Range_Check return Boolean is
6122 P : Node_Id;
6123 begin
6124 P := Parent (N);
6125 while Present (P) loop
6126 if Nkind (P) = N_Raise_Constraint_Error then
6127 return True;
6128
6129 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
6130 or else Nkind (P) = N_Procedure_Call_Statement
6131 or else Nkind (P) in N_Declaration
6132 then
6133 return False;
6134 end if;
6135
6136 P := Parent (P);
6137 end loop;
6138
6139 return False;
6140 end In_Range_Check;
6141
6142 -- Local variables
6143
6144 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6145 R_Op : Node_Id;
6146
6147 -- Start of processing for Predicate_Check
6148
6149 begin
6150 if Present (PFunc)
6151 and then Current_Scope /= PFunc
6152 and then Nkind (Rop) /= N_Range
6153 then
6154 if not In_Range_Check then
6155 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
6156 else
6157 R_Op := New_Occurrence_Of (Standard_True, Loc);
6158 end if;
6159
6160 Rewrite (N,
6161 Make_And_Then (Loc,
6162 Left_Opnd => Relocate_Node (N),
6163 Right_Opnd => R_Op));
6164
6165 -- Analyze new expression, mark left operand as analyzed to
6166 -- avoid infinite recursion adding predicate calls. Similarly,
6167 -- suppress further range checks on the call.
6168
6169 Set_Analyzed (Left_Opnd (N));
6170 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6171
6172 -- All done, skip attempt at compile time determination of result
6173
6174 return;
6175 end if;
6176 end Predicate_Check;
6177 end Expand_N_In;
6178
6179 --------------------------------
6180 -- Expand_N_Indexed_Component --
6181 --------------------------------
6182
6183 procedure Expand_N_Indexed_Component (N : Node_Id) is
6184 Loc : constant Source_Ptr := Sloc (N);
6185 Typ : constant Entity_Id := Etype (N);
6186 P : constant Node_Id := Prefix (N);
6187 T : constant Entity_Id := Etype (P);
6188 Atp : Entity_Id;
6189
6190 begin
6191 -- A special optimization, if we have an indexed component that is
6192 -- selecting from a slice, then we can eliminate the slice, since, for
6193 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6194 -- the range check required by the slice. The range check for the slice
6195 -- itself has already been generated. The range check for the
6196 -- subscripting operation is ensured by converting the subject to
6197 -- the subtype of the slice.
6198
6199 -- This optimization not only generates better code, avoiding slice
6200 -- messing especially in the packed case, but more importantly bypasses
6201 -- some problems in handling this peculiar case, for example, the issue
6202 -- of dealing specially with object renamings.
6203
6204 if Nkind (P) = N_Slice
6205
6206 -- This optimization is disabled for CodePeer because it can transform
6207 -- an index-check constraint_error into a range-check constraint_error
6208 -- and CodePeer cares about that distinction.
6209
6210 and then not CodePeer_Mode
6211 then
6212 Rewrite (N,
6213 Make_Indexed_Component (Loc,
6214 Prefix => Prefix (P),
6215 Expressions => New_List (
6216 Convert_To
6217 (Etype (First_Index (Etype (P))),
6218 First (Expressions (N))))));
6219 Analyze_And_Resolve (N, Typ);
6220 return;
6221 end if;
6222
6223 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6224 -- function, then additional actuals must be passed.
6225
6226 if Ada_Version >= Ada_2005
6227 and then Is_Build_In_Place_Function_Call (P)
6228 then
6229 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6230 end if;
6231
6232 -- If the prefix is an access type, then we unconditionally rewrite if
6233 -- as an explicit dereference. This simplifies processing for several
6234 -- cases, including packed array cases and certain cases in which checks
6235 -- must be generated. We used to try to do this only when it was
6236 -- necessary, but it cleans up the code to do it all the time.
6237
6238 if Is_Access_Type (T) then
6239 Insert_Explicit_Dereference (P);
6240 Analyze_And_Resolve (P, Designated_Type (T));
6241 Atp := Designated_Type (T);
6242 else
6243 Atp := T;
6244 end if;
6245
6246 -- Generate index and validity checks
6247
6248 Generate_Index_Checks (N);
6249
6250 if Validity_Checks_On and then Validity_Check_Subscripts then
6251 Apply_Subscript_Validity_Checks (N);
6252 end if;
6253
6254 -- If selecting from an array with atomic components, and atomic sync
6255 -- is not suppressed for this array type, set atomic sync flag.
6256
6257 if (Has_Atomic_Components (Atp)
6258 and then not Atomic_Synchronization_Disabled (Atp))
6259 or else (Is_Atomic (Typ)
6260 and then not Atomic_Synchronization_Disabled (Typ))
6261 or else (Is_Entity_Name (P)
6262 and then Has_Atomic_Components (Entity (P))
6263 and then not Atomic_Synchronization_Disabled (Entity (P)))
6264 then
6265 Activate_Atomic_Synchronization (N);
6266 end if;
6267
6268 -- All done if the prefix is not a packed array implemented specially
6269
6270 if not (Is_Packed (Etype (Prefix (N)))
6271 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
6272 then
6273 return;
6274 end if;
6275
6276 -- For packed arrays that are not bit-packed (i.e. the case of an array
6277 -- with one or more index types with a non-contiguous enumeration type),
6278 -- we can always use the normal packed element get circuit.
6279
6280 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6281 Expand_Packed_Element_Reference (N);
6282 return;
6283 end if;
6284
6285 -- For a reference to a component of a bit packed array, we convert it
6286 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6287 -- want to do this for simple references, and not for:
6288
6289 -- Left side of assignment, or prefix of left side of assignment, or
6290 -- prefix of the prefix, to handle packed arrays of packed arrays,
6291 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6292
6293 -- Renaming objects in renaming associations
6294 -- This case is handled when a use of the renamed variable occurs
6295
6296 -- Actual parameters for a procedure call
6297 -- This case is handled in Exp_Ch6.Expand_Actuals
6298
6299 -- The second expression in a 'Read attribute reference
6300
6301 -- The prefix of an address or bit or size attribute reference
6302
6303 -- The following circuit detects these exceptions. Note that we need to
6304 -- deal with implicit dereferences when climbing up the parent chain,
6305 -- with the additional difficulty that the type of parents may have yet
6306 -- to be resolved since prefixes are usually resolved first.
6307
6308 declare
6309 Child : Node_Id := N;
6310 Parnt : Node_Id := Parent (N);
6311
6312 begin
6313 loop
6314 if Nkind (Parnt) = N_Unchecked_Expression then
6315 null;
6316
6317 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
6318 N_Procedure_Call_Statement)
6319 or else (Nkind (Parnt) = N_Parameter_Association
6320 and then
6321 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
6322 then
6323 return;
6324
6325 elsif Nkind (Parnt) = N_Attribute_Reference
6326 and then Nam_In (Attribute_Name (Parnt), Name_Address,
6327 Name_Bit,
6328 Name_Size)
6329 and then Prefix (Parnt) = Child
6330 then
6331 return;
6332
6333 elsif Nkind (Parnt) = N_Assignment_Statement
6334 and then Name (Parnt) = Child
6335 then
6336 return;
6337
6338 -- If the expression is an index of an indexed component, it must
6339 -- be expanded regardless of context.
6340
6341 elsif Nkind (Parnt) = N_Indexed_Component
6342 and then Child /= Prefix (Parnt)
6343 then
6344 Expand_Packed_Element_Reference (N);
6345 return;
6346
6347 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
6348 and then Name (Parent (Parnt)) = Parnt
6349 then
6350 return;
6351
6352 elsif Nkind (Parnt) = N_Attribute_Reference
6353 and then Attribute_Name (Parnt) = Name_Read
6354 and then Next (First (Expressions (Parnt))) = Child
6355 then
6356 return;
6357
6358 elsif Nkind (Parnt) = N_Indexed_Component
6359 and then Prefix (Parnt) = Child
6360 then
6361 null;
6362
6363 elsif Nkind (Parnt) = N_Selected_Component
6364 and then Prefix (Parnt) = Child
6365 and then not (Present (Etype (Selector_Name (Parnt)))
6366 and then
6367 Is_Access_Type (Etype (Selector_Name (Parnt))))
6368 then
6369 null;
6370
6371 -- If the parent is a dereference, either implicit or explicit,
6372 -- then the packed reference needs to be expanded.
6373
6374 else
6375 Expand_Packed_Element_Reference (N);
6376 return;
6377 end if;
6378
6379 -- Keep looking up tree for unchecked expression, or if we are the
6380 -- prefix of a possible assignment left side.
6381
6382 Child := Parnt;
6383 Parnt := Parent (Child);
6384 end loop;
6385 end;
6386 end Expand_N_Indexed_Component;
6387
6388 ---------------------
6389 -- Expand_N_Not_In --
6390 ---------------------
6391
6392 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6393 -- can be done. This avoids needing to duplicate this expansion code.
6394
6395 procedure Expand_N_Not_In (N : Node_Id) is
6396 Loc : constant Source_Ptr := Sloc (N);
6397 Typ : constant Entity_Id := Etype (N);
6398 Cfs : constant Boolean := Comes_From_Source (N);
6399
6400 begin
6401 Rewrite (N,
6402 Make_Op_Not (Loc,
6403 Right_Opnd =>
6404 Make_In (Loc,
6405 Left_Opnd => Left_Opnd (N),
6406 Right_Opnd => Right_Opnd (N))));
6407
6408 -- If this is a set membership, preserve list of alternatives
6409
6410 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
6411
6412 -- We want this to appear as coming from source if original does (see
6413 -- transformations in Expand_N_In).
6414
6415 Set_Comes_From_Source (N, Cfs);
6416 Set_Comes_From_Source (Right_Opnd (N), Cfs);
6417
6418 -- Now analyze transformed node
6419
6420 Analyze_And_Resolve (N, Typ);
6421 end Expand_N_Not_In;
6422
6423 -------------------
6424 -- Expand_N_Null --
6425 -------------------
6426
6427 -- The only replacement required is for the case of a null of a type that
6428 -- is an access to protected subprogram, or a subtype thereof. We represent
6429 -- such access values as a record, and so we must replace the occurrence of
6430 -- null by the equivalent record (with a null address and a null pointer in
6431 -- it), so that the backend creates the proper value.
6432
6433 procedure Expand_N_Null (N : Node_Id) is
6434 Loc : constant Source_Ptr := Sloc (N);
6435 Typ : constant Entity_Id := Base_Type (Etype (N));
6436 Agg : Node_Id;
6437
6438 begin
6439 if Is_Access_Protected_Subprogram_Type (Typ) then
6440 Agg :=
6441 Make_Aggregate (Loc,
6442 Expressions => New_List (
6443 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
6444 Make_Null (Loc)));
6445
6446 Rewrite (N, Agg);
6447 Analyze_And_Resolve (N, Equivalent_Type (Typ));
6448
6449 -- For subsequent semantic analysis, the node must retain its type.
6450 -- Gigi in any case replaces this type by the corresponding record
6451 -- type before processing the node.
6452
6453 Set_Etype (N, Typ);
6454 end if;
6455
6456 exception
6457 when RE_Not_Available =>
6458 return;
6459 end Expand_N_Null;
6460
6461 ---------------------
6462 -- Expand_N_Op_Abs --
6463 ---------------------
6464
6465 procedure Expand_N_Op_Abs (N : Node_Id) is
6466 Loc : constant Source_Ptr := Sloc (N);
6467 Expr : constant Node_Id := Right_Opnd (N);
6468
6469 begin
6470 Unary_Op_Validity_Checks (N);
6471
6472 -- Check for MINIMIZED/ELIMINATED overflow mode
6473
6474 if Minimized_Eliminated_Overflow_Check (N) then
6475 Apply_Arithmetic_Overflow_Check (N);
6476 return;
6477 end if;
6478
6479 -- Deal with software overflow checking
6480
6481 if not Backend_Overflow_Checks_On_Target
6482 and then Is_Signed_Integer_Type (Etype (N))
6483 and then Do_Overflow_Check (N)
6484 then
6485 -- The only case to worry about is when the argument is equal to the
6486 -- largest negative number, so what we do is to insert the check:
6487
6488 -- [constraint_error when Expr = typ'Base'First]
6489
6490 -- with the usual Duplicate_Subexpr use coding for expr
6491
6492 Insert_Action (N,
6493 Make_Raise_Constraint_Error (Loc,
6494 Condition =>
6495 Make_Op_Eq (Loc,
6496 Left_Opnd => Duplicate_Subexpr (Expr),
6497 Right_Opnd =>
6498 Make_Attribute_Reference (Loc,
6499 Prefix =>
6500 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
6501 Attribute_Name => Name_First)),
6502 Reason => CE_Overflow_Check_Failed));
6503 end if;
6504 end Expand_N_Op_Abs;
6505
6506 ---------------------
6507 -- Expand_N_Op_Add --
6508 ---------------------
6509
6510 procedure Expand_N_Op_Add (N : Node_Id) is
6511 Typ : constant Entity_Id := Etype (N);
6512
6513 begin
6514 Binary_Op_Validity_Checks (N);
6515
6516 -- Check for MINIMIZED/ELIMINATED overflow mode
6517
6518 if Minimized_Eliminated_Overflow_Check (N) then
6519 Apply_Arithmetic_Overflow_Check (N);
6520 return;
6521 end if;
6522
6523 -- N + 0 = 0 + N = N for integer types
6524
6525 if Is_Integer_Type (Typ) then
6526 if Compile_Time_Known_Value (Right_Opnd (N))
6527 and then Expr_Value (Right_Opnd (N)) = Uint_0
6528 then
6529 Rewrite (N, Left_Opnd (N));
6530 return;
6531
6532 elsif Compile_Time_Known_Value (Left_Opnd (N))
6533 and then Expr_Value (Left_Opnd (N)) = Uint_0
6534 then
6535 Rewrite (N, Right_Opnd (N));
6536 return;
6537 end if;
6538 end if;
6539
6540 -- Arithmetic overflow checks for signed integer/fixed point types
6541
6542 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
6543 Apply_Arithmetic_Overflow_Check (N);
6544 return;
6545 end if;
6546
6547 -- Overflow checks for floating-point if -gnateF mode active
6548
6549 Check_Float_Op_Overflow (N);
6550 end Expand_N_Op_Add;
6551
6552 ---------------------
6553 -- Expand_N_Op_And --
6554 ---------------------
6555
6556 procedure Expand_N_Op_And (N : Node_Id) is
6557 Typ : constant Entity_Id := Etype (N);
6558
6559 begin
6560 Binary_Op_Validity_Checks (N);
6561
6562 if Is_Array_Type (Etype (N)) then
6563 Expand_Boolean_Operator (N);
6564
6565 elsif Is_Boolean_Type (Etype (N)) then
6566 Adjust_Condition (Left_Opnd (N));
6567 Adjust_Condition (Right_Opnd (N));
6568 Set_Etype (N, Standard_Boolean);
6569 Adjust_Result_Type (N, Typ);
6570
6571 elsif Is_Intrinsic_Subprogram (Entity (N)) then
6572 Expand_Intrinsic_Call (N, Entity (N));
6573
6574 end if;
6575 end Expand_N_Op_And;
6576
6577 ------------------------
6578 -- Expand_N_Op_Concat --
6579 ------------------------
6580
6581 procedure Expand_N_Op_Concat (N : Node_Id) is
6582 Opnds : List_Id;
6583 -- List of operands to be concatenated
6584
6585 Cnode : Node_Id;
6586 -- Node which is to be replaced by the result of concatenating the nodes
6587 -- in the list Opnds.
6588
6589 begin
6590 -- Ensure validity of both operands
6591
6592 Binary_Op_Validity_Checks (N);
6593
6594 -- If we are the left operand of a concatenation higher up the tree,
6595 -- then do nothing for now, since we want to deal with a series of
6596 -- concatenations as a unit.
6597
6598 if Nkind (Parent (N)) = N_Op_Concat
6599 and then N = Left_Opnd (Parent (N))
6600 then
6601 return;
6602 end if;
6603
6604 -- We get here with a concatenation whose left operand may be a
6605 -- concatenation itself with a consistent type. We need to process
6606 -- these concatenation operands from left to right, which means
6607 -- from the deepest node in the tree to the highest node.
6608
6609 Cnode := N;
6610 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
6611 Cnode := Left_Opnd (Cnode);
6612 end loop;
6613
6614 -- Now Cnode is the deepest concatenation, and its parents are the
6615 -- concatenation nodes above, so now we process bottom up, doing the
6616 -- operands.
6617
6618 -- The outer loop runs more than once if more than one concatenation
6619 -- type is involved.
6620
6621 Outer : loop
6622 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
6623 Set_Parent (Opnds, N);
6624
6625 -- The inner loop gathers concatenation operands
6626
6627 Inner : while Cnode /= N
6628 and then Base_Type (Etype (Cnode)) =
6629 Base_Type (Etype (Parent (Cnode)))
6630 loop
6631 Cnode := Parent (Cnode);
6632 Append (Right_Opnd (Cnode), Opnds);
6633 end loop Inner;
6634
6635 -- Note: The following code is a temporary workaround for N731-034
6636 -- and N829-028 and will be kept until the general issue of internal
6637 -- symbol serialization is addressed. The workaround is kept under a
6638 -- debug switch to avoid permiating into the general case.
6639
6640 -- Wrap the node to concatenate into an expression actions node to
6641 -- keep it nicely packaged. This is useful in the case of an assert
6642 -- pragma with a concatenation where we want to be able to delete
6643 -- the concatenation and all its expansion stuff.
6644
6645 if Debug_Flag_Dot_H then
6646 declare
6647 Cnod : constant Node_Id := Relocate_Node (Cnode);
6648 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
6649
6650 begin
6651 -- Note: use Rewrite rather than Replace here, so that for
6652 -- example Why_Not_Static can find the original concatenation
6653 -- node OK!
6654
6655 Rewrite (Cnode,
6656 Make_Expression_With_Actions (Sloc (Cnode),
6657 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
6658 Expression => Cnod));
6659
6660 Expand_Concatenate (Cnod, Opnds);
6661 Analyze_And_Resolve (Cnode, Typ);
6662 end;
6663
6664 -- Default case
6665
6666 else
6667 Expand_Concatenate (Cnode, Opnds);
6668 end if;
6669
6670 exit Outer when Cnode = N;
6671 Cnode := Parent (Cnode);
6672 end loop Outer;
6673 end Expand_N_Op_Concat;
6674
6675 ------------------------
6676 -- Expand_N_Op_Divide --
6677 ------------------------
6678
6679 procedure Expand_N_Op_Divide (N : Node_Id) is
6680 Loc : constant Source_Ptr := Sloc (N);
6681 Lopnd : constant Node_Id := Left_Opnd (N);
6682 Ropnd : constant Node_Id := Right_Opnd (N);
6683 Ltyp : constant Entity_Id := Etype (Lopnd);
6684 Rtyp : constant Entity_Id := Etype (Ropnd);
6685 Typ : Entity_Id := Etype (N);
6686 Rknow : constant Boolean := Is_Integer_Type (Typ)
6687 and then
6688 Compile_Time_Known_Value (Ropnd);
6689 Rval : Uint;
6690
6691 begin
6692 Binary_Op_Validity_Checks (N);
6693
6694 -- Check for MINIMIZED/ELIMINATED overflow mode
6695
6696 if Minimized_Eliminated_Overflow_Check (N) then
6697 Apply_Arithmetic_Overflow_Check (N);
6698 return;
6699 end if;
6700
6701 -- Otherwise proceed with expansion of division
6702
6703 if Rknow then
6704 Rval := Expr_Value (Ropnd);
6705 end if;
6706
6707 -- N / 1 = N for integer types
6708
6709 if Rknow and then Rval = Uint_1 then
6710 Rewrite (N, Lopnd);
6711 return;
6712 end if;
6713
6714 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6715 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6716 -- operand is an unsigned integer, as required for this to work.
6717
6718 if Nkind (Ropnd) = N_Op_Expon
6719 and then Is_Power_Of_2_For_Shift (Ropnd)
6720
6721 -- We cannot do this transformation in configurable run time mode if we
6722 -- have 64-bit integers and long shifts are not available.
6723
6724 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
6725 then
6726 Rewrite (N,
6727 Make_Op_Shift_Right (Loc,
6728 Left_Opnd => Lopnd,
6729 Right_Opnd =>
6730 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
6731 Analyze_And_Resolve (N, Typ);
6732 return;
6733 end if;
6734
6735 -- Do required fixup of universal fixed operation
6736
6737 if Typ = Universal_Fixed then
6738 Fixup_Universal_Fixed_Operation (N);
6739 Typ := Etype (N);
6740 end if;
6741
6742 -- Divisions with fixed-point results
6743
6744 if Is_Fixed_Point_Type (Typ) then
6745
6746 -- Deal with divide-by-zero check if back end cannot handle them
6747 -- and the flag is set indicating that we need such a check. Note
6748 -- that we don't need to bother here with the case of mixed-mode
6749 -- (Right operand an integer type), since these will be rewritten
6750 -- with conversions to a divide with a fixed-point right operand.
6751
6752 if Do_Division_Check (N)
6753 and then not Backend_Divide_Checks_On_Target
6754 and then not Is_Integer_Type (Rtyp)
6755 then
6756 Set_Do_Division_Check (N, False);
6757 Insert_Action (N,
6758 Make_Raise_Constraint_Error (Loc,
6759 Condition =>
6760 Make_Op_Eq (Loc,
6761 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
6762 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
6763 Reason => CE_Divide_By_Zero));
6764 end if;
6765
6766 -- No special processing if Treat_Fixed_As_Integer is set, since
6767 -- from a semantic point of view such operations are simply integer
6768 -- operations and will be treated that way.
6769
6770 if not Treat_Fixed_As_Integer (N) then
6771 if Is_Integer_Type (Rtyp) then
6772 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
6773 else
6774 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
6775 end if;
6776 end if;
6777
6778 -- Other cases of division of fixed-point operands. Again we exclude the
6779 -- case where Treat_Fixed_As_Integer is set.
6780
6781 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6782 and then not Treat_Fixed_As_Integer (N)
6783 then
6784 if Is_Integer_Type (Typ) then
6785 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
6786 else
6787 pragma Assert (Is_Floating_Point_Type (Typ));
6788 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
6789 end if;
6790
6791 -- Mixed-mode operations can appear in a non-static universal context,
6792 -- in which case the integer argument must be converted explicitly.
6793
6794 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
6795 Rewrite (Ropnd,
6796 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
6797
6798 Analyze_And_Resolve (Ropnd, Universal_Real);
6799
6800 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
6801 Rewrite (Lopnd,
6802 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
6803
6804 Analyze_And_Resolve (Lopnd, Universal_Real);
6805
6806 -- Non-fixed point cases, do integer zero divide and overflow checks
6807
6808 elsif Is_Integer_Type (Typ) then
6809 Apply_Divide_Checks (N);
6810 end if;
6811
6812 -- Overflow checks for floating-point if -gnateF mode active
6813
6814 Check_Float_Op_Overflow (N);
6815 end Expand_N_Op_Divide;
6816
6817 --------------------
6818 -- Expand_N_Op_Eq --
6819 --------------------
6820
6821 procedure Expand_N_Op_Eq (N : Node_Id) is
6822 Loc : constant Source_Ptr := Sloc (N);
6823 Typ : constant Entity_Id := Etype (N);
6824 Lhs : constant Node_Id := Left_Opnd (N);
6825 Rhs : constant Node_Id := Right_Opnd (N);
6826 Bodies : constant List_Id := New_List;
6827 A_Typ : constant Entity_Id := Etype (Lhs);
6828
6829 Typl : Entity_Id := A_Typ;
6830 Op_Name : Entity_Id;
6831 Prim : Elmt_Id;
6832
6833 procedure Build_Equality_Call (Eq : Entity_Id);
6834 -- If a constructed equality exists for the type or for its parent,
6835 -- build and analyze call, adding conversions if the operation is
6836 -- inherited.
6837
6838 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
6839 -- Determines whether a type has a subcomponent of an unconstrained
6840 -- Unchecked_Union subtype. Typ is a record type.
6841
6842 -------------------------
6843 -- Build_Equality_Call --
6844 -------------------------
6845
6846 procedure Build_Equality_Call (Eq : Entity_Id) is
6847 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
6848 L_Exp : Node_Id := Relocate_Node (Lhs);
6849 R_Exp : Node_Id := Relocate_Node (Rhs);
6850
6851 begin
6852 -- Adjust operands if necessary to comparison type
6853
6854 if Base_Type (Op_Type) /= Base_Type (A_Typ)
6855 and then not Is_Class_Wide_Type (A_Typ)
6856 then
6857 L_Exp := OK_Convert_To (Op_Type, L_Exp);
6858 R_Exp := OK_Convert_To (Op_Type, R_Exp);
6859 end if;
6860
6861 -- If we have an Unchecked_Union, we need to add the inferred
6862 -- discriminant values as actuals in the function call. At this
6863 -- point, the expansion has determined that both operands have
6864 -- inferable discriminants.
6865
6866 if Is_Unchecked_Union (Op_Type) then
6867 declare
6868 Lhs_Type : constant Node_Id := Etype (L_Exp);
6869 Rhs_Type : constant Node_Id := Etype (R_Exp);
6870
6871 Lhs_Discr_Vals : Elist_Id;
6872 -- List of inferred discriminant values for left operand.
6873
6874 Rhs_Discr_Vals : Elist_Id;
6875 -- List of inferred discriminant values for right operand.
6876
6877 Discr : Entity_Id;
6878
6879 begin
6880 Lhs_Discr_Vals := New_Elmt_List;
6881 Rhs_Discr_Vals := New_Elmt_List;
6882
6883 -- Per-object constrained selected components require special
6884 -- attention. If the enclosing scope of the component is an
6885 -- Unchecked_Union, we cannot reference its discriminants
6886 -- directly. This is why we use the extra parameters of the
6887 -- equality function of the enclosing Unchecked_Union.
6888
6889 -- type UU_Type (Discr : Integer := 0) is
6890 -- . . .
6891 -- end record;
6892 -- pragma Unchecked_Union (UU_Type);
6893
6894 -- 1. Unchecked_Union enclosing record:
6895
6896 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6897 -- . . .
6898 -- Comp : UU_Type (Discr);
6899 -- . . .
6900 -- end Enclosing_UU_Type;
6901 -- pragma Unchecked_Union (Enclosing_UU_Type);
6902
6903 -- Obj1 : Enclosing_UU_Type;
6904 -- Obj2 : Enclosing_UU_Type (1);
6905
6906 -- [. . .] Obj1 = Obj2 [. . .]
6907
6908 -- Generated code:
6909
6910 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6911
6912 -- A and B are the formal parameters of the equality function
6913 -- of Enclosing_UU_Type. The function always has two extra
6914 -- formals to capture the inferred discriminant values for
6915 -- each discriminant of the type.
6916
6917 -- 2. Non-Unchecked_Union enclosing record:
6918
6919 -- type
6920 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6921 -- is record
6922 -- . . .
6923 -- Comp : UU_Type (Discr);
6924 -- . . .
6925 -- end Enclosing_Non_UU_Type;
6926
6927 -- Obj1 : Enclosing_Non_UU_Type;
6928 -- Obj2 : Enclosing_Non_UU_Type (1);
6929
6930 -- ... Obj1 = Obj2 ...
6931
6932 -- Generated code:
6933
6934 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6935 -- obj1.discr, obj2.discr)) then
6936
6937 -- In this case we can directly reference the discriminants of
6938 -- the enclosing record.
6939
6940 -- Process left operand of equality
6941
6942 if Nkind (Lhs) = N_Selected_Component
6943 and then
6944 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
6945 then
6946 -- If enclosing record is an Unchecked_Union, use formals
6947 -- corresponding to each discriminant. The name of the
6948 -- formal is that of the discriminant, with added suffix,
6949 -- see Exp_Ch3.Build_Record_Equality for details.
6950
6951 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
6952 then
6953 Discr :=
6954 First_Discriminant
6955 (Scope (Entity (Selector_Name (Lhs))));
6956 while Present (Discr) loop
6957 Append_Elmt
6958 (Make_Identifier (Loc,
6959 Chars => New_External_Name (Chars (Discr), 'A')),
6960 To => Lhs_Discr_Vals);
6961 Next_Discriminant (Discr);
6962 end loop;
6963
6964 -- If enclosing record is of a non-Unchecked_Union type, it
6965 -- is possible to reference its discriminants directly.
6966
6967 else
6968 Discr := First_Discriminant (Lhs_Type);
6969 while Present (Discr) loop
6970 Append_Elmt
6971 (Make_Selected_Component (Loc,
6972 Prefix => Prefix (Lhs),
6973 Selector_Name =>
6974 New_Copy
6975 (Get_Discriminant_Value (Discr,
6976 Lhs_Type,
6977 Stored_Constraint (Lhs_Type)))),
6978 To => Lhs_Discr_Vals);
6979 Next_Discriminant (Discr);
6980 end loop;
6981 end if;
6982
6983 -- Otherwise operand is on object with a constrained type.
6984 -- Infer the discriminant values from the constraint.
6985
6986 else
6987
6988 Discr := First_Discriminant (Lhs_Type);
6989 while Present (Discr) loop
6990 Append_Elmt
6991 (New_Copy
6992 (Get_Discriminant_Value (Discr,
6993 Lhs_Type,
6994 Stored_Constraint (Lhs_Type))),
6995 To => Lhs_Discr_Vals);
6996 Next_Discriminant (Discr);
6997 end loop;
6998 end if;
6999
7000 -- Similar processing for right operand of equality
7001
7002 if Nkind (Rhs) = N_Selected_Component
7003 and then
7004 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7005 then
7006 if Is_Unchecked_Union
7007 (Scope (Entity (Selector_Name (Rhs))))
7008 then
7009 Discr :=
7010 First_Discriminant
7011 (Scope (Entity (Selector_Name (Rhs))));
7012 while Present (Discr) loop
7013 Append_Elmt
7014 (Make_Identifier (Loc,
7015 Chars => New_External_Name (Chars (Discr), 'B')),
7016 To => Rhs_Discr_Vals);
7017 Next_Discriminant (Discr);
7018 end loop;
7019
7020 else
7021 Discr := First_Discriminant (Rhs_Type);
7022 while Present (Discr) loop
7023 Append_Elmt
7024 (Make_Selected_Component (Loc,
7025 Prefix => Prefix (Rhs),
7026 Selector_Name =>
7027 New_Copy (Get_Discriminant_Value
7028 (Discr,
7029 Rhs_Type,
7030 Stored_Constraint (Rhs_Type)))),
7031 To => Rhs_Discr_Vals);
7032 Next_Discriminant (Discr);
7033 end loop;
7034 end if;
7035
7036 else
7037 Discr := First_Discriminant (Rhs_Type);
7038 while Present (Discr) loop
7039 Append_Elmt
7040 (New_Copy (Get_Discriminant_Value
7041 (Discr,
7042 Rhs_Type,
7043 Stored_Constraint (Rhs_Type))),
7044 To => Rhs_Discr_Vals);
7045 Next_Discriminant (Discr);
7046 end loop;
7047 end if;
7048
7049 -- Now merge the list of discriminant values so that values
7050 -- of corresponding discriminants are adjacent.
7051
7052 declare
7053 Params : List_Id;
7054 L_Elmt : Elmt_Id;
7055 R_Elmt : Elmt_Id;
7056
7057 begin
7058 Params := New_List (L_Exp, R_Exp);
7059 L_Elmt := First_Elmt (Lhs_Discr_Vals);
7060 R_Elmt := First_Elmt (Rhs_Discr_Vals);
7061 while Present (L_Elmt) loop
7062 Append_To (Params, Node (L_Elmt));
7063 Append_To (Params, Node (R_Elmt));
7064 Next_Elmt (L_Elmt);
7065 Next_Elmt (R_Elmt);
7066 end loop;
7067
7068 Rewrite (N,
7069 Make_Function_Call (Loc,
7070 Name => New_Occurrence_Of (Eq, Loc),
7071 Parameter_Associations => Params));
7072 end;
7073 end;
7074
7075 -- Normal case, not an unchecked union
7076
7077 else
7078 Rewrite (N,
7079 Make_Function_Call (Loc,
7080 Name => New_Occurrence_Of (Eq, Loc),
7081 Parameter_Associations => New_List (L_Exp, R_Exp)));
7082 end if;
7083
7084 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7085 end Build_Equality_Call;
7086
7087 ------------------------------------
7088 -- Has_Unconstrained_UU_Component --
7089 ------------------------------------
7090
7091 function Has_Unconstrained_UU_Component
7092 (Typ : Node_Id) return Boolean
7093 is
7094 Tdef : constant Node_Id :=
7095 Type_Definition (Declaration_Node (Base_Type (Typ)));
7096 Clist : Node_Id;
7097 Vpart : Node_Id;
7098
7099 function Component_Is_Unconstrained_UU
7100 (Comp : Node_Id) return Boolean;
7101 -- Determines whether the subtype of the component is an
7102 -- unconstrained Unchecked_Union.
7103
7104 function Variant_Is_Unconstrained_UU
7105 (Variant : Node_Id) return Boolean;
7106 -- Determines whether a component of the variant has an unconstrained
7107 -- Unchecked_Union subtype.
7108
7109 -----------------------------------
7110 -- Component_Is_Unconstrained_UU --
7111 -----------------------------------
7112
7113 function Component_Is_Unconstrained_UU
7114 (Comp : Node_Id) return Boolean
7115 is
7116 begin
7117 if Nkind (Comp) /= N_Component_Declaration then
7118 return False;
7119 end if;
7120
7121 declare
7122 Sindic : constant Node_Id :=
7123 Subtype_Indication (Component_Definition (Comp));
7124
7125 begin
7126 -- Unconstrained nominal type. In the case of a constraint
7127 -- present, the node kind would have been N_Subtype_Indication.
7128
7129 if Nkind (Sindic) = N_Identifier then
7130 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7131 end if;
7132
7133 return False;
7134 end;
7135 end Component_Is_Unconstrained_UU;
7136
7137 ---------------------------------
7138 -- Variant_Is_Unconstrained_UU --
7139 ---------------------------------
7140
7141 function Variant_Is_Unconstrained_UU
7142 (Variant : Node_Id) return Boolean
7143 is
7144 Clist : constant Node_Id := Component_List (Variant);
7145
7146 begin
7147 if Is_Empty_List (Component_Items (Clist)) then
7148 return False;
7149 end if;
7150
7151 -- We only need to test one component
7152
7153 declare
7154 Comp : Node_Id := First (Component_Items (Clist));
7155
7156 begin
7157 while Present (Comp) loop
7158 if Component_Is_Unconstrained_UU (Comp) then
7159 return True;
7160 end if;
7161
7162 Next (Comp);
7163 end loop;
7164 end;
7165
7166 -- None of the components withing the variant were of
7167 -- unconstrained Unchecked_Union type.
7168
7169 return False;
7170 end Variant_Is_Unconstrained_UU;
7171
7172 -- Start of processing for Has_Unconstrained_UU_Component
7173
7174 begin
7175 if Null_Present (Tdef) then
7176 return False;
7177 end if;
7178
7179 Clist := Component_List (Tdef);
7180 Vpart := Variant_Part (Clist);
7181
7182 -- Inspect available components
7183
7184 if Present (Component_Items (Clist)) then
7185 declare
7186 Comp : Node_Id := First (Component_Items (Clist));
7187
7188 begin
7189 while Present (Comp) loop
7190
7191 -- One component is sufficient
7192
7193 if Component_Is_Unconstrained_UU (Comp) then
7194 return True;
7195 end if;
7196
7197 Next (Comp);
7198 end loop;
7199 end;
7200 end if;
7201
7202 -- Inspect available components withing variants
7203
7204 if Present (Vpart) then
7205 declare
7206 Variant : Node_Id := First (Variants (Vpart));
7207
7208 begin
7209 while Present (Variant) loop
7210
7211 -- One component within a variant is sufficient
7212
7213 if Variant_Is_Unconstrained_UU (Variant) then
7214 return True;
7215 end if;
7216
7217 Next (Variant);
7218 end loop;
7219 end;
7220 end if;
7221
7222 -- Neither the available components, nor the components inside the
7223 -- variant parts were of an unconstrained Unchecked_Union subtype.
7224
7225 return False;
7226 end Has_Unconstrained_UU_Component;
7227
7228 -- Start of processing for Expand_N_Op_Eq
7229
7230 begin
7231 Binary_Op_Validity_Checks (N);
7232
7233 -- Deal with private types
7234
7235 if Ekind (Typl) = E_Private_Type then
7236 Typl := Underlying_Type (Typl);
7237 elsif Ekind (Typl) = E_Private_Subtype then
7238 Typl := Underlying_Type (Base_Type (Typl));
7239 else
7240 null;
7241 end if;
7242
7243 -- It may happen in error situations that the underlying type is not
7244 -- set. The error will be detected later, here we just defend the
7245 -- expander code.
7246
7247 if No (Typl) then
7248 return;
7249 end if;
7250
7251 -- Now get the implementation base type (note that plain Base_Type here
7252 -- might lead us back to the private type, which is not what we want!)
7253
7254 Typl := Implementation_Base_Type (Typl);
7255
7256 -- Equality between variant records results in a call to a routine
7257 -- that has conditional tests of the discriminant value(s), and hence
7258 -- violates the No_Implicit_Conditionals restriction.
7259
7260 if Has_Variant_Part (Typl) then
7261 declare
7262 Msg : Boolean;
7263
7264 begin
7265 Check_Restriction (Msg, No_Implicit_Conditionals, N);
7266
7267 if Msg then
7268 Error_Msg_N
7269 ("\comparison of variant records tests discriminants", N);
7270 return;
7271 end if;
7272 end;
7273 end if;
7274
7275 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7276 -- means we no longer have a comparison operation, we are all done.
7277
7278 Expand_Compare_Minimize_Eliminate_Overflow (N);
7279
7280 if Nkind (N) /= N_Op_Eq then
7281 return;
7282 end if;
7283
7284 -- Boolean types (requiring handling of non-standard case)
7285
7286 if Is_Boolean_Type (Typl) then
7287 Adjust_Condition (Left_Opnd (N));
7288 Adjust_Condition (Right_Opnd (N));
7289 Set_Etype (N, Standard_Boolean);
7290 Adjust_Result_Type (N, Typ);
7291
7292 -- Array types
7293
7294 elsif Is_Array_Type (Typl) then
7295
7296 -- If we are doing full validity checking, and it is possible for the
7297 -- array elements to be invalid then expand out array comparisons to
7298 -- make sure that we check the array elements.
7299
7300 if Validity_Check_Operands
7301 and then not Is_Known_Valid (Component_Type (Typl))
7302 then
7303 declare
7304 Save_Force_Validity_Checks : constant Boolean :=
7305 Force_Validity_Checks;
7306 begin
7307 Force_Validity_Checks := True;
7308 Rewrite (N,
7309 Expand_Array_Equality
7310 (N,
7311 Relocate_Node (Lhs),
7312 Relocate_Node (Rhs),
7313 Bodies,
7314 Typl));
7315 Insert_Actions (N, Bodies);
7316 Analyze_And_Resolve (N, Standard_Boolean);
7317 Force_Validity_Checks := Save_Force_Validity_Checks;
7318 end;
7319
7320 -- Packed case where both operands are known aligned
7321
7322 elsif Is_Bit_Packed_Array (Typl)
7323 and then not Is_Possibly_Unaligned_Object (Lhs)
7324 and then not Is_Possibly_Unaligned_Object (Rhs)
7325 then
7326 Expand_Packed_Eq (N);
7327
7328 -- Where the component type is elementary we can use a block bit
7329 -- comparison (if supported on the target) exception in the case
7330 -- of floating-point (negative zero issues require element by
7331 -- element comparison), and atomic/VFA types (where we must be sure
7332 -- to load elements independently) and possibly unaligned arrays.
7333
7334 elsif Is_Elementary_Type (Component_Type (Typl))
7335 and then not Is_Floating_Point_Type (Component_Type (Typl))
7336 and then not Is_Atomic_Or_VFA (Component_Type (Typl))
7337 and then not Is_Possibly_Unaligned_Object (Lhs)
7338 and then not Is_Possibly_Unaligned_Object (Rhs)
7339 and then Support_Composite_Compare_On_Target
7340 then
7341 null;
7342
7343 -- For composite and floating-point cases, expand equality loop to
7344 -- make sure of using proper comparisons for tagged types, and
7345 -- correctly handling the floating-point case.
7346
7347 else
7348 Rewrite (N,
7349 Expand_Array_Equality
7350 (N,
7351 Relocate_Node (Lhs),
7352 Relocate_Node (Rhs),
7353 Bodies,
7354 Typl));
7355 Insert_Actions (N, Bodies, Suppress => All_Checks);
7356 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7357 end if;
7358
7359 -- Record Types
7360
7361 elsif Is_Record_Type (Typl) then
7362
7363 -- For tagged types, use the primitive "="
7364
7365 if Is_Tagged_Type (Typl) then
7366
7367 -- No need to do anything else compiling under restriction
7368 -- No_Dispatching_Calls. During the semantic analysis we
7369 -- already notified such violation.
7370
7371 if Restriction_Active (No_Dispatching_Calls) then
7372 return;
7373 end if;
7374
7375 -- If this is derived from an untagged private type completed with
7376 -- a tagged type, it does not have a full view, so we use the
7377 -- primitive operations of the private type. This check should no
7378 -- longer be necessary when these types get their full views???
7379
7380 if Is_Private_Type (A_Typ)
7381 and then not Is_Tagged_Type (A_Typ)
7382 and then Is_Derived_Type (A_Typ)
7383 and then No (Full_View (A_Typ))
7384 then
7385 -- Search for equality operation, checking that the operands
7386 -- have the same type. Note that we must find a matching entry,
7387 -- or something is very wrong.
7388
7389 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
7390
7391 while Present (Prim) loop
7392 exit when Chars (Node (Prim)) = Name_Op_Eq
7393 and then Etype (First_Formal (Node (Prim))) =
7394 Etype (Next_Formal (First_Formal (Node (Prim))))
7395 and then
7396 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7397
7398 Next_Elmt (Prim);
7399 end loop;
7400
7401 pragma Assert (Present (Prim));
7402 Op_Name := Node (Prim);
7403
7404 -- Find the type's predefined equality or an overriding
7405 -- user-defined equality. The reason for not simply calling
7406 -- Find_Prim_Op here is that there may be a user-defined
7407 -- overloaded equality op that precedes the equality that we
7408 -- want, so we have to explicitly search (e.g., there could be
7409 -- an equality with two different parameter types).
7410
7411 else
7412 if Is_Class_Wide_Type (Typl) then
7413 Typl := Find_Specific_Type (Typl);
7414 end if;
7415
7416 Prim := First_Elmt (Primitive_Operations (Typl));
7417 while Present (Prim) loop
7418 exit when Chars (Node (Prim)) = Name_Op_Eq
7419 and then Etype (First_Formal (Node (Prim))) =
7420 Etype (Next_Formal (First_Formal (Node (Prim))))
7421 and then
7422 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7423
7424 Next_Elmt (Prim);
7425 end loop;
7426
7427 pragma Assert (Present (Prim));
7428 Op_Name := Node (Prim);
7429 end if;
7430
7431 Build_Equality_Call (Op_Name);
7432
7433 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7434 -- predefined equality operator for a type which has a subcomponent
7435 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7436
7437 elsif Has_Unconstrained_UU_Component (Typl) then
7438 Insert_Action (N,
7439 Make_Raise_Program_Error (Loc,
7440 Reason => PE_Unchecked_Union_Restriction));
7441
7442 -- Prevent Gigi from generating incorrect code by rewriting the
7443 -- equality as a standard False. (is this documented somewhere???)
7444
7445 Rewrite (N,
7446 New_Occurrence_Of (Standard_False, Loc));
7447
7448 elsif Is_Unchecked_Union (Typl) then
7449
7450 -- If we can infer the discriminants of the operands, we make a
7451 -- call to the TSS equality function.
7452
7453 if Has_Inferable_Discriminants (Lhs)
7454 and then
7455 Has_Inferable_Discriminants (Rhs)
7456 then
7457 Build_Equality_Call
7458 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7459
7460 else
7461 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7462 -- the predefined equality operator for an Unchecked_Union type
7463 -- if either of the operands lack inferable discriminants.
7464
7465 Insert_Action (N,
7466 Make_Raise_Program_Error (Loc,
7467 Reason => PE_Unchecked_Union_Restriction));
7468
7469 -- Emit a warning on source equalities only, otherwise the
7470 -- message may appear out of place due to internal use. The
7471 -- warning is unconditional because it is required by the
7472 -- language.
7473
7474 if Comes_From_Source (N) then
7475 Error_Msg_N
7476 ("Unchecked_Union discriminants cannot be determined??",
7477 N);
7478 Error_Msg_N
7479 ("\Program_Error will be raised for equality operation??",
7480 N);
7481 end if;
7482
7483 -- Prevent Gigi from generating incorrect code by rewriting
7484 -- the equality as a standard False (documented where???).
7485
7486 Rewrite (N,
7487 New_Occurrence_Of (Standard_False, Loc));
7488 end if;
7489
7490 -- If a type support function is present (for complex cases), use it
7491
7492 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
7493 Build_Equality_Call
7494 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7495
7496 -- When comparing two Bounded_Strings, use the primitive equality of
7497 -- the root Super_String type.
7498
7499 elsif Is_Bounded_String (Typl) then
7500 Prim :=
7501 First_Elmt (Collect_Primitive_Operations (Root_Type (Typl)));
7502
7503 while Present (Prim) loop
7504 exit when Chars (Node (Prim)) = Name_Op_Eq
7505 and then Etype (First_Formal (Node (Prim))) =
7506 Etype (Next_Formal (First_Formal (Node (Prim))))
7507 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7508
7509 Next_Elmt (Prim);
7510 end loop;
7511
7512 -- A Super_String type should always have a primitive equality
7513
7514 pragma Assert (Present (Prim));
7515 Build_Equality_Call (Node (Prim));
7516
7517 -- Otherwise expand the component by component equality. Note that
7518 -- we never use block-bit comparisons for records, because of the
7519 -- problems with gaps. The backend will often be able to recombine
7520 -- the separate comparisons that we generate here.
7521
7522 else
7523 Remove_Side_Effects (Lhs);
7524 Remove_Side_Effects (Rhs);
7525 Rewrite (N,
7526 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
7527
7528 Insert_Actions (N, Bodies, Suppress => All_Checks);
7529 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7530 end if;
7531 end if;
7532
7533 -- Test if result is known at compile time
7534
7535 Rewrite_Comparison (N);
7536
7537 -- Special optimization of length comparison
7538
7539 Optimize_Length_Comparison (N);
7540
7541 -- One more special case: if we have a comparison of X'Result = expr
7542 -- in floating-point, then if not already there, change expr to be
7543 -- f'Machine (expr) to eliminate surprise from extra precision.
7544
7545 if Is_Floating_Point_Type (Typl)
7546 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
7547 and then Attribute_Name (Original_Node (Lhs)) = Name_Result
7548 then
7549 -- Stick in the Typ'Machine call if not already there
7550
7551 if Nkind (Rhs) /= N_Attribute_Reference
7552 or else Attribute_Name (Rhs) /= Name_Machine
7553 then
7554 Rewrite (Rhs,
7555 Make_Attribute_Reference (Loc,
7556 Prefix => New_Occurrence_Of (Typl, Loc),
7557 Attribute_Name => Name_Machine,
7558 Expressions => New_List (Relocate_Node (Rhs))));
7559 Analyze_And_Resolve (Rhs, Typl);
7560 end if;
7561 end if;
7562 end Expand_N_Op_Eq;
7563
7564 -----------------------
7565 -- Expand_N_Op_Expon --
7566 -----------------------
7567
7568 procedure Expand_N_Op_Expon (N : Node_Id) is
7569 Loc : constant Source_Ptr := Sloc (N);
7570 Typ : constant Entity_Id := Etype (N);
7571 Rtyp : constant Entity_Id := Root_Type (Typ);
7572 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
7573 Bastyp : constant Node_Id := Etype (Base);
7574 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
7575 Exptyp : constant Entity_Id := Etype (Exp);
7576 Ovflo : constant Boolean := Do_Overflow_Check (N);
7577 Expv : Uint;
7578 Temp : Node_Id;
7579 Rent : RE_Id;
7580 Ent : Entity_Id;
7581 Etyp : Entity_Id;
7582 Xnode : Node_Id;
7583
7584 function Wrap_MA (Exp : Node_Id) return Node_Id;
7585 -- Given an expression Exp, if the root type is Float or Long_Float,
7586 -- then wrap the expression in a call of Bastyp'Machine, to stop any
7587 -- extra precision. This is done to ensure that X**A = X**B when A is
7588 -- a static constant and B is a variable with the same value. For any
7589 -- other type, the node Exp is returned unchanged.
7590
7591 -------------
7592 -- Wrap_MA --
7593 -------------
7594
7595 function Wrap_MA (Exp : Node_Id) return Node_Id is
7596 Loc : constant Source_Ptr := Sloc (Exp);
7597 begin
7598 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
7599 return
7600 Make_Attribute_Reference (Loc,
7601 Attribute_Name => Name_Machine,
7602 Prefix => New_Occurrence_Of (Bastyp, Loc),
7603 Expressions => New_List (Relocate_Node (Exp)));
7604 else
7605 return Exp;
7606 end if;
7607 end Wrap_MA;
7608
7609 -- Start of processing for Expand_N_Op
7610
7611 begin
7612 Binary_Op_Validity_Checks (N);
7613
7614 -- CodePeer wants to see the unexpanded N_Op_Expon node
7615
7616 if CodePeer_Mode then
7617 return;
7618 end if;
7619
7620 -- If either operand is of a private type, then we have the use of an
7621 -- intrinsic operator, and we get rid of the privateness, by using root
7622 -- types of underlying types for the actual operation. Otherwise the
7623 -- private types will cause trouble if we expand multiplications or
7624 -- shifts etc. We also do this transformation if the result type is
7625 -- different from the base type.
7626
7627 if Is_Private_Type (Etype (Base))
7628 or else Is_Private_Type (Typ)
7629 or else Is_Private_Type (Exptyp)
7630 or else Rtyp /= Root_Type (Bastyp)
7631 then
7632 declare
7633 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
7634 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
7635 begin
7636 Rewrite (N,
7637 Unchecked_Convert_To (Typ,
7638 Make_Op_Expon (Loc,
7639 Left_Opnd => Unchecked_Convert_To (Bt, Base),
7640 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
7641 Analyze_And_Resolve (N, Typ);
7642 return;
7643 end;
7644 end if;
7645
7646 -- Check for MINIMIZED/ELIMINATED overflow mode
7647
7648 if Minimized_Eliminated_Overflow_Check (N) then
7649 Apply_Arithmetic_Overflow_Check (N);
7650 return;
7651 end if;
7652
7653 -- Test for case of known right argument where we can replace the
7654 -- exponentiation by an equivalent expression using multiplication.
7655
7656 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7657 -- configurable run-time mode, we may not have the exponentiation
7658 -- routine available, and we don't want the legality of the program
7659 -- to depend on how clever the compiler is in knowing values.
7660
7661 if CRT_Safe_Compile_Time_Known_Value (Exp) then
7662 Expv := Expr_Value (Exp);
7663
7664 -- We only fold small non-negative exponents. You might think we
7665 -- could fold small negative exponents for the real case, but we
7666 -- can't because we are required to raise Constraint_Error for
7667 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7668 -- See ACVC test C4A012B, and it is not worth generating the test.
7669
7670 if Expv >= 0 and then Expv <= 4 then
7671
7672 -- X ** 0 = 1 (or 1.0)
7673
7674 if Expv = 0 then
7675
7676 -- Call Remove_Side_Effects to ensure that any side effects
7677 -- in the ignored left operand (in particular function calls
7678 -- to user defined functions) are properly executed.
7679
7680 Remove_Side_Effects (Base);
7681
7682 if Ekind (Typ) in Integer_Kind then
7683 Xnode := Make_Integer_Literal (Loc, Intval => 1);
7684 else
7685 Xnode := Make_Real_Literal (Loc, Ureal_1);
7686 end if;
7687
7688 -- X ** 1 = X
7689
7690 elsif Expv = 1 then
7691 Xnode := Base;
7692
7693 -- X ** 2 = X * X
7694
7695 elsif Expv = 2 then
7696 Xnode :=
7697 Wrap_MA (
7698 Make_Op_Multiply (Loc,
7699 Left_Opnd => Duplicate_Subexpr (Base),
7700 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
7701
7702 -- X ** 3 = X * X * X
7703
7704 elsif Expv = 3 then
7705 Xnode :=
7706 Wrap_MA (
7707 Make_Op_Multiply (Loc,
7708 Left_Opnd =>
7709 Make_Op_Multiply (Loc,
7710 Left_Opnd => Duplicate_Subexpr (Base),
7711 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
7712 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
7713
7714 -- X ** 4 ->
7715
7716 -- do
7717 -- En : constant base'type := base * base;
7718 -- in
7719 -- En * En
7720
7721 else
7722 pragma Assert (Expv = 4);
7723 Temp := Make_Temporary (Loc, 'E', Base);
7724
7725 Xnode :=
7726 Make_Expression_With_Actions (Loc,
7727 Actions => New_List (
7728 Make_Object_Declaration (Loc,
7729 Defining_Identifier => Temp,
7730 Constant_Present => True,
7731 Object_Definition => New_Occurrence_Of (Typ, Loc),
7732 Expression =>
7733 Wrap_MA (
7734 Make_Op_Multiply (Loc,
7735 Left_Opnd =>
7736 Duplicate_Subexpr (Base),
7737 Right_Opnd =>
7738 Duplicate_Subexpr_No_Checks (Base))))),
7739
7740 Expression =>
7741 Wrap_MA (
7742 Make_Op_Multiply (Loc,
7743 Left_Opnd => New_Occurrence_Of (Temp, Loc),
7744 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
7745 end if;
7746
7747 Rewrite (N, Xnode);
7748 Analyze_And_Resolve (N, Typ);
7749 return;
7750 end if;
7751 end if;
7752
7753 -- Deal with optimizing 2 ** expression to shift where possible
7754
7755 -- Note: we used to check that Exptyp was an unsigned type. But that is
7756 -- an unnecessary check, since if Exp is negative, we have a run-time
7757 -- error that is either caught (so we get the right result) or we have
7758 -- suppressed the check, in which case the code is erroneous anyway.
7759
7760 if Is_Integer_Type (Rtyp)
7761
7762 -- The base value must be "safe compile-time known", and exactly 2
7763
7764 and then Nkind (Base) = N_Integer_Literal
7765 and then CRT_Safe_Compile_Time_Known_Value (Base)
7766 and then Expr_Value (Base) = Uint_2
7767
7768 -- We only handle cases where the right type is a integer
7769
7770 and then Is_Integer_Type (Root_Type (Exptyp))
7771 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
7772
7773 -- This transformation is not applicable for a modular type with a
7774 -- nonbinary modulus because we do not handle modular reduction in
7775 -- a correct manner if we attempt this transformation in this case.
7776
7777 and then not Non_Binary_Modulus (Typ)
7778 then
7779 -- Handle the cases where our parent is a division or multiplication
7780 -- specially. In these cases we can convert to using a shift at the
7781 -- parent level if we are not doing overflow checking, since it is
7782 -- too tricky to combine the overflow check at the parent level.
7783
7784 if not Ovflo
7785 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply)
7786 then
7787 declare
7788 P : constant Node_Id := Parent (N);
7789 L : constant Node_Id := Left_Opnd (P);
7790 R : constant Node_Id := Right_Opnd (P);
7791
7792 begin
7793 if (Nkind (P) = N_Op_Multiply
7794 and then
7795 ((Is_Integer_Type (Etype (L)) and then R = N)
7796 or else
7797 (Is_Integer_Type (Etype (R)) and then L = N))
7798 and then not Do_Overflow_Check (P))
7799
7800 or else
7801 (Nkind (P) = N_Op_Divide
7802 and then Is_Integer_Type (Etype (L))
7803 and then Is_Unsigned_Type (Etype (L))
7804 and then R = N
7805 and then not Do_Overflow_Check (P))
7806 then
7807 Set_Is_Power_Of_2_For_Shift (N);
7808 return;
7809 end if;
7810 end;
7811
7812 -- Here we just have 2 ** N on its own, so we can convert this to a
7813 -- shift node. We are prepared to deal with overflow here, and we
7814 -- also have to handle proper modular reduction for binary modular.
7815
7816 else
7817 declare
7818 OK : Boolean;
7819 Lo : Uint;
7820 Hi : Uint;
7821
7822 MaxS : Uint;
7823 -- Maximum shift count with no overflow
7824
7825 TestS : Boolean;
7826 -- Set True if we must test the shift count
7827
7828 Test_Gt : Node_Id;
7829 -- Node for test against TestS
7830
7831 begin
7832 -- Compute maximum shift based on the underlying size. For a
7833 -- modular type this is one less than the size.
7834
7835 if Is_Modular_Integer_Type (Typ) then
7836
7837 -- For modular integer types, this is the size of the value
7838 -- being shifted minus one. Any larger values will cause
7839 -- modular reduction to a result of zero. Note that we do
7840 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
7841 -- of 6, since 2**7 should be reduced to zero).
7842
7843 MaxS := RM_Size (Rtyp) - 1;
7844
7845 -- For signed integer types, we use the size of the value
7846 -- being shifted minus 2. Larger values cause overflow.
7847
7848 else
7849 MaxS := Esize (Rtyp) - 2;
7850 end if;
7851
7852 -- Determine range to see if it can be larger than MaxS
7853
7854 Determine_Range
7855 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
7856 TestS := (not OK) or else Hi > MaxS;
7857
7858 -- Signed integer case
7859
7860 if Is_Signed_Integer_Type (Typ) then
7861
7862 -- Generate overflow check if overflow is active. Note that
7863 -- we can simply ignore the possibility of overflow if the
7864 -- flag is not set (means that overflow cannot happen or
7865 -- that overflow checks are suppressed).
7866
7867 if Ovflo and TestS then
7868 Insert_Action (N,
7869 Make_Raise_Constraint_Error (Loc,
7870 Condition =>
7871 Make_Op_Gt (Loc,
7872 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
7873 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
7874 Reason => CE_Overflow_Check_Failed));
7875 end if;
7876
7877 -- Now rewrite node as Shift_Left (1, right-operand)
7878
7879 Rewrite (N,
7880 Make_Op_Shift_Left (Loc,
7881 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
7882 Right_Opnd => Right_Opnd (N)));
7883
7884 -- Modular integer case
7885
7886 else pragma Assert (Is_Modular_Integer_Type (Typ));
7887
7888 -- If shift count can be greater than MaxS, we need to wrap
7889 -- the shift in a test that will reduce the result value to
7890 -- zero if this shift count is exceeded.
7891
7892 if TestS then
7893
7894 -- Note: build node for the comparison first, before we
7895 -- reuse the Right_Opnd, so that we have proper parents
7896 -- in place for the Duplicate_Subexpr call.
7897
7898 Test_Gt :=
7899 Make_Op_Gt (Loc,
7900 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
7901 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
7902
7903 Rewrite (N,
7904 Make_If_Expression (Loc,
7905 Expressions => New_List (
7906 Test_Gt,
7907 Make_Integer_Literal (Loc, Uint_0),
7908 Make_Op_Shift_Left (Loc,
7909 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
7910 Right_Opnd => Right_Opnd (N)))));
7911
7912 -- If we know shift count cannot be greater than MaxS, then
7913 -- it is safe to just rewrite as a shift with no test.
7914
7915 else
7916 Rewrite (N,
7917 Make_Op_Shift_Left (Loc,
7918 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
7919 Right_Opnd => Right_Opnd (N)));
7920 end if;
7921 end if;
7922
7923 Analyze_And_Resolve (N, Typ);
7924 return;
7925 end;
7926 end if;
7927 end if;
7928
7929 -- Fall through if exponentiation must be done using a runtime routine
7930
7931 -- First deal with modular case
7932
7933 if Is_Modular_Integer_Type (Rtyp) then
7934
7935 -- Nonbinary modular case, we call the special exponentiation
7936 -- routine for the nonbinary case, converting the argument to
7937 -- Long_Long_Integer and passing the modulus value. Then the
7938 -- result is converted back to the base type.
7939
7940 if Non_Binary_Modulus (Rtyp) then
7941 Rewrite (N,
7942 Convert_To (Typ,
7943 Make_Function_Call (Loc,
7944 Name =>
7945 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
7946 Parameter_Associations => New_List (
7947 Convert_To (RTE (RE_Unsigned), Base),
7948 Make_Integer_Literal (Loc, Modulus (Rtyp)),
7949 Exp))));
7950
7951 -- Binary modular case, in this case, we call one of two routines,
7952 -- either the unsigned integer case, or the unsigned long long
7953 -- integer case, with a final "and" operation to do the required mod.
7954
7955 else
7956 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
7957 Ent := RTE (RE_Exp_Unsigned);
7958 else
7959 Ent := RTE (RE_Exp_Long_Long_Unsigned);
7960 end if;
7961
7962 Rewrite (N,
7963 Convert_To (Typ,
7964 Make_Op_And (Loc,
7965 Left_Opnd =>
7966 Make_Function_Call (Loc,
7967 Name => New_Occurrence_Of (Ent, Loc),
7968 Parameter_Associations => New_List (
7969 Convert_To (Etype (First_Formal (Ent)), Base),
7970 Exp)),
7971 Right_Opnd =>
7972 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
7973
7974 end if;
7975
7976 -- Common exit point for modular type case
7977
7978 Analyze_And_Resolve (N, Typ);
7979 return;
7980
7981 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7982 -- It is not worth having routines for Short_[Short_]Integer, since for
7983 -- most machines it would not help, and it would generate more code that
7984 -- might need certification when a certified run time is required.
7985
7986 -- In the integer cases, we have two routines, one for when overflow
7987 -- checks are required, and one when they are not required, since there
7988 -- is a real gain in omitting checks on many machines.
7989
7990 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
7991 or else (Rtyp = Base_Type (Standard_Long_Integer)
7992 and then
7993 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
7994 or else Rtyp = Universal_Integer
7995 then
7996 Etyp := Standard_Long_Long_Integer;
7997
7998 if Ovflo then
7999 Rent := RE_Exp_Long_Long_Integer;
8000 else
8001 Rent := RE_Exn_Long_Long_Integer;
8002 end if;
8003
8004 elsif Is_Signed_Integer_Type (Rtyp) then
8005 Etyp := Standard_Integer;
8006
8007 if Ovflo then
8008 Rent := RE_Exp_Integer;
8009 else
8010 Rent := RE_Exn_Integer;
8011 end if;
8012
8013 -- Floating-point cases. We do not need separate routines for the
8014 -- overflow case here, since in the case of floating-point, we generate
8015 -- infinities anyway as a rule (either that or we automatically trap
8016 -- overflow), and if there is an infinity generated and a range check
8017 -- is required, the check will fail anyway.
8018
8019 -- Historical note: we used to convert everything to Long_Long_Float
8020 -- and call a single common routine, but this had the undesirable effect
8021 -- of giving different results for small static exponent values and the
8022 -- same dynamic values.
8023
8024 else
8025 pragma Assert (Is_Floating_Point_Type (Rtyp));
8026
8027 if Rtyp = Standard_Float then
8028 Etyp := Standard_Float;
8029 Rent := RE_Exn_Float;
8030
8031 elsif Rtyp = Standard_Long_Float then
8032 Etyp := Standard_Long_Float;
8033 Rent := RE_Exn_Long_Float;
8034
8035 else
8036 Etyp := Standard_Long_Long_Float;
8037 Rent := RE_Exn_Long_Long_Float;
8038 end if;
8039 end if;
8040
8041 -- Common processing for integer cases and floating-point cases.
8042 -- If we are in the right type, we can call runtime routine directly
8043
8044 if Typ = Etyp
8045 and then Rtyp /= Universal_Integer
8046 and then Rtyp /= Universal_Real
8047 then
8048 Rewrite (N,
8049 Wrap_MA (
8050 Make_Function_Call (Loc,
8051 Name => New_Occurrence_Of (RTE (Rent), Loc),
8052 Parameter_Associations => New_List (Base, Exp))));
8053
8054 -- Otherwise we have to introduce conversions (conversions are also
8055 -- required in the universal cases, since the runtime routine is
8056 -- typed using one of the standard types).
8057
8058 else
8059 Rewrite (N,
8060 Convert_To (Typ,
8061 Make_Function_Call (Loc,
8062 Name => New_Occurrence_Of (RTE (Rent), Loc),
8063 Parameter_Associations => New_List (
8064 Convert_To (Etyp, Base),
8065 Exp))));
8066 end if;
8067
8068 Analyze_And_Resolve (N, Typ);
8069 return;
8070
8071 exception
8072 when RE_Not_Available =>
8073 return;
8074 end Expand_N_Op_Expon;
8075
8076 --------------------
8077 -- Expand_N_Op_Ge --
8078 --------------------
8079
8080 procedure Expand_N_Op_Ge (N : Node_Id) is
8081 Typ : constant Entity_Id := Etype (N);
8082 Op1 : constant Node_Id := Left_Opnd (N);
8083 Op2 : constant Node_Id := Right_Opnd (N);
8084 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8085
8086 begin
8087 Binary_Op_Validity_Checks (N);
8088
8089 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8090 -- means we no longer have a comparison operation, we are all done.
8091
8092 Expand_Compare_Minimize_Eliminate_Overflow (N);
8093
8094 if Nkind (N) /= N_Op_Ge then
8095 return;
8096 end if;
8097
8098 -- Array type case
8099
8100 if Is_Array_Type (Typ1) then
8101 Expand_Array_Comparison (N);
8102 return;
8103 end if;
8104
8105 -- Deal with boolean operands
8106
8107 if Is_Boolean_Type (Typ1) then
8108 Adjust_Condition (Op1);
8109 Adjust_Condition (Op2);
8110 Set_Etype (N, Standard_Boolean);
8111 Adjust_Result_Type (N, Typ);
8112 end if;
8113
8114 Rewrite_Comparison (N);
8115
8116 Optimize_Length_Comparison (N);
8117 end Expand_N_Op_Ge;
8118
8119 --------------------
8120 -- Expand_N_Op_Gt --
8121 --------------------
8122
8123 procedure Expand_N_Op_Gt (N : Node_Id) is
8124 Typ : constant Entity_Id := Etype (N);
8125 Op1 : constant Node_Id := Left_Opnd (N);
8126 Op2 : constant Node_Id := Right_Opnd (N);
8127 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8128
8129 begin
8130 Binary_Op_Validity_Checks (N);
8131
8132 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8133 -- means we no longer have a comparison operation, we are all done.
8134
8135 Expand_Compare_Minimize_Eliminate_Overflow (N);
8136
8137 if Nkind (N) /= N_Op_Gt then
8138 return;
8139 end if;
8140
8141 -- Deal with array type operands
8142
8143 if Is_Array_Type (Typ1) then
8144 Expand_Array_Comparison (N);
8145 return;
8146 end if;
8147
8148 -- Deal with boolean type operands
8149
8150 if Is_Boolean_Type (Typ1) then
8151 Adjust_Condition (Op1);
8152 Adjust_Condition (Op2);
8153 Set_Etype (N, Standard_Boolean);
8154 Adjust_Result_Type (N, Typ);
8155 end if;
8156
8157 Rewrite_Comparison (N);
8158
8159 Optimize_Length_Comparison (N);
8160 end Expand_N_Op_Gt;
8161
8162 --------------------
8163 -- Expand_N_Op_Le --
8164 --------------------
8165
8166 procedure Expand_N_Op_Le (N : Node_Id) is
8167 Typ : constant Entity_Id := Etype (N);
8168 Op1 : constant Node_Id := Left_Opnd (N);
8169 Op2 : constant Node_Id := Right_Opnd (N);
8170 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8171
8172 begin
8173 Binary_Op_Validity_Checks (N);
8174
8175 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8176 -- means we no longer have a comparison operation, we are all done.
8177
8178 Expand_Compare_Minimize_Eliminate_Overflow (N);
8179
8180 if Nkind (N) /= N_Op_Le then
8181 return;
8182 end if;
8183
8184 -- Deal with array type operands
8185
8186 if Is_Array_Type (Typ1) then
8187 Expand_Array_Comparison (N);
8188 return;
8189 end if;
8190
8191 -- Deal with Boolean type operands
8192
8193 if Is_Boolean_Type (Typ1) then
8194 Adjust_Condition (Op1);
8195 Adjust_Condition (Op2);
8196 Set_Etype (N, Standard_Boolean);
8197 Adjust_Result_Type (N, Typ);
8198 end if;
8199
8200 Rewrite_Comparison (N);
8201
8202 Optimize_Length_Comparison (N);
8203 end Expand_N_Op_Le;
8204
8205 --------------------
8206 -- Expand_N_Op_Lt --
8207 --------------------
8208
8209 procedure Expand_N_Op_Lt (N : Node_Id) is
8210 Typ : constant Entity_Id := Etype (N);
8211 Op1 : constant Node_Id := Left_Opnd (N);
8212 Op2 : constant Node_Id := Right_Opnd (N);
8213 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8214
8215 begin
8216 Binary_Op_Validity_Checks (N);
8217
8218 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8219 -- means we no longer have a comparison operation, we are all done.
8220
8221 Expand_Compare_Minimize_Eliminate_Overflow (N);
8222
8223 if Nkind (N) /= N_Op_Lt then
8224 return;
8225 end if;
8226
8227 -- Deal with array type operands
8228
8229 if Is_Array_Type (Typ1) then
8230 Expand_Array_Comparison (N);
8231 return;
8232 end if;
8233
8234 -- Deal with Boolean type operands
8235
8236 if Is_Boolean_Type (Typ1) then
8237 Adjust_Condition (Op1);
8238 Adjust_Condition (Op2);
8239 Set_Etype (N, Standard_Boolean);
8240 Adjust_Result_Type (N, Typ);
8241 end if;
8242
8243 Rewrite_Comparison (N);
8244
8245 Optimize_Length_Comparison (N);
8246 end Expand_N_Op_Lt;
8247
8248 -----------------------
8249 -- Expand_N_Op_Minus --
8250 -----------------------
8251
8252 procedure Expand_N_Op_Minus (N : Node_Id) is
8253 Loc : constant Source_Ptr := Sloc (N);
8254 Typ : constant Entity_Id := Etype (N);
8255
8256 begin
8257 Unary_Op_Validity_Checks (N);
8258
8259 -- Check for MINIMIZED/ELIMINATED overflow mode
8260
8261 if Minimized_Eliminated_Overflow_Check (N) then
8262 Apply_Arithmetic_Overflow_Check (N);
8263 return;
8264 end if;
8265
8266 if not Backend_Overflow_Checks_On_Target
8267 and then Is_Signed_Integer_Type (Etype (N))
8268 and then Do_Overflow_Check (N)
8269 then
8270 -- Software overflow checking expands -expr into (0 - expr)
8271
8272 Rewrite (N,
8273 Make_Op_Subtract (Loc,
8274 Left_Opnd => Make_Integer_Literal (Loc, 0),
8275 Right_Opnd => Right_Opnd (N)));
8276
8277 Analyze_And_Resolve (N, Typ);
8278 end if;
8279 end Expand_N_Op_Minus;
8280
8281 ---------------------
8282 -- Expand_N_Op_Mod --
8283 ---------------------
8284
8285 procedure Expand_N_Op_Mod (N : Node_Id) is
8286 Loc : constant Source_Ptr := Sloc (N);
8287 Typ : constant Entity_Id := Etype (N);
8288 DDC : constant Boolean := Do_Division_Check (N);
8289
8290 Left : Node_Id;
8291 Right : Node_Id;
8292
8293 LLB : Uint;
8294 Llo : Uint;
8295 Lhi : Uint;
8296 LOK : Boolean;
8297 Rlo : Uint;
8298 Rhi : Uint;
8299 ROK : Boolean;
8300
8301 pragma Warnings (Off, Lhi);
8302
8303 begin
8304 Binary_Op_Validity_Checks (N);
8305
8306 -- Check for MINIMIZED/ELIMINATED overflow mode
8307
8308 if Minimized_Eliminated_Overflow_Check (N) then
8309 Apply_Arithmetic_Overflow_Check (N);
8310 return;
8311 end if;
8312
8313 if Is_Integer_Type (Etype (N)) then
8314 Apply_Divide_Checks (N);
8315
8316 -- All done if we don't have a MOD any more, which can happen as a
8317 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8318
8319 if Nkind (N) /= N_Op_Mod then
8320 return;
8321 end if;
8322 end if;
8323
8324 -- Proceed with expansion of mod operator
8325
8326 Left := Left_Opnd (N);
8327 Right := Right_Opnd (N);
8328
8329 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
8330 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
8331
8332 -- Convert mod to rem if operands are both known to be non-negative, or
8333 -- both known to be non-positive (these are the cases in which rem and
8334 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8335 -- likely that this will improve the quality of code, (the operation now
8336 -- corresponds to the hardware remainder), and it does not seem likely
8337 -- that it could be harmful. It also avoids some cases of the elaborate
8338 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8339
8340 if (LOK and ROK)
8341 and then ((Llo >= 0 and then Rlo >= 0)
8342 or else
8343 (Lhi <= 0 and then Rhi <= 0))
8344 then
8345 Rewrite (N,
8346 Make_Op_Rem (Sloc (N),
8347 Left_Opnd => Left_Opnd (N),
8348 Right_Opnd => Right_Opnd (N)));
8349
8350 -- Instead of reanalyzing the node we do the analysis manually. This
8351 -- avoids anomalies when the replacement is done in an instance and
8352 -- is epsilon more efficient.
8353
8354 Set_Entity (N, Standard_Entity (S_Op_Rem));
8355 Set_Etype (N, Typ);
8356 Set_Do_Division_Check (N, DDC);
8357 Expand_N_Op_Rem (N);
8358 Set_Analyzed (N);
8359 return;
8360
8361 -- Otherwise, normal mod processing
8362
8363 else
8364 -- Apply optimization x mod 1 = 0. We don't really need that with
8365 -- gcc, but it is useful with other back ends and is certainly
8366 -- harmless.
8367
8368 if Is_Integer_Type (Etype (N))
8369 and then Compile_Time_Known_Value (Right)
8370 and then Expr_Value (Right) = Uint_1
8371 then
8372 -- Call Remove_Side_Effects to ensure that any side effects in
8373 -- the ignored left operand (in particular function calls to
8374 -- user defined functions) are properly executed.
8375
8376 Remove_Side_Effects (Left);
8377
8378 Rewrite (N, Make_Integer_Literal (Loc, 0));
8379 Analyze_And_Resolve (N, Typ);
8380 return;
8381 end if;
8382
8383 -- If we still have a mod operator and we are in Modify_Tree_For_C
8384 -- mode, and we have a signed integer type, then here is where we do
8385 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8386 -- for the special handling of the annoying case of largest negative
8387 -- number mod minus one.
8388
8389 if Nkind (N) = N_Op_Mod
8390 and then Is_Signed_Integer_Type (Typ)
8391 and then Modify_Tree_For_C
8392 then
8393 -- In the general case, we expand A mod B as
8394
8395 -- Tnn : constant typ := A rem B;
8396 -- ..
8397 -- (if (A >= 0) = (B >= 0) then Tnn
8398 -- elsif Tnn = 0 then 0
8399 -- else Tnn + B)
8400
8401 -- The comparison can be written simply as A >= 0 if we know that
8402 -- B >= 0 which is a very common case.
8403
8404 -- An important optimization is when B is known at compile time
8405 -- to be 2**K for some constant. In this case we can simply AND
8406 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8407 -- and that works for both the positive and negative cases.
8408
8409 declare
8410 P2 : constant Nat := Power_Of_Two (Right);
8411
8412 begin
8413 if P2 /= 0 then
8414 Rewrite (N,
8415 Unchecked_Convert_To (Typ,
8416 Make_Op_And (Loc,
8417 Left_Opnd =>
8418 Unchecked_Convert_To
8419 (Corresponding_Unsigned_Type (Typ), Left),
8420 Right_Opnd =>
8421 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
8422 Analyze_And_Resolve (N, Typ);
8423 return;
8424 end if;
8425 end;
8426
8427 -- Here for the full rewrite
8428
8429 declare
8430 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
8431 Cmp : Node_Id;
8432
8433 begin
8434 Cmp :=
8435 Make_Op_Ge (Loc,
8436 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
8437 Right_Opnd => Make_Integer_Literal (Loc, 0));
8438
8439 if not LOK or else Rlo < 0 then
8440 Cmp :=
8441 Make_Op_Eq (Loc,
8442 Left_Opnd => Cmp,
8443 Right_Opnd =>
8444 Make_Op_Ge (Loc,
8445 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
8446 Right_Opnd => Make_Integer_Literal (Loc, 0)));
8447 end if;
8448
8449 Insert_Action (N,
8450 Make_Object_Declaration (Loc,
8451 Defining_Identifier => Tnn,
8452 Constant_Present => True,
8453 Object_Definition => New_Occurrence_Of (Typ, Loc),
8454 Expression =>
8455 Make_Op_Rem (Loc,
8456 Left_Opnd => Left,
8457 Right_Opnd => Right)));
8458
8459 Rewrite (N,
8460 Make_If_Expression (Loc,
8461 Expressions => New_List (
8462 Cmp,
8463 New_Occurrence_Of (Tnn, Loc),
8464 Make_If_Expression (Loc,
8465 Is_Elsif => True,
8466 Expressions => New_List (
8467 Make_Op_Eq (Loc,
8468 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8469 Right_Opnd => Make_Integer_Literal (Loc, 0)),
8470 Make_Integer_Literal (Loc, 0),
8471 Make_Op_Add (Loc,
8472 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8473 Right_Opnd =>
8474 Duplicate_Subexpr_No_Checks (Right)))))));
8475
8476 Analyze_And_Resolve (N, Typ);
8477 return;
8478 end;
8479 end if;
8480
8481 -- Deal with annoying case of largest negative number mod minus one.
8482 -- Gigi may not handle this case correctly, because on some targets,
8483 -- the mod value is computed using a divide instruction which gives
8484 -- an overflow trap for this case.
8485
8486 -- It would be a bit more efficient to figure out which targets
8487 -- this is really needed for, but in practice it is reasonable
8488 -- to do the following special check in all cases, since it means
8489 -- we get a clearer message, and also the overhead is minimal given
8490 -- that division is expensive in any case.
8491
8492 -- In fact the check is quite easy, if the right operand is -1, then
8493 -- the mod value is always 0, and we can just ignore the left operand
8494 -- completely in this case.
8495
8496 -- This only applies if we still have a mod operator. Skip if we
8497 -- have already rewritten this (e.g. in the case of eliminated
8498 -- overflow checks which have driven us into bignum mode).
8499
8500 if Nkind (N) = N_Op_Mod then
8501
8502 -- The operand type may be private (e.g. in the expansion of an
8503 -- intrinsic operation) so we must use the underlying type to get
8504 -- the bounds, and convert the literals explicitly.
8505
8506 LLB :=
8507 Expr_Value
8508 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
8509
8510 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
8511 and then ((not LOK) or else (Llo = LLB))
8512 then
8513 Rewrite (N,
8514 Make_If_Expression (Loc,
8515 Expressions => New_List (
8516 Make_Op_Eq (Loc,
8517 Left_Opnd => Duplicate_Subexpr (Right),
8518 Right_Opnd =>
8519 Unchecked_Convert_To (Typ,
8520 Make_Integer_Literal (Loc, -1))),
8521 Unchecked_Convert_To (Typ,
8522 Make_Integer_Literal (Loc, Uint_0)),
8523 Relocate_Node (N))));
8524
8525 Set_Analyzed (Next (Next (First (Expressions (N)))));
8526 Analyze_And_Resolve (N, Typ);
8527 end if;
8528 end if;
8529 end if;
8530 end Expand_N_Op_Mod;
8531
8532 --------------------------
8533 -- Expand_N_Op_Multiply --
8534 --------------------------
8535
8536 procedure Expand_N_Op_Multiply (N : Node_Id) is
8537 Loc : constant Source_Ptr := Sloc (N);
8538 Lop : constant Node_Id := Left_Opnd (N);
8539 Rop : constant Node_Id := Right_Opnd (N);
8540
8541 Lp2 : constant Boolean :=
8542 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
8543 Rp2 : constant Boolean :=
8544 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
8545
8546 Ltyp : constant Entity_Id := Etype (Lop);
8547 Rtyp : constant Entity_Id := Etype (Rop);
8548 Typ : Entity_Id := Etype (N);
8549
8550 begin
8551 Binary_Op_Validity_Checks (N);
8552
8553 -- Check for MINIMIZED/ELIMINATED overflow mode
8554
8555 if Minimized_Eliminated_Overflow_Check (N) then
8556 Apply_Arithmetic_Overflow_Check (N);
8557 return;
8558 end if;
8559
8560 -- Special optimizations for integer types
8561
8562 if Is_Integer_Type (Typ) then
8563
8564 -- N * 0 = 0 for integer types
8565
8566 if Compile_Time_Known_Value (Rop)
8567 and then Expr_Value (Rop) = Uint_0
8568 then
8569 -- Call Remove_Side_Effects to ensure that any side effects in
8570 -- the ignored left operand (in particular function calls to
8571 -- user defined functions) are properly executed.
8572
8573 Remove_Side_Effects (Lop);
8574
8575 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8576 Analyze_And_Resolve (N, Typ);
8577 return;
8578 end if;
8579
8580 -- Similar handling for 0 * N = 0
8581
8582 if Compile_Time_Known_Value (Lop)
8583 and then Expr_Value (Lop) = Uint_0
8584 then
8585 Remove_Side_Effects (Rop);
8586 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8587 Analyze_And_Resolve (N, Typ);
8588 return;
8589 end if;
8590
8591 -- N * 1 = 1 * N = N for integer types
8592
8593 -- This optimisation is not done if we are going to
8594 -- rewrite the product 1 * 2 ** N to a shift.
8595
8596 if Compile_Time_Known_Value (Rop)
8597 and then Expr_Value (Rop) = Uint_1
8598 and then not Lp2
8599 then
8600 Rewrite (N, Lop);
8601 return;
8602
8603 elsif Compile_Time_Known_Value (Lop)
8604 and then Expr_Value (Lop) = Uint_1
8605 and then not Rp2
8606 then
8607 Rewrite (N, Rop);
8608 return;
8609 end if;
8610 end if;
8611
8612 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8613 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8614 -- operand is an integer, as required for this to work.
8615
8616 if Rp2 then
8617 if Lp2 then
8618
8619 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8620
8621 Rewrite (N,
8622 Make_Op_Expon (Loc,
8623 Left_Opnd => Make_Integer_Literal (Loc, 2),
8624 Right_Opnd =>
8625 Make_Op_Add (Loc,
8626 Left_Opnd => Right_Opnd (Lop),
8627 Right_Opnd => Right_Opnd (Rop))));
8628 Analyze_And_Resolve (N, Typ);
8629 return;
8630
8631 else
8632 -- If the result is modular, perform the reduction of the result
8633 -- appropriately.
8634
8635 if Is_Modular_Integer_Type (Typ)
8636 and then not Non_Binary_Modulus (Typ)
8637 then
8638 Rewrite (N,
8639 Make_Op_And (Loc,
8640 Left_Opnd =>
8641 Make_Op_Shift_Left (Loc,
8642 Left_Opnd => Lop,
8643 Right_Opnd =>
8644 Convert_To (Standard_Natural, Right_Opnd (Rop))),
8645 Right_Opnd =>
8646 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8647
8648 else
8649 Rewrite (N,
8650 Make_Op_Shift_Left (Loc,
8651 Left_Opnd => Lop,
8652 Right_Opnd =>
8653 Convert_To (Standard_Natural, Right_Opnd (Rop))));
8654 end if;
8655
8656 Analyze_And_Resolve (N, Typ);
8657 return;
8658 end if;
8659
8660 -- Same processing for the operands the other way round
8661
8662 elsif Lp2 then
8663 if Is_Modular_Integer_Type (Typ)
8664 and then not Non_Binary_Modulus (Typ)
8665 then
8666 Rewrite (N,
8667 Make_Op_And (Loc,
8668 Left_Opnd =>
8669 Make_Op_Shift_Left (Loc,
8670 Left_Opnd => Rop,
8671 Right_Opnd =>
8672 Convert_To (Standard_Natural, Right_Opnd (Lop))),
8673 Right_Opnd =>
8674 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8675
8676 else
8677 Rewrite (N,
8678 Make_Op_Shift_Left (Loc,
8679 Left_Opnd => Rop,
8680 Right_Opnd =>
8681 Convert_To (Standard_Natural, Right_Opnd (Lop))));
8682 end if;
8683
8684 Analyze_And_Resolve (N, Typ);
8685 return;
8686 end if;
8687
8688 -- Do required fixup of universal fixed operation
8689
8690 if Typ = Universal_Fixed then
8691 Fixup_Universal_Fixed_Operation (N);
8692 Typ := Etype (N);
8693 end if;
8694
8695 -- Multiplications with fixed-point results
8696
8697 if Is_Fixed_Point_Type (Typ) then
8698
8699 -- No special processing if Treat_Fixed_As_Integer is set, since from
8700 -- a semantic point of view such operations are simply integer
8701 -- operations and will be treated that way.
8702
8703 if not Treat_Fixed_As_Integer (N) then
8704
8705 -- Case of fixed * integer => fixed
8706
8707 if Is_Integer_Type (Rtyp) then
8708 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
8709
8710 -- Case of integer * fixed => fixed
8711
8712 elsif Is_Integer_Type (Ltyp) then
8713 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
8714
8715 -- Case of fixed * fixed => fixed
8716
8717 else
8718 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
8719 end if;
8720 end if;
8721
8722 -- Other cases of multiplication of fixed-point operands. Again we
8723 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8724
8725 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
8726 and then not Treat_Fixed_As_Integer (N)
8727 then
8728 if Is_Integer_Type (Typ) then
8729 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
8730 else
8731 pragma Assert (Is_Floating_Point_Type (Typ));
8732 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
8733 end if;
8734
8735 -- Mixed-mode operations can appear in a non-static universal context,
8736 -- in which case the integer argument must be converted explicitly.
8737
8738 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
8739 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
8740 Analyze_And_Resolve (Rop, Universal_Real);
8741
8742 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
8743 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
8744 Analyze_And_Resolve (Lop, Universal_Real);
8745
8746 -- Non-fixed point cases, check software overflow checking required
8747
8748 elsif Is_Signed_Integer_Type (Etype (N)) then
8749 Apply_Arithmetic_Overflow_Check (N);
8750 end if;
8751
8752 -- Overflow checks for floating-point if -gnateF mode active
8753
8754 Check_Float_Op_Overflow (N);
8755 end Expand_N_Op_Multiply;
8756
8757 --------------------
8758 -- Expand_N_Op_Ne --
8759 --------------------
8760
8761 procedure Expand_N_Op_Ne (N : Node_Id) is
8762 Typ : constant Entity_Id := Etype (Left_Opnd (N));
8763
8764 begin
8765 -- Case of elementary type with standard operator
8766
8767 if Is_Elementary_Type (Typ)
8768 and then Sloc (Entity (N)) = Standard_Location
8769 then
8770 Binary_Op_Validity_Checks (N);
8771
8772 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8773 -- means we no longer have a /= operation, we are all done.
8774
8775 Expand_Compare_Minimize_Eliminate_Overflow (N);
8776
8777 if Nkind (N) /= N_Op_Ne then
8778 return;
8779 end if;
8780
8781 -- Boolean types (requiring handling of non-standard case)
8782
8783 if Is_Boolean_Type (Typ) then
8784 Adjust_Condition (Left_Opnd (N));
8785 Adjust_Condition (Right_Opnd (N));
8786 Set_Etype (N, Standard_Boolean);
8787 Adjust_Result_Type (N, Typ);
8788 end if;
8789
8790 Rewrite_Comparison (N);
8791
8792 -- For all cases other than elementary types, we rewrite node as the
8793 -- negation of an equality operation, and reanalyze. The equality to be
8794 -- used is defined in the same scope and has the same signature. This
8795 -- signature must be set explicitly since in an instance it may not have
8796 -- the same visibility as in the generic unit. This avoids duplicating
8797 -- or factoring the complex code for record/array equality tests etc.
8798
8799 else
8800 declare
8801 Loc : constant Source_Ptr := Sloc (N);
8802 Neg : Node_Id;
8803 Ne : constant Entity_Id := Entity (N);
8804
8805 begin
8806 Binary_Op_Validity_Checks (N);
8807
8808 Neg :=
8809 Make_Op_Not (Loc,
8810 Right_Opnd =>
8811 Make_Op_Eq (Loc,
8812 Left_Opnd => Left_Opnd (N),
8813 Right_Opnd => Right_Opnd (N)));
8814 Set_Paren_Count (Right_Opnd (Neg), 1);
8815
8816 if Scope (Ne) /= Standard_Standard then
8817 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
8818 end if;
8819
8820 -- For navigation purposes, we want to treat the inequality as an
8821 -- implicit reference to the corresponding equality. Preserve the
8822 -- Comes_From_ source flag to generate proper Xref entries.
8823
8824 Preserve_Comes_From_Source (Neg, N);
8825 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
8826 Rewrite (N, Neg);
8827 Analyze_And_Resolve (N, Standard_Boolean);
8828 end;
8829 end if;
8830
8831 Optimize_Length_Comparison (N);
8832 end Expand_N_Op_Ne;
8833
8834 ---------------------
8835 -- Expand_N_Op_Not --
8836 ---------------------
8837
8838 -- If the argument is other than a Boolean array type, there is no special
8839 -- expansion required, except for dealing with validity checks, and non-
8840 -- standard boolean representations.
8841
8842 -- For the packed array case, we call the special routine in Exp_Pakd,
8843 -- except that if the component size is greater than one, we use the
8844 -- standard routine generating a gruesome loop (it is so peculiar to have
8845 -- packed arrays with non-standard Boolean representations anyway, so it
8846 -- does not matter that we do not handle this case efficiently).
8847
8848 -- For the unpacked array case (and for the special packed case where we
8849 -- have non standard Booleans, as discussed above), we generate and insert
8850 -- into the tree the following function definition:
8851
8852 -- function Nnnn (A : arr) is
8853 -- B : arr;
8854 -- begin
8855 -- for J in a'range loop
8856 -- B (J) := not A (J);
8857 -- end loop;
8858 -- return B;
8859 -- end Nnnn;
8860
8861 -- Here arr is the actual subtype of the parameter (and hence always
8862 -- constrained). Then we replace the not with a call to this function.
8863
8864 procedure Expand_N_Op_Not (N : Node_Id) is
8865 Loc : constant Source_Ptr := Sloc (N);
8866 Typ : constant Entity_Id := Etype (N);
8867 Opnd : Node_Id;
8868 Arr : Entity_Id;
8869 A : Entity_Id;
8870 B : Entity_Id;
8871 J : Entity_Id;
8872 A_J : Node_Id;
8873 B_J : Node_Id;
8874
8875 Func_Name : Entity_Id;
8876 Loop_Statement : Node_Id;
8877
8878 begin
8879 Unary_Op_Validity_Checks (N);
8880
8881 -- For boolean operand, deal with non-standard booleans
8882
8883 if Is_Boolean_Type (Typ) then
8884 Adjust_Condition (Right_Opnd (N));
8885 Set_Etype (N, Standard_Boolean);
8886 Adjust_Result_Type (N, Typ);
8887 return;
8888 end if;
8889
8890 -- Only array types need any other processing
8891
8892 if not Is_Array_Type (Typ) then
8893 return;
8894 end if;
8895
8896 -- Case of array operand. If bit packed with a component size of 1,
8897 -- handle it in Exp_Pakd if the operand is known to be aligned.
8898
8899 if Is_Bit_Packed_Array (Typ)
8900 and then Component_Size (Typ) = 1
8901 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
8902 then
8903 Expand_Packed_Not (N);
8904 return;
8905 end if;
8906
8907 -- Case of array operand which is not bit-packed. If the context is
8908 -- a safe assignment, call in-place operation, If context is a larger
8909 -- boolean expression in the context of a safe assignment, expansion is
8910 -- done by enclosing operation.
8911
8912 Opnd := Relocate_Node (Right_Opnd (N));
8913 Convert_To_Actual_Subtype (Opnd);
8914 Arr := Etype (Opnd);
8915 Ensure_Defined (Arr, N);
8916 Silly_Boolean_Array_Not_Test (N, Arr);
8917
8918 if Nkind (Parent (N)) = N_Assignment_Statement then
8919 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
8920 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8921 return;
8922
8923 -- Special case the negation of a binary operation
8924
8925 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
8926 and then Safe_In_Place_Array_Op
8927 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
8928 then
8929 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8930 return;
8931 end if;
8932
8933 elsif Nkind (Parent (N)) in N_Binary_Op
8934 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
8935 then
8936 declare
8937 Op1 : constant Node_Id := Left_Opnd (Parent (N));
8938 Op2 : constant Node_Id := Right_Opnd (Parent (N));
8939 Lhs : constant Node_Id := Name (Parent (Parent (N)));
8940
8941 begin
8942 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
8943
8944 -- (not A) op (not B) can be reduced to a single call
8945
8946 if N = Op1 and then Nkind (Op2) = N_Op_Not then
8947 return;
8948
8949 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
8950 return;
8951
8952 -- A xor (not B) can also be special-cased
8953
8954 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
8955 return;
8956 end if;
8957 end if;
8958 end;
8959 end if;
8960
8961 A := Make_Defining_Identifier (Loc, Name_uA);
8962 B := Make_Defining_Identifier (Loc, Name_uB);
8963 J := Make_Defining_Identifier (Loc, Name_uJ);
8964
8965 A_J :=
8966 Make_Indexed_Component (Loc,
8967 Prefix => New_Occurrence_Of (A, Loc),
8968 Expressions => New_List (New_Occurrence_Of (J, Loc)));
8969
8970 B_J :=
8971 Make_Indexed_Component (Loc,
8972 Prefix => New_Occurrence_Of (B, Loc),
8973 Expressions => New_List (New_Occurrence_Of (J, Loc)));
8974
8975 Loop_Statement :=
8976 Make_Implicit_Loop_Statement (N,
8977 Identifier => Empty,
8978
8979 Iteration_Scheme =>
8980 Make_Iteration_Scheme (Loc,
8981 Loop_Parameter_Specification =>
8982 Make_Loop_Parameter_Specification (Loc,
8983 Defining_Identifier => J,
8984 Discrete_Subtype_Definition =>
8985 Make_Attribute_Reference (Loc,
8986 Prefix => Make_Identifier (Loc, Chars (A)),
8987 Attribute_Name => Name_Range))),
8988
8989 Statements => New_List (
8990 Make_Assignment_Statement (Loc,
8991 Name => B_J,
8992 Expression => Make_Op_Not (Loc, A_J))));
8993
8994 Func_Name := Make_Temporary (Loc, 'N');
8995 Set_Is_Inlined (Func_Name);
8996
8997 Insert_Action (N,
8998 Make_Subprogram_Body (Loc,
8999 Specification =>
9000 Make_Function_Specification (Loc,
9001 Defining_Unit_Name => Func_Name,
9002 Parameter_Specifications => New_List (
9003 Make_Parameter_Specification (Loc,
9004 Defining_Identifier => A,
9005 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9006 Result_Definition => New_Occurrence_Of (Typ, Loc)),
9007
9008 Declarations => New_List (
9009 Make_Object_Declaration (Loc,
9010 Defining_Identifier => B,
9011 Object_Definition => New_Occurrence_Of (Arr, Loc))),
9012
9013 Handled_Statement_Sequence =>
9014 Make_Handled_Sequence_Of_Statements (Loc,
9015 Statements => New_List (
9016 Loop_Statement,
9017 Make_Simple_Return_Statement (Loc,
9018 Expression => Make_Identifier (Loc, Chars (B)))))));
9019
9020 Rewrite (N,
9021 Make_Function_Call (Loc,
9022 Name => New_Occurrence_Of (Func_Name, Loc),
9023 Parameter_Associations => New_List (Opnd)));
9024
9025 Analyze_And_Resolve (N, Typ);
9026 end Expand_N_Op_Not;
9027
9028 --------------------
9029 -- Expand_N_Op_Or --
9030 --------------------
9031
9032 procedure Expand_N_Op_Or (N : Node_Id) is
9033 Typ : constant Entity_Id := Etype (N);
9034
9035 begin
9036 Binary_Op_Validity_Checks (N);
9037
9038 if Is_Array_Type (Etype (N)) then
9039 Expand_Boolean_Operator (N);
9040
9041 elsif Is_Boolean_Type (Etype (N)) then
9042 Adjust_Condition (Left_Opnd (N));
9043 Adjust_Condition (Right_Opnd (N));
9044 Set_Etype (N, Standard_Boolean);
9045 Adjust_Result_Type (N, Typ);
9046
9047 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9048 Expand_Intrinsic_Call (N, Entity (N));
9049
9050 end if;
9051 end Expand_N_Op_Or;
9052
9053 ----------------------
9054 -- Expand_N_Op_Plus --
9055 ----------------------
9056
9057 procedure Expand_N_Op_Plus (N : Node_Id) is
9058 begin
9059 Unary_Op_Validity_Checks (N);
9060
9061 -- Check for MINIMIZED/ELIMINATED overflow mode
9062
9063 if Minimized_Eliminated_Overflow_Check (N) then
9064 Apply_Arithmetic_Overflow_Check (N);
9065 return;
9066 end if;
9067 end Expand_N_Op_Plus;
9068
9069 ---------------------
9070 -- Expand_N_Op_Rem --
9071 ---------------------
9072
9073 procedure Expand_N_Op_Rem (N : Node_Id) is
9074 Loc : constant Source_Ptr := Sloc (N);
9075 Typ : constant Entity_Id := Etype (N);
9076
9077 Left : Node_Id;
9078 Right : Node_Id;
9079
9080 Lo : Uint;
9081 Hi : Uint;
9082 OK : Boolean;
9083
9084 Lneg : Boolean;
9085 Rneg : Boolean;
9086 -- Set if corresponding operand can be negative
9087
9088 pragma Unreferenced (Hi);
9089
9090 begin
9091 Binary_Op_Validity_Checks (N);
9092
9093 -- Check for MINIMIZED/ELIMINATED overflow mode
9094
9095 if Minimized_Eliminated_Overflow_Check (N) then
9096 Apply_Arithmetic_Overflow_Check (N);
9097 return;
9098 end if;
9099
9100 if Is_Integer_Type (Etype (N)) then
9101 Apply_Divide_Checks (N);
9102
9103 -- All done if we don't have a REM any more, which can happen as a
9104 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9105
9106 if Nkind (N) /= N_Op_Rem then
9107 return;
9108 end if;
9109 end if;
9110
9111 -- Proceed with expansion of REM
9112
9113 Left := Left_Opnd (N);
9114 Right := Right_Opnd (N);
9115
9116 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9117 -- but it is useful with other back ends, and is certainly harmless.
9118
9119 if Is_Integer_Type (Etype (N))
9120 and then Compile_Time_Known_Value (Right)
9121 and then Expr_Value (Right) = Uint_1
9122 then
9123 -- Call Remove_Side_Effects to ensure that any side effects in the
9124 -- ignored left operand (in particular function calls to user defined
9125 -- functions) are properly executed.
9126
9127 Remove_Side_Effects (Left);
9128
9129 Rewrite (N, Make_Integer_Literal (Loc, 0));
9130 Analyze_And_Resolve (N, Typ);
9131 return;
9132 end if;
9133
9134 -- Deal with annoying case of largest negative number remainder minus
9135 -- one. Gigi may not handle this case correctly, because on some
9136 -- targets, the mod value is computed using a divide instruction
9137 -- which gives an overflow trap for this case.
9138
9139 -- It would be a bit more efficient to figure out which targets this
9140 -- is really needed for, but in practice it is reasonable to do the
9141 -- following special check in all cases, since it means we get a clearer
9142 -- message, and also the overhead is minimal given that division is
9143 -- expensive in any case.
9144
9145 -- In fact the check is quite easy, if the right operand is -1, then
9146 -- the remainder is always 0, and we can just ignore the left operand
9147 -- completely in this case.
9148
9149 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9150 Lneg := (not OK) or else Lo < 0;
9151
9152 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
9153 Rneg := (not OK) or else Lo < 0;
9154
9155 -- We won't mess with trying to find out if the left operand can really
9156 -- be the largest negative number (that's a pain in the case of private
9157 -- types and this is really marginal). We will just assume that we need
9158 -- the test if the left operand can be negative at all.
9159
9160 if Lneg and Rneg then
9161 Rewrite (N,
9162 Make_If_Expression (Loc,
9163 Expressions => New_List (
9164 Make_Op_Eq (Loc,
9165 Left_Opnd => Duplicate_Subexpr (Right),
9166 Right_Opnd =>
9167 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
9168
9169 Unchecked_Convert_To (Typ,
9170 Make_Integer_Literal (Loc, Uint_0)),
9171
9172 Relocate_Node (N))));
9173
9174 Set_Analyzed (Next (Next (First (Expressions (N)))));
9175 Analyze_And_Resolve (N, Typ);
9176 end if;
9177 end Expand_N_Op_Rem;
9178
9179 -----------------------------
9180 -- Expand_N_Op_Rotate_Left --
9181 -----------------------------
9182
9183 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
9184 begin
9185 Binary_Op_Validity_Checks (N);
9186
9187 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9188 -- so we rewrite in terms of logical shifts
9189
9190 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9191
9192 -- where Bits is the shift count mod Esize (the mod operation here
9193 -- deals with ludicrous large shift counts, which are apparently OK).
9194
9195 -- What about nonbinary modulus ???
9196
9197 declare
9198 Loc : constant Source_Ptr := Sloc (N);
9199 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
9200 Typ : constant Entity_Id := Etype (N);
9201
9202 begin
9203 if Modify_Tree_For_C then
9204 Rewrite (Right_Opnd (N),
9205 Make_Op_Rem (Loc,
9206 Left_Opnd => Relocate_Node (Right_Opnd (N)),
9207 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
9208
9209 Analyze_And_Resolve (Right_Opnd (N), Rtp);
9210
9211 Rewrite (N,
9212 Make_Op_Or (Loc,
9213 Left_Opnd =>
9214 Make_Op_Shift_Left (Loc,
9215 Left_Opnd => Left_Opnd (N),
9216 Right_Opnd => Right_Opnd (N)),
9217
9218 Right_Opnd =>
9219 Make_Op_Shift_Right (Loc,
9220 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9221 Right_Opnd =>
9222 Make_Op_Subtract (Loc,
9223 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9224 Right_Opnd =>
9225 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9226
9227 Analyze_And_Resolve (N, Typ);
9228 end if;
9229 end;
9230 end Expand_N_Op_Rotate_Left;
9231
9232 ------------------------------
9233 -- Expand_N_Op_Rotate_Right --
9234 ------------------------------
9235
9236 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
9237 begin
9238 Binary_Op_Validity_Checks (N);
9239
9240 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9241 -- so we rewrite in terms of logical shifts
9242
9243 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9244
9245 -- where Bits is the shift count mod Esize (the mod operation here
9246 -- deals with ludicrous large shift counts, which are apparently OK).
9247
9248 -- What about nonbinary modulus ???
9249
9250 declare
9251 Loc : constant Source_Ptr := Sloc (N);
9252 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
9253 Typ : constant Entity_Id := Etype (N);
9254
9255 begin
9256 Rewrite (Right_Opnd (N),
9257 Make_Op_Rem (Loc,
9258 Left_Opnd => Relocate_Node (Right_Opnd (N)),
9259 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
9260
9261 Analyze_And_Resolve (Right_Opnd (N), Rtp);
9262
9263 if Modify_Tree_For_C then
9264 Rewrite (N,
9265 Make_Op_Or (Loc,
9266 Left_Opnd =>
9267 Make_Op_Shift_Right (Loc,
9268 Left_Opnd => Left_Opnd (N),
9269 Right_Opnd => Right_Opnd (N)),
9270
9271 Right_Opnd =>
9272 Make_Op_Shift_Left (Loc,
9273 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9274 Right_Opnd =>
9275 Make_Op_Subtract (Loc,
9276 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9277 Right_Opnd =>
9278 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9279
9280 Analyze_And_Resolve (N, Typ);
9281 end if;
9282 end;
9283 end Expand_N_Op_Rotate_Right;
9284
9285 ----------------------------
9286 -- Expand_N_Op_Shift_Left --
9287 ----------------------------
9288
9289 -- Note: nothing in this routine depends on left as opposed to right shifts
9290 -- so we share the routine for expanding shift right operations.
9291
9292 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
9293 begin
9294 Binary_Op_Validity_Checks (N);
9295
9296 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9297 -- operand is not greater than the word size (since that would not
9298 -- be defined properly by the corresponding C shift operator).
9299
9300 if Modify_Tree_For_C then
9301 declare
9302 Right : constant Node_Id := Right_Opnd (N);
9303 Loc : constant Source_Ptr := Sloc (Right);
9304 Typ : constant Entity_Id := Etype (N);
9305 Siz : constant Uint := Esize (Typ);
9306 Orig : Node_Id;
9307 OK : Boolean;
9308 Lo : Uint;
9309 Hi : Uint;
9310
9311 begin
9312 if Compile_Time_Known_Value (Right) then
9313 if Expr_Value (Right) >= Siz then
9314 Rewrite (N, Make_Integer_Literal (Loc, 0));
9315 Analyze_And_Resolve (N, Typ);
9316 end if;
9317
9318 -- Not compile time known, find range
9319
9320 else
9321 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9322
9323 -- Nothing to do if known to be OK range, otherwise expand
9324
9325 if not OK or else Hi >= Siz then
9326
9327 -- Prevent recursion on copy of shift node
9328
9329 Orig := Relocate_Node (N);
9330 Set_Analyzed (Orig);
9331
9332 -- Now do the rewrite
9333
9334 Rewrite (N,
9335 Make_If_Expression (Loc,
9336 Expressions => New_List (
9337 Make_Op_Ge (Loc,
9338 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
9339 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
9340 Make_Integer_Literal (Loc, 0),
9341 Orig)));
9342 Analyze_And_Resolve (N, Typ);
9343 end if;
9344 end if;
9345 end;
9346 end if;
9347 end Expand_N_Op_Shift_Left;
9348
9349 -----------------------------
9350 -- Expand_N_Op_Shift_Right --
9351 -----------------------------
9352
9353 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
9354 begin
9355 -- Share shift left circuit
9356
9357 Expand_N_Op_Shift_Left (N);
9358 end Expand_N_Op_Shift_Right;
9359
9360 ----------------------------------------
9361 -- Expand_N_Op_Shift_Right_Arithmetic --
9362 ----------------------------------------
9363
9364 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
9365 begin
9366 Binary_Op_Validity_Checks (N);
9367
9368 -- If we are in Modify_Tree_For_C mode, there is no shift right
9369 -- arithmetic in C, so we rewrite in terms of logical shifts.
9370
9371 -- Shift_Right (Num, Bits) or
9372 -- (if Num >= Sign
9373 -- then not (Shift_Right (Mask, bits))
9374 -- else 0)
9375
9376 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9377
9378 -- Note: in almost all C compilers it would work to just shift a
9379 -- signed integer right, but it's undefined and we cannot rely on it.
9380
9381 -- Note: the above works fine for shift counts greater than or equal
9382 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9383 -- generates all 1'bits.
9384
9385 -- What about nonbinary modulus ???
9386
9387 declare
9388 Loc : constant Source_Ptr := Sloc (N);
9389 Typ : constant Entity_Id := Etype (N);
9390 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
9391 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
9392 Left : constant Node_Id := Left_Opnd (N);
9393 Right : constant Node_Id := Right_Opnd (N);
9394 Maskx : Node_Id;
9395
9396 begin
9397 if Modify_Tree_For_C then
9398
9399 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9400 -- compile time as a single constant.
9401
9402 if Compile_Time_Known_Value (Right) then
9403 declare
9404 Val : constant Uint := Expr_Value (Right);
9405
9406 begin
9407 if Val >= Esize (Typ) then
9408 Maskx := Make_Integer_Literal (Loc, Mask);
9409
9410 else
9411 Maskx :=
9412 Make_Integer_Literal (Loc,
9413 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
9414 end if;
9415 end;
9416
9417 else
9418 Maskx :=
9419 Make_Op_Not (Loc,
9420 Right_Opnd =>
9421 Make_Op_Shift_Right (Loc,
9422 Left_Opnd => Make_Integer_Literal (Loc, Mask),
9423 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
9424 end if;
9425
9426 -- Now do the rewrite
9427
9428 Rewrite (N,
9429 Make_Op_Or (Loc,
9430 Left_Opnd =>
9431 Make_Op_Shift_Right (Loc,
9432 Left_Opnd => Left,
9433 Right_Opnd => Right),
9434 Right_Opnd =>
9435 Make_If_Expression (Loc,
9436 Expressions => New_List (
9437 Make_Op_Ge (Loc,
9438 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9439 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
9440 Maskx,
9441 Make_Integer_Literal (Loc, 0)))));
9442 Analyze_And_Resolve (N, Typ);
9443 end if;
9444 end;
9445 end Expand_N_Op_Shift_Right_Arithmetic;
9446
9447 --------------------------
9448 -- Expand_N_Op_Subtract --
9449 --------------------------
9450
9451 procedure Expand_N_Op_Subtract (N : Node_Id) is
9452 Typ : constant Entity_Id := Etype (N);
9453
9454 begin
9455 Binary_Op_Validity_Checks (N);
9456
9457 -- Check for MINIMIZED/ELIMINATED overflow mode
9458
9459 if Minimized_Eliminated_Overflow_Check (N) then
9460 Apply_Arithmetic_Overflow_Check (N);
9461 return;
9462 end if;
9463
9464 -- N - 0 = N for integer types
9465
9466 if Is_Integer_Type (Typ)
9467 and then Compile_Time_Known_Value (Right_Opnd (N))
9468 and then Expr_Value (Right_Opnd (N)) = 0
9469 then
9470 Rewrite (N, Left_Opnd (N));
9471 return;
9472 end if;
9473
9474 -- Arithmetic overflow checks for signed integer/fixed point types
9475
9476 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
9477 Apply_Arithmetic_Overflow_Check (N);
9478 end if;
9479
9480 -- Overflow checks for floating-point if -gnateF mode active
9481
9482 Check_Float_Op_Overflow (N);
9483 end Expand_N_Op_Subtract;
9484
9485 ---------------------
9486 -- Expand_N_Op_Xor --
9487 ---------------------
9488
9489 procedure Expand_N_Op_Xor (N : Node_Id) is
9490 Typ : constant Entity_Id := Etype (N);
9491
9492 begin
9493 Binary_Op_Validity_Checks (N);
9494
9495 if Is_Array_Type (Etype (N)) then
9496 Expand_Boolean_Operator (N);
9497
9498 elsif Is_Boolean_Type (Etype (N)) then
9499 Adjust_Condition (Left_Opnd (N));
9500 Adjust_Condition (Right_Opnd (N));
9501 Set_Etype (N, Standard_Boolean);
9502 Adjust_Result_Type (N, Typ);
9503
9504 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9505 Expand_Intrinsic_Call (N, Entity (N));
9506
9507 end if;
9508 end Expand_N_Op_Xor;
9509
9510 ----------------------
9511 -- Expand_N_Or_Else --
9512 ----------------------
9513
9514 procedure Expand_N_Or_Else (N : Node_Id)
9515 renames Expand_Short_Circuit_Operator;
9516
9517 -----------------------------------
9518 -- Expand_N_Qualified_Expression --
9519 -----------------------------------
9520
9521 procedure Expand_N_Qualified_Expression (N : Node_Id) is
9522 Operand : constant Node_Id := Expression (N);
9523 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
9524
9525 begin
9526 -- Do validity check if validity checking operands
9527
9528 if Validity_Checks_On and Validity_Check_Operands then
9529 Ensure_Valid (Operand);
9530 end if;
9531
9532 -- Apply possible constraint check
9533
9534 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
9535
9536 if Do_Range_Check (Operand) then
9537 Set_Do_Range_Check (Operand, False);
9538 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
9539 end if;
9540 end Expand_N_Qualified_Expression;
9541
9542 ------------------------------------
9543 -- Expand_N_Quantified_Expression --
9544 ------------------------------------
9545
9546 -- We expand:
9547
9548 -- for all X in range => Cond
9549
9550 -- into:
9551
9552 -- T := True;
9553 -- for X in range loop
9554 -- if not Cond then
9555 -- T := False;
9556 -- exit;
9557 -- end if;
9558 -- end loop;
9559
9560 -- Similarly, an existentially quantified expression:
9561
9562 -- for some X in range => Cond
9563
9564 -- becomes:
9565
9566 -- T := False;
9567 -- for X in range loop
9568 -- if Cond then
9569 -- T := True;
9570 -- exit;
9571 -- end if;
9572 -- end loop;
9573
9574 -- In both cases, the iteration may be over a container in which case it is
9575 -- given by an iterator specification, not a loop parameter specification.
9576
9577 procedure Expand_N_Quantified_Expression (N : Node_Id) is
9578 Actions : constant List_Id := New_List;
9579 For_All : constant Boolean := All_Present (N);
9580 Iter_Spec : constant Node_Id := Iterator_Specification (N);
9581 Loc : constant Source_Ptr := Sloc (N);
9582 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
9583 Cond : Node_Id;
9584 Flag : Entity_Id;
9585 Scheme : Node_Id;
9586 Stmts : List_Id;
9587
9588 begin
9589 -- Create the declaration of the flag which tracks the status of the
9590 -- quantified expression. Generate:
9591
9592 -- Flag : Boolean := (True | False);
9593
9594 Flag := Make_Temporary (Loc, 'T', N);
9595
9596 Append_To (Actions,
9597 Make_Object_Declaration (Loc,
9598 Defining_Identifier => Flag,
9599 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
9600 Expression =>
9601 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
9602
9603 -- Construct the circuitry which tracks the status of the quantified
9604 -- expression. Generate:
9605
9606 -- if [not] Cond then
9607 -- Flag := (False | True);
9608 -- exit;
9609 -- end if;
9610
9611 Cond := Relocate_Node (Condition (N));
9612
9613 if For_All then
9614 Cond := Make_Op_Not (Loc, Cond);
9615 end if;
9616
9617 Stmts := New_List (
9618 Make_Implicit_If_Statement (N,
9619 Condition => Cond,
9620 Then_Statements => New_List (
9621 Make_Assignment_Statement (Loc,
9622 Name => New_Occurrence_Of (Flag, Loc),
9623 Expression =>
9624 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
9625 Make_Exit_Statement (Loc))));
9626
9627 -- Build the loop equivalent of the quantified expression
9628
9629 if Present (Iter_Spec) then
9630 Scheme :=
9631 Make_Iteration_Scheme (Loc,
9632 Iterator_Specification => Iter_Spec);
9633 else
9634 Scheme :=
9635 Make_Iteration_Scheme (Loc,
9636 Loop_Parameter_Specification => Loop_Spec);
9637 end if;
9638
9639 Append_To (Actions,
9640 Make_Loop_Statement (Loc,
9641 Iteration_Scheme => Scheme,
9642 Statements => Stmts,
9643 End_Label => Empty));
9644
9645 -- Transform the quantified expression
9646
9647 Rewrite (N,
9648 Make_Expression_With_Actions (Loc,
9649 Expression => New_Occurrence_Of (Flag, Loc),
9650 Actions => Actions));
9651 Analyze_And_Resolve (N, Standard_Boolean);
9652 end Expand_N_Quantified_Expression;
9653
9654 ---------------------------------
9655 -- Expand_N_Selected_Component --
9656 ---------------------------------
9657
9658 procedure Expand_N_Selected_Component (N : Node_Id) is
9659 Loc : constant Source_Ptr := Sloc (N);
9660 Par : constant Node_Id := Parent (N);
9661 P : constant Node_Id := Prefix (N);
9662 S : constant Node_Id := Selector_Name (N);
9663 Ptyp : Entity_Id := Underlying_Type (Etype (P));
9664 Disc : Entity_Id;
9665 New_N : Node_Id;
9666 Dcon : Elmt_Id;
9667 Dval : Node_Id;
9668
9669 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
9670 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9671 -- unless the context of an assignment can provide size information.
9672 -- Don't we have a general routine that does this???
9673
9674 function Is_Subtype_Declaration return Boolean;
9675 -- The replacement of a discriminant reference by its value is required
9676 -- if this is part of the initialization of an temporary generated by a
9677 -- change of representation. This shows up as the construction of a
9678 -- discriminant constraint for a subtype declared at the same point as
9679 -- the entity in the prefix of the selected component. We recognize this
9680 -- case when the context of the reference is:
9681 -- subtype ST is T(Obj.D);
9682 -- where the entity for Obj comes from source, and ST has the same sloc.
9683
9684 -----------------------
9685 -- In_Left_Hand_Side --
9686 -----------------------
9687
9688 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
9689 begin
9690 return (Nkind (Parent (Comp)) = N_Assignment_Statement
9691 and then Comp = Name (Parent (Comp)))
9692 or else (Present (Parent (Comp))
9693 and then Nkind (Parent (Comp)) in N_Subexpr
9694 and then In_Left_Hand_Side (Parent (Comp)));
9695 end In_Left_Hand_Side;
9696
9697 -----------------------------
9698 -- Is_Subtype_Declaration --
9699 -----------------------------
9700
9701 function Is_Subtype_Declaration return Boolean is
9702 Par : constant Node_Id := Parent (N);
9703 begin
9704 return
9705 Nkind (Par) = N_Index_Or_Discriminant_Constraint
9706 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
9707 and then Comes_From_Source (Entity (Prefix (N)))
9708 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
9709 end Is_Subtype_Declaration;
9710
9711 -- Start of processing for Expand_N_Selected_Component
9712
9713 begin
9714 -- Insert explicit dereference if required
9715
9716 if Is_Access_Type (Ptyp) then
9717
9718 -- First set prefix type to proper access type, in case it currently
9719 -- has a private (non-access) view of this type.
9720
9721 Set_Etype (P, Ptyp);
9722
9723 Insert_Explicit_Dereference (P);
9724 Analyze_And_Resolve (P, Designated_Type (Ptyp));
9725
9726 if Ekind (Etype (P)) = E_Private_Subtype
9727 and then Is_For_Access_Subtype (Etype (P))
9728 then
9729 Set_Etype (P, Base_Type (Etype (P)));
9730 end if;
9731
9732 Ptyp := Etype (P);
9733 end if;
9734
9735 -- Deal with discriminant check required
9736
9737 if Do_Discriminant_Check (N) then
9738 if Present (Discriminant_Checking_Func
9739 (Original_Record_Component (Entity (S))))
9740 then
9741 -- Present the discriminant checking function to the backend, so
9742 -- that it can inline the call to the function.
9743
9744 Add_Inlined_Body
9745 (Discriminant_Checking_Func
9746 (Original_Record_Component (Entity (S))),
9747 N);
9748
9749 -- Now reset the flag and generate the call
9750
9751 Set_Do_Discriminant_Check (N, False);
9752 Generate_Discriminant_Check (N);
9753
9754 -- In the case of Unchecked_Union, no discriminant checking is
9755 -- actually performed.
9756
9757 else
9758 Set_Do_Discriminant_Check (N, False);
9759 end if;
9760 end if;
9761
9762 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9763 -- function, then additional actuals must be passed.
9764
9765 if Ada_Version >= Ada_2005
9766 and then Is_Build_In_Place_Function_Call (P)
9767 then
9768 Make_Build_In_Place_Call_In_Anonymous_Context (P);
9769 end if;
9770
9771 -- Gigi cannot handle unchecked conversions that are the prefix of a
9772 -- selected component with discriminants. This must be checked during
9773 -- expansion, because during analysis the type of the selector is not
9774 -- known at the point the prefix is analyzed. If the conversion is the
9775 -- target of an assignment, then we cannot force the evaluation.
9776
9777 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
9778 and then Has_Discriminants (Etype (N))
9779 and then not In_Left_Hand_Side (N)
9780 then
9781 Force_Evaluation (Prefix (N));
9782 end if;
9783
9784 -- Remaining processing applies only if selector is a discriminant
9785
9786 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
9787
9788 -- If the selector is a discriminant of a constrained record type,
9789 -- we may be able to rewrite the expression with the actual value
9790 -- of the discriminant, a useful optimization in some cases.
9791
9792 if Is_Record_Type (Ptyp)
9793 and then Has_Discriminants (Ptyp)
9794 and then Is_Constrained (Ptyp)
9795 then
9796 -- Do this optimization for discrete types only, and not for
9797 -- access types (access discriminants get us into trouble).
9798
9799 if not Is_Discrete_Type (Etype (N)) then
9800 null;
9801
9802 -- Don't do this on the left-hand side of an assignment statement.
9803 -- Normally one would think that references like this would not
9804 -- occur, but they do in generated code, and mean that we really
9805 -- do want to assign the discriminant.
9806
9807 elsif Nkind (Par) = N_Assignment_Statement
9808 and then Name (Par) = N
9809 then
9810 null;
9811
9812 -- Don't do this optimization for the prefix of an attribute or
9813 -- the name of an object renaming declaration since these are
9814 -- contexts where we do not want the value anyway.
9815
9816 elsif (Nkind (Par) = N_Attribute_Reference
9817 and then Prefix (Par) = N)
9818 or else Is_Renamed_Object (N)
9819 then
9820 null;
9821
9822 -- Don't do this optimization if we are within the code for a
9823 -- discriminant check, since the whole point of such a check may
9824 -- be to verify the condition on which the code below depends.
9825
9826 elsif Is_In_Discriminant_Check (N) then
9827 null;
9828
9829 -- Green light to see if we can do the optimization. There is
9830 -- still one condition that inhibits the optimization below but
9831 -- now is the time to check the particular discriminant.
9832
9833 else
9834 -- Loop through discriminants to find the matching discriminant
9835 -- constraint to see if we can copy it.
9836
9837 Disc := First_Discriminant (Ptyp);
9838 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
9839 Discr_Loop : while Present (Dcon) loop
9840 Dval := Node (Dcon);
9841
9842 -- Check if this is the matching discriminant and if the
9843 -- discriminant value is simple enough to make sense to
9844 -- copy. We don't want to copy complex expressions, and
9845 -- indeed to do so can cause trouble (before we put in
9846 -- this guard, a discriminant expression containing an
9847 -- AND THEN was copied, causing problems for coverage
9848 -- analysis tools).
9849
9850 -- However, if the reference is part of the initialization
9851 -- code generated for an object declaration, we must use
9852 -- the discriminant value from the subtype constraint,
9853 -- because the selected component may be a reference to the
9854 -- object being initialized, whose discriminant is not yet
9855 -- set. This only happens in complex cases involving changes
9856 -- or representation.
9857
9858 if Disc = Entity (Selector_Name (N))
9859 and then (Is_Entity_Name (Dval)
9860 or else Compile_Time_Known_Value (Dval)
9861 or else Is_Subtype_Declaration)
9862 then
9863 -- Here we have the matching discriminant. Check for
9864 -- the case of a discriminant of a component that is
9865 -- constrained by an outer discriminant, which cannot
9866 -- be optimized away.
9867
9868 if Denotes_Discriminant
9869 (Dval, Check_Concurrent => True)
9870 then
9871 exit Discr_Loop;
9872
9873 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
9874 and then
9875 Denotes_Discriminant
9876 (Selector_Name (Original_Node (Dval)), True)
9877 then
9878 exit Discr_Loop;
9879
9880 -- Do not retrieve value if constraint is not static. It
9881 -- is generally not useful, and the constraint may be a
9882 -- rewritten outer discriminant in which case it is in
9883 -- fact incorrect.
9884
9885 elsif Is_Entity_Name (Dval)
9886 and then
9887 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
9888 and then Present (Expression (Parent (Entity (Dval))))
9889 and then not
9890 Is_OK_Static_Expression
9891 (Expression (Parent (Entity (Dval))))
9892 then
9893 exit Discr_Loop;
9894
9895 -- In the context of a case statement, the expression may
9896 -- have the base type of the discriminant, and we need to
9897 -- preserve the constraint to avoid spurious errors on
9898 -- missing cases.
9899
9900 elsif Nkind (Parent (N)) = N_Case_Statement
9901 and then Etype (Dval) /= Etype (Disc)
9902 then
9903 Rewrite (N,
9904 Make_Qualified_Expression (Loc,
9905 Subtype_Mark =>
9906 New_Occurrence_Of (Etype (Disc), Loc),
9907 Expression =>
9908 New_Copy_Tree (Dval)));
9909 Analyze_And_Resolve (N, Etype (Disc));
9910
9911 -- In case that comes out as a static expression,
9912 -- reset it (a selected component is never static).
9913
9914 Set_Is_Static_Expression (N, False);
9915 return;
9916
9917 -- Otherwise we can just copy the constraint, but the
9918 -- result is certainly not static. In some cases the
9919 -- discriminant constraint has been analyzed in the
9920 -- context of the original subtype indication, but for
9921 -- itypes the constraint might not have been analyzed
9922 -- yet, and this must be done now.
9923
9924 else
9925 Rewrite (N, New_Copy_Tree (Dval));
9926 Analyze_And_Resolve (N);
9927 Set_Is_Static_Expression (N, False);
9928 return;
9929 end if;
9930 end if;
9931
9932 Next_Elmt (Dcon);
9933 Next_Discriminant (Disc);
9934 end loop Discr_Loop;
9935
9936 -- Note: the above loop should always find a matching
9937 -- discriminant, but if it does not, we just missed an
9938 -- optimization due to some glitch (perhaps a previous
9939 -- error), so ignore.
9940
9941 end if;
9942 end if;
9943
9944 -- The only remaining processing is in the case of a discriminant of
9945 -- a concurrent object, where we rewrite the prefix to denote the
9946 -- corresponding record type. If the type is derived and has renamed
9947 -- discriminants, use corresponding discriminant, which is the one
9948 -- that appears in the corresponding record.
9949
9950 if not Is_Concurrent_Type (Ptyp) then
9951 return;
9952 end if;
9953
9954 Disc := Entity (Selector_Name (N));
9955
9956 if Is_Derived_Type (Ptyp)
9957 and then Present (Corresponding_Discriminant (Disc))
9958 then
9959 Disc := Corresponding_Discriminant (Disc);
9960 end if;
9961
9962 New_N :=
9963 Make_Selected_Component (Loc,
9964 Prefix =>
9965 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
9966 New_Copy_Tree (P)),
9967 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
9968
9969 Rewrite (N, New_N);
9970 Analyze (N);
9971 end if;
9972
9973 -- Set Atomic_Sync_Required if necessary for atomic component
9974
9975 if Nkind (N) = N_Selected_Component then
9976 declare
9977 E : constant Entity_Id := Entity (Selector_Name (N));
9978 Set : Boolean;
9979
9980 begin
9981 -- If component is atomic, but type is not, setting depends on
9982 -- disable/enable state for the component.
9983
9984 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
9985 Set := not Atomic_Synchronization_Disabled (E);
9986
9987 -- If component is not atomic, but its type is atomic, setting
9988 -- depends on disable/enable state for the type.
9989
9990 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9991 Set := not Atomic_Synchronization_Disabled (Etype (E));
9992
9993 -- If both component and type are atomic, we disable if either
9994 -- component or its type have sync disabled.
9995
9996 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9997 Set := (not Atomic_Synchronization_Disabled (E))
9998 and then
9999 (not Atomic_Synchronization_Disabled (Etype (E)));
10000
10001 else
10002 Set := False;
10003 end if;
10004
10005 -- Set flag if required
10006
10007 if Set then
10008 Activate_Atomic_Synchronization (N);
10009 end if;
10010 end;
10011 end if;
10012 end Expand_N_Selected_Component;
10013
10014 --------------------
10015 -- Expand_N_Slice --
10016 --------------------
10017
10018 procedure Expand_N_Slice (N : Node_Id) is
10019 Loc : constant Source_Ptr := Sloc (N);
10020 Typ : constant Entity_Id := Etype (N);
10021
10022 function Is_Procedure_Actual (N : Node_Id) return Boolean;
10023 -- Check whether the argument is an actual for a procedure call, in
10024 -- which case the expansion of a bit-packed slice is deferred until the
10025 -- call itself is expanded. The reason this is required is that we might
10026 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10027 -- that copy out would be missed if we created a temporary here in
10028 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10029 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10030 -- is harmless to defer expansion in the IN case, since the call
10031 -- processing will still generate the appropriate copy in operation,
10032 -- which will take care of the slice.
10033
10034 procedure Make_Temporary_For_Slice;
10035 -- Create a named variable for the value of the slice, in cases where
10036 -- the back-end cannot handle it properly, e.g. when packed types or
10037 -- unaligned slices are involved.
10038
10039 -------------------------
10040 -- Is_Procedure_Actual --
10041 -------------------------
10042
10043 function Is_Procedure_Actual (N : Node_Id) return Boolean is
10044 Par : Node_Id := Parent (N);
10045
10046 begin
10047 loop
10048 -- If our parent is a procedure call we can return
10049
10050 if Nkind (Par) = N_Procedure_Call_Statement then
10051 return True;
10052
10053 -- If our parent is a type conversion, keep climbing the tree,
10054 -- since a type conversion can be a procedure actual. Also keep
10055 -- climbing if parameter association or a qualified expression,
10056 -- since these are additional cases that do can appear on
10057 -- procedure actuals.
10058
10059 elsif Nkind_In (Par, N_Type_Conversion,
10060 N_Parameter_Association,
10061 N_Qualified_Expression)
10062 then
10063 Par := Parent (Par);
10064
10065 -- Any other case is not what we are looking for
10066
10067 else
10068 return False;
10069 end if;
10070 end loop;
10071 end Is_Procedure_Actual;
10072
10073 ------------------------------
10074 -- Make_Temporary_For_Slice --
10075 ------------------------------
10076
10077 procedure Make_Temporary_For_Slice is
10078 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
10079 Decl : Node_Id;
10080
10081 begin
10082 Decl :=
10083 Make_Object_Declaration (Loc,
10084 Defining_Identifier => Ent,
10085 Object_Definition => New_Occurrence_Of (Typ, Loc));
10086
10087 Set_No_Initialization (Decl);
10088
10089 Insert_Actions (N, New_List (
10090 Decl,
10091 Make_Assignment_Statement (Loc,
10092 Name => New_Occurrence_Of (Ent, Loc),
10093 Expression => Relocate_Node (N))));
10094
10095 Rewrite (N, New_Occurrence_Of (Ent, Loc));
10096 Analyze_And_Resolve (N, Typ);
10097 end Make_Temporary_For_Slice;
10098
10099 -- Local variables
10100
10101 Pref : constant Node_Id := Prefix (N);
10102 Pref_Typ : Entity_Id := Etype (Pref);
10103
10104 -- Start of processing for Expand_N_Slice
10105
10106 begin
10107 -- Special handling for access types
10108
10109 if Is_Access_Type (Pref_Typ) then
10110 Pref_Typ := Designated_Type (Pref_Typ);
10111
10112 Rewrite (Pref,
10113 Make_Explicit_Dereference (Sloc (N),
10114 Prefix => Relocate_Node (Pref)));
10115
10116 Analyze_And_Resolve (Pref, Pref_Typ);
10117 end if;
10118
10119 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10120 -- function, then additional actuals must be passed.
10121
10122 if Ada_Version >= Ada_2005
10123 and then Is_Build_In_Place_Function_Call (Pref)
10124 then
10125 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
10126 end if;
10127
10128 -- The remaining case to be handled is packed slices. We can leave
10129 -- packed slices as they are in the following situations:
10130
10131 -- 1. Right or left side of an assignment (we can handle this
10132 -- situation correctly in the assignment statement expansion).
10133
10134 -- 2. Prefix of indexed component (the slide is optimized away in this
10135 -- case, see the start of Expand_N_Slice.)
10136
10137 -- 3. Object renaming declaration, since we want the name of the
10138 -- slice, not the value.
10139
10140 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10141 -- be required, and this is handled in the expansion of call
10142 -- itself.
10143
10144 -- 5. Prefix of an address attribute (this is an error which is caught
10145 -- elsewhere, and the expansion would interfere with generating the
10146 -- error message).
10147
10148 if not Is_Packed (Typ) then
10149
10150 -- Apply transformation for actuals of a function call, where
10151 -- Expand_Actuals is not used.
10152
10153 if Nkind (Parent (N)) = N_Function_Call
10154 and then Is_Possibly_Unaligned_Slice (N)
10155 then
10156 Make_Temporary_For_Slice;
10157 end if;
10158
10159 elsif Nkind (Parent (N)) = N_Assignment_Statement
10160 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
10161 and then Parent (N) = Name (Parent (Parent (N))))
10162 then
10163 return;
10164
10165 elsif Nkind (Parent (N)) = N_Indexed_Component
10166 or else Is_Renamed_Object (N)
10167 or else Is_Procedure_Actual (N)
10168 then
10169 return;
10170
10171 elsif Nkind (Parent (N)) = N_Attribute_Reference
10172 and then Attribute_Name (Parent (N)) = Name_Address
10173 then
10174 return;
10175
10176 else
10177 Make_Temporary_For_Slice;
10178 end if;
10179 end Expand_N_Slice;
10180
10181 ------------------------------
10182 -- Expand_N_Type_Conversion --
10183 ------------------------------
10184
10185 procedure Expand_N_Type_Conversion (N : Node_Id) is
10186 Loc : constant Source_Ptr := Sloc (N);
10187 Operand : constant Node_Id := Expression (N);
10188 Target_Type : constant Entity_Id := Etype (N);
10189 Operand_Type : Entity_Id := Etype (Operand);
10190
10191 procedure Handle_Changed_Representation;
10192 -- This is called in the case of record and array type conversions to
10193 -- see if there is a change of representation to be handled. Change of
10194 -- representation is actually handled at the assignment statement level,
10195 -- and what this procedure does is rewrite node N conversion as an
10196 -- assignment to temporary. If there is no change of representation,
10197 -- then the conversion node is unchanged.
10198
10199 procedure Raise_Accessibility_Error;
10200 -- Called when we know that an accessibility check will fail. Rewrites
10201 -- node N to an appropriate raise statement and outputs warning msgs.
10202 -- The Etype of the raise node is set to Target_Type. Note that in this
10203 -- case the rest of the processing should be skipped (i.e. the call to
10204 -- this procedure will be followed by "goto Done").
10205
10206 procedure Real_Range_Check;
10207 -- Handles generation of range check for real target value
10208
10209 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
10210 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10211 -- evaluates to True.
10212
10213 -----------------------------------
10214 -- Handle_Changed_Representation --
10215 -----------------------------------
10216
10217 procedure Handle_Changed_Representation is
10218 Temp : Entity_Id;
10219 Decl : Node_Id;
10220 Odef : Node_Id;
10221 Disc : Node_Id;
10222 N_Ix : Node_Id;
10223 Cons : List_Id;
10224
10225 begin
10226 -- Nothing else to do if no change of representation
10227
10228 if Same_Representation (Operand_Type, Target_Type) then
10229 return;
10230
10231 -- The real change of representation work is done by the assignment
10232 -- statement processing. So if this type conversion is appearing as
10233 -- the expression of an assignment statement, nothing needs to be
10234 -- done to the conversion.
10235
10236 elsif Nkind (Parent (N)) = N_Assignment_Statement then
10237 return;
10238
10239 -- Otherwise we need to generate a temporary variable, and do the
10240 -- change of representation assignment into that temporary variable.
10241 -- The conversion is then replaced by a reference to this variable.
10242
10243 else
10244 Cons := No_List;
10245
10246 -- If type is unconstrained we have to add a constraint, copied
10247 -- from the actual value of the left-hand side.
10248
10249 if not Is_Constrained (Target_Type) then
10250 if Has_Discriminants (Operand_Type) then
10251 Disc := First_Discriminant (Operand_Type);
10252
10253 if Disc /= First_Stored_Discriminant (Operand_Type) then
10254 Disc := First_Stored_Discriminant (Operand_Type);
10255 end if;
10256
10257 Cons := New_List;
10258 while Present (Disc) loop
10259 Append_To (Cons,
10260 Make_Selected_Component (Loc,
10261 Prefix =>
10262 Duplicate_Subexpr_Move_Checks (Operand),
10263 Selector_Name =>
10264 Make_Identifier (Loc, Chars (Disc))));
10265 Next_Discriminant (Disc);
10266 end loop;
10267
10268 elsif Is_Array_Type (Operand_Type) then
10269 N_Ix := First_Index (Target_Type);
10270 Cons := New_List;
10271
10272 for J in 1 .. Number_Dimensions (Operand_Type) loop
10273
10274 -- We convert the bounds explicitly. We use an unchecked
10275 -- conversion because bounds checks are done elsewhere.
10276
10277 Append_To (Cons,
10278 Make_Range (Loc,
10279 Low_Bound =>
10280 Unchecked_Convert_To (Etype (N_Ix),
10281 Make_Attribute_Reference (Loc,
10282 Prefix =>
10283 Duplicate_Subexpr_No_Checks
10284 (Operand, Name_Req => True),
10285 Attribute_Name => Name_First,
10286 Expressions => New_List (
10287 Make_Integer_Literal (Loc, J)))),
10288
10289 High_Bound =>
10290 Unchecked_Convert_To (Etype (N_Ix),
10291 Make_Attribute_Reference (Loc,
10292 Prefix =>
10293 Duplicate_Subexpr_No_Checks
10294 (Operand, Name_Req => True),
10295 Attribute_Name => Name_Last,
10296 Expressions => New_List (
10297 Make_Integer_Literal (Loc, J))))));
10298
10299 Next_Index (N_Ix);
10300 end loop;
10301 end if;
10302 end if;
10303
10304 Odef := New_Occurrence_Of (Target_Type, Loc);
10305
10306 if Present (Cons) then
10307 Odef :=
10308 Make_Subtype_Indication (Loc,
10309 Subtype_Mark => Odef,
10310 Constraint =>
10311 Make_Index_Or_Discriminant_Constraint (Loc,
10312 Constraints => Cons));
10313 end if;
10314
10315 Temp := Make_Temporary (Loc, 'C');
10316 Decl :=
10317 Make_Object_Declaration (Loc,
10318 Defining_Identifier => Temp,
10319 Object_Definition => Odef);
10320
10321 Set_No_Initialization (Decl, True);
10322
10323 -- Insert required actions. It is essential to suppress checks
10324 -- since we have suppressed default initialization, which means
10325 -- that the variable we create may have no discriminants.
10326
10327 Insert_Actions (N,
10328 New_List (
10329 Decl,
10330 Make_Assignment_Statement (Loc,
10331 Name => New_Occurrence_Of (Temp, Loc),
10332 Expression => Relocate_Node (N))),
10333 Suppress => All_Checks);
10334
10335 Rewrite (N, New_Occurrence_Of (Temp, Loc));
10336 return;
10337 end if;
10338 end Handle_Changed_Representation;
10339
10340 -------------------------------
10341 -- Raise_Accessibility_Error --
10342 -------------------------------
10343
10344 procedure Raise_Accessibility_Error is
10345 begin
10346 Error_Msg_Warn := SPARK_Mode /= On;
10347 Rewrite (N,
10348 Make_Raise_Program_Error (Sloc (N),
10349 Reason => PE_Accessibility_Check_Failed));
10350 Set_Etype (N, Target_Type);
10351
10352 Error_Msg_N ("<<accessibility check failure", N);
10353 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
10354 end Raise_Accessibility_Error;
10355
10356 ----------------------
10357 -- Real_Range_Check --
10358 ----------------------
10359
10360 -- Case of conversions to floating-point or fixed-point. If range checks
10361 -- are enabled and the target type has a range constraint, we convert:
10362
10363 -- typ (x)
10364
10365 -- to
10366
10367 -- Tnn : typ'Base := typ'Base (x);
10368 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10369 -- Tnn
10370
10371 -- This is necessary when there is a conversion of integer to float or
10372 -- to fixed-point to ensure that the correct checks are made. It is not
10373 -- necessary for float to float where it is enough to simply set the
10374 -- Do_Range_Check flag.
10375
10376 procedure Real_Range_Check is
10377 Btyp : constant Entity_Id := Base_Type (Target_Type);
10378 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
10379 Hi : constant Node_Id := Type_High_Bound (Target_Type);
10380 Xtyp : constant Entity_Id := Etype (Operand);
10381 Conv : Node_Id;
10382 Tnn : Entity_Id;
10383
10384 begin
10385 -- Nothing to do if conversion was rewritten
10386
10387 if Nkind (N) /= N_Type_Conversion then
10388 return;
10389 end if;
10390
10391 -- Nothing to do if range checks suppressed, or target has the same
10392 -- range as the base type (or is the base type).
10393
10394 if Range_Checks_Suppressed (Target_Type)
10395 or else (Lo = Type_Low_Bound (Btyp)
10396 and then
10397 Hi = Type_High_Bound (Btyp))
10398 then
10399 return;
10400 end if;
10401
10402 -- Nothing to do if expression is an entity on which checks have been
10403 -- suppressed.
10404
10405 if Is_Entity_Name (Operand)
10406 and then Range_Checks_Suppressed (Entity (Operand))
10407 then
10408 return;
10409 end if;
10410
10411 -- Nothing to do if bounds are all static and we can tell that the
10412 -- expression is within the bounds of the target. Note that if the
10413 -- operand is of an unconstrained floating-point type, then we do
10414 -- not trust it to be in range (might be infinite)
10415
10416 declare
10417 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
10418 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
10419
10420 begin
10421 if (not Is_Floating_Point_Type (Xtyp)
10422 or else Is_Constrained (Xtyp))
10423 and then Compile_Time_Known_Value (S_Lo)
10424 and then Compile_Time_Known_Value (S_Hi)
10425 and then Compile_Time_Known_Value (Hi)
10426 and then Compile_Time_Known_Value (Lo)
10427 then
10428 declare
10429 D_Lov : constant Ureal := Expr_Value_R (Lo);
10430 D_Hiv : constant Ureal := Expr_Value_R (Hi);
10431 S_Lov : Ureal;
10432 S_Hiv : Ureal;
10433
10434 begin
10435 if Is_Real_Type (Xtyp) then
10436 S_Lov := Expr_Value_R (S_Lo);
10437 S_Hiv := Expr_Value_R (S_Hi);
10438 else
10439 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
10440 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
10441 end if;
10442
10443 if D_Hiv > D_Lov
10444 and then S_Lov >= D_Lov
10445 and then S_Hiv <= D_Hiv
10446 then
10447 -- Unset the range check flag on the current value of
10448 -- Expression (N), since the captured Operand may have
10449 -- been rewritten (such as for the case of a conversion
10450 -- to a fixed-point type).
10451
10452 Set_Do_Range_Check (Expression (N), False);
10453
10454 return;
10455 end if;
10456 end;
10457 end if;
10458 end;
10459
10460 -- For float to float conversions, we are done
10461
10462 if Is_Floating_Point_Type (Xtyp)
10463 and then
10464 Is_Floating_Point_Type (Btyp)
10465 then
10466 return;
10467 end if;
10468
10469 -- Otherwise rewrite the conversion as described above
10470
10471 Conv := Relocate_Node (N);
10472 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
10473 Set_Etype (Conv, Btyp);
10474
10475 -- Enable overflow except for case of integer to float conversions,
10476 -- where it is never required, since we can never have overflow in
10477 -- this case.
10478
10479 if not Is_Integer_Type (Etype (Operand)) then
10480 Enable_Overflow_Check (Conv);
10481 end if;
10482
10483 Tnn := Make_Temporary (Loc, 'T', Conv);
10484
10485 Insert_Actions (N, New_List (
10486 Make_Object_Declaration (Loc,
10487 Defining_Identifier => Tnn,
10488 Object_Definition => New_Occurrence_Of (Btyp, Loc),
10489 Constant_Present => True,
10490 Expression => Conv),
10491
10492 Make_Raise_Constraint_Error (Loc,
10493 Condition =>
10494 Make_Or_Else (Loc,
10495 Left_Opnd =>
10496 Make_Op_Lt (Loc,
10497 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10498 Right_Opnd =>
10499 Make_Attribute_Reference (Loc,
10500 Attribute_Name => Name_First,
10501 Prefix =>
10502 New_Occurrence_Of (Target_Type, Loc))),
10503
10504 Right_Opnd =>
10505 Make_Op_Gt (Loc,
10506 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10507 Right_Opnd =>
10508 Make_Attribute_Reference (Loc,
10509 Attribute_Name => Name_Last,
10510 Prefix =>
10511 New_Occurrence_Of (Target_Type, Loc)))),
10512 Reason => CE_Range_Check_Failed)));
10513
10514 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
10515 Analyze_And_Resolve (N, Btyp);
10516 end Real_Range_Check;
10517
10518 -----------------------------
10519 -- Has_Extra_Accessibility --
10520 -----------------------------
10521
10522 -- Returns true for a formal of an anonymous access type or for
10523 -- an Ada 2012-style stand-alone object of an anonymous access type.
10524
10525 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
10526 begin
10527 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
10528 return Present (Effective_Extra_Accessibility (Id));
10529 else
10530 return False;
10531 end if;
10532 end Has_Extra_Accessibility;
10533
10534 -- Start of processing for Expand_N_Type_Conversion
10535
10536 begin
10537 -- First remove check marks put by the semantic analysis on the type
10538 -- conversion between array types. We need these checks, and they will
10539 -- be generated by this expansion routine, but we do not depend on these
10540 -- flags being set, and since we do intend to expand the checks in the
10541 -- front end, we don't want them on the tree passed to the back end.
10542
10543 if Is_Array_Type (Target_Type) then
10544 if Is_Constrained (Target_Type) then
10545 Set_Do_Length_Check (N, False);
10546 else
10547 Set_Do_Range_Check (Operand, False);
10548 end if;
10549 end if;
10550
10551 -- Nothing at all to do if conversion is to the identical type so remove
10552 -- the conversion completely, it is useless, except that it may carry
10553 -- an Assignment_OK attribute, which must be propagated to the operand.
10554
10555 if Operand_Type = Target_Type then
10556 if Assignment_OK (N) then
10557 Set_Assignment_OK (Operand);
10558 end if;
10559
10560 Rewrite (N, Relocate_Node (Operand));
10561 goto Done;
10562 end if;
10563
10564 -- Nothing to do if this is the second argument of read. This is a
10565 -- "backwards" conversion that will be handled by the specialized code
10566 -- in attribute processing.
10567
10568 if Nkind (Parent (N)) = N_Attribute_Reference
10569 and then Attribute_Name (Parent (N)) = Name_Read
10570 and then Next (First (Expressions (Parent (N)))) = N
10571 then
10572 goto Done;
10573 end if;
10574
10575 -- Check for case of converting to a type that has an invariant
10576 -- associated with it. This required an invariant check. We convert
10577
10578 -- typ (expr)
10579
10580 -- into
10581
10582 -- do invariant_check (typ (expr)) in typ (expr);
10583
10584 -- using Duplicate_Subexpr to avoid multiple side effects
10585
10586 -- Note: the Comes_From_Source check, and then the resetting of this
10587 -- flag prevents what would otherwise be an infinite recursion.
10588
10589 if Has_Invariants (Target_Type)
10590 and then Present (Invariant_Procedure (Target_Type))
10591 and then Comes_From_Source (N)
10592 then
10593 Set_Comes_From_Source (N, False);
10594 Rewrite (N,
10595 Make_Expression_With_Actions (Loc,
10596 Actions => New_List (
10597 Make_Invariant_Call (Duplicate_Subexpr (N))),
10598 Expression => Duplicate_Subexpr_No_Checks (N)));
10599 Analyze_And_Resolve (N, Target_Type);
10600 goto Done;
10601 end if;
10602
10603 -- Here if we may need to expand conversion
10604
10605 -- If the operand of the type conversion is an arithmetic operation on
10606 -- signed integers, and the based type of the signed integer type in
10607 -- question is smaller than Standard.Integer, we promote both of the
10608 -- operands to type Integer.
10609
10610 -- For example, if we have
10611
10612 -- target-type (opnd1 + opnd2)
10613
10614 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10615 -- this as:
10616
10617 -- target-type (integer(opnd1) + integer(opnd2))
10618
10619 -- We do this because we are always allowed to compute in a larger type
10620 -- if we do the right thing with the result, and in this case we are
10621 -- going to do a conversion which will do an appropriate check to make
10622 -- sure that things are in range of the target type in any case. This
10623 -- avoids some unnecessary intermediate overflows.
10624
10625 -- We might consider a similar transformation in the case where the
10626 -- target is a real type or a 64-bit integer type, and the operand
10627 -- is an arithmetic operation using a 32-bit integer type. However,
10628 -- we do not bother with this case, because it could cause significant
10629 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10630 -- much cheaper, but we don't want different behavior on 32-bit and
10631 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10632 -- handles the configurable run-time cases where 64-bit arithmetic
10633 -- may simply be unavailable.
10634
10635 -- Note: this circuit is partially redundant with respect to the circuit
10636 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10637 -- the processing here. Also we still need the Checks circuit, since we
10638 -- have to be sure not to generate junk overflow checks in the first
10639 -- place, since it would be trick to remove them here.
10640
10641 if Integer_Promotion_Possible (N) then
10642
10643 -- All conditions met, go ahead with transformation
10644
10645 declare
10646 Opnd : Node_Id;
10647 L, R : Node_Id;
10648
10649 begin
10650 R :=
10651 Make_Type_Conversion (Loc,
10652 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
10653 Expression => Relocate_Node (Right_Opnd (Operand)));
10654
10655 Opnd := New_Op_Node (Nkind (Operand), Loc);
10656 Set_Right_Opnd (Opnd, R);
10657
10658 if Nkind (Operand) in N_Binary_Op then
10659 L :=
10660 Make_Type_Conversion (Loc,
10661 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
10662 Expression => Relocate_Node (Left_Opnd (Operand)));
10663
10664 Set_Left_Opnd (Opnd, L);
10665 end if;
10666
10667 Rewrite (N,
10668 Make_Type_Conversion (Loc,
10669 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
10670 Expression => Opnd));
10671
10672 Analyze_And_Resolve (N, Target_Type);
10673 goto Done;
10674 end;
10675 end if;
10676
10677 -- Do validity check if validity checking operands
10678
10679 if Validity_Checks_On and Validity_Check_Operands then
10680 Ensure_Valid (Operand);
10681 end if;
10682
10683 -- Special case of converting from non-standard boolean type
10684
10685 if Is_Boolean_Type (Operand_Type)
10686 and then (Nonzero_Is_True (Operand_Type))
10687 then
10688 Adjust_Condition (Operand);
10689 Set_Etype (Operand, Standard_Boolean);
10690 Operand_Type := Standard_Boolean;
10691 end if;
10692
10693 -- Case of converting to an access type
10694
10695 if Is_Access_Type (Target_Type) then
10696
10697 -- Apply an accessibility check when the conversion operand is an
10698 -- access parameter (or a renaming thereof), unless conversion was
10699 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10700 -- Note that other checks may still need to be applied below (such
10701 -- as tagged type checks).
10702
10703 if Is_Entity_Name (Operand)
10704 and then Has_Extra_Accessibility (Entity (Operand))
10705 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
10706 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
10707 or else Attribute_Name (Original_Node (N)) = Name_Access)
10708 then
10709 Apply_Accessibility_Check
10710 (Operand, Target_Type, Insert_Node => Operand);
10711
10712 -- If the level of the operand type is statically deeper than the
10713 -- level of the target type, then force Program_Error. Note that this
10714 -- can only occur for cases where the attribute is within the body of
10715 -- an instantiation, otherwise the conversion will already have been
10716 -- rejected as illegal.
10717
10718 -- Note: warnings are issued by the analyzer for the instance cases
10719
10720 elsif In_Instance_Body
10721
10722 -- The case where the target type is an anonymous access type of
10723 -- a discriminant is excluded, because the level of such a type
10724 -- depends on the context and currently the level returned for such
10725 -- types is zero, resulting in warnings about about check failures
10726 -- in certain legal cases involving class-wide interfaces as the
10727 -- designated type (some cases, such as return statements, are
10728 -- checked at run time, but not clear if these are handled right
10729 -- in general, see 3.10.2(12/2-12.5/3) ???).
10730
10731 and then
10732 not (Ekind (Target_Type) = E_Anonymous_Access_Type
10733 and then Present (Associated_Node_For_Itype (Target_Type))
10734 and then Nkind (Associated_Node_For_Itype (Target_Type)) =
10735 N_Discriminant_Specification)
10736 and then
10737 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
10738 then
10739 Raise_Accessibility_Error;
10740 goto Done;
10741
10742 -- When the operand is a selected access discriminant the check needs
10743 -- to be made against the level of the object denoted by the prefix
10744 -- of the selected name. Force Program_Error for this case as well
10745 -- (this accessibility violation can only happen if within the body
10746 -- of an instantiation).
10747
10748 elsif In_Instance_Body
10749 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
10750 and then Nkind (Operand) = N_Selected_Component
10751 and then Object_Access_Level (Operand) >
10752 Type_Access_Level (Target_Type)
10753 then
10754 Raise_Accessibility_Error;
10755 goto Done;
10756 end if;
10757 end if;
10758
10759 -- Case of conversions of tagged types and access to tagged types
10760
10761 -- When needed, that is to say when the expression is class-wide, Add
10762 -- runtime a tag check for (strict) downward conversion by using the
10763 -- membership test, generating:
10764
10765 -- [constraint_error when Operand not in Target_Type'Class]
10766
10767 -- or in the access type case
10768
10769 -- [constraint_error
10770 -- when Operand /= null
10771 -- and then Operand.all not in
10772 -- Designated_Type (Target_Type)'Class]
10773
10774 if (Is_Access_Type (Target_Type)
10775 and then Is_Tagged_Type (Designated_Type (Target_Type)))
10776 or else Is_Tagged_Type (Target_Type)
10777 then
10778 -- Do not do any expansion in the access type case if the parent is a
10779 -- renaming, since this is an error situation which will be caught by
10780 -- Sem_Ch8, and the expansion can interfere with this error check.
10781
10782 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
10783 goto Done;
10784 end if;
10785
10786 -- Otherwise, proceed with processing tagged conversion
10787
10788 Tagged_Conversion : declare
10789 Actual_Op_Typ : Entity_Id;
10790 Actual_Targ_Typ : Entity_Id;
10791 Make_Conversion : Boolean := False;
10792 Root_Op_Typ : Entity_Id;
10793
10794 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
10795 -- Create a membership check to test whether Operand is a member
10796 -- of Targ_Typ. If the original Target_Type is an access, include
10797 -- a test for null value. The check is inserted at N.
10798
10799 --------------------
10800 -- Make_Tag_Check --
10801 --------------------
10802
10803 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
10804 Cond : Node_Id;
10805
10806 begin
10807 -- Generate:
10808 -- [Constraint_Error
10809 -- when Operand /= null
10810 -- and then Operand.all not in Targ_Typ]
10811
10812 if Is_Access_Type (Target_Type) then
10813 Cond :=
10814 Make_And_Then (Loc,
10815 Left_Opnd =>
10816 Make_Op_Ne (Loc,
10817 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10818 Right_Opnd => Make_Null (Loc)),
10819
10820 Right_Opnd =>
10821 Make_Not_In (Loc,
10822 Left_Opnd =>
10823 Make_Explicit_Dereference (Loc,
10824 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
10825 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
10826
10827 -- Generate:
10828 -- [Constraint_Error when Operand not in Targ_Typ]
10829
10830 else
10831 Cond :=
10832 Make_Not_In (Loc,
10833 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10834 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
10835 end if;
10836
10837 Insert_Action (N,
10838 Make_Raise_Constraint_Error (Loc,
10839 Condition => Cond,
10840 Reason => CE_Tag_Check_Failed));
10841 end Make_Tag_Check;
10842
10843 -- Start of processing for Tagged_Conversion
10844
10845 begin
10846 -- Handle entities from the limited view
10847
10848 if Is_Access_Type (Operand_Type) then
10849 Actual_Op_Typ :=
10850 Available_View (Designated_Type (Operand_Type));
10851 else
10852 Actual_Op_Typ := Operand_Type;
10853 end if;
10854
10855 if Is_Access_Type (Target_Type) then
10856 Actual_Targ_Typ :=
10857 Available_View (Designated_Type (Target_Type));
10858 else
10859 Actual_Targ_Typ := Target_Type;
10860 end if;
10861
10862 Root_Op_Typ := Root_Type (Actual_Op_Typ);
10863
10864 -- Ada 2005 (AI-251): Handle interface type conversion
10865
10866 if Is_Interface (Actual_Op_Typ)
10867 or else
10868 Is_Interface (Actual_Targ_Typ)
10869 then
10870 Expand_Interface_Conversion (N);
10871 goto Done;
10872 end if;
10873
10874 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
10875
10876 -- Create a runtime tag check for a downward class-wide type
10877 -- conversion.
10878
10879 if Is_Class_Wide_Type (Actual_Op_Typ)
10880 and then Actual_Op_Typ /= Actual_Targ_Typ
10881 and then Root_Op_Typ /= Actual_Targ_Typ
10882 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
10883 Use_Full_View => True)
10884 then
10885 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
10886 Make_Conversion := True;
10887 end if;
10888
10889 -- AI05-0073: If the result subtype of the function is defined
10890 -- by an access_definition designating a specific tagged type
10891 -- T, a check is made that the result value is null or the tag
10892 -- of the object designated by the result value identifies T.
10893 -- Constraint_Error is raised if this check fails.
10894
10895 if Nkind (Parent (N)) = N_Simple_Return_Statement then
10896 declare
10897 Func : Entity_Id;
10898 Func_Typ : Entity_Id;
10899
10900 begin
10901 -- Climb scope stack looking for the enclosing function
10902
10903 Func := Current_Scope;
10904 while Present (Func)
10905 and then Ekind (Func) /= E_Function
10906 loop
10907 Func := Scope (Func);
10908 end loop;
10909
10910 -- The function's return subtype must be defined using
10911 -- an access definition.
10912
10913 if Nkind (Result_Definition (Parent (Func))) =
10914 N_Access_Definition
10915 then
10916 Func_Typ := Directly_Designated_Type (Etype (Func));
10917
10918 -- The return subtype denotes a specific tagged type,
10919 -- in other words, a non class-wide type.
10920
10921 if Is_Tagged_Type (Func_Typ)
10922 and then not Is_Class_Wide_Type (Func_Typ)
10923 then
10924 Make_Tag_Check (Actual_Targ_Typ);
10925 Make_Conversion := True;
10926 end if;
10927 end if;
10928 end;
10929 end if;
10930
10931 -- We have generated a tag check for either a class-wide type
10932 -- conversion or for AI05-0073.
10933
10934 if Make_Conversion then
10935 declare
10936 Conv : Node_Id;
10937 begin
10938 Conv :=
10939 Make_Unchecked_Type_Conversion (Loc,
10940 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
10941 Expression => Relocate_Node (Expression (N)));
10942 Rewrite (N, Conv);
10943 Analyze_And_Resolve (N, Target_Type);
10944 end;
10945 end if;
10946 end if;
10947 end Tagged_Conversion;
10948
10949 -- Case of other access type conversions
10950
10951 elsif Is_Access_Type (Target_Type) then
10952 Apply_Constraint_Check (Operand, Target_Type);
10953
10954 -- Case of conversions from a fixed-point type
10955
10956 -- These conversions require special expansion and processing, found in
10957 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10958 -- since from a semantic point of view, these are simple integer
10959 -- conversions, which do not need further processing.
10960
10961 elsif Is_Fixed_Point_Type (Operand_Type)
10962 and then not Conversion_OK (N)
10963 then
10964 -- We should never see universal fixed at this case, since the
10965 -- expansion of the constituent divide or multiply should have
10966 -- eliminated the explicit mention of universal fixed.
10967
10968 pragma Assert (Operand_Type /= Universal_Fixed);
10969
10970 -- Check for special case of the conversion to universal real that
10971 -- occurs as a result of the use of a round attribute. In this case,
10972 -- the real type for the conversion is taken from the target type of
10973 -- the Round attribute and the result must be marked as rounded.
10974
10975 if Target_Type = Universal_Real
10976 and then Nkind (Parent (N)) = N_Attribute_Reference
10977 and then Attribute_Name (Parent (N)) = Name_Round
10978 then
10979 Set_Rounded_Result (N);
10980 Set_Etype (N, Etype (Parent (N)));
10981 end if;
10982
10983 -- Otherwise do correct fixed-conversion, but skip these if the
10984 -- Conversion_OK flag is set, because from a semantic point of view
10985 -- these are simple integer conversions needing no further processing
10986 -- (the backend will simply treat them as integers).
10987
10988 if not Conversion_OK (N) then
10989 if Is_Fixed_Point_Type (Etype (N)) then
10990 Expand_Convert_Fixed_To_Fixed (N);
10991 Real_Range_Check;
10992
10993 elsif Is_Integer_Type (Etype (N)) then
10994 Expand_Convert_Fixed_To_Integer (N);
10995
10996 else
10997 pragma Assert (Is_Floating_Point_Type (Etype (N)));
10998 Expand_Convert_Fixed_To_Float (N);
10999 Real_Range_Check;
11000 end if;
11001 end if;
11002
11003 -- Case of conversions to a fixed-point type
11004
11005 -- These conversions require special expansion and processing, found in
11006 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
11007 -- since from a semantic point of view, these are simple integer
11008 -- conversions, which do not need further processing.
11009
11010 elsif Is_Fixed_Point_Type (Target_Type)
11011 and then not Conversion_OK (N)
11012 then
11013 if Is_Integer_Type (Operand_Type) then
11014 Expand_Convert_Integer_To_Fixed (N);
11015 Real_Range_Check;
11016 else
11017 pragma Assert (Is_Floating_Point_Type (Operand_Type));
11018 Expand_Convert_Float_To_Fixed (N);
11019 Real_Range_Check;
11020 end if;
11021
11022 -- Case of float-to-integer conversions
11023
11024 -- We also handle float-to-fixed conversions with Conversion_OK set
11025 -- since semantically the fixed-point target is treated as though it
11026 -- were an integer in such cases.
11027
11028 elsif Is_Floating_Point_Type (Operand_Type)
11029 and then
11030 (Is_Integer_Type (Target_Type)
11031 or else
11032 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
11033 then
11034 -- One more check here, gcc is still not able to do conversions of
11035 -- this type with proper overflow checking, and so gigi is doing an
11036 -- approximation of what is required by doing floating-point compares
11037 -- with the end-point. But that can lose precision in some cases, and
11038 -- give a wrong result. Converting the operand to Universal_Real is
11039 -- helpful, but still does not catch all cases with 64-bit integers
11040 -- on targets with only 64-bit floats.
11041
11042 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
11043 -- Can this code be removed ???
11044
11045 if Do_Range_Check (Operand) then
11046 Rewrite (Operand,
11047 Make_Type_Conversion (Loc,
11048 Subtype_Mark =>
11049 New_Occurrence_Of (Universal_Real, Loc),
11050 Expression =>
11051 Relocate_Node (Operand)));
11052
11053 Set_Etype (Operand, Universal_Real);
11054 Enable_Range_Check (Operand);
11055 Set_Do_Range_Check (Expression (Operand), False);
11056 end if;
11057
11058 -- Case of array conversions
11059
11060 -- Expansion of array conversions, add required length/range checks but
11061 -- only do this if there is no change of representation. For handling of
11062 -- this case, see Handle_Changed_Representation.
11063
11064 elsif Is_Array_Type (Target_Type) then
11065 if Is_Constrained (Target_Type) then
11066 Apply_Length_Check (Operand, Target_Type);
11067 else
11068 Apply_Range_Check (Operand, Target_Type);
11069 end if;
11070
11071 Handle_Changed_Representation;
11072
11073 -- Case of conversions of discriminated types
11074
11075 -- Add required discriminant checks if target is constrained. Again this
11076 -- change is skipped if we have a change of representation.
11077
11078 elsif Has_Discriminants (Target_Type)
11079 and then Is_Constrained (Target_Type)
11080 then
11081 Apply_Discriminant_Check (Operand, Target_Type);
11082 Handle_Changed_Representation;
11083
11084 -- Case of all other record conversions. The only processing required
11085 -- is to check for a change of representation requiring the special
11086 -- assignment processing.
11087
11088 elsif Is_Record_Type (Target_Type) then
11089
11090 -- Ada 2005 (AI-216): Program_Error is raised when converting from
11091 -- a derived Unchecked_Union type to an unconstrained type that is
11092 -- not Unchecked_Union if the operand lacks inferable discriminants.
11093
11094 if Is_Derived_Type (Operand_Type)
11095 and then Is_Unchecked_Union (Base_Type (Operand_Type))
11096 and then not Is_Constrained (Target_Type)
11097 and then not Is_Unchecked_Union (Base_Type (Target_Type))
11098 and then not Has_Inferable_Discriminants (Operand)
11099 then
11100 -- To prevent Gigi from generating illegal code, we generate a
11101 -- Program_Error node, but we give it the target type of the
11102 -- conversion (is this requirement documented somewhere ???)
11103
11104 declare
11105 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
11106 Reason => PE_Unchecked_Union_Restriction);
11107
11108 begin
11109 Set_Etype (PE, Target_Type);
11110 Rewrite (N, PE);
11111
11112 end;
11113 else
11114 Handle_Changed_Representation;
11115 end if;
11116
11117 -- Case of conversions of enumeration types
11118
11119 elsif Is_Enumeration_Type (Target_Type) then
11120
11121 -- Special processing is required if there is a change of
11122 -- representation (from enumeration representation clauses).
11123
11124 if not Same_Representation (Target_Type, Operand_Type) then
11125
11126 -- Convert: x(y) to x'val (ytyp'val (y))
11127
11128 Rewrite (N,
11129 Make_Attribute_Reference (Loc,
11130 Prefix => New_Occurrence_Of (Target_Type, Loc),
11131 Attribute_Name => Name_Val,
11132 Expressions => New_List (
11133 Make_Attribute_Reference (Loc,
11134 Prefix => New_Occurrence_Of (Operand_Type, Loc),
11135 Attribute_Name => Name_Pos,
11136 Expressions => New_List (Operand)))));
11137
11138 Analyze_And_Resolve (N, Target_Type);
11139 end if;
11140
11141 -- Case of conversions to floating-point
11142
11143 elsif Is_Floating_Point_Type (Target_Type) then
11144 Real_Range_Check;
11145 end if;
11146
11147 -- At this stage, either the conversion node has been transformed into
11148 -- some other equivalent expression, or left as a conversion that can be
11149 -- handled by Gigi, in the following cases:
11150
11151 -- Conversions with no change of representation or type
11152
11153 -- Numeric conversions involving integer, floating- and fixed-point
11154 -- values. Fixed-point values are allowed only if Conversion_OK is
11155 -- set, i.e. if the fixed-point values are to be treated as integers.
11156
11157 -- No other conversions should be passed to Gigi
11158
11159 -- Check: are these rules stated in sinfo??? if so, why restate here???
11160
11161 -- The only remaining step is to generate a range check if we still have
11162 -- a type conversion at this stage and Do_Range_Check is set. For now we
11163 -- do this only for conversions of discrete types and for float-to-float
11164 -- conversions.
11165
11166 if Nkind (N) = N_Type_Conversion then
11167
11168 -- For now we only support floating-point cases where both source
11169 -- and target are floating-point types. Conversions where the source
11170 -- and target involve integer or fixed-point types are still TBD,
11171 -- though not clear whether those can even happen at this point, due
11172 -- to transformations above. ???
11173
11174 if Is_Floating_Point_Type (Etype (N))
11175 and then Is_Floating_Point_Type (Etype (Expression (N)))
11176 then
11177 if Do_Range_Check (Expression (N))
11178 and then Is_Floating_Point_Type (Target_Type)
11179 then
11180 Generate_Range_Check
11181 (Expression (N), Target_Type, CE_Range_Check_Failed);
11182 end if;
11183
11184 -- Discrete-to-discrete conversions
11185
11186 elsif Is_Discrete_Type (Etype (N)) then
11187 declare
11188 Expr : constant Node_Id := Expression (N);
11189 Ftyp : Entity_Id;
11190 Ityp : Entity_Id;
11191
11192 begin
11193 if Do_Range_Check (Expr)
11194 and then Is_Discrete_Type (Etype (Expr))
11195 then
11196 Set_Do_Range_Check (Expr, False);
11197
11198 -- Before we do a range check, we have to deal with treating
11199 -- a fixed-point operand as an integer. The way we do this
11200 -- is simply to do an unchecked conversion to an appropriate
11201 -- integer type large enough to hold the result.
11202
11203 -- This code is not active yet, because we are only dealing
11204 -- with discrete types so far ???
11205
11206 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
11207 and then Treat_Fixed_As_Integer (Expr)
11208 then
11209 Ftyp := Base_Type (Etype (Expr));
11210
11211 if Esize (Ftyp) >= Esize (Standard_Integer) then
11212 Ityp := Standard_Long_Long_Integer;
11213 else
11214 Ityp := Standard_Integer;
11215 end if;
11216
11217 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11218 end if;
11219
11220 -- Reset overflow flag, since the range check will include
11221 -- dealing with possible overflow, and generate the check.
11222 -- If Address is either a source type or target type,
11223 -- suppress range check to avoid typing anomalies when
11224 -- it is a visible integer type.
11225
11226 Set_Do_Overflow_Check (N, False);
11227
11228 if not Is_Descendant_Of_Address (Etype (Expr))
11229 and then not Is_Descendant_Of_Address (Target_Type)
11230 then
11231 Generate_Range_Check
11232 (Expr, Target_Type, CE_Range_Check_Failed);
11233 end if;
11234 end if;
11235 end;
11236 end if;
11237 end if;
11238
11239 -- Here at end of processing
11240
11241 <<Done>>
11242 -- Apply predicate check if required. Note that we can't just call
11243 -- Apply_Predicate_Check here, because the type looks right after
11244 -- the conversion and it would omit the check. The Comes_From_Source
11245 -- guard is necessary to prevent infinite recursions when we generate
11246 -- internal conversions for the purpose of checking predicates.
11247
11248 if Present (Predicate_Function (Target_Type))
11249 and then not Predicates_Ignored (Target_Type)
11250 and then Target_Type /= Operand_Type
11251 and then Comes_From_Source (N)
11252 then
11253 declare
11254 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
11255
11256 begin
11257 -- Avoid infinite recursion on the subsequent expansion of
11258 -- of the copy of the original type conversion.
11259
11260 Set_Comes_From_Source (New_Expr, False);
11261 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr));
11262 end;
11263 end if;
11264 end Expand_N_Type_Conversion;
11265
11266 -----------------------------------
11267 -- Expand_N_Unchecked_Expression --
11268 -----------------------------------
11269
11270 -- Remove the unchecked expression node from the tree. Its job was simply
11271 -- to make sure that its constituent expression was handled with checks
11272 -- off, and now that that is done, we can remove it from the tree, and
11273 -- indeed must, since Gigi does not expect to see these nodes.
11274
11275 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
11276 Exp : constant Node_Id := Expression (N);
11277 begin
11278 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
11279 Rewrite (N, Exp);
11280 end Expand_N_Unchecked_Expression;
11281
11282 ----------------------------------------
11283 -- Expand_N_Unchecked_Type_Conversion --
11284 ----------------------------------------
11285
11286 -- If this cannot be handled by Gigi and we haven't already made a
11287 -- temporary for it, do it now.
11288
11289 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
11290 Target_Type : constant Entity_Id := Etype (N);
11291 Operand : constant Node_Id := Expression (N);
11292 Operand_Type : constant Entity_Id := Etype (Operand);
11293
11294 begin
11295 -- Nothing at all to do if conversion is to the identical type so remove
11296 -- the conversion completely, it is useless, except that it may carry
11297 -- an Assignment_OK indication which must be propagated to the operand.
11298
11299 if Operand_Type = Target_Type then
11300
11301 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11302
11303 if Assignment_OK (N) then
11304 Set_Assignment_OK (Operand);
11305 end if;
11306
11307 Rewrite (N, Relocate_Node (Operand));
11308 return;
11309 end if;
11310
11311 -- If we have a conversion of a compile time known value to a target
11312 -- type and the value is in range of the target type, then we can simply
11313 -- replace the construct by an integer literal of the correct type. We
11314 -- only apply this to integer types being converted. Possibly it may
11315 -- apply in other cases, but it is too much trouble to worry about.
11316
11317 -- Note that we do not do this transformation if the Kill_Range_Check
11318 -- flag is set, since then the value may be outside the expected range.
11319 -- This happens in the Normalize_Scalars case.
11320
11321 -- We also skip this if either the target or operand type is biased
11322 -- because in this case, the unchecked conversion is supposed to
11323 -- preserve the bit pattern, not the integer value.
11324
11325 if Is_Integer_Type (Target_Type)
11326 and then not Has_Biased_Representation (Target_Type)
11327 and then Is_Integer_Type (Operand_Type)
11328 and then not Has_Biased_Representation (Operand_Type)
11329 and then Compile_Time_Known_Value (Operand)
11330 and then not Kill_Range_Check (N)
11331 then
11332 declare
11333 Val : constant Uint := Expr_Value (Operand);
11334
11335 begin
11336 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
11337 and then
11338 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
11339 and then
11340 Val >= Expr_Value (Type_Low_Bound (Target_Type))
11341 and then
11342 Val <= Expr_Value (Type_High_Bound (Target_Type))
11343 then
11344 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
11345
11346 -- If Address is the target type, just set the type to avoid a
11347 -- spurious type error on the literal when Address is a visible
11348 -- integer type.
11349
11350 if Is_Descendant_Of_Address (Target_Type) then
11351 Set_Etype (N, Target_Type);
11352 else
11353 Analyze_And_Resolve (N, Target_Type);
11354 end if;
11355
11356 return;
11357 end if;
11358 end;
11359 end if;
11360
11361 -- Nothing to do if conversion is safe
11362
11363 if Safe_Unchecked_Type_Conversion (N) then
11364 return;
11365 end if;
11366
11367 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11368 -- flag indicates ??? More comments needed here)
11369
11370 if Assignment_OK (N) then
11371 null;
11372 else
11373 Force_Evaluation (N);
11374 end if;
11375 end Expand_N_Unchecked_Type_Conversion;
11376
11377 ----------------------------
11378 -- Expand_Record_Equality --
11379 ----------------------------
11380
11381 -- For non-variant records, Equality is expanded when needed into:
11382
11383 -- and then Lhs.Discr1 = Rhs.Discr1
11384 -- and then ...
11385 -- and then Lhs.Discrn = Rhs.Discrn
11386 -- and then Lhs.Cmp1 = Rhs.Cmp1
11387 -- and then ...
11388 -- and then Lhs.Cmpn = Rhs.Cmpn
11389
11390 -- The expression is folded by the back-end for adjacent fields. This
11391 -- function is called for tagged record in only one occasion: for imple-
11392 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11393 -- otherwise the primitive "=" is used directly.
11394
11395 function Expand_Record_Equality
11396 (Nod : Node_Id;
11397 Typ : Entity_Id;
11398 Lhs : Node_Id;
11399 Rhs : Node_Id;
11400 Bodies : List_Id) return Node_Id
11401 is
11402 Loc : constant Source_Ptr := Sloc (Nod);
11403
11404 Result : Node_Id;
11405 C : Entity_Id;
11406
11407 First_Time : Boolean := True;
11408
11409 function Element_To_Compare (C : Entity_Id) return Entity_Id;
11410 -- Return the next discriminant or component to compare, starting with
11411 -- C, skipping inherited components.
11412
11413 ------------------------
11414 -- Element_To_Compare --
11415 ------------------------
11416
11417 function Element_To_Compare (C : Entity_Id) return Entity_Id is
11418 Comp : Entity_Id;
11419
11420 begin
11421 Comp := C;
11422 loop
11423 -- Exit loop when the next element to be compared is found, or
11424 -- there is no more such element.
11425
11426 exit when No (Comp);
11427
11428 exit when Ekind_In (Comp, E_Discriminant, E_Component)
11429 and then not (
11430
11431 -- Skip inherited components
11432
11433 -- Note: for a tagged type, we always generate the "=" primitive
11434 -- for the base type (not on the first subtype), so the test for
11435 -- Comp /= Original_Record_Component (Comp) is True for
11436 -- inherited components only.
11437
11438 (Is_Tagged_Type (Typ)
11439 and then Comp /= Original_Record_Component (Comp))
11440
11441 -- Skip _Tag
11442
11443 or else Chars (Comp) = Name_uTag
11444
11445 -- Skip interface elements (secondary tags???)
11446
11447 or else Is_Interface (Etype (Comp)));
11448
11449 Next_Entity (Comp);
11450 end loop;
11451
11452 return Comp;
11453 end Element_To_Compare;
11454
11455 -- Start of processing for Expand_Record_Equality
11456
11457 begin
11458 -- Generates the following code: (assuming that Typ has one Discr and
11459 -- component C2 is also a record)
11460
11461 -- True
11462 -- and then Lhs.Discr1 = Rhs.Discr1
11463 -- and then Lhs.C1 = Rhs.C1
11464 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11465 -- and then ...
11466 -- and then Lhs.Cmpn = Rhs.Cmpn
11467
11468 Result := New_Occurrence_Of (Standard_True, Loc);
11469 C := Element_To_Compare (First_Entity (Typ));
11470 while Present (C) loop
11471 declare
11472 New_Lhs : Node_Id;
11473 New_Rhs : Node_Id;
11474 Check : Node_Id;
11475
11476 begin
11477 if First_Time then
11478 First_Time := False;
11479 New_Lhs := Lhs;
11480 New_Rhs := Rhs;
11481 else
11482 New_Lhs := New_Copy_Tree (Lhs);
11483 New_Rhs := New_Copy_Tree (Rhs);
11484 end if;
11485
11486 Check :=
11487 Expand_Composite_Equality (Nod, Etype (C),
11488 Lhs =>
11489 Make_Selected_Component (Loc,
11490 Prefix => New_Lhs,
11491 Selector_Name => New_Occurrence_Of (C, Loc)),
11492 Rhs =>
11493 Make_Selected_Component (Loc,
11494 Prefix => New_Rhs,
11495 Selector_Name => New_Occurrence_Of (C, Loc)),
11496 Bodies => Bodies);
11497
11498 -- If some (sub)component is an unchecked_union, the whole
11499 -- operation will raise program error.
11500
11501 if Nkind (Check) = N_Raise_Program_Error then
11502 Result := Check;
11503 Set_Etype (Result, Standard_Boolean);
11504 exit;
11505 else
11506 Result :=
11507 Make_And_Then (Loc,
11508 Left_Opnd => Result,
11509 Right_Opnd => Check);
11510 end if;
11511 end;
11512
11513 C := Element_To_Compare (Next_Entity (C));
11514 end loop;
11515
11516 return Result;
11517 end Expand_Record_Equality;
11518
11519 ---------------------------
11520 -- Expand_Set_Membership --
11521 ---------------------------
11522
11523 procedure Expand_Set_Membership (N : Node_Id) is
11524 Lop : constant Node_Id := Left_Opnd (N);
11525 Alt : Node_Id;
11526 Res : Node_Id;
11527
11528 function Make_Cond (Alt : Node_Id) return Node_Id;
11529 -- If the alternative is a subtype mark, create a simple membership
11530 -- test. Otherwise create an equality test for it.
11531
11532 ---------------
11533 -- Make_Cond --
11534 ---------------
11535
11536 function Make_Cond (Alt : Node_Id) return Node_Id is
11537 Cond : Node_Id;
11538 L : constant Node_Id := New_Copy (Lop);
11539 R : constant Node_Id := Relocate_Node (Alt);
11540
11541 begin
11542 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
11543 or else Nkind (Alt) = N_Range
11544 then
11545 Cond :=
11546 Make_In (Sloc (Alt),
11547 Left_Opnd => L,
11548 Right_Opnd => R);
11549 else
11550 Cond :=
11551 Make_Op_Eq (Sloc (Alt),
11552 Left_Opnd => L,
11553 Right_Opnd => R);
11554 end if;
11555
11556 return Cond;
11557 end Make_Cond;
11558
11559 -- Start of processing for Expand_Set_Membership
11560
11561 begin
11562 Remove_Side_Effects (Lop);
11563
11564 Alt := Last (Alternatives (N));
11565 Res := Make_Cond (Alt);
11566
11567 Prev (Alt);
11568 while Present (Alt) loop
11569 Res :=
11570 Make_Or_Else (Sloc (Alt),
11571 Left_Opnd => Make_Cond (Alt),
11572 Right_Opnd => Res);
11573 Prev (Alt);
11574 end loop;
11575
11576 Rewrite (N, Res);
11577 Analyze_And_Resolve (N, Standard_Boolean);
11578 end Expand_Set_Membership;
11579
11580 -----------------------------------
11581 -- Expand_Short_Circuit_Operator --
11582 -----------------------------------
11583
11584 -- Deal with special expansion if actions are present for the right operand
11585 -- and deal with optimizing case of arguments being True or False. We also
11586 -- deal with the special case of non-standard boolean values.
11587
11588 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
11589 Loc : constant Source_Ptr := Sloc (N);
11590 Typ : constant Entity_Id := Etype (N);
11591 Left : constant Node_Id := Left_Opnd (N);
11592 Right : constant Node_Id := Right_Opnd (N);
11593 LocR : constant Source_Ptr := Sloc (Right);
11594 Actlist : List_Id;
11595
11596 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
11597 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
11598 -- If Left = Shortcut_Value then Right need not be evaluated
11599
11600 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
11601 -- For Opnd a boolean expression, return a Boolean expression equivalent
11602 -- to Opnd /= Shortcut_Value.
11603
11604 --------------------
11605 -- Make_Test_Expr --
11606 --------------------
11607
11608 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
11609 begin
11610 if Shortcut_Value then
11611 return Make_Op_Not (Sloc (Opnd), Opnd);
11612 else
11613 return Opnd;
11614 end if;
11615 end Make_Test_Expr;
11616
11617 -- Local variables
11618
11619 Op_Var : Entity_Id;
11620 -- Entity for a temporary variable holding the value of the operator,
11621 -- used for expansion in the case where actions are present.
11622
11623 -- Start of processing for Expand_Short_Circuit_Operator
11624
11625 begin
11626 -- Deal with non-standard booleans
11627
11628 if Is_Boolean_Type (Typ) then
11629 Adjust_Condition (Left);
11630 Adjust_Condition (Right);
11631 Set_Etype (N, Standard_Boolean);
11632 end if;
11633
11634 -- Check for cases where left argument is known to be True or False
11635
11636 if Compile_Time_Known_Value (Left) then
11637
11638 -- Mark SCO for left condition as compile time known
11639
11640 if Generate_SCO and then Comes_From_Source (Left) then
11641 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
11642 end if;
11643
11644 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11645 -- Any actions associated with Right will be executed unconditionally
11646 -- and can thus be inserted into the tree unconditionally.
11647
11648 if Expr_Value_E (Left) /= Shortcut_Ent then
11649 if Present (Actions (N)) then
11650 Insert_Actions (N, Actions (N));
11651 end if;
11652
11653 Rewrite (N, Right);
11654
11655 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11656 -- In this case we can forget the actions associated with Right,
11657 -- since they will never be executed.
11658
11659 else
11660 Kill_Dead_Code (Right);
11661 Kill_Dead_Code (Actions (N));
11662 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11663 end if;
11664
11665 Adjust_Result_Type (N, Typ);
11666 return;
11667 end if;
11668
11669 -- If Actions are present for the right operand, we have to do some
11670 -- special processing. We can't just let these actions filter back into
11671 -- code preceding the short circuit (which is what would have happened
11672 -- if we had not trapped them in the short-circuit form), since they
11673 -- must only be executed if the right operand of the short circuit is
11674 -- executed and not otherwise.
11675
11676 if Present (Actions (N)) then
11677 Actlist := Actions (N);
11678
11679 -- The old approach is to expand:
11680
11681 -- left AND THEN right
11682
11683 -- into
11684
11685 -- C : Boolean := False;
11686 -- IF left THEN
11687 -- Actions;
11688 -- IF right THEN
11689 -- C := True;
11690 -- END IF;
11691 -- END IF;
11692
11693 -- and finally rewrite the operator into a reference to C. Similarly
11694 -- for left OR ELSE right, with negated values. Note that this
11695 -- rewrite causes some difficulties for coverage analysis because
11696 -- of the introduction of the new variable C, which obscures the
11697 -- structure of the test.
11698
11699 -- We use this "old approach" if Minimize_Expression_With_Actions
11700 -- is True.
11701
11702 if Minimize_Expression_With_Actions then
11703 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
11704
11705 Insert_Action (N,
11706 Make_Object_Declaration (Loc,
11707 Defining_Identifier => Op_Var,
11708 Object_Definition =>
11709 New_Occurrence_Of (Standard_Boolean, Loc),
11710 Expression =>
11711 New_Occurrence_Of (Shortcut_Ent, Loc)));
11712
11713 Append_To (Actlist,
11714 Make_Implicit_If_Statement (Right,
11715 Condition => Make_Test_Expr (Right),
11716 Then_Statements => New_List (
11717 Make_Assignment_Statement (LocR,
11718 Name => New_Occurrence_Of (Op_Var, LocR),
11719 Expression =>
11720 New_Occurrence_Of
11721 (Boolean_Literals (not Shortcut_Value), LocR)))));
11722
11723 Insert_Action (N,
11724 Make_Implicit_If_Statement (Left,
11725 Condition => Make_Test_Expr (Left),
11726 Then_Statements => Actlist));
11727
11728 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
11729 Analyze_And_Resolve (N, Standard_Boolean);
11730
11731 -- The new approach (the default) is to use an
11732 -- Expression_With_Actions node for the right operand of the
11733 -- short-circuit form. Note that this solves the traceability
11734 -- problems for coverage analysis.
11735
11736 else
11737 Rewrite (Right,
11738 Make_Expression_With_Actions (LocR,
11739 Expression => Relocate_Node (Right),
11740 Actions => Actlist));
11741
11742 Set_Actions (N, No_List);
11743 Analyze_And_Resolve (Right, Standard_Boolean);
11744 end if;
11745
11746 Adjust_Result_Type (N, Typ);
11747 return;
11748 end if;
11749
11750 -- No actions present, check for cases of right argument True/False
11751
11752 if Compile_Time_Known_Value (Right) then
11753
11754 -- Mark SCO for left condition as compile time known
11755
11756 if Generate_SCO and then Comes_From_Source (Right) then
11757 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
11758 end if;
11759
11760 -- Change (Left and then True), (Left or else False) to Left. Note
11761 -- that we know there are no actions associated with the right
11762 -- operand, since we just checked for this case above.
11763
11764 if Expr_Value_E (Right) /= Shortcut_Ent then
11765 Rewrite (N, Left);
11766
11767 -- Change (Left and then False), (Left or else True) to Right,
11768 -- making sure to preserve any side effects associated with the Left
11769 -- operand.
11770
11771 else
11772 Remove_Side_Effects (Left);
11773 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11774 end if;
11775 end if;
11776
11777 Adjust_Result_Type (N, Typ);
11778 end Expand_Short_Circuit_Operator;
11779
11780 -------------------------------------
11781 -- Fixup_Universal_Fixed_Operation --
11782 -------------------------------------
11783
11784 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
11785 Conv : constant Node_Id := Parent (N);
11786
11787 begin
11788 -- We must have a type conversion immediately above us
11789
11790 pragma Assert (Nkind (Conv) = N_Type_Conversion);
11791
11792 -- Normally the type conversion gives our target type. The exception
11793 -- occurs in the case of the Round attribute, where the conversion
11794 -- will be to universal real, and our real type comes from the Round
11795 -- attribute (as well as an indication that we must round the result)
11796
11797 if Nkind (Parent (Conv)) = N_Attribute_Reference
11798 and then Attribute_Name (Parent (Conv)) = Name_Round
11799 then
11800 Set_Etype (N, Etype (Parent (Conv)));
11801 Set_Rounded_Result (N);
11802
11803 -- Normal case where type comes from conversion above us
11804
11805 else
11806 Set_Etype (N, Etype (Conv));
11807 end if;
11808 end Fixup_Universal_Fixed_Operation;
11809
11810 ---------------------------------
11811 -- Has_Inferable_Discriminants --
11812 ---------------------------------
11813
11814 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
11815
11816 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
11817 -- Determines whether the left-most prefix of a selected component is a
11818 -- formal parameter in a subprogram. Assumes N is a selected component.
11819
11820 --------------------------------
11821 -- Prefix_Is_Formal_Parameter --
11822 --------------------------------
11823
11824 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
11825 Sel_Comp : Node_Id;
11826
11827 begin
11828 -- Move to the left-most prefix by climbing up the tree
11829
11830 Sel_Comp := N;
11831 while Present (Parent (Sel_Comp))
11832 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
11833 loop
11834 Sel_Comp := Parent (Sel_Comp);
11835 end loop;
11836
11837 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
11838 end Prefix_Is_Formal_Parameter;
11839
11840 -- Start of processing for Has_Inferable_Discriminants
11841
11842 begin
11843 -- For selected components, the subtype of the selector must be a
11844 -- constrained Unchecked_Union. If the component is subject to a
11845 -- per-object constraint, then the enclosing object must have inferable
11846 -- discriminants.
11847
11848 if Nkind (N) = N_Selected_Component then
11849 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
11850
11851 -- A small hack. If we have a per-object constrained selected
11852 -- component of a formal parameter, return True since we do not
11853 -- know the actual parameter association yet.
11854
11855 if Prefix_Is_Formal_Parameter (N) then
11856 return True;
11857
11858 -- Otherwise, check the enclosing object and the selector
11859
11860 else
11861 return Has_Inferable_Discriminants (Prefix (N))
11862 and then Has_Inferable_Discriminants (Selector_Name (N));
11863 end if;
11864
11865 -- The call to Has_Inferable_Discriminants will determine whether
11866 -- the selector has a constrained Unchecked_Union nominal type.
11867
11868 else
11869 return Has_Inferable_Discriminants (Selector_Name (N));
11870 end if;
11871
11872 -- A qualified expression has inferable discriminants if its subtype
11873 -- mark is a constrained Unchecked_Union subtype.
11874
11875 elsif Nkind (N) = N_Qualified_Expression then
11876 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
11877 and then Is_Constrained (Etype (Subtype_Mark (N)));
11878
11879 -- For all other names, it is sufficient to have a constrained
11880 -- Unchecked_Union nominal subtype.
11881
11882 else
11883 return Is_Unchecked_Union (Base_Type (Etype (N)))
11884 and then Is_Constrained (Etype (N));
11885 end if;
11886 end Has_Inferable_Discriminants;
11887
11888 -------------------------------
11889 -- Insert_Dereference_Action --
11890 -------------------------------
11891
11892 procedure Insert_Dereference_Action (N : Node_Id) is
11893
11894 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
11895 -- Return true if type of P is derived from Checked_Pool;
11896
11897 -----------------------------
11898 -- Is_Checked_Storage_Pool --
11899 -----------------------------
11900
11901 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
11902 T : Entity_Id;
11903
11904 begin
11905 if No (P) then
11906 return False;
11907 end if;
11908
11909 T := Etype (P);
11910 while T /= Etype (T) loop
11911 if Is_RTE (T, RE_Checked_Pool) then
11912 return True;
11913 else
11914 T := Etype (T);
11915 end if;
11916 end loop;
11917
11918 return False;
11919 end Is_Checked_Storage_Pool;
11920
11921 -- Local variables
11922
11923 Typ : constant Entity_Id := Etype (N);
11924 Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
11925 Loc : constant Source_Ptr := Sloc (N);
11926 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
11927 Pnod : constant Node_Id := Parent (N);
11928
11929 Addr : Entity_Id;
11930 Alig : Entity_Id;
11931 Deref : Node_Id;
11932 Size : Entity_Id;
11933 Size_Bits : Node_Id;
11934 Stmt : Node_Id;
11935
11936 -- Start of processing for Insert_Dereference_Action
11937
11938 begin
11939 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
11940
11941 -- Do not re-expand a dereference which has already been processed by
11942 -- this routine.
11943
11944 if Has_Dereference_Action (Pnod) then
11945 return;
11946
11947 -- Do not perform this type of expansion for internally-generated
11948 -- dereferences.
11949
11950 elsif not Comes_From_Source (Original_Node (Pnod)) then
11951 return;
11952
11953 -- A dereference action is only applicable to objects which have been
11954 -- allocated on a checked pool.
11955
11956 elsif not Is_Checked_Storage_Pool (Pool) then
11957 return;
11958 end if;
11959
11960 -- Extract the address of the dereferenced object. Generate:
11961
11962 -- Addr : System.Address := <N>'Pool_Address;
11963
11964 Addr := Make_Temporary (Loc, 'P');
11965
11966 Insert_Action (N,
11967 Make_Object_Declaration (Loc,
11968 Defining_Identifier => Addr,
11969 Object_Definition =>
11970 New_Occurrence_Of (RTE (RE_Address), Loc),
11971 Expression =>
11972 Make_Attribute_Reference (Loc,
11973 Prefix => Duplicate_Subexpr_Move_Checks (N),
11974 Attribute_Name => Name_Pool_Address)));
11975
11976 -- Calculate the size of the dereferenced object. Generate:
11977
11978 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11979
11980 Deref :=
11981 Make_Explicit_Dereference (Loc,
11982 Prefix => Duplicate_Subexpr_Move_Checks (N));
11983 Set_Has_Dereference_Action (Deref);
11984
11985 Size_Bits :=
11986 Make_Attribute_Reference (Loc,
11987 Prefix => Deref,
11988 Attribute_Name => Name_Size);
11989
11990 -- Special case of an unconstrained array: need to add descriptor size
11991
11992 if Is_Array_Type (Desig)
11993 and then not Is_Constrained (First_Subtype (Desig))
11994 then
11995 Size_Bits :=
11996 Make_Op_Add (Loc,
11997 Left_Opnd =>
11998 Make_Attribute_Reference (Loc,
11999 Prefix =>
12000 New_Occurrence_Of (First_Subtype (Desig), Loc),
12001 Attribute_Name => Name_Descriptor_Size),
12002 Right_Opnd => Size_Bits);
12003 end if;
12004
12005 Size := Make_Temporary (Loc, 'S');
12006 Insert_Action (N,
12007 Make_Object_Declaration (Loc,
12008 Defining_Identifier => Size,
12009 Object_Definition =>
12010 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
12011 Expression =>
12012 Make_Op_Divide (Loc,
12013 Left_Opnd => Size_Bits,
12014 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
12015
12016 -- Calculate the alignment of the dereferenced object. Generate:
12017 -- Alig : constant Storage_Count := <N>.all'Alignment;
12018
12019 Deref :=
12020 Make_Explicit_Dereference (Loc,
12021 Prefix => Duplicate_Subexpr_Move_Checks (N));
12022 Set_Has_Dereference_Action (Deref);
12023
12024 Alig := Make_Temporary (Loc, 'A');
12025 Insert_Action (N,
12026 Make_Object_Declaration (Loc,
12027 Defining_Identifier => Alig,
12028 Object_Definition =>
12029 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
12030 Expression =>
12031 Make_Attribute_Reference (Loc,
12032 Prefix => Deref,
12033 Attribute_Name => Name_Alignment)));
12034
12035 -- A dereference of a controlled object requires special processing. The
12036 -- finalization machinery requests additional space from the underlying
12037 -- pool to allocate and hide two pointers. As a result, a checked pool
12038 -- may mark the wrong memory as valid. Since checked pools do not have
12039 -- knowledge of hidden pointers, we have to bring the two pointers back
12040 -- in view in order to restore the original state of the object.
12041
12042 if Needs_Finalization (Desig) then
12043
12044 -- Adjust the address and size of the dereferenced object. Generate:
12045 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
12046
12047 Stmt :=
12048 Make_Procedure_Call_Statement (Loc,
12049 Name =>
12050 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
12051 Parameter_Associations => New_List (
12052 New_Occurrence_Of (Addr, Loc),
12053 New_Occurrence_Of (Size, Loc),
12054 New_Occurrence_Of (Alig, Loc)));
12055
12056 -- Class-wide types complicate things because we cannot determine
12057 -- statically whether the actual object is truly controlled. We must
12058 -- generate a runtime check to detect this property. Generate:
12059 --
12060 -- if Needs_Finalization (<N>.all'Tag) then
12061 -- <Stmt>;
12062 -- end if;
12063
12064 if Is_Class_Wide_Type (Desig) then
12065 Deref :=
12066 Make_Explicit_Dereference (Loc,
12067 Prefix => Duplicate_Subexpr_Move_Checks (N));
12068 Set_Has_Dereference_Action (Deref);
12069
12070 Stmt :=
12071 Make_Implicit_If_Statement (N,
12072 Condition =>
12073 Make_Function_Call (Loc,
12074 Name =>
12075 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
12076 Parameter_Associations => New_List (
12077 Make_Attribute_Reference (Loc,
12078 Prefix => Deref,
12079 Attribute_Name => Name_Tag))),
12080 Then_Statements => New_List (Stmt));
12081 end if;
12082
12083 Insert_Action (N, Stmt);
12084 end if;
12085
12086 -- Generate:
12087 -- Dereference (Pool, Addr, Size, Alig);
12088
12089 Insert_Action (N,
12090 Make_Procedure_Call_Statement (Loc,
12091 Name =>
12092 New_Occurrence_Of
12093 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
12094 Parameter_Associations => New_List (
12095 New_Occurrence_Of (Pool, Loc),
12096 New_Occurrence_Of (Addr, Loc),
12097 New_Occurrence_Of (Size, Loc),
12098 New_Occurrence_Of (Alig, Loc))));
12099
12100 -- Mark the explicit dereference as processed to avoid potential
12101 -- infinite expansion.
12102
12103 Set_Has_Dereference_Action (Pnod);
12104
12105 exception
12106 when RE_Not_Available =>
12107 return;
12108 end Insert_Dereference_Action;
12109
12110 --------------------------------
12111 -- Integer_Promotion_Possible --
12112 --------------------------------
12113
12114 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
12115 Operand : constant Node_Id := Expression (N);
12116 Operand_Type : constant Entity_Id := Etype (Operand);
12117 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
12118
12119 begin
12120 pragma Assert (Nkind (N) = N_Type_Conversion);
12121
12122 return
12123
12124 -- We only do the transformation for source constructs. We assume
12125 -- that the expander knows what it is doing when it generates code.
12126
12127 Comes_From_Source (N)
12128
12129 -- If the operand type is Short_Integer or Short_Short_Integer,
12130 -- then we will promote to Integer, which is available on all
12131 -- targets, and is sufficient to ensure no intermediate overflow.
12132 -- Furthermore it is likely to be as efficient or more efficient
12133 -- than using the smaller type for the computation so we do this
12134 -- unconditionally.
12135
12136 and then
12137 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
12138 or else
12139 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
12140
12141 -- Test for interesting operation, which includes addition,
12142 -- division, exponentiation, multiplication, subtraction, absolute
12143 -- value and unary negation. Unary "+" is omitted since it is a
12144 -- no-op and thus can't overflow.
12145
12146 and then Nkind_In (Operand, N_Op_Abs,
12147 N_Op_Add,
12148 N_Op_Divide,
12149 N_Op_Expon,
12150 N_Op_Minus,
12151 N_Op_Multiply,
12152 N_Op_Subtract);
12153 end Integer_Promotion_Possible;
12154
12155 ------------------------------
12156 -- Make_Array_Comparison_Op --
12157 ------------------------------
12158
12159 -- This is a hand-coded expansion of the following generic function:
12160
12161 -- generic
12162 -- type elem is (<>);
12163 -- type index is (<>);
12164 -- type a is array (index range <>) of elem;
12165
12166 -- function Gnnn (X : a; Y: a) return boolean is
12167 -- J : index := Y'first;
12168
12169 -- begin
12170 -- if X'length = 0 then
12171 -- return false;
12172
12173 -- elsif Y'length = 0 then
12174 -- return true;
12175
12176 -- else
12177 -- for I in X'range loop
12178 -- if X (I) = Y (J) then
12179 -- if J = Y'last then
12180 -- exit;
12181 -- else
12182 -- J := index'succ (J);
12183 -- end if;
12184
12185 -- else
12186 -- return X (I) > Y (J);
12187 -- end if;
12188 -- end loop;
12189
12190 -- return X'length > Y'length;
12191 -- end if;
12192 -- end Gnnn;
12193
12194 -- Note that since we are essentially doing this expansion by hand, we
12195 -- do not need to generate an actual or formal generic part, just the
12196 -- instantiated function itself.
12197
12198 -- Perhaps we could have the actual generic available in the run-time,
12199 -- obtained by rtsfind, and actually expand a real instantiation ???
12200
12201 function Make_Array_Comparison_Op
12202 (Typ : Entity_Id;
12203 Nod : Node_Id) return Node_Id
12204 is
12205 Loc : constant Source_Ptr := Sloc (Nod);
12206
12207 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
12208 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
12209 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
12210 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
12211
12212 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
12213
12214 Loop_Statement : Node_Id;
12215 Loop_Body : Node_Id;
12216 If_Stat : Node_Id;
12217 Inner_If : Node_Id;
12218 Final_Expr : Node_Id;
12219 Func_Body : Node_Id;
12220 Func_Name : Entity_Id;
12221 Formals : List_Id;
12222 Length1 : Node_Id;
12223 Length2 : Node_Id;
12224
12225 begin
12226 -- if J = Y'last then
12227 -- exit;
12228 -- else
12229 -- J := index'succ (J);
12230 -- end if;
12231
12232 Inner_If :=
12233 Make_Implicit_If_Statement (Nod,
12234 Condition =>
12235 Make_Op_Eq (Loc,
12236 Left_Opnd => New_Occurrence_Of (J, Loc),
12237 Right_Opnd =>
12238 Make_Attribute_Reference (Loc,
12239 Prefix => New_Occurrence_Of (Y, Loc),
12240 Attribute_Name => Name_Last)),
12241
12242 Then_Statements => New_List (
12243 Make_Exit_Statement (Loc)),
12244
12245 Else_Statements =>
12246 New_List (
12247 Make_Assignment_Statement (Loc,
12248 Name => New_Occurrence_Of (J, Loc),
12249 Expression =>
12250 Make_Attribute_Reference (Loc,
12251 Prefix => New_Occurrence_Of (Index, Loc),
12252 Attribute_Name => Name_Succ,
12253 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
12254
12255 -- if X (I) = Y (J) then
12256 -- if ... end if;
12257 -- else
12258 -- return X (I) > Y (J);
12259 -- end if;
12260
12261 Loop_Body :=
12262 Make_Implicit_If_Statement (Nod,
12263 Condition =>
12264 Make_Op_Eq (Loc,
12265 Left_Opnd =>
12266 Make_Indexed_Component (Loc,
12267 Prefix => New_Occurrence_Of (X, Loc),
12268 Expressions => New_List (New_Occurrence_Of (I, Loc))),
12269
12270 Right_Opnd =>
12271 Make_Indexed_Component (Loc,
12272 Prefix => New_Occurrence_Of (Y, Loc),
12273 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
12274
12275 Then_Statements => New_List (Inner_If),
12276
12277 Else_Statements => New_List (
12278 Make_Simple_Return_Statement (Loc,
12279 Expression =>
12280 Make_Op_Gt (Loc,
12281 Left_Opnd =>
12282 Make_Indexed_Component (Loc,
12283 Prefix => New_Occurrence_Of (X, Loc),
12284 Expressions => New_List (New_Occurrence_Of (I, Loc))),
12285
12286 Right_Opnd =>
12287 Make_Indexed_Component (Loc,
12288 Prefix => New_Occurrence_Of (Y, Loc),
12289 Expressions => New_List (
12290 New_Occurrence_Of (J, Loc)))))));
12291
12292 -- for I in X'range loop
12293 -- if ... end if;
12294 -- end loop;
12295
12296 Loop_Statement :=
12297 Make_Implicit_Loop_Statement (Nod,
12298 Identifier => Empty,
12299
12300 Iteration_Scheme =>
12301 Make_Iteration_Scheme (Loc,
12302 Loop_Parameter_Specification =>
12303 Make_Loop_Parameter_Specification (Loc,
12304 Defining_Identifier => I,
12305 Discrete_Subtype_Definition =>
12306 Make_Attribute_Reference (Loc,
12307 Prefix => New_Occurrence_Of (X, Loc),
12308 Attribute_Name => Name_Range))),
12309
12310 Statements => New_List (Loop_Body));
12311
12312 -- if X'length = 0 then
12313 -- return false;
12314 -- elsif Y'length = 0 then
12315 -- return true;
12316 -- else
12317 -- for ... loop ... end loop;
12318 -- return X'length > Y'length;
12319 -- end if;
12320
12321 Length1 :=
12322 Make_Attribute_Reference (Loc,
12323 Prefix => New_Occurrence_Of (X, Loc),
12324 Attribute_Name => Name_Length);
12325
12326 Length2 :=
12327 Make_Attribute_Reference (Loc,
12328 Prefix => New_Occurrence_Of (Y, Loc),
12329 Attribute_Name => Name_Length);
12330
12331 Final_Expr :=
12332 Make_Op_Gt (Loc,
12333 Left_Opnd => Length1,
12334 Right_Opnd => Length2);
12335
12336 If_Stat :=
12337 Make_Implicit_If_Statement (Nod,
12338 Condition =>
12339 Make_Op_Eq (Loc,
12340 Left_Opnd =>
12341 Make_Attribute_Reference (Loc,
12342 Prefix => New_Occurrence_Of (X, Loc),
12343 Attribute_Name => Name_Length),
12344 Right_Opnd =>
12345 Make_Integer_Literal (Loc, 0)),
12346
12347 Then_Statements =>
12348 New_List (
12349 Make_Simple_Return_Statement (Loc,
12350 Expression => New_Occurrence_Of (Standard_False, Loc))),
12351
12352 Elsif_Parts => New_List (
12353 Make_Elsif_Part (Loc,
12354 Condition =>
12355 Make_Op_Eq (Loc,
12356 Left_Opnd =>
12357 Make_Attribute_Reference (Loc,
12358 Prefix => New_Occurrence_Of (Y, Loc),
12359 Attribute_Name => Name_Length),
12360 Right_Opnd =>
12361 Make_Integer_Literal (Loc, 0)),
12362
12363 Then_Statements =>
12364 New_List (
12365 Make_Simple_Return_Statement (Loc,
12366 Expression => New_Occurrence_Of (Standard_True, Loc))))),
12367
12368 Else_Statements => New_List (
12369 Loop_Statement,
12370 Make_Simple_Return_Statement (Loc,
12371 Expression => Final_Expr)));
12372
12373 -- (X : a; Y: a)
12374
12375 Formals := New_List (
12376 Make_Parameter_Specification (Loc,
12377 Defining_Identifier => X,
12378 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
12379
12380 Make_Parameter_Specification (Loc,
12381 Defining_Identifier => Y,
12382 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
12383
12384 -- function Gnnn (...) return boolean is
12385 -- J : index := Y'first;
12386 -- begin
12387 -- if ... end if;
12388 -- end Gnnn;
12389
12390 Func_Name := Make_Temporary (Loc, 'G');
12391
12392 Func_Body :=
12393 Make_Subprogram_Body (Loc,
12394 Specification =>
12395 Make_Function_Specification (Loc,
12396 Defining_Unit_Name => Func_Name,
12397 Parameter_Specifications => Formals,
12398 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
12399
12400 Declarations => New_List (
12401 Make_Object_Declaration (Loc,
12402 Defining_Identifier => J,
12403 Object_Definition => New_Occurrence_Of (Index, Loc),
12404 Expression =>
12405 Make_Attribute_Reference (Loc,
12406 Prefix => New_Occurrence_Of (Y, Loc),
12407 Attribute_Name => Name_First))),
12408
12409 Handled_Statement_Sequence =>
12410 Make_Handled_Sequence_Of_Statements (Loc,
12411 Statements => New_List (If_Stat)));
12412
12413 return Func_Body;
12414 end Make_Array_Comparison_Op;
12415
12416 ---------------------------
12417 -- Make_Boolean_Array_Op --
12418 ---------------------------
12419
12420 -- For logical operations on boolean arrays, expand in line the following,
12421 -- replacing 'and' with 'or' or 'xor' where needed:
12422
12423 -- function Annn (A : typ; B: typ) return typ is
12424 -- C : typ;
12425 -- begin
12426 -- for J in A'range loop
12427 -- C (J) := A (J) op B (J);
12428 -- end loop;
12429 -- return C;
12430 -- end Annn;
12431
12432 -- Here typ is the boolean array type
12433
12434 function Make_Boolean_Array_Op
12435 (Typ : Entity_Id;
12436 N : Node_Id) return Node_Id
12437 is
12438 Loc : constant Source_Ptr := Sloc (N);
12439
12440 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
12441 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
12442 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
12443 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
12444
12445 A_J : Node_Id;
12446 B_J : Node_Id;
12447 C_J : Node_Id;
12448 Op : Node_Id;
12449
12450 Formals : List_Id;
12451 Func_Name : Entity_Id;
12452 Func_Body : Node_Id;
12453 Loop_Statement : Node_Id;
12454
12455 begin
12456 A_J :=
12457 Make_Indexed_Component (Loc,
12458 Prefix => New_Occurrence_Of (A, Loc),
12459 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12460
12461 B_J :=
12462 Make_Indexed_Component (Loc,
12463 Prefix => New_Occurrence_Of (B, Loc),
12464 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12465
12466 C_J :=
12467 Make_Indexed_Component (Loc,
12468 Prefix => New_Occurrence_Of (C, Loc),
12469 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12470
12471 if Nkind (N) = N_Op_And then
12472 Op :=
12473 Make_Op_And (Loc,
12474 Left_Opnd => A_J,
12475 Right_Opnd => B_J);
12476
12477 elsif Nkind (N) = N_Op_Or then
12478 Op :=
12479 Make_Op_Or (Loc,
12480 Left_Opnd => A_J,
12481 Right_Opnd => B_J);
12482
12483 else
12484 Op :=
12485 Make_Op_Xor (Loc,
12486 Left_Opnd => A_J,
12487 Right_Opnd => B_J);
12488 end if;
12489
12490 Loop_Statement :=
12491 Make_Implicit_Loop_Statement (N,
12492 Identifier => Empty,
12493
12494 Iteration_Scheme =>
12495 Make_Iteration_Scheme (Loc,
12496 Loop_Parameter_Specification =>
12497 Make_Loop_Parameter_Specification (Loc,
12498 Defining_Identifier => J,
12499 Discrete_Subtype_Definition =>
12500 Make_Attribute_Reference (Loc,
12501 Prefix => New_Occurrence_Of (A, Loc),
12502 Attribute_Name => Name_Range))),
12503
12504 Statements => New_List (
12505 Make_Assignment_Statement (Loc,
12506 Name => C_J,
12507 Expression => Op)));
12508
12509 Formals := New_List (
12510 Make_Parameter_Specification (Loc,
12511 Defining_Identifier => A,
12512 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
12513
12514 Make_Parameter_Specification (Loc,
12515 Defining_Identifier => B,
12516 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
12517
12518 Func_Name := Make_Temporary (Loc, 'A');
12519 Set_Is_Inlined (Func_Name);
12520
12521 Func_Body :=
12522 Make_Subprogram_Body (Loc,
12523 Specification =>
12524 Make_Function_Specification (Loc,
12525 Defining_Unit_Name => Func_Name,
12526 Parameter_Specifications => Formals,
12527 Result_Definition => New_Occurrence_Of (Typ, Loc)),
12528
12529 Declarations => New_List (
12530 Make_Object_Declaration (Loc,
12531 Defining_Identifier => C,
12532 Object_Definition => New_Occurrence_Of (Typ, Loc))),
12533
12534 Handled_Statement_Sequence =>
12535 Make_Handled_Sequence_Of_Statements (Loc,
12536 Statements => New_List (
12537 Loop_Statement,
12538 Make_Simple_Return_Statement (Loc,
12539 Expression => New_Occurrence_Of (C, Loc)))));
12540
12541 return Func_Body;
12542 end Make_Boolean_Array_Op;
12543
12544 -----------------------------------------
12545 -- Minimized_Eliminated_Overflow_Check --
12546 -----------------------------------------
12547
12548 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
12549 begin
12550 return
12551 Is_Signed_Integer_Type (Etype (N))
12552 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
12553 end Minimized_Eliminated_Overflow_Check;
12554
12555 --------------------------------
12556 -- Optimize_Length_Comparison --
12557 --------------------------------
12558
12559 procedure Optimize_Length_Comparison (N : Node_Id) is
12560 Loc : constant Source_Ptr := Sloc (N);
12561 Typ : constant Entity_Id := Etype (N);
12562 Result : Node_Id;
12563
12564 Left : Node_Id;
12565 Right : Node_Id;
12566 -- First and Last attribute reference nodes, which end up as left and
12567 -- right operands of the optimized result.
12568
12569 Is_Zero : Boolean;
12570 -- True for comparison operand of zero
12571
12572 Comp : Node_Id;
12573 -- Comparison operand, set only if Is_Zero is false
12574
12575 Ent : Entity_Id;
12576 -- Entity whose length is being compared
12577
12578 Index : Node_Id;
12579 -- Integer_Literal node for length attribute expression, or Empty
12580 -- if there is no such expression present.
12581
12582 Ityp : Entity_Id;
12583 -- Type of array index to which 'Length is applied
12584
12585 Op : Node_Kind := Nkind (N);
12586 -- Kind of comparison operator, gets flipped if operands backwards
12587
12588 function Is_Optimizable (N : Node_Id) return Boolean;
12589 -- Tests N to see if it is an optimizable comparison value (defined as
12590 -- constant zero or one, or something else where the value is known to
12591 -- be positive and in the range of 32-bits, and where the corresponding
12592 -- Length value is also known to be 32-bits. If result is true, sets
12593 -- Is_Zero, Ityp, and Comp accordingly.
12594
12595 function Is_Entity_Length (N : Node_Id) return Boolean;
12596 -- Tests if N is a length attribute applied to a simple entity. If so,
12597 -- returns True, and sets Ent to the entity, and Index to the integer
12598 -- literal provided as an attribute expression, or to Empty if none.
12599 -- Also returns True if the expression is a generated type conversion
12600 -- whose expression is of the desired form. This latter case arises
12601 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12602 -- to check for being in range, which is not needed in this context.
12603 -- Returns False if neither condition holds.
12604
12605 function Prepare_64 (N : Node_Id) return Node_Id;
12606 -- Given a discrete expression, returns a Long_Long_Integer typed
12607 -- expression representing the underlying value of the expression.
12608 -- This is done with an unchecked conversion to the result type. We
12609 -- use unchecked conversion to handle the enumeration type case.
12610
12611 ----------------------
12612 -- Is_Entity_Length --
12613 ----------------------
12614
12615 function Is_Entity_Length (N : Node_Id) return Boolean is
12616 begin
12617 if Nkind (N) = N_Attribute_Reference
12618 and then Attribute_Name (N) = Name_Length
12619 and then Is_Entity_Name (Prefix (N))
12620 then
12621 Ent := Entity (Prefix (N));
12622
12623 if Present (Expressions (N)) then
12624 Index := First (Expressions (N));
12625 else
12626 Index := Empty;
12627 end if;
12628
12629 return True;
12630
12631 elsif Nkind (N) = N_Type_Conversion
12632 and then not Comes_From_Source (N)
12633 then
12634 return Is_Entity_Length (Expression (N));
12635
12636 else
12637 return False;
12638 end if;
12639 end Is_Entity_Length;
12640
12641 --------------------
12642 -- Is_Optimizable --
12643 --------------------
12644
12645 function Is_Optimizable (N : Node_Id) return Boolean is
12646 Val : Uint;
12647 OK : Boolean;
12648 Lo : Uint;
12649 Hi : Uint;
12650 Indx : Node_Id;
12651
12652 begin
12653 if Compile_Time_Known_Value (N) then
12654 Val := Expr_Value (N);
12655
12656 if Val = Uint_0 then
12657 Is_Zero := True;
12658 Comp := Empty;
12659 return True;
12660
12661 elsif Val = Uint_1 then
12662 Is_Zero := False;
12663 Comp := Empty;
12664 return True;
12665 end if;
12666 end if;
12667
12668 -- Here we have to make sure of being within 32-bits
12669
12670 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
12671
12672 if not OK
12673 or else Lo < Uint_1
12674 or else Hi > UI_From_Int (Int'Last)
12675 then
12676 return False;
12677 end if;
12678
12679 -- Comparison value was within range, so now we must check the index
12680 -- value to make sure it is also within 32-bits.
12681
12682 Indx := First_Index (Etype (Ent));
12683
12684 if Present (Index) then
12685 for J in 2 .. UI_To_Int (Intval (Index)) loop
12686 Next_Index (Indx);
12687 end loop;
12688 end if;
12689
12690 Ityp := Etype (Indx);
12691
12692 if Esize (Ityp) > 32 then
12693 return False;
12694 end if;
12695
12696 Is_Zero := False;
12697 Comp := N;
12698 return True;
12699 end Is_Optimizable;
12700
12701 ----------------
12702 -- Prepare_64 --
12703 ----------------
12704
12705 function Prepare_64 (N : Node_Id) return Node_Id is
12706 begin
12707 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
12708 end Prepare_64;
12709
12710 -- Start of processing for Optimize_Length_Comparison
12711
12712 begin
12713 -- Nothing to do if not a comparison
12714
12715 if Op not in N_Op_Compare then
12716 return;
12717 end if;
12718
12719 -- Nothing to do if special -gnatd.P debug flag set.
12720
12721 if Debug_Flag_Dot_PP then
12722 return;
12723 end if;
12724
12725 -- Ent'Length op 0/1
12726
12727 if Is_Entity_Length (Left_Opnd (N))
12728 and then Is_Optimizable (Right_Opnd (N))
12729 then
12730 null;
12731
12732 -- 0/1 op Ent'Length
12733
12734 elsif Is_Entity_Length (Right_Opnd (N))
12735 and then Is_Optimizable (Left_Opnd (N))
12736 then
12737 -- Flip comparison to opposite sense
12738
12739 case Op is
12740 when N_Op_Lt => Op := N_Op_Gt;
12741 when N_Op_Le => Op := N_Op_Ge;
12742 when N_Op_Gt => Op := N_Op_Lt;
12743 when N_Op_Ge => Op := N_Op_Le;
12744 when others => null;
12745 end case;
12746
12747 -- Else optimization not possible
12748
12749 else
12750 return;
12751 end if;
12752
12753 -- Fall through if we will do the optimization
12754
12755 -- Cases to handle:
12756
12757 -- X'Length = 0 => X'First > X'Last
12758 -- X'Length = 1 => X'First = X'Last
12759 -- X'Length = n => X'First + (n - 1) = X'Last
12760
12761 -- X'Length /= 0 => X'First <= X'Last
12762 -- X'Length /= 1 => X'First /= X'Last
12763 -- X'Length /= n => X'First + (n - 1) /= X'Last
12764
12765 -- X'Length >= 0 => always true, warn
12766 -- X'Length >= 1 => X'First <= X'Last
12767 -- X'Length >= n => X'First + (n - 1) <= X'Last
12768
12769 -- X'Length > 0 => X'First <= X'Last
12770 -- X'Length > 1 => X'First < X'Last
12771 -- X'Length > n => X'First + (n - 1) < X'Last
12772
12773 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12774 -- X'Length <= 1 => X'First >= X'Last
12775 -- X'Length <= n => X'First + (n - 1) >= X'Last
12776
12777 -- X'Length < 0 => always false (warn)
12778 -- X'Length < 1 => X'First > X'Last
12779 -- X'Length < n => X'First + (n - 1) > X'Last
12780
12781 -- Note: for the cases of n (not constant 0,1), we require that the
12782 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12783 -- and the same for the comparison value. Then we do the comparison
12784 -- using 64-bit arithmetic (actually long long integer), so that we
12785 -- cannot have overflow intefering with the result.
12786
12787 -- First deal with warning cases
12788
12789 if Is_Zero then
12790 case Op is
12791
12792 -- X'Length >= 0
12793
12794 when N_Op_Ge =>
12795 Rewrite (N,
12796 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
12797 Analyze_And_Resolve (N, Typ);
12798 Warn_On_Known_Condition (N);
12799 return;
12800
12801 -- X'Length < 0
12802
12803 when N_Op_Lt =>
12804 Rewrite (N,
12805 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
12806 Analyze_And_Resolve (N, Typ);
12807 Warn_On_Known_Condition (N);
12808 return;
12809
12810 when N_Op_Le =>
12811 if Constant_Condition_Warnings
12812 and then Comes_From_Source (Original_Node (N))
12813 then
12814 Error_Msg_N ("could replace by ""'=""?c?", N);
12815 end if;
12816
12817 Op := N_Op_Eq;
12818
12819 when others =>
12820 null;
12821 end case;
12822 end if;
12823
12824 -- Build the First reference we will use
12825
12826 Left :=
12827 Make_Attribute_Reference (Loc,
12828 Prefix => New_Occurrence_Of (Ent, Loc),
12829 Attribute_Name => Name_First);
12830
12831 if Present (Index) then
12832 Set_Expressions (Left, New_List (New_Copy (Index)));
12833 end if;
12834
12835 -- If general value case, then do the addition of (n - 1), and
12836 -- also add the needed conversions to type Long_Long_Integer.
12837
12838 if Present (Comp) then
12839 Left :=
12840 Make_Op_Add (Loc,
12841 Left_Opnd => Prepare_64 (Left),
12842 Right_Opnd =>
12843 Make_Op_Subtract (Loc,
12844 Left_Opnd => Prepare_64 (Comp),
12845 Right_Opnd => Make_Integer_Literal (Loc, 1)));
12846 end if;
12847
12848 -- Build the Last reference we will use
12849
12850 Right :=
12851 Make_Attribute_Reference (Loc,
12852 Prefix => New_Occurrence_Of (Ent, Loc),
12853 Attribute_Name => Name_Last);
12854
12855 if Present (Index) then
12856 Set_Expressions (Right, New_List (New_Copy (Index)));
12857 end if;
12858
12859 -- If general operand, convert Last reference to Long_Long_Integer
12860
12861 if Present (Comp) then
12862 Right := Prepare_64 (Right);
12863 end if;
12864
12865 -- Check for cases to optimize
12866
12867 -- X'Length = 0 => X'First > X'Last
12868 -- X'Length < 1 => X'First > X'Last
12869 -- X'Length < n => X'First + (n - 1) > X'Last
12870
12871 if (Is_Zero and then Op = N_Op_Eq)
12872 or else (not Is_Zero and then Op = N_Op_Lt)
12873 then
12874 Result :=
12875 Make_Op_Gt (Loc,
12876 Left_Opnd => Left,
12877 Right_Opnd => Right);
12878
12879 -- X'Length = 1 => X'First = X'Last
12880 -- X'Length = n => X'First + (n - 1) = X'Last
12881
12882 elsif not Is_Zero and then Op = N_Op_Eq then
12883 Result :=
12884 Make_Op_Eq (Loc,
12885 Left_Opnd => Left,
12886 Right_Opnd => Right);
12887
12888 -- X'Length /= 0 => X'First <= X'Last
12889 -- X'Length > 0 => X'First <= X'Last
12890
12891 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
12892 Result :=
12893 Make_Op_Le (Loc,
12894 Left_Opnd => Left,
12895 Right_Opnd => Right);
12896
12897 -- X'Length /= 1 => X'First /= X'Last
12898 -- X'Length /= n => X'First + (n - 1) /= X'Last
12899
12900 elsif not Is_Zero and then Op = N_Op_Ne then
12901 Result :=
12902 Make_Op_Ne (Loc,
12903 Left_Opnd => Left,
12904 Right_Opnd => Right);
12905
12906 -- X'Length >= 1 => X'First <= X'Last
12907 -- X'Length >= n => X'First + (n - 1) <= X'Last
12908
12909 elsif not Is_Zero and then Op = N_Op_Ge then
12910 Result :=
12911 Make_Op_Le (Loc,
12912 Left_Opnd => Left,
12913 Right_Opnd => Right);
12914
12915 -- X'Length > 1 => X'First < X'Last
12916 -- X'Length > n => X'First + (n = 1) < X'Last
12917
12918 elsif not Is_Zero and then Op = N_Op_Gt then
12919 Result :=
12920 Make_Op_Lt (Loc,
12921 Left_Opnd => Left,
12922 Right_Opnd => Right);
12923
12924 -- X'Length <= 1 => X'First >= X'Last
12925 -- X'Length <= n => X'First + (n - 1) >= X'Last
12926
12927 elsif not Is_Zero and then Op = N_Op_Le then
12928 Result :=
12929 Make_Op_Ge (Loc,
12930 Left_Opnd => Left,
12931 Right_Opnd => Right);
12932
12933 -- Should not happen at this stage
12934
12935 else
12936 raise Program_Error;
12937 end if;
12938
12939 -- Rewrite and finish up
12940
12941 Rewrite (N, Result);
12942 Analyze_And_Resolve (N, Typ);
12943 return;
12944 end Optimize_Length_Comparison;
12945
12946 --------------------------------
12947 -- Process_If_Case_Statements --
12948 --------------------------------
12949
12950 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
12951 Decl : Node_Id;
12952
12953 begin
12954 Decl := First (Stmts);
12955 while Present (Decl) loop
12956 if Nkind (Decl) = N_Object_Declaration
12957 and then Is_Finalizable_Transient (Decl, N)
12958 then
12959 Process_Transient_Object (Decl, N, Stmts);
12960 end if;
12961
12962 Next (Decl);
12963 end loop;
12964 end Process_If_Case_Statements;
12965
12966 ------------------------------
12967 -- Process_Transient_Object --
12968 ------------------------------
12969
12970 procedure Process_Transient_Object
12971 (Decl : Node_Id;
12972 N : Node_Id;
12973 Stmts : List_Id)
12974 is
12975 Loc : constant Source_Ptr := Sloc (Decl);
12976 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
12977 Obj_Typ : constant Node_Id := Etype (Obj_Id);
12978
12979 Desig_Typ : Entity_Id;
12980 Expr : Node_Id;
12981 Hook_Id : Entity_Id;
12982 Hook_Insert : Node_Id;
12983 Ptr_Id : Entity_Id;
12984
12985 Hook_Context : constant Node_Id := Find_Hook_Context (N);
12986 -- The node on which to insert the hook as an action. This is usually
12987 -- the innermost enclosing non-transient construct.
12988
12989 Fin_Context : Node_Id;
12990 -- The node after which to insert the finalization actions of the
12991 -- transient controlled object.
12992
12993 begin
12994 pragma Assert (Nkind_In (N, N_Case_Expression,
12995 N_Expression_With_Actions,
12996 N_If_Expression));
12997
12998 -- When the context is a Boolean evaluation, all three nodes capture the
12999 -- result of their computation in a local temporary:
13000
13001 -- do
13002 -- Trans_Id : Ctrl_Typ := ...;
13003 -- Result : constant Boolean := ... Trans_Id ...;
13004 -- <finalize Trans_Id>
13005 -- in Result end;
13006
13007 -- As a result, the finalization of any transient controlled objects can
13008 -- safely take place after the result capture.
13009
13010 -- ??? could this be extended to elementary types?
13011
13012 if Is_Boolean_Type (Etype (N)) then
13013 Fin_Context := Last (Stmts);
13014
13015 -- Otherwise the immediate context may not be safe enough to carry out
13016 -- transient controlled object finalization due to aliasing and nesting
13017 -- of constructs. Insert calls to [Deep_]Finalize after the innermost
13018 -- enclosing non-transient construct.
13019
13020 else
13021 Fin_Context := Hook_Context;
13022 end if;
13023
13024 -- Step 1: Create the access type which provides a reference to the
13025 -- transient controlled object.
13026
13027 if Is_Access_Type (Obj_Typ) then
13028 Desig_Typ := Directly_Designated_Type (Obj_Typ);
13029 else
13030 Desig_Typ := Obj_Typ;
13031 end if;
13032
13033 Desig_Typ := Base_Type (Desig_Typ);
13034
13035 -- Generate:
13036 -- Ann : access [all] <Desig_Typ>;
13037
13038 Ptr_Id := Make_Temporary (Loc, 'A');
13039
13040 Insert_Action (Hook_Context,
13041 Make_Full_Type_Declaration (Loc,
13042 Defining_Identifier => Ptr_Id,
13043 Type_Definition =>
13044 Make_Access_To_Object_Definition (Loc,
13045 All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
13046 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
13047
13048 -- Step 2: Create a temporary which acts as a hook to the transient
13049 -- controlled object. Generate:
13050
13051 -- Hook : Ptr_Id := null;
13052
13053 Hook_Id := Make_Temporary (Loc, 'T');
13054
13055 Insert_Action (Hook_Context,
13056 Make_Object_Declaration (Loc,
13057 Defining_Identifier => Hook_Id,
13058 Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
13059
13060 -- Mark the hook as created for the purposes of exporting the transient
13061 -- controlled object out of the expression_with_action or if expression.
13062 -- This signals the machinery in Build_Finalizer to treat this case in
13063 -- a special manner.
13064
13065 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Decl);
13066
13067 -- Step 3: Associate the transient object to the hook
13068
13069 -- This must be inserted right after the object declaration, so that
13070 -- the assignment is executed if, and only if, the object is actually
13071 -- created (whereas the declaration of the hook pointer, and the
13072 -- finalization call, may be inserted at an outer level, and may
13073 -- remain unused for some executions, if the actual creation of
13074 -- the object is conditional).
13075
13076 -- The use of unchecked conversion / unrestricted access is needed to
13077 -- avoid an accessibility violation. Note that the finalization code is
13078 -- structured in such a way that the "hook" is processed only when it
13079 -- points to an existing object.
13080
13081 if Is_Access_Type (Obj_Typ) then
13082 Expr :=
13083 Unchecked_Convert_To
13084 (Typ => Ptr_Id,
13085 Expr => New_Occurrence_Of (Obj_Id, Loc));
13086 else
13087 Expr :=
13088 Make_Attribute_Reference (Loc,
13089 Prefix => New_Occurrence_Of (Obj_Id, Loc),
13090 Attribute_Name => Name_Unrestricted_Access);
13091 end if;
13092
13093 -- Generate:
13094 -- Hook := Ptr_Id (Obj_Id);
13095 -- <or>
13096 -- Hook := Obj_Id'Unrestricted_Access;
13097
13098 -- When the transient object is initialized by an aggregate, the hook
13099 -- must capture the object after the last component assignment takes
13100 -- place. Only then is the object fully initialized.
13101
13102 if Ekind (Obj_Id) = E_Variable
13103 and then Present (Last_Aggregate_Assignment (Obj_Id))
13104 then
13105 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
13106
13107 -- Otherwise the hook seizes the related object immediately
13108
13109 else
13110 Hook_Insert := Decl;
13111 end if;
13112
13113 Insert_After_And_Analyze (Hook_Insert,
13114 Make_Assignment_Statement (Loc,
13115 Name => New_Occurrence_Of (Hook_Id, Loc),
13116 Expression => Expr));
13117
13118 -- Step 4: Finalize the hook after the context has been evaluated or
13119 -- elaborated. Generate:
13120
13121 -- if Hook /= null then
13122 -- [Deep_]Finalize (Hook.all);
13123 -- Hook := null;
13124 -- end if;
13125
13126 -- When the node is part of a return statement, there is no need to
13127 -- insert a finalization call, as the general finalization mechanism
13128 -- (see Build_Finalizer) would take care of the transient controlled
13129 -- object on subprogram exit. Note that it would also be impossible to
13130 -- insert the finalization code after the return statement as this will
13131 -- render it unreachable.
13132
13133 if Nkind (Fin_Context) = N_Simple_Return_Statement then
13134 null;
13135
13136 -- Otherwise finalize the hook
13137
13138 else
13139 Insert_Action_After (Fin_Context,
13140 Make_Implicit_If_Statement (Decl,
13141 Condition =>
13142 Make_Op_Ne (Loc,
13143 Left_Opnd => New_Occurrence_Of (Hook_Id, Loc),
13144 Right_Opnd => Make_Null (Loc)),
13145
13146 Then_Statements => New_List (
13147 Make_Final_Call
13148 (Obj_Ref =>
13149 Make_Explicit_Dereference (Loc,
13150 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
13151 Typ => Desig_Typ),
13152
13153 Make_Assignment_Statement (Loc,
13154 Name => New_Occurrence_Of (Hook_Id, Loc),
13155 Expression => Make_Null (Loc)))));
13156 end if;
13157 end Process_Transient_Object;
13158
13159 ------------------------
13160 -- Rewrite_Comparison --
13161 ------------------------
13162
13163 procedure Rewrite_Comparison (N : Node_Id) is
13164 Warning_Generated : Boolean := False;
13165 -- Set to True if first pass with Assume_Valid generates a warning in
13166 -- which case we skip the second pass to avoid warning overloaded.
13167
13168 Result : Node_Id;
13169 -- Set to Standard_True or Standard_False
13170
13171 begin
13172 if Nkind (N) = N_Type_Conversion then
13173 Rewrite_Comparison (Expression (N));
13174 return;
13175
13176 elsif Nkind (N) not in N_Op_Compare then
13177 return;
13178 end if;
13179
13180 -- Now start looking at the comparison in detail. We potentially go
13181 -- through this loop twice. The first time, Assume_Valid is set False
13182 -- in the call to Compile_Time_Compare. If this call results in a
13183 -- clear result of always True or Always False, that's decisive and
13184 -- we are done. Otherwise we repeat the processing with Assume_Valid
13185 -- set to True to generate additional warnings. We can skip that step
13186 -- if Constant_Condition_Warnings is False.
13187
13188 for AV in False .. True loop
13189 declare
13190 Typ : constant Entity_Id := Etype (N);
13191 Op1 : constant Node_Id := Left_Opnd (N);
13192 Op2 : constant Node_Id := Right_Opnd (N);
13193
13194 Res : constant Compare_Result :=
13195 Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
13196 -- Res indicates if compare outcome can be compile time determined
13197
13198 True_Result : Boolean;
13199 False_Result : Boolean;
13200
13201 begin
13202 case N_Op_Compare (Nkind (N)) is
13203 when N_Op_Eq =>
13204 True_Result := Res = EQ;
13205 False_Result := Res = LT or else Res = GT or else Res = NE;
13206
13207 when N_Op_Ge =>
13208 True_Result := Res in Compare_GE;
13209 False_Result := Res = LT;
13210
13211 if Res = LE
13212 and then Constant_Condition_Warnings
13213 and then Comes_From_Source (Original_Node (N))
13214 and then Nkind (Original_Node (N)) = N_Op_Ge
13215 and then not In_Instance
13216 and then Is_Integer_Type (Etype (Left_Opnd (N)))
13217 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
13218 then
13219 Error_Msg_N
13220 ("can never be greater than, could replace by ""'=""?c?",
13221 N);
13222 Warning_Generated := True;
13223 end if;
13224
13225 when N_Op_Gt =>
13226 True_Result := Res = GT;
13227 False_Result := Res in Compare_LE;
13228
13229 when N_Op_Lt =>
13230 True_Result := Res = LT;
13231 False_Result := Res in Compare_GE;
13232
13233 when N_Op_Le =>
13234 True_Result := Res in Compare_LE;
13235 False_Result := Res = GT;
13236
13237 if Res = GE
13238 and then Constant_Condition_Warnings
13239 and then Comes_From_Source (Original_Node (N))
13240 and then Nkind (Original_Node (N)) = N_Op_Le
13241 and then not In_Instance
13242 and then Is_Integer_Type (Etype (Left_Opnd (N)))
13243 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
13244 then
13245 Error_Msg_N
13246 ("can never be less than, could replace by ""'=""?c?", N);
13247 Warning_Generated := True;
13248 end if;
13249
13250 when N_Op_Ne =>
13251 True_Result := Res = NE or else Res = GT or else Res = LT;
13252 False_Result := Res = EQ;
13253 end case;
13254
13255 -- If this is the first iteration, then we actually convert the
13256 -- comparison into True or False, if the result is certain.
13257
13258 if AV = False then
13259 if True_Result or False_Result then
13260 Result := Boolean_Literals (True_Result);
13261 Rewrite (N,
13262 Convert_To (Typ,
13263 New_Occurrence_Of (Result, Sloc (N))));
13264 Analyze_And_Resolve (N, Typ);
13265 Warn_On_Known_Condition (N);
13266 return;
13267 end if;
13268
13269 -- If this is the second iteration (AV = True), and the original
13270 -- node comes from source and we are not in an instance, then give
13271 -- a warning if we know result would be True or False. Note: we
13272 -- know Constant_Condition_Warnings is set if we get here.
13273
13274 elsif Comes_From_Source (Original_Node (N))
13275 and then not In_Instance
13276 then
13277 if True_Result then
13278 Error_Msg_N
13279 ("condition can only be False if invalid values present??",
13280 N);
13281 elsif False_Result then
13282 Error_Msg_N
13283 ("condition can only be True if invalid values present??",
13284 N);
13285 end if;
13286 end if;
13287 end;
13288
13289 -- Skip second iteration if not warning on constant conditions or
13290 -- if the first iteration already generated a warning of some kind or
13291 -- if we are in any case assuming all values are valid (so that the
13292 -- first iteration took care of the valid case).
13293
13294 exit when not Constant_Condition_Warnings;
13295 exit when Warning_Generated;
13296 exit when Assume_No_Invalid_Values;
13297 end loop;
13298 end Rewrite_Comparison;
13299
13300 ----------------------------
13301 -- Safe_In_Place_Array_Op --
13302 ----------------------------
13303
13304 function Safe_In_Place_Array_Op
13305 (Lhs : Node_Id;
13306 Op1 : Node_Id;
13307 Op2 : Node_Id) return Boolean
13308 is
13309 Target : Entity_Id;
13310
13311 function Is_Safe_Operand (Op : Node_Id) return Boolean;
13312 -- Operand is safe if it cannot overlap part of the target of the
13313 -- operation. If the operand and the target are identical, the operand
13314 -- is safe. The operand can be empty in the case of negation.
13315
13316 function Is_Unaliased (N : Node_Id) return Boolean;
13317 -- Check that N is a stand-alone entity
13318
13319 ------------------
13320 -- Is_Unaliased --
13321 ------------------
13322
13323 function Is_Unaliased (N : Node_Id) return Boolean is
13324 begin
13325 return
13326 Is_Entity_Name (N)
13327 and then No (Address_Clause (Entity (N)))
13328 and then No (Renamed_Object (Entity (N)));
13329 end Is_Unaliased;
13330
13331 ---------------------
13332 -- Is_Safe_Operand --
13333 ---------------------
13334
13335 function Is_Safe_Operand (Op : Node_Id) return Boolean is
13336 begin
13337 if No (Op) then
13338 return True;
13339
13340 elsif Is_Entity_Name (Op) then
13341 return Is_Unaliased (Op);
13342
13343 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
13344 return Is_Unaliased (Prefix (Op));
13345
13346 elsif Nkind (Op) = N_Slice then
13347 return
13348 Is_Unaliased (Prefix (Op))
13349 and then Entity (Prefix (Op)) /= Target;
13350
13351 elsif Nkind (Op) = N_Op_Not then
13352 return Is_Safe_Operand (Right_Opnd (Op));
13353
13354 else
13355 return False;
13356 end if;
13357 end Is_Safe_Operand;
13358
13359 -- Start of processing for Safe_In_Place_Array_Op
13360
13361 begin
13362 -- Skip this processing if the component size is different from system
13363 -- storage unit (since at least for NOT this would cause problems).
13364
13365 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
13366 return False;
13367
13368 -- Cannot do in place stuff if non-standard Boolean representation
13369
13370 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
13371 return False;
13372
13373 elsif not Is_Unaliased (Lhs) then
13374 return False;
13375
13376 else
13377 Target := Entity (Lhs);
13378 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
13379 end if;
13380 end Safe_In_Place_Array_Op;
13381
13382 -----------------------
13383 -- Tagged_Membership --
13384 -----------------------
13385
13386 -- There are two different cases to consider depending on whether the right
13387 -- operand is a class-wide type or not. If not we just compare the actual
13388 -- tag of the left expr to the target type tag:
13389 --
13390 -- Left_Expr.Tag = Right_Type'Tag;
13391 --
13392 -- If it is a class-wide type we use the RT function CW_Membership which is
13393 -- usually implemented by looking in the ancestor tables contained in the
13394 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13395
13396 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13397 -- function IW_Membership which is usually implemented by looking in the
13398 -- table of abstract interface types plus the ancestor table contained in
13399 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13400
13401 procedure Tagged_Membership
13402 (N : Node_Id;
13403 SCIL_Node : out Node_Id;
13404 Result : out Node_Id)
13405 is
13406 Left : constant Node_Id := Left_Opnd (N);
13407 Right : constant Node_Id := Right_Opnd (N);
13408 Loc : constant Source_Ptr := Sloc (N);
13409
13410 Full_R_Typ : Entity_Id;
13411 Left_Type : Entity_Id;
13412 New_Node : Node_Id;
13413 Right_Type : Entity_Id;
13414 Obj_Tag : Node_Id;
13415
13416 begin
13417 SCIL_Node := Empty;
13418
13419 -- Handle entities from the limited view
13420
13421 Left_Type := Available_View (Etype (Left));
13422 Right_Type := Available_View (Etype (Right));
13423
13424 -- In the case where the type is an access type, the test is applied
13425 -- using the designated types (needed in Ada 2012 for implicit anonymous
13426 -- access conversions, for AI05-0149).
13427
13428 if Is_Access_Type (Right_Type) then
13429 Left_Type := Designated_Type (Left_Type);
13430 Right_Type := Designated_Type (Right_Type);
13431 end if;
13432
13433 if Is_Class_Wide_Type (Left_Type) then
13434 Left_Type := Root_Type (Left_Type);
13435 end if;
13436
13437 if Is_Class_Wide_Type (Right_Type) then
13438 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
13439 else
13440 Full_R_Typ := Underlying_Type (Right_Type);
13441 end if;
13442
13443 Obj_Tag :=
13444 Make_Selected_Component (Loc,
13445 Prefix => Relocate_Node (Left),
13446 Selector_Name =>
13447 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
13448
13449 if Is_Class_Wide_Type (Right_Type) then
13450
13451 -- No need to issue a run-time check if we statically know that the
13452 -- result of this membership test is always true. For example,
13453 -- considering the following declarations:
13454
13455 -- type Iface is interface;
13456 -- type T is tagged null record;
13457 -- type DT is new T and Iface with null record;
13458
13459 -- Obj1 : T;
13460 -- Obj2 : DT;
13461
13462 -- These membership tests are always true:
13463
13464 -- Obj1 in T'Class
13465 -- Obj2 in T'Class;
13466 -- Obj2 in Iface'Class;
13467
13468 -- We do not need to handle cases where the membership is illegal.
13469 -- For example:
13470
13471 -- Obj1 in DT'Class; -- Compile time error
13472 -- Obj1 in Iface'Class; -- Compile time error
13473
13474 if not Is_Class_Wide_Type (Left_Type)
13475 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
13476 Use_Full_View => True)
13477 or else (Is_Interface (Etype (Right_Type))
13478 and then Interface_Present_In_Ancestor
13479 (Typ => Left_Type,
13480 Iface => Etype (Right_Type))))
13481 then
13482 Result := New_Occurrence_Of (Standard_True, Loc);
13483 return;
13484 end if;
13485
13486 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13487
13488 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
13489
13490 -- Support to: "Iface_CW_Typ in Typ'Class"
13491
13492 or else Is_Interface (Left_Type)
13493 then
13494 -- Issue error if IW_Membership operation not available in a
13495 -- configurable run time setting.
13496
13497 if not RTE_Available (RE_IW_Membership) then
13498 Error_Msg_CRT
13499 ("dynamic membership test on interface types", N);
13500 Result := Empty;
13501 return;
13502 end if;
13503
13504 Result :=
13505 Make_Function_Call (Loc,
13506 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
13507 Parameter_Associations => New_List (
13508 Make_Attribute_Reference (Loc,
13509 Prefix => Obj_Tag,
13510 Attribute_Name => Name_Address),
13511 New_Occurrence_Of (
13512 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
13513 Loc)));
13514
13515 -- Ada 95: Normal case
13516
13517 else
13518 Build_CW_Membership (Loc,
13519 Obj_Tag_Node => Obj_Tag,
13520 Typ_Tag_Node =>
13521 New_Occurrence_Of (
13522 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
13523 Related_Nod => N,
13524 New_Node => New_Node);
13525
13526 -- Generate the SCIL node for this class-wide membership test.
13527 -- Done here because the previous call to Build_CW_Membership
13528 -- relocates Obj_Tag.
13529
13530 if Generate_SCIL then
13531 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
13532 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
13533 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
13534 end if;
13535
13536 Result := New_Node;
13537 end if;
13538
13539 -- Right_Type is not a class-wide type
13540
13541 else
13542 -- No need to check the tag of the object if Right_Typ is abstract
13543
13544 if Is_Abstract_Type (Right_Type) then
13545 Result := New_Occurrence_Of (Standard_False, Loc);
13546
13547 else
13548 Result :=
13549 Make_Op_Eq (Loc,
13550 Left_Opnd => Obj_Tag,
13551 Right_Opnd =>
13552 New_Occurrence_Of
13553 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
13554 end if;
13555 end if;
13556 end Tagged_Membership;
13557
13558 ------------------------------
13559 -- Unary_Op_Validity_Checks --
13560 ------------------------------
13561
13562 procedure Unary_Op_Validity_Checks (N : Node_Id) is
13563 begin
13564 if Validity_Checks_On and Validity_Check_Operands then
13565 Ensure_Valid (Right_Opnd (N));
13566 end if;
13567 end Unary_Op_Validity_Checks;
13568
13569 end Exp_Ch4;