projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
decl.c (validate_size): Set minimum size for fat pointers same as access types.
[gcc.git] / gcc / ada / 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-2008, 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 Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Exp_Aggr; use Exp_Aggr;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch3; use Exp_Ch3;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Disp; use Exp_Disp;
38 with Exp_Fixd; use Exp_Fixd;
39 with Exp_Pakd; use Exp_Pakd;
40 with Exp_Tss; use Exp_Tss;
41 with Exp_Util; use Exp_Util;
42 with Exp_VFpt; use Exp_VFpt;
43 with Freeze; use Freeze;
44 with Inline; use Inline;
45 with Namet; use Namet;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
48 with Opt; use Opt;
49 with Restrict; use Restrict;
50 with Rident; use Rident;
51 with Rtsfind; use Rtsfind;
52 with Sem; use Sem;
53 with Sem_Cat; use Sem_Cat;
54 with Sem_Ch3; use Sem_Ch3;
55 with Sem_Ch8; use Sem_Ch8;
56 with Sem_Ch13; use Sem_Ch13;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Res; use Sem_Res;
59 with Sem_Type; use Sem_Type;
60 with Sem_Util; use Sem_Util;
61 with Sem_Warn; use Sem_Warn;
62 with Sinfo; use Sinfo;
63 with Snames; use Snames;
64 with Stand; use Stand;
65 with Targparm; use Targparm;
66 with Tbuild; use Tbuild;
67 with Ttypes; use Ttypes;
68 with Uintp; use Uintp;
69 with Urealp; use Urealp;
70 with Validsw; use Validsw;
71
72 package body Exp_Ch4 is
73
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
77
78 procedure Binary_Op_Validity_Checks (N : Node_Id);
79 pragma Inline (Binary_Op_Validity_Checks);
80 -- Performs validity checks for a binary operator
81
82 procedure Build_Boolean_Array_Proc_Call
83 (N : Node_Id;
84 Op1 : Node_Id;
85 Op2 : Node_Id);
86 -- If a boolean array assignment can be done in place, build call to
87 -- corresponding library procedure.
88
89 procedure Displace_Allocator_Pointer (N : Node_Id);
90 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
91 -- Expand_Allocator_Expression. Allocating class-wide interface objects
92 -- this routine displaces the pointer to the allocated object to reference
93 -- the component referencing the corresponding secondary dispatch table.
94
95 procedure Expand_Allocator_Expression (N : Node_Id);
96 -- Subsidiary to Expand_N_Allocator, for the case when the expression
97 -- is a qualified expression or an aggregate.
98
99 procedure Expand_Array_Comparison (N : Node_Id);
100 -- This routine handles expansion of the comparison operators (N_Op_Lt,
101 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
102 -- code for these operators is similar, differing only in the details of
103 -- the actual comparison call that is made. Special processing (call a
104 -- run-time routine)
105
106 function Expand_Array_Equality
107 (Nod : Node_Id;
108 Lhs : Node_Id;
109 Rhs : Node_Id;
110 Bodies : List_Id;
111 Typ : Entity_Id) return Node_Id;
112 -- Expand an array equality into a call to a function implementing this
113 -- equality, and a call to it. Loc is the location for the generated
114 -- nodes. Lhs and Rhs are the array expressions to be compared.
115 -- Bodies is a list on which to attach bodies of local functions that
116 -- are created in the process. It is the responsibility of the
117 -- caller to insert those bodies at the right place. Nod provides
118 -- the Sloc value for the generated code. Normally the types used
119 -- for the generated equality routine are taken from Lhs and Rhs.
120 -- However, in some situations of generated code, the Etype fields
121 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
122 -- type to be used for the formal parameters.
123
124 procedure Expand_Boolean_Operator (N : Node_Id);
125 -- Common expansion processing for Boolean operators (And, Or, Xor)
126 -- for the case of array type arguments.
127
128 function Expand_Composite_Equality
129 (Nod : Node_Id;
130 Typ : Entity_Id;
131 Lhs : Node_Id;
132 Rhs : Node_Id;
133 Bodies : List_Id) return Node_Id;
134 -- Local recursive function used to expand equality for nested
135 -- composite types. Used by Expand_Record/Array_Equality, Bodies
136 -- is a list on which to attach bodies of local functions that are
137 -- created in the process. This is the responsibility of the caller
138 -- to insert those bodies at the right place. Nod provides the Sloc
139 -- value for generated code. Lhs and Rhs are the left and right sides
140 -- for the comparison, and Typ is the type of the arrays to compare.
141
142 procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
143 -- This routine handles expansion of concatenation operations, where
144 -- N is the N_Op_Concat node being expanded and Operands is the list
145 -- of operands (at least two are present). The caller has dealt with
146 -- converting any singleton operands into singleton aggregates.
147
148 procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
149 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
150 -- and replace node Cnode with the result of the concatenation. If there
151 -- are two operands, they can be string or character. If there are more
152 -- than two operands, then are always of type string (i.e. the caller has
153 -- already converted character operands to strings in this case).
154
155 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
156 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
157 -- universal fixed. We do not have such a type at runtime, so the
158 -- purpose of this routine is to find the real type by looking up
159 -- the tree. We also determine if the operation must be rounded.
160
161 function Get_Allocator_Final_List
162 (N : Node_Id;
163 T : Entity_Id;
164 PtrT : Entity_Id) return Entity_Id;
165 -- If the designated type is controlled, build final_list expression
166 -- for created object. If context is an access parameter, create a
167 -- local access type to have a usable finalization list.
168
169 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
170 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
171 -- discriminants if it has a constrained nominal type, unless the object
172 -- is a component of an enclosing Unchecked_Union object that is subject
173 -- to a per-object constraint and the enclosing object lacks inferable
174 -- discriminants.
175 --
176 -- An expression of an Unchecked_Union type has inferable discriminants
177 -- if it is either a name of an object with inferable discriminants or a
178 -- qualified expression whose subtype mark denotes a constrained subtype.
179
180 procedure Insert_Dereference_Action (N : Node_Id);
181 -- N is an expression whose type is an access. When the type of the
182 -- associated storage pool is derived from Checked_Pool, generate a
183 -- call to the 'Dereference' primitive operation.
184
185 function Make_Array_Comparison_Op
186 (Typ : Entity_Id;
187 Nod : Node_Id) return Node_Id;
188 -- Comparisons between arrays are expanded in line. This function
189 -- produces the body of the implementation of (a > b), where a and b
190 -- are one-dimensional arrays of some discrete type. The original
191 -- node is then expanded into the appropriate call to this function.
192 -- Nod provides the Sloc value for the generated code.
193
194 function Make_Boolean_Array_Op
195 (Typ : Entity_Id;
196 N : Node_Id) return Node_Id;
197 -- Boolean operations on boolean arrays are expanded in line. This
198 -- function produce the body for the node N, which is (a and b),
199 -- (a or b), or (a xor b). It is used only the normal case and not
200 -- the packed case. The type involved, Typ, is the Boolean array type,
201 -- and the logical operations in the body are simple boolean operations.
202 -- Note that Typ is always a constrained type (the caller has ensured
203 -- this by using Convert_To_Actual_Subtype if necessary).
204
205 procedure Rewrite_Comparison (N : Node_Id);
206 -- If N is the node for a comparison whose outcome can be determined at
207 -- compile time, then the node N can be rewritten with True or False. If
208 -- the outcome cannot be determined at compile time, the call has no
209 -- effect. If N is a type conversion, then this processing is applied to
210 -- its expression. If N is neither comparison nor a type conversion, the
211 -- call has no effect.
212
213 function Tagged_Membership (N : Node_Id) return Node_Id;
214 -- Construct the expression corresponding to the tagged membership test.
215 -- Deals with a second operand being (or not) a class-wide type.
216
217 function Safe_In_Place_Array_Op
218 (Lhs : Node_Id;
219 Op1 : Node_Id;
220 Op2 : Node_Id) return Boolean;
221 -- In the context of an assignment, where the right-hand side is a
222 -- boolean operation on arrays, check whether operation can be performed
223 -- in place.
224
225 procedure Unary_Op_Validity_Checks (N : Node_Id);
226 pragma Inline (Unary_Op_Validity_Checks);
227 -- Performs validity checks for a unary operator
228
229 -------------------------------
230 -- Binary_Op_Validity_Checks --
231 -------------------------------
232
233 procedure Binary_Op_Validity_Checks (N : Node_Id) is
234 begin
235 if Validity_Checks_On and Validity_Check_Operands then
236 Ensure_Valid (Left_Opnd (N));
237 Ensure_Valid (Right_Opnd (N));
238 end if;
239 end Binary_Op_Validity_Checks;
240
241 ------------------------------------
242 -- Build_Boolean_Array_Proc_Call --
243 ------------------------------------
244
245 procedure Build_Boolean_Array_Proc_Call
246 (N : Node_Id;
247 Op1 : Node_Id;
248 Op2 : Node_Id)
249 is
250 Loc : constant Source_Ptr := Sloc (N);
251 Kind : constant Node_Kind := Nkind (Expression (N));
252 Target : constant Node_Id :=
253 Make_Attribute_Reference (Loc,
254 Prefix => Name (N),
255 Attribute_Name => Name_Address);
256
257 Arg1 : constant Node_Id := Op1;
258 Arg2 : Node_Id := Op2;
259 Call_Node : Node_Id;
260 Proc_Name : Entity_Id;
261
262 begin
263 if Kind = N_Op_Not then
264 if Nkind (Op1) in N_Binary_Op then
265
266 -- Use negated version of the binary operators
267
268 if Nkind (Op1) = N_Op_And then
269 Proc_Name := RTE (RE_Vector_Nand);
270
271 elsif Nkind (Op1) = N_Op_Or then
272 Proc_Name := RTE (RE_Vector_Nor);
273
274 else pragma Assert (Nkind (Op1) = N_Op_Xor);
275 Proc_Name := RTE (RE_Vector_Xor);
276 end if;
277
278 Call_Node :=
279 Make_Procedure_Call_Statement (Loc,
280 Name => New_Occurrence_Of (Proc_Name, Loc),
281
282 Parameter_Associations => New_List (
283 Target,
284 Make_Attribute_Reference (Loc,
285 Prefix => Left_Opnd (Op1),
286 Attribute_Name => Name_Address),
287
288 Make_Attribute_Reference (Loc,
289 Prefix => Right_Opnd (Op1),
290 Attribute_Name => Name_Address),
291
292 Make_Attribute_Reference (Loc,
293 Prefix => Left_Opnd (Op1),
294 Attribute_Name => Name_Length)));
295
296 else
297 Proc_Name := RTE (RE_Vector_Not);
298
299 Call_Node :=
300 Make_Procedure_Call_Statement (Loc,
301 Name => New_Occurrence_Of (Proc_Name, Loc),
302 Parameter_Associations => New_List (
303 Target,
304
305 Make_Attribute_Reference (Loc,
306 Prefix => Op1,
307 Attribute_Name => Name_Address),
308
309 Make_Attribute_Reference (Loc,
310 Prefix => Op1,
311 Attribute_Name => Name_Length)));
312 end if;
313
314 else
315 -- We use the following equivalences:
316
317 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
318 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
319 -- (not X) xor (not Y) = X xor Y
320 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
321
322 if Nkind (Op1) = N_Op_Not then
323 if Kind = N_Op_And then
324 Proc_Name := RTE (RE_Vector_Nor);
325
326 elsif Kind = N_Op_Or then
327 Proc_Name := RTE (RE_Vector_Nand);
328
329 else
330 Proc_Name := RTE (RE_Vector_Xor);
331 end if;
332
333 else
334 if Kind = N_Op_And then
335 Proc_Name := RTE (RE_Vector_And);
336
337 elsif Kind = N_Op_Or then
338 Proc_Name := RTE (RE_Vector_Or);
339
340 elsif Nkind (Op2) = N_Op_Not then
341 Proc_Name := RTE (RE_Vector_Nxor);
342 Arg2 := Right_Opnd (Op2);
343
344 else
345 Proc_Name := RTE (RE_Vector_Xor);
346 end if;
347 end if;
348
349 Call_Node :=
350 Make_Procedure_Call_Statement (Loc,
351 Name => New_Occurrence_Of (Proc_Name, Loc),
352 Parameter_Associations => New_List (
353 Target,
354 Make_Attribute_Reference (Loc,
355 Prefix => Arg1,
356 Attribute_Name => Name_Address),
357 Make_Attribute_Reference (Loc,
358 Prefix => Arg2,
359 Attribute_Name => Name_Address),
360 Make_Attribute_Reference (Loc,
361 Prefix => Op1,
362 Attribute_Name => Name_Length)));
363 end if;
364
365 Rewrite (N, Call_Node);
366 Analyze (N);
367
368 exception
369 when RE_Not_Available =>
370 return;
371 end Build_Boolean_Array_Proc_Call;
372
373 --------------------------------
374 -- Displace_Allocator_Pointer --
375 --------------------------------
376
377 procedure Displace_Allocator_Pointer (N : Node_Id) is
378 Loc : constant Source_Ptr := Sloc (N);
379 Orig_Node : constant Node_Id := Original_Node (N);
380 Dtyp : Entity_Id;
381 Etyp : Entity_Id;
382 PtrT : Entity_Id;
383
384 begin
385 -- Do nothing in case of VM targets: the virtual machine will handle
386 -- interfaces directly.
387
388 if VM_Target /= No_VM then
389 return;
390 end if;
391
392 pragma Assert (Nkind (N) = N_Identifier
393 and then Nkind (Orig_Node) = N_Allocator);
394
395 PtrT := Etype (Orig_Node);
396 Dtyp := Designated_Type (PtrT);
397 Etyp := Etype (Expression (Orig_Node));
398
399 if Is_Class_Wide_Type (Dtyp)
400 and then Is_Interface (Dtyp)
401 then
402 -- If the type of the allocator expression is not an interface type
403 -- we can generate code to reference the record component containing
404 -- the pointer to the secondary dispatch table.
405
406 if not Is_Interface (Etyp) then
407 declare
408 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
409
410 begin
411 -- 1) Get access to the allocated object
412
413 Rewrite (N,
414 Make_Explicit_Dereference (Loc,
415 Relocate_Node (N)));
416 Set_Etype (N, Etyp);
417 Set_Analyzed (N);
418
419 -- 2) Add the conversion to displace the pointer to reference
420 -- the secondary dispatch table.
421
422 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
423 Analyze_And_Resolve (N, Dtyp);
424
425 -- 3) The 'access to the secondary dispatch table will be used
426 -- as the value returned by the allocator.
427
428 Rewrite (N,
429 Make_Attribute_Reference (Loc,
430 Prefix => Relocate_Node (N),
431 Attribute_Name => Name_Access));
432 Set_Etype (N, Saved_Typ);
433 Set_Analyzed (N);
434 end;
435
436 -- If the type of the allocator expression is an interface type we
437 -- generate a run-time call to displace "this" to reference the
438 -- component containing the pointer to the secondary dispatch table
439 -- or else raise Constraint_Error if the actual object does not
440 -- implement the target interface. This case corresponds with the
441 -- following example:
442
443 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
444 -- begin
445 -- return new Iface_2'Class'(Obj);
446 -- end Op;
447
448 else
449 Rewrite (N,
450 Unchecked_Convert_To (PtrT,
451 Make_Function_Call (Loc,
452 Name => New_Reference_To (RTE (RE_Displace), Loc),
453 Parameter_Associations => New_List (
454 Unchecked_Convert_To (RTE (RE_Address),
455 Relocate_Node (N)),
456
457 New_Occurrence_Of
458 (Elists.Node
459 (First_Elmt
460 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
461 Loc)))));
462 Analyze_And_Resolve (N, PtrT);
463 end if;
464 end if;
465 end Displace_Allocator_Pointer;
466
467 ---------------------------------
468 -- Expand_Allocator_Expression --
469 ---------------------------------
470
471 procedure Expand_Allocator_Expression (N : Node_Id) is
472 Loc : constant Source_Ptr := Sloc (N);
473 Exp : constant Node_Id := Expression (Expression (N));
474 PtrT : constant Entity_Id := Etype (N);
475 DesigT : constant Entity_Id := Designated_Type (PtrT);
476
477 procedure Apply_Accessibility_Check
478 (Ref : Node_Id;
479 Built_In_Place : Boolean := False);
480 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
481 -- type, generate an accessibility check to verify that the level of
482 -- the type of the created object is not deeper than the level of the
483 -- access type. If the type of the qualified expression is class-
484 -- wide, then always generate the check (except in the case where it
485 -- is known to be unnecessary, see comment below). Otherwise, only
486 -- generate the check if the level of the qualified expression type
487 -- is statically deeper than the access type. Although the static
488 -- accessibility will generally have been performed as a legality
489 -- check, it won't have been done in cases where the allocator
490 -- appears in generic body, so a run-time check is needed in general.
491 -- One special case is when the access type is declared in the same
492 -- scope as the class-wide allocator, in which case the check can
493 -- never fail, so it need not be generated. As an open issue, there
494 -- seem to be cases where the static level associated with the
495 -- class-wide object's underlying type is not sufficient to perform
496 -- the proper accessibility check, such as for allocators in nested
497 -- subprograms or accept statements initialized by class-wide formals
498 -- when the actual originates outside at a deeper static level. The
499 -- nested subprogram case might require passing accessibility levels
500 -- along with class-wide parameters, and the task case seems to be
501 -- an actual gap in the language rules that needs to be fixed by the
502 -- ARG. ???
503
504 -------------------------------
505 -- Apply_Accessibility_Check --
506 -------------------------------
507
508 procedure Apply_Accessibility_Check
509 (Ref : Node_Id;
510 Built_In_Place : Boolean := False)
511 is
512 Ref_Node : Node_Id;
513
514 begin
515 -- Note: we skip the accessibility check for the VM case, since
516 -- there does not seem to be any practical way of implementing it.
517
518 if Ada_Version >= Ada_05
519 and then VM_Target = No_VM
520 and then Is_Class_Wide_Type (DesigT)
521 and then not Scope_Suppress (Accessibility_Check)
522 and then
523 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
524 or else
525 (Is_Class_Wide_Type (Etype (Exp))
526 and then Scope (PtrT) /= Current_Scope))
527 then
528 -- If the allocator was built in place Ref is already a reference
529 -- to the access object initialized to the result of the allocator
530 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
531 -- it is the entity associated with the object containing the
532 -- address of the allocated object.
533
534 if Built_In_Place then
535 Ref_Node := New_Copy (Ref);
536 else
537 Ref_Node := New_Reference_To (Ref, Loc);
538 end if;
539
540 Insert_Action (N,
541 Make_Raise_Program_Error (Loc,
542 Condition =>
543 Make_Op_Gt (Loc,
544 Left_Opnd =>
545 Build_Get_Access_Level (Loc,
546 Make_Attribute_Reference (Loc,
547 Prefix => Ref_Node,
548 Attribute_Name => Name_Tag)),
549 Right_Opnd =>
550 Make_Integer_Literal (Loc,
551 Type_Access_Level (PtrT))),
552 Reason => PE_Accessibility_Check_Failed));
553 end if;
554 end Apply_Accessibility_Check;
555
556 -- Local variables
557
558 Indic : constant Node_Id := Subtype_Mark (Expression (N));
559 T : constant Entity_Id := Entity (Indic);
560 Flist : Node_Id;
561 Node : Node_Id;
562 Temp : Entity_Id;
563
564 TagT : Entity_Id := Empty;
565 -- Type used as source for tag assignment
566
567 TagR : Node_Id := Empty;
568 -- Target reference for tag assignment
569
570 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
571
572 Tag_Assign : Node_Id;
573 Tmp_Node : Node_Id;
574
575 -- Start of processing for Expand_Allocator_Expression
576
577 begin
578 if Is_Tagged_Type (T) or else Controlled_Type (T) then
579
580 -- Ada 2005 (AI-318-02): If the initialization expression is a
581 -- call to a build-in-place function, then access to the allocated
582 -- object must be passed to the function. Currently we limit such
583 -- functions to those with constrained limited result subtypes,
584 -- but eventually we plan to expand the allowed forms of functions
585 -- that are treated as build-in-place.
586
587 if Ada_Version >= Ada_05
588 and then Is_Build_In_Place_Function_Call (Exp)
589 then
590 Make_Build_In_Place_Call_In_Allocator (N, Exp);
591 Apply_Accessibility_Check (N, Built_In_Place => True);
592 return;
593 end if;
594
595 -- Actions inserted before:
596 -- Temp : constant ptr_T := new T'(Expression);
597 -- <no CW> Temp._tag := T'tag;
598 -- <CTRL> Adjust (Finalizable (Temp.all));
599 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
600
601 -- We analyze by hand the new internal allocator to avoid
602 -- any recursion and inappropriate call to Initialize
603
604 -- We don't want to remove side effects when the expression must be
605 -- built in place. In the case of a build-in-place function call,
606 -- that could lead to a duplication of the call, which was already
607 -- substituted for the allocator.
608
609 if not Aggr_In_Place then
610 Remove_Side_Effects (Exp);
611 end if;
612
613 Temp :=
614 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
615
616 -- For a class wide allocation generate the following code:
617
618 -- type Equiv_Record is record ... end record;
619 -- implicit subtype CW is <Class_Wide_Subytpe>;
620 -- temp : PtrT := new CW'(CW!(expr));
621
622 if Is_Class_Wide_Type (T) then
623 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
624
625 -- Ada 2005 (AI-251): If the expression is a class-wide interface
626 -- object we generate code to move up "this" to reference the
627 -- base of the object before allocating the new object.
628
629 -- Note that Exp'Address is recursively expanded into a call
630 -- to Base_Address (Exp.Tag)
631
632 if Is_Class_Wide_Type (Etype (Exp))
633 and then Is_Interface (Etype (Exp))
634 and then VM_Target = No_VM
635 then
636 Set_Expression
637 (Expression (N),
638 Unchecked_Convert_To (Entity (Indic),
639 Make_Explicit_Dereference (Loc,
640 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
641 Make_Attribute_Reference (Loc,
642 Prefix => Exp,
643 Attribute_Name => Name_Address)))));
644
645 else
646 Set_Expression
647 (Expression (N),
648 Unchecked_Convert_To (Entity (Indic), Exp));
649 end if;
650
651 Analyze_And_Resolve (Expression (N), Entity (Indic));
652 end if;
653
654 -- Keep separate the management of allocators returning interfaces
655
656 if not Is_Interface (Directly_Designated_Type (PtrT)) then
657 if Aggr_In_Place then
658 Tmp_Node :=
659 Make_Object_Declaration (Loc,
660 Defining_Identifier => Temp,
661 Object_Definition => New_Reference_To (PtrT, Loc),
662 Expression =>
663 Make_Allocator (Loc,
664 New_Reference_To (Etype (Exp), Loc)));
665
666 Set_Comes_From_Source
667 (Expression (Tmp_Node), Comes_From_Source (N));
668
669 Set_No_Initialization (Expression (Tmp_Node));
670 Insert_Action (N, Tmp_Node);
671
672 if Controlled_Type (T)
673 and then Ekind (PtrT) = E_Anonymous_Access_Type
674 then
675 -- Create local finalization list for access parameter
676
677 Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
678 end if;
679
680 Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
681 else
682 Node := Relocate_Node (N);
683 Set_Analyzed (Node);
684 Insert_Action (N,
685 Make_Object_Declaration (Loc,
686 Defining_Identifier => Temp,
687 Constant_Present => True,
688 Object_Definition => New_Reference_To (PtrT, Loc),
689 Expression => Node));
690 end if;
691
692 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
693 -- interface type. In this case we use the type of the qualified
694 -- expression to allocate the object.
695
696 else
697 declare
698 Def_Id : constant Entity_Id :=
699 Make_Defining_Identifier (Loc,
700 New_Internal_Name ('T'));
701 New_Decl : Node_Id;
702
703 begin
704 New_Decl :=
705 Make_Full_Type_Declaration (Loc,
706 Defining_Identifier => Def_Id,
707 Type_Definition =>
708 Make_Access_To_Object_Definition (Loc,
709 All_Present => True,
710 Null_Exclusion_Present => False,
711 Constant_Present => False,
712 Subtype_Indication =>
713 New_Reference_To (Etype (Exp), Loc)));
714
715 Insert_Action (N, New_Decl);
716
717 -- Inherit the final chain to ensure that the expansion of the
718 -- aggregate is correct in case of controlled types
719
720 if Controlled_Type (Directly_Designated_Type (PtrT)) then
721 Set_Associated_Final_Chain (Def_Id,
722 Associated_Final_Chain (PtrT));
723 end if;
724
725 -- Declare the object using the previous type declaration
726
727 if Aggr_In_Place then
728 Tmp_Node :=
729 Make_Object_Declaration (Loc,
730 Defining_Identifier => Temp,
731 Object_Definition => New_Reference_To (Def_Id, Loc),
732 Expression =>
733 Make_Allocator (Loc,
734 New_Reference_To (Etype (Exp), Loc)));
735
736 Set_Comes_From_Source
737 (Expression (Tmp_Node), Comes_From_Source (N));
738
739 Set_No_Initialization (Expression (Tmp_Node));
740 Insert_Action (N, Tmp_Node);
741
742 if Controlled_Type (T)
743 and then Ekind (PtrT) = E_Anonymous_Access_Type
744 then
745 -- Create local finalization list for access parameter
746
747 Flist :=
748 Get_Allocator_Final_List (N, Base_Type (T), PtrT);
749 end if;
750
751 Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
752 else
753 Node := Relocate_Node (N);
754 Set_Analyzed (Node);
755 Insert_Action (N,
756 Make_Object_Declaration (Loc,
757 Defining_Identifier => Temp,
758 Constant_Present => True,
759 Object_Definition => New_Reference_To (Def_Id, Loc),
760 Expression => Node));
761 end if;
762
763 -- Generate an additional object containing the address of the
764 -- returned object. The type of this second object declaration
765 -- is the correct type required for the common processing
766 -- that is still performed by this subprogram. The displacement
767 -- of this pointer to reference the component associated with
768 -- the interface type will be done at the end of the common
769 -- processing.
770
771 New_Decl :=
772 Make_Object_Declaration (Loc,
773 Defining_Identifier => Make_Defining_Identifier (Loc,
774 New_Internal_Name ('P')),
775 Object_Definition => New_Reference_To (PtrT, Loc),
776 Expression => Unchecked_Convert_To (PtrT,
777 New_Reference_To (Temp, Loc)));
778
779 Insert_Action (N, New_Decl);
780
781 Tmp_Node := New_Decl;
782 Temp := Defining_Identifier (New_Decl);
783 end;
784 end if;
785
786 Apply_Accessibility_Check (Temp);
787
788 -- Generate the tag assignment
789
790 -- Suppress the tag assignment when VM_Target because VM tags are
791 -- represented implicitly in objects.
792
793 if VM_Target /= No_VM then
794 null;
795
796 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
797 -- interface objects because in this case the tag does not change.
798
799 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
800 pragma Assert (Is_Class_Wide_Type
801 (Directly_Designated_Type (Etype (N))));
802 null;
803
804 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
805 TagT := T;
806 TagR := New_Reference_To (Temp, Loc);
807
808 elsif Is_Private_Type (T)
809 and then Is_Tagged_Type (Underlying_Type (T))
810 then
811 TagT := Underlying_Type (T);
812 TagR :=
813 Unchecked_Convert_To (Underlying_Type (T),
814 Make_Explicit_Dereference (Loc,
815 Prefix => New_Reference_To (Temp, Loc)));
816 end if;
817
818 if Present (TagT) then
819 Tag_Assign :=
820 Make_Assignment_Statement (Loc,
821 Name =>
822 Make_Selected_Component (Loc,
823 Prefix => TagR,
824 Selector_Name =>
825 New_Reference_To (First_Tag_Component (TagT), Loc)),
826
827 Expression =>
828 Unchecked_Convert_To (RTE (RE_Tag),
829 New_Reference_To
830 (Elists.Node (First_Elmt (Access_Disp_Table (TagT))),
831 Loc)));
832
833 -- The previous assignment has to be done in any case
834
835 Set_Assignment_OK (Name (Tag_Assign));
836 Insert_Action (N, Tag_Assign);
837 end if;
838
839 if Controlled_Type (DesigT)
840 and then Controlled_Type (T)
841 then
842 declare
843 Attach : Node_Id;
844 Apool : constant Entity_Id :=
845 Associated_Storage_Pool (PtrT);
846
847 begin
848 -- If it is an allocation on the secondary stack
849 -- (i.e. a value returned from a function), the object
850 -- is attached on the caller side as soon as the call
851 -- is completed (see Expand_Ctrl_Function_Call)
852
853 if Is_RTE (Apool, RE_SS_Pool) then
854 declare
855 F : constant Entity_Id :=
856 Make_Defining_Identifier (Loc,
857 New_Internal_Name ('F'));
858 begin
859 Insert_Action (N,
860 Make_Object_Declaration (Loc,
861 Defining_Identifier => F,
862 Object_Definition => New_Reference_To (RTE
863 (RE_Finalizable_Ptr), Loc)));
864
865 Flist := New_Reference_To (F, Loc);
866 Attach := Make_Integer_Literal (Loc, 1);
867 end;
868
869 -- Normal case, not a secondary stack allocation
870
871 else
872 if Controlled_Type (T)
873 and then Ekind (PtrT) = E_Anonymous_Access_Type
874 then
875 -- Create local finalization list for access parameter
876
877 Flist :=
878 Get_Allocator_Final_List (N, Base_Type (T), PtrT);
879 else
880 Flist := Find_Final_List (PtrT);
881 end if;
882
883 Attach := Make_Integer_Literal (Loc, 2);
884 end if;
885
886 -- Generate an Adjust call if the object will be moved. In Ada
887 -- 2005, the object may be inherently limited, in which case
888 -- there is no Adjust procedure, and the object is built in
889 -- place. In Ada 95, the object can be limited but not
890 -- inherently limited if this allocator came from a return
891 -- statement (we're allocating the result on the secondary
892 -- stack). In that case, the object will be moved, so we _do_
893 -- want to Adjust.
894
895 if not Aggr_In_Place
896 and then not Is_Inherently_Limited_Type (T)
897 then
898 Insert_Actions (N,
899 Make_Adjust_Call (
900 Ref =>
901
902 -- An unchecked conversion is needed in the
903 -- classwide case because the designated type
904 -- can be an ancestor of the subtype mark of
905 -- the allocator.
906
907 Unchecked_Convert_To (T,
908 Make_Explicit_Dereference (Loc,
909 Prefix => New_Reference_To (Temp, Loc))),
910
911 Typ => T,
912 Flist_Ref => Flist,
913 With_Attach => Attach,
914 Allocator => True));
915 end if;
916 end;
917 end if;
918
919 Rewrite (N, New_Reference_To (Temp, Loc));
920 Analyze_And_Resolve (N, PtrT);
921
922 -- Ada 2005 (AI-251): Displace the pointer to reference the
923 -- record component containing the secondary dispatch table
924 -- of the interface type.
925
926 if Is_Interface (Directly_Designated_Type (PtrT)) then
927 Displace_Allocator_Pointer (N);
928 end if;
929
930 elsif Aggr_In_Place then
931 Temp :=
932 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
933 Tmp_Node :=
934 Make_Object_Declaration (Loc,
935 Defining_Identifier => Temp,
936 Object_Definition => New_Reference_To (PtrT, Loc),
937 Expression => Make_Allocator (Loc,
938 New_Reference_To (Etype (Exp), Loc)));
939
940 Set_Comes_From_Source
941 (Expression (Tmp_Node), Comes_From_Source (N));
942
943 Set_No_Initialization (Expression (Tmp_Node));
944 Insert_Action (N, Tmp_Node);
945 Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
946 Rewrite (N, New_Reference_To (Temp, Loc));
947 Analyze_And_Resolve (N, PtrT);
948
949 elsif Is_Access_Type (DesigT)
950 and then Nkind (Exp) = N_Allocator
951 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
952 then
953 -- Apply constraint to designated subtype indication
954
955 Apply_Constraint_Check (Expression (Exp),
956 Designated_Type (DesigT),
957 No_Sliding => True);
958
959 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
960
961 -- Propagate constraint_error to enclosing allocator
962
963 Rewrite (Exp, New_Copy (Expression (Exp)));
964 end if;
965 else
966 -- First check against the type of the qualified expression
967 --
968 -- NOTE: The commented call should be correct, but for
969 -- some reason causes the compiler to bomb (sigsegv) on
970 -- ACVC test c34007g, so for now we just perform the old
971 -- (incorrect) test against the designated subtype with
972 -- no sliding in the else part of the if statement below.
973 -- ???
974 --
975 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
976
977 -- A check is also needed in cases where the designated
978 -- subtype is constrained and differs from the subtype
979 -- given in the qualified expression. Note that the check
980 -- on the qualified expression does not allow sliding,
981 -- but this check does (a relaxation from Ada 83).
982
983 if Is_Constrained (DesigT)
984 and then not Subtypes_Statically_Match
985 (T, DesigT)
986 then
987 Apply_Constraint_Check
988 (Exp, DesigT, No_Sliding => False);
989
990 -- The nonsliding check should really be performed
991 -- (unconditionally) against the subtype of the
992 -- qualified expression, but that causes a problem
993 -- with c34007g (see above), so for now we retain this.
994
995 else
996 Apply_Constraint_Check
997 (Exp, DesigT, No_Sliding => True);
998 end if;
999
1000 -- For an access to unconstrained packed array, GIGI needs
1001 -- to see an expression with a constrained subtype in order
1002 -- to compute the proper size for the allocator.
1003
1004 if Is_Array_Type (T)
1005 and then not Is_Constrained (T)
1006 and then Is_Packed (T)
1007 then
1008 declare
1009 ConstrT : constant Entity_Id :=
1010 Make_Defining_Identifier (Loc,
1011 Chars => New_Internal_Name ('A'));
1012 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1013 begin
1014 Insert_Action (Exp,
1015 Make_Subtype_Declaration (Loc,
1016 Defining_Identifier => ConstrT,
1017 Subtype_Indication =>
1018 Make_Subtype_From_Expr (Exp, T)));
1019 Freeze_Itype (ConstrT, Exp);
1020 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1021 end;
1022 end if;
1023
1024 -- Ada 2005 (AI-318-02): If the initialization expression is a
1025 -- call to a build-in-place function, then access to the allocated
1026 -- object must be passed to the function. Currently we limit such
1027 -- functions to those with constrained limited result subtypes,
1028 -- but eventually we plan to expand the allowed forms of functions
1029 -- that are treated as build-in-place.
1030
1031 if Ada_Version >= Ada_05
1032 and then Is_Build_In_Place_Function_Call (Exp)
1033 then
1034 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1035 end if;
1036 end if;
1037
1038 exception
1039 when RE_Not_Available =>
1040 return;
1041 end Expand_Allocator_Expression;
1042
1043 -----------------------------
1044 -- Expand_Array_Comparison --
1045 -----------------------------
1046
1047 -- Expansion is only required in the case of array types. For the
1048 -- unpacked case, an appropriate runtime routine is called. For
1049 -- packed cases, and also in some other cases where a runtime
1050 -- routine cannot be called, the form of the expansion is:
1051
1052 -- [body for greater_nn; boolean_expression]
1053
1054 -- The body is built by Make_Array_Comparison_Op, and the form of the
1055 -- Boolean expression depends on the operator involved.
1056
1057 procedure Expand_Array_Comparison (N : Node_Id) is
1058 Loc : constant Source_Ptr := Sloc (N);
1059 Op1 : Node_Id := Left_Opnd (N);
1060 Op2 : Node_Id := Right_Opnd (N);
1061 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1062 Ctyp : constant Entity_Id := Component_Type (Typ1);
1063
1064 Expr : Node_Id;
1065 Func_Body : Node_Id;
1066 Func_Name : Entity_Id;
1067
1068 Comp : RE_Id;
1069
1070 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1071 -- True for byte addressable target
1072
1073 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1074 -- Returns True if the length of the given operand is known to be
1075 -- less than 4. Returns False if this length is known to be four
1076 -- or greater or is not known at compile time.
1077
1078 ------------------------
1079 -- Length_Less_Than_4 --
1080 ------------------------
1081
1082 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1083 Otyp : constant Entity_Id := Etype (Opnd);
1084
1085 begin
1086 if Ekind (Otyp) = E_String_Literal_Subtype then
1087 return String_Literal_Length (Otyp) < 4;
1088
1089 else
1090 declare
1091 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1092 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1093 Hi : constant Node_Id := Type_High_Bound (Ityp);
1094 Lov : Uint;
1095 Hiv : Uint;
1096
1097 begin
1098 if Compile_Time_Known_Value (Lo) then
1099 Lov := Expr_Value (Lo);
1100 else
1101 return False;
1102 end if;
1103
1104 if Compile_Time_Known_Value (Hi) then
1105 Hiv := Expr_Value (Hi);
1106 else
1107 return False;
1108 end if;
1109
1110 return Hiv < Lov + 3;
1111 end;
1112 end if;
1113 end Length_Less_Than_4;
1114
1115 -- Start of processing for Expand_Array_Comparison
1116
1117 begin
1118 -- Deal first with unpacked case, where we can call a runtime routine
1119 -- except that we avoid this for targets for which are not addressable
1120 -- by bytes, and for the JVM/CIL, since they do not support direct
1121 -- addressing of array components.
1122
1123 if not Is_Bit_Packed_Array (Typ1)
1124 and then Byte_Addressable
1125 and then VM_Target = No_VM
1126 then
1127 -- The call we generate is:
1128
1129 -- Compare_Array_xn[_Unaligned]
1130 -- (left'address, right'address, left'length, right'length) <op> 0
1131
1132 -- x = U for unsigned, S for signed
1133 -- n = 8,16,32,64 for component size
1134 -- Add _Unaligned if length < 4 and component size is 8.
1135 -- <op> is the standard comparison operator
1136
1137 if Component_Size (Typ1) = 8 then
1138 if Length_Less_Than_4 (Op1)
1139 or else
1140 Length_Less_Than_4 (Op2)
1141 then
1142 if Is_Unsigned_Type (Ctyp) then
1143 Comp := RE_Compare_Array_U8_Unaligned;
1144 else
1145 Comp := RE_Compare_Array_S8_Unaligned;
1146 end if;
1147
1148 else
1149 if Is_Unsigned_Type (Ctyp) then
1150 Comp := RE_Compare_Array_U8;
1151 else
1152 Comp := RE_Compare_Array_S8;
1153 end if;
1154 end if;
1155
1156 elsif Component_Size (Typ1) = 16 then
1157 if Is_Unsigned_Type (Ctyp) then
1158 Comp := RE_Compare_Array_U16;
1159 else
1160 Comp := RE_Compare_Array_S16;
1161 end if;
1162
1163 elsif Component_Size (Typ1) = 32 then
1164 if Is_Unsigned_Type (Ctyp) then
1165 Comp := RE_Compare_Array_U32;
1166 else
1167 Comp := RE_Compare_Array_S32;
1168 end if;
1169
1170 else pragma Assert (Component_Size (Typ1) = 64);
1171 if Is_Unsigned_Type (Ctyp) then
1172 Comp := RE_Compare_Array_U64;
1173 else
1174 Comp := RE_Compare_Array_S64;
1175 end if;
1176 end if;
1177
1178 Remove_Side_Effects (Op1, Name_Req => True);
1179 Remove_Side_Effects (Op2, Name_Req => True);
1180
1181 Rewrite (Op1,
1182 Make_Function_Call (Sloc (Op1),
1183 Name => New_Occurrence_Of (RTE (Comp), Loc),
1184
1185 Parameter_Associations => New_List (
1186 Make_Attribute_Reference (Loc,
1187 Prefix => Relocate_Node (Op1),
1188 Attribute_Name => Name_Address),
1189
1190 Make_Attribute_Reference (Loc,
1191 Prefix => Relocate_Node (Op2),
1192 Attribute_Name => Name_Address),
1193
1194 Make_Attribute_Reference (Loc,
1195 Prefix => Relocate_Node (Op1),
1196 Attribute_Name => Name_Length),
1197
1198 Make_Attribute_Reference (Loc,
1199 Prefix => Relocate_Node (Op2),
1200 Attribute_Name => Name_Length))));
1201
1202 Rewrite (Op2,
1203 Make_Integer_Literal (Sloc (Op2),
1204 Intval => Uint_0));
1205
1206 Analyze_And_Resolve (Op1, Standard_Integer);
1207 Analyze_And_Resolve (Op2, Standard_Integer);
1208 return;
1209 end if;
1210
1211 -- Cases where we cannot make runtime call
1212
1213 -- For (a <= b) we convert to not (a > b)
1214
1215 if Chars (N) = Name_Op_Le then
1216 Rewrite (N,
1217 Make_Op_Not (Loc,
1218 Right_Opnd =>
1219 Make_Op_Gt (Loc,
1220 Left_Opnd => Op1,
1221 Right_Opnd => Op2)));
1222 Analyze_And_Resolve (N, Standard_Boolean);
1223 return;
1224
1225 -- For < the Boolean expression is
1226 -- greater__nn (op2, op1)
1227
1228 elsif Chars (N) = Name_Op_Lt then
1229 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1230
1231 -- Switch operands
1232
1233 Op1 := Right_Opnd (N);
1234 Op2 := Left_Opnd (N);
1235
1236 -- For (a >= b) we convert to not (a < b)
1237
1238 elsif Chars (N) = Name_Op_Ge then
1239 Rewrite (N,
1240 Make_Op_Not (Loc,
1241 Right_Opnd =>
1242 Make_Op_Lt (Loc,
1243 Left_Opnd => Op1,
1244 Right_Opnd => Op2)));
1245 Analyze_And_Resolve (N, Standard_Boolean);
1246 return;
1247
1248 -- For > the Boolean expression is
1249 -- greater__nn (op1, op2)
1250
1251 else
1252 pragma Assert (Chars (N) = Name_Op_Gt);
1253 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1254 end if;
1255
1256 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1257 Expr :=
1258 Make_Function_Call (Loc,
1259 Name => New_Reference_To (Func_Name, Loc),
1260 Parameter_Associations => New_List (Op1, Op2));
1261
1262 Insert_Action (N, Func_Body);
1263 Rewrite (N, Expr);
1264 Analyze_And_Resolve (N, Standard_Boolean);
1265
1266 exception
1267 when RE_Not_Available =>
1268 return;
1269 end Expand_Array_Comparison;
1270
1271 ---------------------------
1272 -- Expand_Array_Equality --
1273 ---------------------------
1274
1275 -- Expand an equality function for multi-dimensional arrays. Here is
1276 -- an example of such a function for Nb_Dimension = 2
1277
1278 -- function Enn (A : atyp; B : btyp) return boolean is
1279 -- begin
1280 -- if (A'length (1) = 0 or else A'length (2) = 0)
1281 -- and then
1282 -- (B'length (1) = 0 or else B'length (2) = 0)
1283 -- then
1284 -- return True; -- RM 4.5.2(22)
1285 -- end if;
1286
1287 -- if A'length (1) /= B'length (1)
1288 -- or else
1289 -- A'length (2) /= B'length (2)
1290 -- then
1291 -- return False; -- RM 4.5.2(23)
1292 -- end if;
1293
1294 -- declare
1295 -- A1 : Index_T1 := A'first (1);
1296 -- B1 : Index_T1 := B'first (1);
1297 -- begin
1298 -- loop
1299 -- declare
1300 -- A2 : Index_T2 := A'first (2);
1301 -- B2 : Index_T2 := B'first (2);
1302 -- begin
1303 -- loop
1304 -- if A (A1, A2) /= B (B1, B2) then
1305 -- return False;
1306 -- end if;
1307
1308 -- exit when A2 = A'last (2);
1309 -- A2 := Index_T2'succ (A2);
1310 -- B2 := Index_T2'succ (B2);
1311 -- end loop;
1312 -- end;
1313
1314 -- exit when A1 = A'last (1);
1315 -- A1 := Index_T1'succ (A1);
1316 -- B1 := Index_T1'succ (B1);
1317 -- end loop;
1318 -- end;
1319
1320 -- return true;
1321 -- end Enn;
1322
1323 -- Note on the formal types used (atyp and btyp). If either of the
1324 -- arrays is of a private type, we use the underlying type, and
1325 -- do an unchecked conversion of the actual. If either of the arrays
1326 -- has a bound depending on a discriminant, then we use the base type
1327 -- since otherwise we have an escaped discriminant in the function.
1328
1329 -- If both arrays are constrained and have the same bounds, we can
1330 -- generate a loop with an explicit iteration scheme using a 'Range
1331 -- attribute over the first array.
1332
1333 function Expand_Array_Equality
1334 (Nod : Node_Id;
1335 Lhs : Node_Id;
1336 Rhs : Node_Id;
1337 Bodies : List_Id;
1338 Typ : Entity_Id) return Node_Id
1339 is
1340 Loc : constant Source_Ptr := Sloc (Nod);
1341 Decls : constant List_Id := New_List;
1342 Index_List1 : constant List_Id := New_List;
1343 Index_List2 : constant List_Id := New_List;
1344
1345 Actuals : List_Id;
1346 Formals : List_Id;
1347 Func_Name : Entity_Id;
1348 Func_Body : Node_Id;
1349
1350 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1351 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1352
1353 Ltyp : Entity_Id;
1354 Rtyp : Entity_Id;
1355 -- The parameter types to be used for the formals
1356
1357 function Arr_Attr
1358 (Arr : Entity_Id;
1359 Nam : Name_Id;
1360 Num : Int) return Node_Id;
1361 -- This builds the attribute reference Arr'Nam (Expr)
1362
1363 function Component_Equality (Typ : Entity_Id) return Node_Id;
1364 -- Create one statement to compare corresponding components,
1365 -- designated by a full set of indices.
1366
1367 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1368 -- Given one of the arguments, computes the appropriate type to
1369 -- be used for that argument in the corresponding function formal
1370
1371 function Handle_One_Dimension
1372 (N : Int;
1373 Index : Node_Id) return Node_Id;
1374 -- This procedure returns the following code
1375 --
1376 -- declare
1377 -- Bn : Index_T := B'First (N);
1378 -- begin
1379 -- loop
1380 -- xxx
1381 -- exit when An = A'Last (N);
1382 -- An := Index_T'Succ (An)
1383 -- Bn := Index_T'Succ (Bn)
1384 -- end loop;
1385 -- end;
1386 --
1387 -- If both indices are constrained and identical, the procedure
1388 -- returns a simpler loop:
1389 --
1390 -- for An in A'Range (N) loop
1391 -- xxx
1392 -- end loop
1393 --
1394 -- N is the dimension for which we are generating a loop. Index is the
1395 -- N'th index node, whose Etype is Index_Type_n in the above code.
1396 -- The xxx statement is either the loop or declare for the next
1397 -- dimension or if this is the last dimension the comparison
1398 -- of corresponding components of the arrays.
1399 --
1400 -- The actual way the code works is to return the comparison
1401 -- of corresponding components for the N+1 call. That's neater!
1402
1403 function Test_Empty_Arrays return Node_Id;
1404 -- This function constructs the test for both arrays being empty
1405 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1406 -- and then
1407 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1408
1409 function Test_Lengths_Correspond return Node_Id;
1410 -- This function constructs the test for arrays having different
1411 -- lengths in at least one index position, in which case resull
1412
1413 -- A'length (1) /= B'length (1)
1414 -- or else
1415 -- A'length (2) /= B'length (2)
1416 -- or else
1417 -- ...
1418
1419 --------------
1420 -- Arr_Attr --
1421 --------------
1422
1423 function Arr_Attr
1424 (Arr : Entity_Id;
1425 Nam : Name_Id;
1426 Num : Int) return Node_Id
1427 is
1428 begin
1429 return
1430 Make_Attribute_Reference (Loc,
1431 Attribute_Name => Nam,
1432 Prefix => New_Reference_To (Arr, Loc),
1433 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1434 end Arr_Attr;
1435
1436 ------------------------
1437 -- Component_Equality --
1438 ------------------------
1439
1440 function Component_Equality (Typ : Entity_Id) return Node_Id is
1441 Test : Node_Id;
1442 L, R : Node_Id;
1443
1444 begin
1445 -- if a(i1...) /= b(j1...) then return false; end if;
1446
1447 L :=
1448 Make_Indexed_Component (Loc,
1449 Prefix => Make_Identifier (Loc, Chars (A)),
1450 Expressions => Index_List1);
1451
1452 R :=
1453 Make_Indexed_Component (Loc,
1454 Prefix => Make_Identifier (Loc, Chars (B)),
1455 Expressions => Index_List2);
1456
1457 Test := Expand_Composite_Equality
1458 (Nod, Component_Type (Typ), L, R, Decls);
1459
1460 -- If some (sub)component is an unchecked_union, the whole operation
1461 -- will raise program error.
1462
1463 if Nkind (Test) = N_Raise_Program_Error then
1464
1465 -- This node is going to be inserted at a location where a
1466 -- statement is expected: clear its Etype so analysis will
1467 -- set it to the expected Standard_Void_Type.
1468
1469 Set_Etype (Test, Empty);
1470 return Test;
1471
1472 else
1473 return
1474 Make_Implicit_If_Statement (Nod,
1475 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1476 Then_Statements => New_List (
1477 Make_Simple_Return_Statement (Loc,
1478 Expression => New_Occurrence_Of (Standard_False, Loc))));
1479 end if;
1480 end Component_Equality;
1481
1482 ------------------
1483 -- Get_Arg_Type --
1484 ------------------
1485
1486 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1487 T : Entity_Id;
1488 X : Node_Id;
1489
1490 begin
1491 T := Etype (N);
1492
1493 if No (T) then
1494 return Typ;
1495
1496 else
1497 T := Underlying_Type (T);
1498
1499 X := First_Index (T);
1500 while Present (X) loop
1501 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1502 or else
1503 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1504 then
1505 T := Base_Type (T);
1506 exit;
1507 end if;
1508
1509 Next_Index (X);
1510 end loop;
1511
1512 return T;
1513 end if;
1514 end Get_Arg_Type;
1515
1516 --------------------------
1517 -- Handle_One_Dimension --
1518 ---------------------------
1519
1520 function Handle_One_Dimension
1521 (N : Int;
1522 Index : Node_Id) return Node_Id
1523 is
1524 Need_Separate_Indexes : constant Boolean :=
1525 Ltyp /= Rtyp
1526 or else not Is_Constrained (Ltyp);
1527 -- If the index types are identical, and we are working with
1528 -- constrained types, then we can use the same index for both of
1529 -- the arrays.
1530
1531 An : constant Entity_Id := Make_Defining_Identifier (Loc,
1532 Chars => New_Internal_Name ('A'));
1533
1534 Bn : Entity_Id;
1535 Index_T : Entity_Id;
1536 Stm_List : List_Id;
1537 Loop_Stm : Node_Id;
1538
1539 begin
1540 if N > Number_Dimensions (Ltyp) then
1541 return Component_Equality (Ltyp);
1542 end if;
1543
1544 -- Case where we generate a loop
1545
1546 Index_T := Base_Type (Etype (Index));
1547
1548 if Need_Separate_Indexes then
1549 Bn :=
1550 Make_Defining_Identifier (Loc,
1551 Chars => New_Internal_Name ('B'));
1552 else
1553 Bn := An;
1554 end if;
1555
1556 Append (New_Reference_To (An, Loc), Index_List1);
1557 Append (New_Reference_To (Bn, Loc), Index_List2);
1558
1559 Stm_List := New_List (
1560 Handle_One_Dimension (N + 1, Next_Index (Index)));
1561
1562 if Need_Separate_Indexes then
1563
1564 -- Generate guard for loop, followed by increments of indices
1565
1566 Append_To (Stm_List,
1567 Make_Exit_Statement (Loc,
1568 Condition =>
1569 Make_Op_Eq (Loc,
1570 Left_Opnd => New_Reference_To (An, Loc),
1571 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1572
1573 Append_To (Stm_List,
1574 Make_Assignment_Statement (Loc,
1575 Name => New_Reference_To (An, Loc),
1576 Expression =>
1577 Make_Attribute_Reference (Loc,
1578 Prefix => New_Reference_To (Index_T, Loc),
1579 Attribute_Name => Name_Succ,
1580 Expressions => New_List (New_Reference_To (An, Loc)))));
1581
1582 Append_To (Stm_List,
1583 Make_Assignment_Statement (Loc,
1584 Name => New_Reference_To (Bn, Loc),
1585 Expression =>
1586 Make_Attribute_Reference (Loc,
1587 Prefix => New_Reference_To (Index_T, Loc),
1588 Attribute_Name => Name_Succ,
1589 Expressions => New_List (New_Reference_To (Bn, Loc)))));
1590 end if;
1591
1592 -- If separate indexes, we need a declare block for An and Bn, and a
1593 -- loop without an iteration scheme.
1594
1595 if Need_Separate_Indexes then
1596 Loop_Stm :=
1597 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1598
1599 return
1600 Make_Block_Statement (Loc,
1601 Declarations => New_List (
1602 Make_Object_Declaration (Loc,
1603 Defining_Identifier => An,
1604 Object_Definition => New_Reference_To (Index_T, Loc),
1605 Expression => Arr_Attr (A, Name_First, N)),
1606
1607 Make_Object_Declaration (Loc,
1608 Defining_Identifier => Bn,
1609 Object_Definition => New_Reference_To (Index_T, Loc),
1610 Expression => Arr_Attr (B, Name_First, N))),
1611
1612 Handled_Statement_Sequence =>
1613 Make_Handled_Sequence_Of_Statements (Loc,
1614 Statements => New_List (Loop_Stm)));
1615
1616 -- If no separate indexes, return loop statement with explicit
1617 -- iteration scheme on its own
1618
1619 else
1620 Loop_Stm :=
1621 Make_Implicit_Loop_Statement (Nod,
1622 Statements => Stm_List,
1623 Iteration_Scheme =>
1624 Make_Iteration_Scheme (Loc,
1625 Loop_Parameter_Specification =>
1626 Make_Loop_Parameter_Specification (Loc,
1627 Defining_Identifier => An,
1628 Discrete_Subtype_Definition =>
1629 Arr_Attr (A, Name_Range, N))));
1630 return Loop_Stm;
1631 end if;
1632 end Handle_One_Dimension;
1633
1634 -----------------------
1635 -- Test_Empty_Arrays --
1636 -----------------------
1637
1638 function Test_Empty_Arrays return Node_Id is
1639 Alist : Node_Id;
1640 Blist : Node_Id;
1641
1642 Atest : Node_Id;
1643 Btest : Node_Id;
1644
1645 begin
1646 Alist := Empty;
1647 Blist := Empty;
1648 for J in 1 .. Number_Dimensions (Ltyp) loop
1649 Atest :=
1650 Make_Op_Eq (Loc,
1651 Left_Opnd => Arr_Attr (A, Name_Length, J),
1652 Right_Opnd => Make_Integer_Literal (Loc, 0));
1653
1654 Btest :=
1655 Make_Op_Eq (Loc,
1656 Left_Opnd => Arr_Attr (B, Name_Length, J),
1657 Right_Opnd => Make_Integer_Literal (Loc, 0));
1658
1659 if No (Alist) then
1660 Alist := Atest;
1661 Blist := Btest;
1662
1663 else
1664 Alist :=
1665 Make_Or_Else (Loc,
1666 Left_Opnd => Relocate_Node (Alist),
1667 Right_Opnd => Atest);
1668
1669 Blist :=
1670 Make_Or_Else (Loc,
1671 Left_Opnd => Relocate_Node (Blist),
1672 Right_Opnd => Btest);
1673 end if;
1674 end loop;
1675
1676 return
1677 Make_And_Then (Loc,
1678 Left_Opnd => Alist,
1679 Right_Opnd => Blist);
1680 end Test_Empty_Arrays;
1681
1682 -----------------------------
1683 -- Test_Lengths_Correspond --
1684 -----------------------------
1685
1686 function Test_Lengths_Correspond return Node_Id is
1687 Result : Node_Id;
1688 Rtest : Node_Id;
1689
1690 begin
1691 Result := Empty;
1692 for J in 1 .. Number_Dimensions (Ltyp) loop
1693 Rtest :=
1694 Make_Op_Ne (Loc,
1695 Left_Opnd => Arr_Attr (A, Name_Length, J),
1696 Right_Opnd => Arr_Attr (B, Name_Length, J));
1697
1698 if No (Result) then
1699 Result := Rtest;
1700 else
1701 Result :=
1702 Make_Or_Else (Loc,
1703 Left_Opnd => Relocate_Node (Result),
1704 Right_Opnd => Rtest);
1705 end if;
1706 end loop;
1707
1708 return Result;
1709 end Test_Lengths_Correspond;
1710
1711 -- Start of processing for Expand_Array_Equality
1712
1713 begin
1714 Ltyp := Get_Arg_Type (Lhs);
1715 Rtyp := Get_Arg_Type (Rhs);
1716
1717 -- For now, if the argument types are not the same, go to the
1718 -- base type, since the code assumes that the formals have the
1719 -- same type. This is fixable in future ???
1720
1721 if Ltyp /= Rtyp then
1722 Ltyp := Base_Type (Ltyp);
1723 Rtyp := Base_Type (Rtyp);
1724 pragma Assert (Ltyp = Rtyp);
1725 end if;
1726
1727 -- Build list of formals for function
1728
1729 Formals := New_List (
1730 Make_Parameter_Specification (Loc,
1731 Defining_Identifier => A,
1732 Parameter_Type => New_Reference_To (Ltyp, Loc)),
1733
1734 Make_Parameter_Specification (Loc,
1735 Defining_Identifier => B,
1736 Parameter_Type => New_Reference_To (Rtyp, Loc)));
1737
1738 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1739
1740 -- Build statement sequence for function
1741
1742 Func_Body :=
1743 Make_Subprogram_Body (Loc,
1744 Specification =>
1745 Make_Function_Specification (Loc,
1746 Defining_Unit_Name => Func_Name,
1747 Parameter_Specifications => Formals,
1748 Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
1749
1750 Declarations => Decls,
1751
1752 Handled_Statement_Sequence =>
1753 Make_Handled_Sequence_Of_Statements (Loc,
1754 Statements => New_List (
1755
1756 Make_Implicit_If_Statement (Nod,
1757 Condition => Test_Empty_Arrays,
1758 Then_Statements => New_List (
1759 Make_Simple_Return_Statement (Loc,
1760 Expression =>
1761 New_Occurrence_Of (Standard_True, Loc)))),
1762
1763 Make_Implicit_If_Statement (Nod,
1764 Condition => Test_Lengths_Correspond,
1765 Then_Statements => New_List (
1766 Make_Simple_Return_Statement (Loc,
1767 Expression =>
1768 New_Occurrence_Of (Standard_False, Loc)))),
1769
1770 Handle_One_Dimension (1, First_Index (Ltyp)),
1771
1772 Make_Simple_Return_Statement (Loc,
1773 Expression => New_Occurrence_Of (Standard_True, Loc)))));
1774
1775 Set_Has_Completion (Func_Name, True);
1776 Set_Is_Inlined (Func_Name);
1777
1778 -- If the array type is distinct from the type of the arguments,
1779 -- it is the full view of a private type. Apply an unchecked
1780 -- conversion to insure that analysis of the call succeeds.
1781
1782 declare
1783 L, R : Node_Id;
1784
1785 begin
1786 L := Lhs;
1787 R := Rhs;
1788
1789 if No (Etype (Lhs))
1790 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1791 then
1792 L := OK_Convert_To (Ltyp, Lhs);
1793 end if;
1794
1795 if No (Etype (Rhs))
1796 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1797 then
1798 R := OK_Convert_To (Rtyp, Rhs);
1799 end if;
1800
1801 Actuals := New_List (L, R);
1802 end;
1803
1804 Append_To (Bodies, Func_Body);
1805
1806 return
1807 Make_Function_Call (Loc,
1808 Name => New_Reference_To (Func_Name, Loc),
1809 Parameter_Associations => Actuals);
1810 end Expand_Array_Equality;
1811
1812 -----------------------------
1813 -- Expand_Boolean_Operator --
1814 -----------------------------
1815
1816 -- Note that we first get the actual subtypes of the operands,
1817 -- since we always want to deal with types that have bounds.
1818
1819 procedure Expand_Boolean_Operator (N : Node_Id) is
1820 Typ : constant Entity_Id := Etype (N);
1821
1822 begin
1823 -- Special case of bit packed array where both operands are known
1824 -- to be properly aligned. In this case we use an efficient run time
1825 -- routine to carry out the operation (see System.Bit_Ops).
1826
1827 if Is_Bit_Packed_Array (Typ)
1828 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
1829 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
1830 then
1831 Expand_Packed_Boolean_Operator (N);
1832 return;
1833 end if;
1834
1835 -- For the normal non-packed case, the general expansion is to build
1836 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1837 -- and then inserting it into the tree. The original operator node is
1838 -- then rewritten as a call to this function. We also use this in the
1839 -- packed case if either operand is a possibly unaligned object.
1840
1841 declare
1842 Loc : constant Source_Ptr := Sloc (N);
1843 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
1844 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
1845 Func_Body : Node_Id;
1846 Func_Name : Entity_Id;
1847
1848 begin
1849 Convert_To_Actual_Subtype (L);
1850 Convert_To_Actual_Subtype (R);
1851 Ensure_Defined (Etype (L), N);
1852 Ensure_Defined (Etype (R), N);
1853 Apply_Length_Check (R, Etype (L));
1854
1855 if Nkind (N) = N_Op_Xor then
1856 Silly_Boolean_Array_Xor_Test (N, Etype (L));
1857 end if;
1858
1859 if Nkind (Parent (N)) = N_Assignment_Statement
1860 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
1861 then
1862 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
1863
1864 elsif Nkind (Parent (N)) = N_Op_Not
1865 and then Nkind (N) = N_Op_And
1866 and then
1867 Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
1868 then
1869 return;
1870 else
1871
1872 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
1873 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1874 Insert_Action (N, Func_Body);
1875
1876 -- Now rewrite the expression with a call
1877
1878 Rewrite (N,
1879 Make_Function_Call (Loc,
1880 Name => New_Reference_To (Func_Name, Loc),
1881 Parameter_Associations =>
1882 New_List (
1883 L,
1884 Make_Type_Conversion
1885 (Loc, New_Reference_To (Etype (L), Loc), R))));
1886
1887 Analyze_And_Resolve (N, Typ);
1888 end if;
1889 end;
1890 end Expand_Boolean_Operator;
1891
1892 -------------------------------
1893 -- Expand_Composite_Equality --
1894 -------------------------------
1895
1896 -- This function is only called for comparing internal fields of composite
1897 -- types when these fields are themselves composites. This is a special
1898 -- case because it is not possible to respect normal Ada visibility rules.
1899
1900 function Expand_Composite_Equality
1901 (Nod : Node_Id;
1902 Typ : Entity_Id;
1903 Lhs : Node_Id;
1904 Rhs : Node_Id;
1905 Bodies : List_Id) return Node_Id
1906 is
1907 Loc : constant Source_Ptr := Sloc (Nod);
1908 Full_Type : Entity_Id;
1909 Prim : Elmt_Id;
1910 Eq_Op : Entity_Id;
1911
1912 begin
1913 if Is_Private_Type (Typ) then
1914 Full_Type := Underlying_Type (Typ);
1915 else
1916 Full_Type := Typ;
1917 end if;
1918
1919 -- Defense against malformed private types with no completion
1920 -- the error will be diagnosed later by check_completion
1921
1922 if No (Full_Type) then
1923 return New_Reference_To (Standard_False, Loc);
1924 end if;
1925
1926 Full_Type := Base_Type (Full_Type);
1927
1928 if Is_Array_Type (Full_Type) then
1929
1930 -- If the operand is an elementary type other than a floating-point
1931 -- type, then we can simply use the built-in block bitwise equality,
1932 -- since the predefined equality operators always apply and bitwise
1933 -- equality is fine for all these cases.
1934
1935 if Is_Elementary_Type (Component_Type (Full_Type))
1936 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
1937 then
1938 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
1939
1940 -- For composite component types, and floating-point types, use
1941 -- the expansion. This deals with tagged component types (where
1942 -- we use the applicable equality routine) and floating-point,
1943 -- (where we need to worry about negative zeroes), and also the
1944 -- case of any composite type recursively containing such fields.
1945
1946 else
1947 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
1948 end if;
1949
1950 elsif Is_Tagged_Type (Full_Type) then
1951
1952 -- Call the primitive operation "=" of this type
1953
1954 if Is_Class_Wide_Type (Full_Type) then
1955 Full_Type := Root_Type (Full_Type);
1956 end if;
1957
1958 -- If this is derived from an untagged private type completed
1959 -- with a tagged type, it does not have a full view, so we
1960 -- use the primitive operations of the private type.
1961 -- This check should no longer be necessary when these
1962 -- types receive their full views ???
1963
1964 if Is_Private_Type (Typ)
1965 and then not Is_Tagged_Type (Typ)
1966 and then not Is_Controlled (Typ)
1967 and then Is_Derived_Type (Typ)
1968 and then No (Full_View (Typ))
1969 then
1970 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
1971 else
1972 Prim := First_Elmt (Primitive_Operations (Full_Type));
1973 end if;
1974
1975 loop
1976 Eq_Op := Node (Prim);
1977 exit when Chars (Eq_Op) = Name_Op_Eq
1978 and then Etype (First_Formal (Eq_Op)) =
1979 Etype (Next_Formal (First_Formal (Eq_Op)))
1980 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
1981 Next_Elmt (Prim);
1982 pragma Assert (Present (Prim));
1983 end loop;
1984
1985 Eq_Op := Node (Prim);
1986
1987 return
1988 Make_Function_Call (Loc,
1989 Name => New_Reference_To (Eq_Op, Loc),
1990 Parameter_Associations =>
1991 New_List
1992 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
1993 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
1994
1995 elsif Is_Record_Type (Full_Type) then
1996 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
1997
1998 if Present (Eq_Op) then
1999 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2000
2001 -- Inherited equality from parent type. Convert the actuals
2002 -- to match signature of operation.
2003
2004 declare
2005 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2006
2007 begin
2008 return
2009 Make_Function_Call (Loc,
2010 Name => New_Reference_To (Eq_Op, Loc),
2011 Parameter_Associations =>
2012 New_List (OK_Convert_To (T, Lhs),
2013 OK_Convert_To (T, Rhs)));
2014 end;
2015
2016 else
2017 -- Comparison between Unchecked_Union components
2018
2019 if Is_Unchecked_Union (Full_Type) then
2020 declare
2021 Lhs_Type : Node_Id := Full_Type;
2022 Rhs_Type : Node_Id := Full_Type;
2023 Lhs_Discr_Val : Node_Id;
2024 Rhs_Discr_Val : Node_Id;
2025
2026 begin
2027 -- Lhs subtype
2028
2029 if Nkind (Lhs) = N_Selected_Component then
2030 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2031 end if;
2032
2033 -- Rhs subtype
2034
2035 if Nkind (Rhs) = N_Selected_Component then
2036 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2037 end if;
2038
2039 -- Lhs of the composite equality
2040
2041 if Is_Constrained (Lhs_Type) then
2042
2043 -- Since the enclosing record can never be an
2044 -- Unchecked_Union (this code is executed for records
2045 -- that do not have variants), we may reference its
2046 -- discriminant(s).
2047
2048 if Nkind (Lhs) = N_Selected_Component
2049 and then Has_Per_Object_Constraint (
2050 Entity (Selector_Name (Lhs)))
2051 then
2052 Lhs_Discr_Val :=
2053 Make_Selected_Component (Loc,
2054 Prefix => Prefix (Lhs),
2055 Selector_Name =>
2056 New_Copy (
2057 Get_Discriminant_Value (
2058 First_Discriminant (Lhs_Type),
2059 Lhs_Type,
2060 Stored_Constraint (Lhs_Type))));
2061
2062 else
2063 Lhs_Discr_Val := New_Copy (
2064 Get_Discriminant_Value (
2065 First_Discriminant (Lhs_Type),
2066 Lhs_Type,
2067 Stored_Constraint (Lhs_Type)));
2068
2069 end if;
2070 else
2071 -- It is not possible to infer the discriminant since
2072 -- the subtype is not constrained.
2073
2074 return
2075 Make_Raise_Program_Error (Loc,
2076 Reason => PE_Unchecked_Union_Restriction);
2077 end if;
2078
2079 -- Rhs of the composite equality
2080
2081 if Is_Constrained (Rhs_Type) then
2082 if Nkind (Rhs) = N_Selected_Component
2083 and then Has_Per_Object_Constraint (
2084 Entity (Selector_Name (Rhs)))
2085 then
2086 Rhs_Discr_Val :=
2087 Make_Selected_Component (Loc,
2088 Prefix => Prefix (Rhs),
2089 Selector_Name =>
2090 New_Copy (
2091 Get_Discriminant_Value (
2092 First_Discriminant (Rhs_Type),
2093 Rhs_Type,
2094 Stored_Constraint (Rhs_Type))));
2095
2096 else
2097 Rhs_Discr_Val := New_Copy (
2098 Get_Discriminant_Value (
2099 First_Discriminant (Rhs_Type),
2100 Rhs_Type,
2101 Stored_Constraint (Rhs_Type)));
2102
2103 end if;
2104 else
2105 return
2106 Make_Raise_Program_Error (Loc,
2107 Reason => PE_Unchecked_Union_Restriction);
2108 end if;
2109
2110 -- Call the TSS equality function with the inferred
2111 -- discriminant values.
2112
2113 return
2114 Make_Function_Call (Loc,
2115 Name => New_Reference_To (Eq_Op, Loc),
2116 Parameter_Associations => New_List (
2117 Lhs,
2118 Rhs,
2119 Lhs_Discr_Val,
2120 Rhs_Discr_Val));
2121 end;
2122 end if;
2123
2124 -- Shouldn't this be an else, we can't fall through
2125 -- the above IF, right???
2126
2127 return
2128 Make_Function_Call (Loc,
2129 Name => New_Reference_To (Eq_Op, Loc),
2130 Parameter_Associations => New_List (Lhs, Rhs));
2131 end if;
2132
2133 else
2134 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2135 end if;
2136
2137 else
2138 -- It can be a simple record or the full view of a scalar private
2139
2140 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2141 end if;
2142 end Expand_Composite_Equality;
2143
2144 ------------------------------
2145 -- Expand_Concatenate_Other --
2146 ------------------------------
2147
2148 -- Let n be the number of array operands to be concatenated, Base_Typ
2149 -- their base type, Ind_Typ their index type, and Arr_Typ the original
2150 -- array type to which the concatenation operator applies, then the
2151 -- following subprogram is constructed:
2152
2153 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
2154 -- L : Ind_Typ;
2155 -- begin
2156 -- if S1'Length /= 0 then
2157 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
2158 -- XXX = Arr_Typ'First otherwise
2159 -- elsif S2'Length /= 0 then
2160 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
2161 -- YYY = Arr_Typ'First otherwise
2162 -- ...
2163 -- elsif Sn-1'Length /= 0 then
2164 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
2165 -- ZZZ = Arr_Typ'First otherwise
2166 -- else
2167 -- return Sn;
2168 -- end if;
2169
2170 -- declare
2171 -- P : Ind_Typ;
2172 -- H : Ind_Typ :=
2173 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
2174 -- + Ind_Typ'Pos (L));
2175 -- R : Base_Typ (L .. H);
2176 -- begin
2177 -- if S1'Length /= 0 then
2178 -- P := S1'First;
2179 -- loop
2180 -- R (L) := S1 (P);
2181 -- L := Ind_Typ'Succ (L);
2182 -- exit when P = S1'Last;
2183 -- P := Ind_Typ'Succ (P);
2184 -- end loop;
2185 -- end if;
2186 --
2187 -- if S2'Length /= 0 then
2188 -- L := Ind_Typ'Succ (L);
2189 -- loop
2190 -- R (L) := S2 (P);
2191 -- L := Ind_Typ'Succ (L);
2192 -- exit when P = S2'Last;
2193 -- P := Ind_Typ'Succ (P);
2194 -- end loop;
2195 -- end if;
2196
2197 -- ...
2198
2199 -- if Sn'Length /= 0 then
2200 -- P := Sn'First;
2201 -- loop
2202 -- R (L) := Sn (P);
2203 -- L := Ind_Typ'Succ (L);
2204 -- exit when P = Sn'Last;
2205 -- P := Ind_Typ'Succ (P);
2206 -- end loop;
2207 -- end if;
2208
2209 -- return R;
2210 -- end;
2211 -- end Cnn;]
2212
2213 procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
2214 Loc : constant Source_Ptr := Sloc (Cnode);
2215 Nb_Opnds : constant Nat := List_Length (Opnds);
2216
2217 Arr_Typ : constant Entity_Id := Etype (Entity (Cnode));
2218 Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
2219 Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ));
2220
2221 Func_Id : Node_Id;
2222 Func_Spec : Node_Id;
2223 Param_Specs : List_Id;
2224
2225 Func_Body : Node_Id;
2226 Func_Decls : List_Id;
2227 Func_Stmts : List_Id;
2228
2229 L_Decl : Node_Id;
2230
2231 If_Stmt : Node_Id;
2232 Elsif_List : List_Id;
2233
2234 Declare_Block : Node_Id;
2235 Declare_Decls : List_Id;
2236 Declare_Stmts : List_Id;
2237
2238 H_Decl : Node_Id;
2239 H_Init : Node_Id;
2240 P_Decl : Node_Id;
2241 R_Decl : Node_Id;
2242 R_Constr : Node_Id;
2243 R_Range : Node_Id;
2244
2245 Params : List_Id;
2246 Operand : Node_Id;
2247
2248 function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
2249 -- Builds the sequence of statement:
2250 -- P := Si'First;
2251 -- loop
2252 -- R (L) := Si (P);
2253 -- L := Ind_Typ'Succ (L);
2254 -- exit when P = Si'Last;
2255 -- P := Ind_Typ'Succ (P);
2256 -- end loop;
2257 --
2258 -- where i is the input parameter I given.
2259 -- If the flag Last is true, the exit statement is emitted before
2260 -- incrementing the lower bound, to prevent the creation out of
2261 -- bound values.
2262
2263 function Init_L (I : Nat) return Node_Id;
2264 -- Builds the statement:
2265 -- L := Arr_Typ'First; If Arr_Typ is constrained
2266 -- L := Si'First; otherwise (where I is the input param given)
2267
2268 function H return Node_Id;
2269 -- Builds reference to identifier H
2270
2271 function Ind_Val (E : Node_Id) return Node_Id;
2272 -- Builds expression Ind_Typ'Val (E);
2273
2274 function L return Node_Id;
2275 -- Builds reference to identifier L
2276
2277 function L_Pos return Node_Id;
2278 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
2279 -- expression to avoid universal_integer computations whenever possible,
2280 -- in the expression for the upper bound H.
2281
2282 function L_Succ return Node_Id;
2283 -- Builds expression Ind_Typ'Succ (L)
2284
2285 function One return Node_Id;
2286 -- Builds integer literal one
2287
2288 function P return Node_Id;
2289 -- Builds reference to identifier P
2290
2291 function P_Succ return Node_Id;
2292 -- Builds expression Ind_Typ'Succ (P)
2293
2294 function R return Node_Id;
2295 -- Builds reference to identifier R
2296
2297 function S (I : Nat) return Node_Id;
2298 -- Builds reference to identifier Si, where I is the value given
2299
2300 function S_First (I : Nat) return Node_Id;
2301 -- Builds expression Si'First, where I is the value given
2302
2303 function S_Last (I : Nat) return Node_Id;
2304 -- Builds expression Si'Last, where I is the value given
2305
2306 function S_Length (I : Nat) return Node_Id;
2307 -- Builds expression Si'Length, where I is the value given
2308
2309 function S_Length_Test (I : Nat) return Node_Id;
2310 -- Builds expression Si'Length /= 0, where I is the value given
2311
2312 -------------------
2313 -- Copy_Into_R_S --
2314 -------------------
2315
2316 function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
2317 Stmts : constant List_Id := New_List;
2318 P_Start : Node_Id;
2319 Loop_Stmt : Node_Id;
2320 R_Copy : Node_Id;
2321 Exit_Stmt : Node_Id;
2322 L_Inc : Node_Id;
2323 P_Inc : Node_Id;
2324
2325 begin
2326 -- First construct the initializations
2327
2328 P_Start := Make_Assignment_Statement (Loc,
2329 Name => P,
2330 Expression => S_First (I));
2331 Append_To (Stmts, P_Start);
2332
2333 -- Then build the loop
2334
2335 R_Copy := Make_Assignment_Statement (Loc,
2336 Name => Make_Indexed_Component (Loc,
2337 Prefix => R,
2338 Expressions => New_List (L)),
2339 Expression => Make_Indexed_Component (Loc,
2340 Prefix => S (I),
2341 Expressions => New_List (P)));
2342
2343 L_Inc := Make_Assignment_Statement (Loc,
2344 Name => L,
2345 Expression => L_Succ);
2346
2347 Exit_Stmt := Make_Exit_Statement (Loc,
2348 Condition => Make_Op_Eq (Loc, P, S_Last (I)));
2349
2350 P_Inc := Make_Assignment_Statement (Loc,
2351 Name => P,
2352 Expression => P_Succ);
2353
2354 if Last then
2355 Loop_Stmt :=
2356 Make_Implicit_Loop_Statement (Cnode,
2357 Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
2358 else
2359 Loop_Stmt :=
2360 Make_Implicit_Loop_Statement (Cnode,
2361 Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
2362 end if;
2363
2364 Append_To (Stmts, Loop_Stmt);
2365
2366 return Stmts;
2367 end Copy_Into_R_S;
2368
2369 -------
2370 -- H --
2371 -------
2372
2373 function H return Node_Id is
2374 begin
2375 return Make_Identifier (Loc, Name_uH);
2376 end H;
2377
2378 -------------
2379 -- Ind_Val --
2380 -------------
2381
2382 function Ind_Val (E : Node_Id) return Node_Id is
2383 begin
2384 return
2385 Make_Attribute_Reference (Loc,
2386 Prefix => New_Reference_To (Ind_Typ, Loc),
2387 Attribute_Name => Name_Val,
2388 Expressions => New_List (E));
2389 end Ind_Val;
2390
2391 ------------
2392 -- Init_L --
2393 ------------
2394
2395 function Init_L (I : Nat) return Node_Id is
2396 E : Node_Id;
2397
2398 begin
2399 if Is_Constrained (Arr_Typ) then
2400 E := Make_Attribute_Reference (Loc,
2401 Prefix => New_Reference_To (Arr_Typ, Loc),
2402 Attribute_Name => Name_First);
2403
2404 else
2405 E := S_First (I);
2406 end if;
2407
2408 return Make_Assignment_Statement (Loc, Name => L, Expression => E);
2409 end Init_L;
2410
2411 -------
2412 -- L --
2413 -------
2414
2415 function L return Node_Id is
2416 begin
2417 return Make_Identifier (Loc, Name_uL);
2418 end L;
2419
2420 -----------
2421 -- L_Pos --
2422 -----------
2423
2424 function L_Pos return Node_Id is
2425 Target_Type : Entity_Id;
2426
2427 begin
2428 -- If the index type is an enumeration type, the computation
2429 -- can be done in standard integer. Otherwise, choose a large
2430 -- enough integer type.
2431
2432 if Is_Enumeration_Type (Ind_Typ)
2433 or else Root_Type (Ind_Typ) = Standard_Integer
2434 or else Root_Type (Ind_Typ) = Standard_Short_Integer
2435 or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
2436 then
2437 Target_Type := Standard_Integer;
2438 else
2439 Target_Type := Root_Type (Ind_Typ);
2440 end if;
2441
2442 return
2443 Make_Qualified_Expression (Loc,
2444 Subtype_Mark => New_Reference_To (Target_Type, Loc),
2445 Expression =>
2446 Make_Attribute_Reference (Loc,
2447 Prefix => New_Reference_To (Ind_Typ, Loc),
2448 Attribute_Name => Name_Pos,
2449 Expressions => New_List (L)));
2450 end L_Pos;
2451
2452 ------------
2453 -- L_Succ --
2454 ------------
2455
2456 function L_Succ return Node_Id is
2457 begin
2458 return
2459 Make_Attribute_Reference (Loc,
2460 Prefix => New_Reference_To (Ind_Typ, Loc),
2461 Attribute_Name => Name_Succ,
2462 Expressions => New_List (L));
2463 end L_Succ;
2464
2465 ---------
2466 -- One --
2467 ---------
2468
2469 function One return Node_Id is
2470 begin
2471 return Make_Integer_Literal (Loc, 1);
2472 end One;
2473
2474 -------
2475 -- P --
2476 -------
2477
2478 function P return Node_Id is
2479 begin
2480 return Make_Identifier (Loc, Name_uP);
2481 end P;
2482
2483 ------------
2484 -- P_Succ --
2485 ------------
2486
2487 function P_Succ return Node_Id is
2488 begin
2489 return
2490 Make_Attribute_Reference (Loc,
2491 Prefix => New_Reference_To (Ind_Typ, Loc),
2492 Attribute_Name => Name_Succ,
2493 Expressions => New_List (P));
2494 end P_Succ;
2495
2496 -------
2497 -- R --
2498 -------
2499
2500 function R return Node_Id is
2501 begin
2502 return Make_Identifier (Loc, Name_uR);
2503 end R;
2504
2505 -------
2506 -- S --
2507 -------
2508
2509 function S (I : Nat) return Node_Id is
2510 begin
2511 return Make_Identifier (Loc, New_External_Name ('S', I));
2512 end S;
2513
2514 -------------
2515 -- S_First --
2516 -------------
2517
2518 function S_First (I : Nat) return Node_Id is
2519 begin
2520 return Make_Attribute_Reference (Loc,
2521 Prefix => S (I),
2522 Attribute_Name => Name_First);
2523 end S_First;
2524
2525 ------------
2526 -- S_Last --
2527 ------------
2528
2529 function S_Last (I : Nat) return Node_Id is
2530 begin
2531 return Make_Attribute_Reference (Loc,
2532 Prefix => S (I),
2533 Attribute_Name => Name_Last);
2534 end S_Last;
2535
2536 --------------
2537 -- S_Length --
2538 --------------
2539
2540 function S_Length (I : Nat) return Node_Id is
2541 begin
2542 return Make_Attribute_Reference (Loc,
2543 Prefix => S (I),
2544 Attribute_Name => Name_Length);
2545 end S_Length;
2546
2547 -------------------
2548 -- S_Length_Test --
2549 -------------------
2550
2551 function S_Length_Test (I : Nat) return Node_Id is
2552 begin
2553 return
2554 Make_Op_Ne (Loc,
2555 Left_Opnd => S_Length (I),
2556 Right_Opnd => Make_Integer_Literal (Loc, 0));
2557 end S_Length_Test;
2558
2559 -- Start of processing for Expand_Concatenate_Other
2560
2561 begin
2562 -- Construct the parameter specs and the overall function spec
2563
2564 Param_Specs := New_List;
2565 for I in 1 .. Nb_Opnds loop
2566 Append_To
2567 (Param_Specs,
2568 Make_Parameter_Specification (Loc,
2569 Defining_Identifier =>
2570 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
2571 Parameter_Type => New_Reference_To (Base_Typ, Loc)));
2572 end loop;
2573
2574 Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2575 Func_Spec :=
2576 Make_Function_Specification (Loc,
2577 Defining_Unit_Name => Func_Id,
2578 Parameter_Specifications => Param_Specs,
2579 Result_Definition => New_Reference_To (Base_Typ, Loc));
2580
2581 -- Construct L's object declaration
2582
2583 L_Decl :=
2584 Make_Object_Declaration (Loc,
2585 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
2586 Object_Definition => New_Reference_To (Ind_Typ, Loc));
2587
2588 Func_Decls := New_List (L_Decl);
2589
2590 -- Construct the if-then-elsif statements
2591
2592 Elsif_List := New_List;
2593 for I in 2 .. Nb_Opnds - 1 loop
2594 Append_To (Elsif_List, Make_Elsif_Part (Loc,
2595 Condition => S_Length_Test (I),
2596 Then_Statements => New_List (Init_L (I))));
2597 end loop;
2598
2599 If_Stmt :=
2600 Make_Implicit_If_Statement (Cnode,
2601 Condition => S_Length_Test (1),
2602 Then_Statements => New_List (Init_L (1)),
2603 Elsif_Parts => Elsif_List,
2604 Else_Statements => New_List (Make_Simple_Return_Statement (Loc,
2605 Expression => S (Nb_Opnds))));
2606
2607 -- Construct the declaration for H
2608
2609 P_Decl :=
2610 Make_Object_Declaration (Loc,
2611 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2612 Object_Definition => New_Reference_To (Ind_Typ, Loc));
2613
2614 H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
2615 for I in 2 .. Nb_Opnds loop
2616 H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
2617 end loop;
2618 H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
2619
2620 H_Decl :=
2621 Make_Object_Declaration (Loc,
2622 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
2623 Object_Definition => New_Reference_To (Ind_Typ, Loc),
2624 Expression => H_Init);
2625
2626 -- Construct the declaration for R
2627
2628 R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
2629 R_Constr :=
2630 Make_Index_Or_Discriminant_Constraint (Loc,
2631 Constraints => New_List (R_Range));
2632
2633 R_Decl :=
2634 Make_Object_Declaration (Loc,
2635 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
2636 Object_Definition =>
2637 Make_Subtype_Indication (Loc,
2638 Subtype_Mark => New_Reference_To (Base_Typ, Loc),
2639 Constraint => R_Constr));
2640
2641 -- Construct the declarations for the declare block
2642
2643 Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
2644
2645 -- Construct list of statements for the declare block
2646
2647 Declare_Stmts := New_List;
2648 for I in 1 .. Nb_Opnds loop
2649 Append_To (Declare_Stmts,
2650 Make_Implicit_If_Statement (Cnode,
2651 Condition => S_Length_Test (I),
2652 Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
2653 end loop;
2654
2655 Append_To
2656 (Declare_Stmts, Make_Simple_Return_Statement (Loc, Expression => R));
2657
2658 -- Construct the declare block
2659
2660 Declare_Block := Make_Block_Statement (Loc,
2661 Declarations => Declare_Decls,
2662 Handled_Statement_Sequence =>
2663 Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
2664
2665 -- Construct the list of function statements
2666
2667 Func_Stmts := New_List (If_Stmt, Declare_Block);
2668
2669 -- Construct the function body
2670
2671 Func_Body :=
2672 Make_Subprogram_Body (Loc,
2673 Specification => Func_Spec,
2674 Declarations => Func_Decls,
2675 Handled_Statement_Sequence =>
2676 Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
2677
2678 -- Insert the newly generated function in the code. This is analyzed
2679 -- with all checks off, since we have completed all the checks.
2680
2681 -- Note that this does *not* fix the array concatenation bug when the
2682 -- low bound is Integer'first sibce that bug comes from the pointer
2683 -- dereferencing an unconstrained array. And there we need a constraint
2684 -- check to make sure the length of the concatenated array is ok. ???
2685
2686 Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
2687
2688 -- Construct list of arguments for the function call
2689
2690 Params := New_List;
2691 Operand := First (Opnds);
2692 for I in 1 .. Nb_Opnds loop
2693 Append_To (Params, Relocate_Node (Operand));
2694 Next (Operand);
2695 end loop;
2696
2697 -- Insert the function call
2698
2699 Rewrite
2700 (Cnode,
2701 Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
2702
2703 Analyze_And_Resolve (Cnode, Base_Typ);
2704 Set_Is_Inlined (Func_Id);
2705 end Expand_Concatenate_Other;
2706
2707 -------------------------------
2708 -- Expand_Concatenate_String --
2709 -------------------------------
2710
2711 procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
2712 Loc : constant Source_Ptr := Sloc (Cnode);
2713 Opnd1 : constant Node_Id := First (Opnds);
2714 Opnd2 : constant Node_Id := Next (Opnd1);
2715 Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1));
2716 Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2));
2717
2718 R : RE_Id;
2719 -- RE_Id value for function to be called
2720
2721 begin
2722 -- In all cases, we build a call to a routine giving the list of
2723 -- arguments as the parameter list to the routine.
2724
2725 case List_Length (Opnds) is
2726 when 2 =>
2727 if Typ1 = Standard_Character then
2728 if Typ2 = Standard_Character then
2729 R := RE_Str_Concat_CC;
2730
2731 else
2732 pragma Assert (Typ2 = Standard_String);
2733 R := RE_Str_Concat_CS;
2734 end if;
2735
2736 elsif Typ1 = Standard_String then
2737 if Typ2 = Standard_Character then
2738 R := RE_Str_Concat_SC;
2739
2740 else
2741 pragma Assert (Typ2 = Standard_String);
2742 R := RE_Str_Concat;
2743 end if;
2744
2745 -- If we have anything other than Standard_Character or
2746 -- Standard_String, then we must have had a serious error
2747 -- earlier, so we just abandon the attempt at expansion.
2748
2749 else
2750 pragma Assert (Serious_Errors_Detected > 0);
2751 return;
2752 end if;
2753
2754 when 3 =>
2755 R := RE_Str_Concat_3;
2756
2757 when 4 =>
2758 R := RE_Str_Concat_4;
2759
2760 when 5 =>
2761 R := RE_Str_Concat_5;
2762
2763 when others =>
2764 R := RE_Null;
2765 raise Program_Error;
2766 end case;
2767
2768 -- Now generate the appropriate call
2769
2770 Rewrite (Cnode,
2771 Make_Function_Call (Sloc (Cnode),
2772 Name => New_Occurrence_Of (RTE (R), Loc),
2773 Parameter_Associations => Opnds));
2774
2775 Analyze_And_Resolve (Cnode, Standard_String);
2776
2777 exception
2778 when RE_Not_Available =>
2779 return;
2780 end Expand_Concatenate_String;
2781
2782 ------------------------
2783 -- Expand_N_Allocator --
2784 ------------------------
2785
2786 procedure Expand_N_Allocator (N : Node_Id) is
2787 PtrT : constant Entity_Id := Etype (N);
2788 Dtyp : constant Entity_Id := Designated_Type (PtrT);
2789 Etyp : constant Entity_Id := Etype (Expression (N));
2790 Loc : constant Source_Ptr := Sloc (N);
2791 Desig : Entity_Id;
2792 Temp : Entity_Id;
2793 Nod : Node_Id;
2794
2795 procedure Complete_Coextension_Finalization;
2796 -- Generate finalization calls for all nested coextensions of N. This
2797 -- routine may allocate list controllers if necessary.
2798
2799 procedure Rewrite_Coextension (N : Node_Id);
2800 -- Static coextensions have the same lifetime as the entity they
2801 -- constrain. Such occurrences can be rewritten as aliased objects
2802 -- and their unrestricted access used instead of the coextension.
2803
2804 ---------------------------------------
2805 -- Complete_Coextension_Finalization --
2806 ---------------------------------------
2807
2808 procedure Complete_Coextension_Finalization is
2809 Coext : Node_Id;
2810 Coext_Elmt : Elmt_Id;
2811 Flist : Node_Id;
2812 Ref : Node_Id;
2813
2814 function Inside_A_Return_Statement (N : Node_Id) return Boolean;
2815 -- Determine whether node N is part of a return statement
2816
2817 function Needs_Initialization_Call (N : Node_Id) return Boolean;
2818 -- Determine whether node N is a subtype indicator allocator which
2819 -- acts a coextension. Such coextensions need initialization.
2820
2821 -------------------------------
2822 -- Inside_A_Return_Statement --
2823 -------------------------------
2824
2825 function Inside_A_Return_Statement (N : Node_Id) return Boolean is
2826 P : Node_Id;
2827
2828 begin
2829 P := Parent (N);
2830 while Present (P) loop
2831 if Nkind_In
2832 (P, N_Extended_Return_Statement, N_Simple_Return_Statement)
2833 then
2834 return True;
2835
2836 -- Stop the traversal when we reach a subprogram body
2837
2838 elsif Nkind (P) = N_Subprogram_Body then
2839 return False;
2840 end if;
2841
2842 P := Parent (P);
2843 end loop;
2844
2845 return False;
2846 end Inside_A_Return_Statement;
2847
2848 -------------------------------
2849 -- Needs_Initialization_Call --
2850 -------------------------------
2851
2852 function Needs_Initialization_Call (N : Node_Id) return Boolean is
2853 Obj_Decl : Node_Id;
2854
2855 begin
2856 if Nkind (N) = N_Explicit_Dereference
2857 and then Nkind (Prefix (N)) = N_Identifier
2858 and then Nkind (Parent (Entity (Prefix (N)))) =
2859 N_Object_Declaration
2860 then
2861 Obj_Decl := Parent (Entity (Prefix (N)));
2862
2863 return
2864 Present (Expression (Obj_Decl))
2865 and then Nkind (Expression (Obj_Decl)) = N_Allocator
2866 and then Nkind (Expression (Expression (Obj_Decl))) /=
2867 N_Qualified_Expression;
2868 end if;
2869
2870 return False;
2871 end Needs_Initialization_Call;
2872
2873 -- Start of processing for Complete_Coextension_Finalization
2874
2875 begin
2876 -- When a coextension root is inside a return statement, we need to
2877 -- use the finalization chain of the function's scope. This does not
2878 -- apply for controlled named access types because in those cases we
2879 -- can use the finalization chain of the type itself.
2880
2881 if Inside_A_Return_Statement (N)
2882 and then
2883 (Ekind (PtrT) = E_Anonymous_Access_Type
2884 or else
2885 (Ekind (PtrT) = E_Access_Type
2886 and then No (Associated_Final_Chain (PtrT))))
2887 then
2888 declare
2889 Decl : Node_Id;
2890 Outer_S : Entity_Id;
2891 S : Entity_Id := Current_Scope;
2892
2893 begin
2894 while Present (S) and then S /= Standard_Standard loop
2895 if Ekind (S) = E_Function then
2896 Outer_S := Scope (S);
2897
2898 -- Retrieve the declaration of the body
2899
2900 Decl := Parent (Parent (
2901 Corresponding_Body (Parent (Parent (S)))));
2902 exit;
2903 end if;
2904
2905 S := Scope (S);
2906 end loop;
2907
2908 -- Push the scope of the function body since we are inserting
2909 -- the list before the body, but we are currently in the body
2910 -- itself. Override the finalization list of PtrT since the
2911 -- finalization context is now different.
2912
2913 Push_Scope (Outer_S);
2914 Build_Final_List (Decl, PtrT);
2915 Pop_Scope;
2916 end;
2917
2918 -- The root allocator may not be controlled, but it still needs a
2919 -- finalization list for all nested coextensions.
2920
2921 elsif No (Associated_Final_Chain (PtrT)) then
2922 Build_Final_List (N, PtrT);
2923 end if;
2924
2925 Flist :=
2926 Make_Selected_Component (Loc,
2927 Prefix =>
2928 New_Reference_To (Associated_Final_Chain (PtrT), Loc),
2929 Selector_Name =>
2930 Make_Identifier (Loc, Name_F));
2931
2932 Coext_Elmt := First_Elmt (Coextensions (N));
2933 while Present (Coext_Elmt) loop
2934 Coext := Node (Coext_Elmt);
2935
2936 -- Generate:
2937 -- typ! (coext.all)
2938
2939 if Nkind (Coext) = N_Identifier then
2940 Ref := Make_Unchecked_Type_Conversion (Loc,
2941 Subtype_Mark =>
2942 New_Reference_To (Etype (Coext), Loc),
2943 Expression =>
2944 Make_Explicit_Dereference (Loc,
2945 New_Copy_Tree (Coext)));
2946 else
2947 Ref := New_Copy_Tree (Coext);
2948 end if;
2949
2950 -- No initialization call if not allowed
2951
2952 Check_Restriction (No_Default_Initialization, N);
2953
2954 if not Restriction_Active (No_Default_Initialization) then
2955
2956 -- Generate:
2957 -- initialize (Ref)
2958 -- attach_to_final_list (Ref, Flist, 2)
2959
2960 if Needs_Initialization_Call (Coext) then
2961 Insert_Actions (N,
2962 Make_Init_Call (
2963 Ref => Ref,
2964 Typ => Etype (Coext),
2965 Flist_Ref => Flist,
2966 With_Attach => Make_Integer_Literal (Loc, Uint_2)));
2967
2968 -- Generate:
2969 -- attach_to_final_list (Ref, Flist, 2)
2970
2971 else
2972 Insert_Action (N,
2973 Make_Attach_Call (
2974 Obj_Ref => Ref,
2975 Flist_Ref => New_Copy_Tree (Flist),
2976 With_Attach => Make_Integer_Literal (Loc, Uint_2)));
2977 end if;
2978 end if;
2979
2980 Next_Elmt (Coext_Elmt);
2981 end loop;
2982 end Complete_Coextension_Finalization;
2983
2984 -------------------------
2985 -- Rewrite_Coextension --
2986 -------------------------
2987
2988 procedure Rewrite_Coextension (N : Node_Id) is
2989 Temp : constant Node_Id :=
2990 Make_Defining_Identifier (Loc,
2991 New_Internal_Name ('C'));
2992
2993 -- Generate:
2994 -- Cnn : aliased Etyp;
2995
2996 Decl : constant Node_Id :=
2997 Make_Object_Declaration (Loc,
2998 Defining_Identifier => Temp,
2999 Aliased_Present => True,
3000 Object_Definition =>
3001 New_Occurrence_Of (Etyp, Loc));
3002 Nod : Node_Id;
3003
3004 begin
3005 if Nkind (Expression (N)) = N_Qualified_Expression then
3006 Set_Expression (Decl, Expression (Expression (N)));
3007 end if;
3008
3009 -- Find the proper insertion node for the declaration
3010
3011 Nod := Parent (N);
3012 while Present (Nod) loop
3013 exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call
3014 or else Nkind (Nod) = N_Procedure_Call_Statement
3015 or else Nkind (Nod) in N_Declaration;
3016 Nod := Parent (Nod);
3017 end loop;
3018
3019 Insert_Before (Nod, Decl);
3020 Analyze (Decl);
3021
3022 Rewrite (N,
3023 Make_Attribute_Reference (Loc,
3024 Prefix => New_Occurrence_Of (Temp, Loc),
3025 Attribute_Name => Name_Unrestricted_Access));
3026
3027 Analyze_And_Resolve (N, PtrT);
3028 end Rewrite_Coextension;
3029
3030 -- Start of processing for Expand_N_Allocator
3031
3032 begin
3033 -- RM E.2.3(22). We enforce that the expected type of an allocator
3034 -- shall not be a remote access-to-class-wide-limited-private type
3035
3036 -- Why is this being done at expansion time, seems clearly wrong ???
3037
3038 Validate_Remote_Access_To_Class_Wide_Type (N);
3039
3040 -- Set the Storage Pool
3041
3042 Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
3043
3044 if Present (Storage_Pool (N)) then
3045 if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
3046 if VM_Target = No_VM then
3047 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
3048 end if;
3049
3050 elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
3051 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
3052
3053 else
3054 Set_Procedure_To_Call (N,
3055 Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
3056 end if;
3057 end if;
3058
3059 -- Under certain circumstances we can replace an allocator by an
3060 -- access to statically allocated storage. The conditions, as noted
3061 -- in AARM 3.10 (10c) are as follows:
3062
3063 -- Size and initial value is known at compile time
3064 -- Access type is access-to-constant
3065
3066 -- The allocator is not part of a constraint on a record component,
3067 -- because in that case the inserted actions are delayed until the
3068 -- record declaration is fully analyzed, which is too late for the
3069 -- analysis of the rewritten allocator.
3070
3071 if Is_Access_Constant (PtrT)
3072 and then Nkind (Expression (N)) = N_Qualified_Expression
3073 and then Compile_Time_Known_Value (Expression (Expression (N)))
3074 and then Size_Known_At_Compile_Time (Etype (Expression
3075 (Expression (N))))
3076 and then not Is_Record_Type (Current_Scope)
3077 then
3078 -- Here we can do the optimization. For the allocator
3079
3080 -- new x'(y)
3081
3082 -- We insert an object declaration
3083
3084 -- Tnn : aliased x := y;
3085
3086 -- and replace the allocator by Tnn'Unrestricted_Access.
3087 -- Tnn is marked as requiring static allocation.
3088
3089 Temp :=
3090 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3091
3092 Desig := Subtype_Mark (Expression (N));
3093
3094 -- If context is constrained, use constrained subtype directly,
3095 -- so that the constant is not labelled as having a nominally
3096 -- unconstrained subtype.
3097
3098 if Entity (Desig) = Base_Type (Dtyp) then
3099 Desig := New_Occurrence_Of (Dtyp, Loc);
3100 end if;
3101
3102 Insert_Action (N,
3103 Make_Object_Declaration (Loc,
3104 Defining_Identifier => Temp,
3105 Aliased_Present => True,
3106 Constant_Present => Is_Access_Constant (PtrT),
3107 Object_Definition => Desig,
3108 Expression => Expression (Expression (N))));
3109
3110 Rewrite (N,
3111 Make_Attribute_Reference (Loc,
3112 Prefix => New_Occurrence_Of (Temp, Loc),
3113 Attribute_Name => Name_Unrestricted_Access));
3114
3115 Analyze_And_Resolve (N, PtrT);
3116
3117 -- We set the variable as statically allocated, since we don't
3118 -- want it going on the stack of the current procedure!
3119
3120 Set_Is_Statically_Allocated (Temp);
3121 return;
3122 end if;
3123
3124 -- Same if the allocator is an access discriminant for a local object:
3125 -- instead of an allocator we create a local value and constrain the
3126 -- the enclosing object with the corresponding access attribute.
3127
3128 if Is_Static_Coextension (N) then
3129 Rewrite_Coextension (N);
3130 return;
3131 end if;
3132
3133 -- The current allocator creates an object which may contain nested
3134 -- coextensions. Use the current allocator's finalization list to
3135 -- generate finalization call for all nested coextensions.
3136
3137 if Is_Coextension_Root (N) then
3138 Complete_Coextension_Finalization;
3139 end if;
3140
3141 -- Handle case of qualified expression (other than optimization above)
3142
3143 if Nkind (Expression (N)) = N_Qualified_Expression then
3144 Expand_Allocator_Expression (N);
3145 return;
3146 end if;
3147
3148 -- If the allocator is for a type which requires initialization, and
3149 -- there is no initial value (i.e. operand is a subtype indication
3150 -- rather than a qualified expression), then we must generate a call
3151 -- to the initialization routine. This is done using an expression
3152 -- actions node:
3153
3154 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3155
3156 -- Here ptr_T is the pointer type for the allocator, and T is the
3157 -- subtype of the allocator. A special case arises if the designated
3158 -- type of the access type is a task or contains tasks. In this case
3159 -- the call to Init (Temp.all ...) is replaced by code that ensures
3160 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3161 -- for details). In addition, if the type T is a task T, then the
3162 -- first argument to Init must be converted to the task record type.
3163
3164 declare
3165 T : constant Entity_Id := Entity (Expression (N));
3166 Init : Entity_Id;
3167 Arg1 : Node_Id;
3168 Args : List_Id;
3169 Decls : List_Id;
3170 Decl : Node_Id;
3171 Discr : Elmt_Id;
3172 Flist : Node_Id;
3173 Temp_Decl : Node_Id;
3174 Temp_Type : Entity_Id;
3175 Attach_Level : Uint;
3176
3177 begin
3178 if No_Initialization (N) then
3179 null;
3180
3181 -- Case of no initialization procedure present
3182
3183 elsif not Has_Non_Null_Base_Init_Proc (T) then
3184
3185 -- Case of simple initialization required
3186
3187 if Needs_Simple_Initialization (T) then
3188 Check_Restriction (No_Default_Initialization, N);
3189 Rewrite (Expression (N),
3190 Make_Qualified_Expression (Loc,
3191 Subtype_Mark => New_Occurrence_Of (T, Loc),
3192 Expression => Get_Simple_Init_Val (T, N)));
3193
3194 Analyze_And_Resolve (Expression (Expression (N)), T);
3195 Analyze_And_Resolve (Expression (N), T);
3196 Set_Paren_Count (Expression (Expression (N)), 1);
3197 Expand_N_Allocator (N);
3198
3199 -- No initialization required
3200
3201 else
3202 null;
3203 end if;
3204
3205 -- Case of initialization procedure present, must be called
3206
3207 else
3208 Check_Restriction (No_Default_Initialization, N);
3209
3210 if not Restriction_Active (No_Default_Initialization) then
3211 Init := Base_Init_Proc (T);
3212 Nod := N;
3213 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3214
3215 -- Construct argument list for the initialization routine call
3216
3217 Arg1 :=
3218 Make_Explicit_Dereference (Loc,
3219 Prefix => New_Reference_To (Temp, Loc));
3220 Set_Assignment_OK (Arg1);
3221 Temp_Type := PtrT;
3222
3223 -- The initialization procedure expects a specific type. if the
3224 -- context is access to class wide, indicate that the object
3225 -- being allocated has the right specific type.
3226
3227 if Is_Class_Wide_Type (Dtyp) then
3228 Arg1 := Unchecked_Convert_To (T, Arg1);
3229 end if;
3230
3231 -- If designated type is a concurrent type or if it is private
3232 -- type whose definition is a concurrent type, the first
3233 -- argument in the Init routine has to be unchecked conversion
3234 -- to the corresponding record type. If the designated type is
3235 -- a derived type, we also convert the argument to its root
3236 -- type.
3237
3238 if Is_Concurrent_Type (T) then
3239 Arg1 :=
3240 Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
3241
3242 elsif Is_Private_Type (T)
3243 and then Present (Full_View (T))
3244 and then Is_Concurrent_Type (Full_View (T))
3245 then
3246 Arg1 :=
3247 Unchecked_Convert_To
3248 (Corresponding_Record_Type (Full_View (T)), Arg1);
3249
3250 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
3251 declare
3252 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
3253 begin
3254 Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
3255 Set_Etype (Arg1, Ftyp);
3256 end;
3257 end if;
3258
3259 Args := New_List (Arg1);
3260
3261 -- For the task case, pass the Master_Id of the access type as
3262 -- the value of the _Master parameter, and _Chain as the value
3263 -- of the _Chain parameter (_Chain will be defined as part of
3264 -- the generated code for the allocator).
3265
3266 -- In Ada 2005, the context may be a function that returns an
3267 -- anonymous access type. In that case the Master_Id has been
3268 -- created when expanding the function declaration.
3269
3270 if Has_Task (T) then
3271 if No (Master_Id (Base_Type (PtrT))) then
3272
3273 -- If we have a non-library level task with restriction
3274 -- No_Task_Hierarchy set, then no point in expanding.
3275
3276 if not Is_Library_Level_Entity (T)
3277 and then Restriction_Active (No_Task_Hierarchy)
3278 then
3279 return;
3280 end if;
3281
3282 -- The designated type was an incomplete type, and the
3283 -- access type did not get expanded. Salvage it now.
3284
3285 pragma Assert (Present (Parent (Base_Type (PtrT))));
3286 Expand_N_Full_Type_Declaration
3287 (Parent (Base_Type (PtrT)));
3288 end if;
3289
3290 -- If the context of the allocator is a declaration or an
3291 -- assignment, we can generate a meaningful image for it,
3292 -- even though subsequent assignments might remove the
3293 -- connection between task and entity. We build this image
3294 -- when the left-hand side is a simple variable, a simple
3295 -- indexed assignment or a simple selected component.
3296
3297 if Nkind (Parent (N)) = N_Assignment_Statement then
3298 declare
3299 Nam : constant Node_Id := Name (Parent (N));
3300
3301 begin
3302 if Is_Entity_Name (Nam) then
3303 Decls :=
3304 Build_Task_Image_Decls
3305 (Loc,
3306 New_Occurrence_Of
3307 (Entity (Nam), Sloc (Nam)), T);
3308
3309 elsif Nkind_In
3310 (Nam, N_Indexed_Component, N_Selected_Component)
3311 and then Is_Entity_Name (Prefix (Nam))
3312 then
3313 Decls :=
3314 Build_Task_Image_Decls
3315 (Loc, Nam, Etype (Prefix (Nam)));
3316 else
3317 Decls := Build_Task_Image_Decls (Loc, T, T);
3318 end if;
3319 end;
3320
3321 elsif Nkind (Parent (N)) = N_Object_Declaration then
3322 Decls :=
3323 Build_Task_Image_Decls
3324 (Loc, Defining_Identifier (Parent (N)), T);
3325
3326 else
3327 Decls := Build_Task_Image_Decls (Loc, T, T);
3328 end if;
3329
3330 Append_To (Args,
3331 New_Reference_To
3332 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
3333 Append_To (Args, Make_Identifier (Loc, Name_uChain));
3334
3335 Decl := Last (Decls);
3336 Append_To (Args,
3337 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
3338
3339 -- Has_Task is false, Decls not used
3340
3341 else
3342 Decls := No_List;
3343 end if;
3344
3345 -- Add discriminants if discriminated type
3346
3347 declare
3348 Dis : Boolean := False;
3349 Typ : Entity_Id;
3350
3351 begin
3352 if Has_Discriminants (T) then
3353 Dis := True;
3354 Typ := T;
3355
3356 elsif Is_Private_Type (T)
3357 and then Present (Full_View (T))
3358 and then Has_Discriminants (Full_View (T))
3359 then
3360 Dis := True;
3361 Typ := Full_View (T);
3362 end if;
3363
3364 if Dis then
3365
3366 -- If the allocated object will be constrained by the
3367 -- default values for discriminants, then build a
3368 -- subtype with those defaults, and change the allocated
3369 -- subtype to that. Note that this happens in fewer
3370 -- cases in Ada 2005 (AI-363).
3371
3372 if not Is_Constrained (Typ)
3373 and then Present (Discriminant_Default_Value
3374 (First_Discriminant (Typ)))
3375 and then (Ada_Version < Ada_05
3376 or else
3377 not Has_Constrained_Partial_View (Typ))
3378 then
3379 Typ := Build_Default_Subtype (Typ, N);
3380 Set_Expression (N, New_Reference_To (Typ, Loc));
3381 end if;
3382
3383 Discr := First_Elmt (Discriminant_Constraint (Typ));
3384 while Present (Discr) loop
3385 Nod := Node (Discr);
3386 Append (New_Copy_Tree (Node (Discr)), Args);
3387
3388 -- AI-416: when the discriminant constraint is an
3389 -- anonymous access type make sure an accessibility
3390 -- check is inserted if necessary (3.10.2(22.q/2))
3391
3392 if Ada_Version >= Ada_05
3393 and then
3394 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
3395 then
3396 Apply_Accessibility_Check (Nod, Typ);
3397 end if;
3398
3399 Next_Elmt (Discr);
3400 end loop;
3401 end if;
3402 end;
3403
3404 -- We set the allocator as analyzed so that when we analyze the
3405 -- expression actions node, we do not get an unwanted recursive
3406 -- expansion of the allocator expression.
3407
3408 Set_Analyzed (N, True);
3409 Nod := Relocate_Node (N);
3410
3411 -- Here is the transformation:
3412 -- input: new T
3413 -- output: Temp : constant ptr_T := new T;
3414 -- Init (Temp.all, ...);
3415 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3416 -- <CTRL> Initialize (Finalizable (Temp.all));
3417
3418 -- Here ptr_T is the pointer type for the allocator, and is the
3419 -- subtype of the allocator.
3420
3421 Temp_Decl :=
3422 Make_Object_Declaration (Loc,
3423 Defining_Identifier => Temp,
3424 Constant_Present => True,
3425 Object_Definition => New_Reference_To (Temp_Type, Loc),
3426 Expression => Nod);
3427
3428 Set_Assignment_OK (Temp_Decl);
3429 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
3430
3431 -- If the designated type is a task type or contains tasks,
3432 -- create block to activate created tasks, and insert
3433 -- declaration for Task_Image variable ahead of call.
3434
3435 if Has_Task (T) then
3436 declare
3437 L : constant List_Id := New_List;
3438 Blk : Node_Id;
3439 begin
3440 Build_Task_Allocate_Block (L, Nod, Args);
3441 Blk := Last (L);
3442 Insert_List_Before (First (Declarations (Blk)), Decls);
3443 Insert_Actions (N, L);
3444 end;
3445
3446 else
3447 Insert_Action (N,
3448 Make_Procedure_Call_Statement (Loc,
3449 Name => New_Reference_To (Init, Loc),
3450 Parameter_Associations => Args));
3451 end if;
3452
3453 if Controlled_Type (T) then
3454
3455 -- Postpone the generation of a finalization call for the
3456 -- current allocator if it acts as a coextension.
3457
3458 if Is_Dynamic_Coextension (N) then
3459 if No (Coextensions (N)) then
3460 Set_Coextensions (N, New_Elmt_List);
3461 end if;
3462
3463 Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
3464
3465 else
3466 Flist :=
3467 Get_Allocator_Final_List (N, Base_Type (T), PtrT);
3468
3469 -- Anonymous access types created for access parameters
3470 -- are attached to an explicitly constructed controller,
3471 -- which ensures that they can be finalized properly,
3472 -- even if their deallocation might not happen. The list
3473 -- associated with the controller is doubly-linked. For
3474 -- other anonymous access types, the object may end up
3475 -- on the global final list which is singly-linked.
3476 -- Work needed for access discriminants in Ada 2005 ???
3477
3478 if Ekind (PtrT) = E_Anonymous_Access_Type
3479 and then
3480 Nkind (Associated_Node_For_Itype (PtrT))
3481 not in N_Subprogram_Specification
3482 then
3483 Attach_Level := Uint_1;
3484 else
3485 Attach_Level := Uint_2;
3486 end if;
3487
3488 Insert_Actions (N,
3489 Make_Init_Call (
3490 Ref => New_Copy_Tree (Arg1),
3491 Typ => T,
3492 Flist_Ref => Flist,
3493 With_Attach => Make_Integer_Literal (Loc,
3494 Intval => Attach_Level)));
3495 end if;
3496 end if;
3497
3498 Rewrite (N, New_Reference_To (Temp, Loc));
3499 Analyze_And_Resolve (N, PtrT);
3500 end if;
3501 end if;
3502 end;
3503
3504 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3505 -- object that has been rewritten as a reference, we displace "this"
3506 -- to reference properly its secondary dispatch table.
3507
3508 if Nkind (N) = N_Identifier
3509 and then Is_Interface (Dtyp)
3510 then
3511 Displace_Allocator_Pointer (N);
3512 end if;
3513
3514 exception
3515 when RE_Not_Available =>
3516 return;
3517 end Expand_N_Allocator;
3518
3519 -----------------------
3520 -- Expand_N_And_Then --
3521 -----------------------
3522
3523 -- Expand into conditional expression if Actions present, and also deal
3524 -- with optimizing case of arguments being True or False.
3525
3526 procedure Expand_N_And_Then (N : Node_Id) is
3527 Loc : constant Source_Ptr := Sloc (N);
3528 Typ : constant Entity_Id := Etype (N);
3529 Left : constant Node_Id := Left_Opnd (N);
3530 Right : constant Node_Id := Right_Opnd (N);
3531 Actlist : List_Id;
3532
3533 begin
3534 -- Deal with non-standard booleans
3535
3536 if Is_Boolean_Type (Typ) then
3537 Adjust_Condition (Left);
3538 Adjust_Condition (Right);
3539 Set_Etype (N, Standard_Boolean);
3540 end if;
3541
3542 -- Check for cases of left argument is True or False
3543
3544 if Nkind (Left) = N_Identifier then
3545
3546 -- If left argument is True, change (True and then Right) to Right.
3547 -- Any actions associated with Right will be executed unconditionally
3548 -- and can thus be inserted into the tree unconditionally.
3549
3550 if Entity (Left) = Standard_True then
3551 if Present (Actions (N)) then
3552 Insert_Actions (N, Actions (N));
3553 end if;
3554
3555 Rewrite (N, Right);
3556 Adjust_Result_Type (N, Typ);
3557 return;
3558
3559 -- If left argument is False, change (False and then Right) to False.
3560 -- In this case we can forget the actions associated with Right,
3561 -- since they will never be executed.
3562
3563 elsif Entity (Left) = Standard_False then
3564 Kill_Dead_Code (Right);
3565 Kill_Dead_Code (Actions (N));
3566 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3567 Adjust_Result_Type (N, Typ);
3568 return;
3569 end if;
3570 end if;
3571
3572 -- If Actions are present, we expand
3573
3574 -- left and then right
3575
3576 -- into
3577
3578 -- if left then right else false end
3579
3580 -- with the actions becoming the Then_Actions of the conditional
3581 -- expression. This conditional expression is then further expanded
3582 -- (and will eventually disappear)
3583
3584 if Present (Actions (N)) then
3585 Actlist := Actions (N);
3586 Rewrite (N,
3587 Make_Conditional_Expression (Loc,
3588 Expressions => New_List (
3589 Left,
3590 Right,
3591 New_Occurrence_Of (Standard_False, Loc))));
3592
3593 Set_Then_Actions (N, Actlist);
3594 Analyze_And_Resolve (N, Standard_Boolean);
3595 Adjust_Result_Type (N, Typ);
3596 return;
3597 end if;
3598
3599 -- No actions present, check for cases of right argument True/False
3600
3601 if Nkind (Right) = N_Identifier then
3602
3603 -- Change (Left and then True) to Left. Note that we know there
3604 -- are no actions associated with the True operand, since we
3605 -- just checked for this case above.
3606
3607 if Entity (Right) = Standard_True then
3608 Rewrite (N, Left);
3609
3610 -- Change (Left and then False) to False, making sure to preserve
3611 -- any side effects associated with the Left operand.
3612
3613 elsif Entity (Right) = Standard_False then
3614 Remove_Side_Effects (Left);
3615 Rewrite
3616 (N, New_Occurrence_Of (Standard_False, Loc));
3617 end if;
3618 end if;
3619
3620 Adjust_Result_Type (N, Typ);
3621 end Expand_N_And_Then;
3622
3623 -------------------------------------
3624 -- Expand_N_Conditional_Expression --
3625 -------------------------------------
3626
3627 -- Expand into expression actions if then/else actions present
3628
3629 procedure Expand_N_Conditional_Expression (N : Node_Id) is
3630 Loc : constant Source_Ptr := Sloc (N);
3631 Cond : constant Node_Id := First (Expressions (N));
3632 Thenx : constant Node_Id := Next (Cond);
3633 Elsex : constant Node_Id := Next (Thenx);
3634 Typ : constant Entity_Id := Etype (N);
3635 Cnn : Entity_Id;
3636 New_If : Node_Id;
3637
3638 begin
3639 -- If either then or else actions are present, then given:
3640
3641 -- if cond then then-expr else else-expr end
3642
3643 -- we insert the following sequence of actions (using Insert_Actions):
3644
3645 -- Cnn : typ;
3646 -- if cond then
3647 -- <<then actions>>
3648 -- Cnn := then-expr;
3649 -- else
3650 -- <<else actions>>
3651 -- Cnn := else-expr
3652 -- end if;
3653
3654 -- and replace the conditional expression by a reference to Cnn
3655
3656 if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
3657 Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
3658
3659 New_If :=
3660 Make_Implicit_If_Statement (N,
3661 Condition => Relocate_Node (Cond),
3662
3663 Then_Statements => New_List (
3664 Make_Assignment_Statement (Sloc (Thenx),
3665 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
3666 Expression => Relocate_Node (Thenx))),
3667
3668 Else_Statements => New_List (
3669 Make_Assignment_Statement (Sloc (Elsex),
3670 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
3671 Expression => Relocate_Node (Elsex))));
3672
3673 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
3674 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
3675
3676 if Present (Then_Actions (N)) then
3677 Insert_List_Before
3678 (First (Then_Statements (New_If)), Then_Actions (N));
3679 end if;
3680
3681 if Present (Else_Actions (N)) then
3682 Insert_List_Before
3683 (First (Else_Statements (New_If)), Else_Actions (N));
3684 end if;
3685
3686 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
3687
3688 Insert_Action (N,
3689 Make_Object_Declaration (Loc,
3690 Defining_Identifier => Cnn,
3691 Object_Definition => New_Occurrence_Of (Typ, Loc)));
3692
3693 Insert_Action (N, New_If);
3694 Analyze_And_Resolve (N, Typ);
3695 end if;
3696 end Expand_N_Conditional_Expression;
3697
3698 -----------------------------------
3699 -- Expand_N_Explicit_Dereference --
3700 -----------------------------------
3701
3702 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
3703 begin
3704 -- Insert explicit dereference call for the checked storage pool case
3705
3706 Insert_Dereference_Action (Prefix (N));
3707 end Expand_N_Explicit_Dereference;
3708
3709 -----------------
3710 -- Expand_N_In --
3711 -----------------
3712
3713 procedure Expand_N_In (N : Node_Id) is
3714 Loc : constant Source_Ptr := Sloc (N);
3715 Rtyp : constant Entity_Id := Etype (N);
3716 Lop : constant Node_Id := Left_Opnd (N);
3717 Rop : constant Node_Id := Right_Opnd (N);
3718 Static : constant Boolean := Is_OK_Static_Expression (N);
3719
3720 procedure Substitute_Valid_Check;
3721 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3722 -- test for the left operand being in range of its subtype.
3723
3724 ----------------------------
3725 -- Substitute_Valid_Check --
3726 ----------------------------
3727
3728 procedure Substitute_Valid_Check is
3729 begin
3730 Rewrite (N,
3731 Make_Attribute_Reference (Loc,
3732 Prefix => Relocate_Node (Lop),
3733 Attribute_Name => Name_Valid));
3734
3735 Analyze_And_Resolve (N, Rtyp);
3736
3737 Error_Msg_N ("?explicit membership test may be optimized away", N);
3738 Error_Msg_N ("\?use ''Valid attribute instead", N);
3739 return;
3740 end Substitute_Valid_Check;
3741
3742 -- Start of processing for Expand_N_In
3743
3744 begin
3745 -- Check case of explicit test for an expression in range of its
3746 -- subtype. This is suspicious usage and we replace it with a 'Valid
3747 -- test and give a warning.
3748
3749 if Is_Scalar_Type (Etype (Lop))
3750 and then Nkind (Rop) in N_Has_Entity
3751 and then Etype (Lop) = Entity (Rop)
3752 and then Comes_From_Source (N)
3753 and then VM_Target = No_VM
3754 then
3755 Substitute_Valid_Check;
3756 return;
3757 end if;
3758
3759 -- Do validity check on operands
3760
3761 if Validity_Checks_On and Validity_Check_Operands then
3762 Ensure_Valid (Left_Opnd (N));
3763 Validity_Check_Range (Right_Opnd (N));
3764 end if;
3765
3766 -- Case of explicit range
3767
3768 if Nkind (Rop) = N_Range then
3769 declare
3770 Lo : constant Node_Id := Low_Bound (Rop);
3771 Hi : constant Node_Id := High_Bound (Rop);
3772
3773 Ltyp : constant Entity_Id := Etype (Lop);
3774
3775 Lo_Orig : constant Node_Id := Original_Node (Lo);
3776 Hi_Orig : constant Node_Id := Original_Node (Hi);
3777
3778 Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
3779 Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
3780
3781 Warn1 : constant Boolean :=
3782 Constant_Condition_Warnings
3783 and then Comes_From_Source (N);
3784 -- This must be true for any of the optimization warnings, we
3785 -- clearly want to give them only for source with the flag on.
3786
3787 Warn2 : constant Boolean :=
3788 Warn1
3789 and then Nkind (Original_Node (Rop)) = N_Range
3790 and then Is_Integer_Type (Etype (Lo));
3791 -- For the case where only one bound warning is elided, we also
3792 -- insist on an explicit range and an integer type. The reason is
3793 -- that the use of enumeration ranges including an end point is
3794 -- common, as is the use of a subtype name, one of whose bounds
3795 -- is the same as the type of the expression.
3796
3797 begin
3798 -- If test is explicit x'first .. x'last, replace by valid check
3799
3800 if Is_Scalar_Type (Ltyp)
3801 and then Nkind (Lo_Orig) = N_Attribute_Reference
3802 and then Attribute_Name (Lo_Orig) = Name_First
3803 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
3804 and then Entity (Prefix (Lo_Orig)) = Ltyp
3805 and then Nkind (Hi_Orig) = N_Attribute_Reference
3806 and then Attribute_Name (Hi_Orig) = Name_Last
3807 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
3808 and then Entity (Prefix (Hi_Orig)) = Ltyp
3809 and then Comes_From_Source (N)
3810 and then VM_Target = No_VM
3811 then
3812 Substitute_Valid_Check;
3813 return;
3814 end if;
3815
3816 -- If bounds of type are known at compile time, and the end points
3817 -- are known at compile time and identical, this is another case
3818 -- for substituting a valid test. We only do this for discrete
3819 -- types, since it won't arise in practice for float types.
3820
3821 if Comes_From_Source (N)
3822 and then Is_Discrete_Type (Ltyp)
3823 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
3824 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
3825 and then Compile_Time_Known_Value (Lo)
3826 and then Compile_Time_Known_Value (Hi)
3827 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
3828 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
3829 then
3830 Substitute_Valid_Check;
3831 return;
3832 end if;
3833
3834 -- If we have an explicit range, do a bit of optimization based
3835 -- on range analysis (we may be able to kill one or both checks).
3836
3837 -- If either check is known to fail, replace result by False since
3838 -- the other check does not matter. Preserve the static flag for
3839 -- legality checks, because we are constant-folding beyond RM 4.9.
3840
3841 if Lcheck = LT or else Ucheck = GT then
3842 if Warn1 then
3843 Error_Msg_N ("?range test optimized away", N);
3844 Error_Msg_N ("\?value is known to be out of range", N);
3845 end if;
3846
3847 Rewrite (N,
3848 New_Reference_To (Standard_False, Loc));
3849 Analyze_And_Resolve (N, Rtyp);
3850 Set_Is_Static_Expression (N, Static);
3851
3852 return;
3853
3854 -- If both checks are known to succeed, replace result
3855 -- by True, since we know we are in range.
3856
3857 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
3858 if Warn1 then
3859 Error_Msg_N ("?range test optimized away", N);
3860 Error_Msg_N ("\?value is known to be in range", N);
3861 end if;
3862
3863 Rewrite (N,
3864 New_Reference_To (Standard_True, Loc));
3865 Analyze_And_Resolve (N, Rtyp);
3866 Set_Is_Static_Expression (N, Static);
3867
3868 return;
3869
3870 -- If lower bound check succeeds and upper bound check is not
3871 -- known to succeed or fail, then replace the range check with
3872 -- a comparison against the upper bound.
3873
3874 elsif Lcheck in Compare_GE then
3875 if Warn2 then
3876 Error_Msg_N ("?lower bound test optimized away", Lo);
3877 Error_Msg_N ("\?value is known to be in range", Lo);
3878 end if;
3879
3880 Rewrite (N,
3881 Make_Op_Le (Loc,
3882 Left_Opnd => Lop,
3883 Right_Opnd => High_Bound (Rop)));
3884 Analyze_And_Resolve (N, Rtyp);
3885
3886 return;
3887
3888 -- If upper bound check succeeds and lower bound check is not
3889 -- known to succeed or fail, then replace the range check with
3890 -- a comparison against the lower bound.
3891
3892 elsif Ucheck in Compare_LE then
3893 if Warn2 then
3894 Error_Msg_N ("?upper bound test optimized away", Hi);
3895 Error_Msg_N ("\?value is known to be in range", Hi);
3896 end if;
3897
3898 Rewrite (N,
3899 Make_Op_Ge (Loc,
3900 Left_Opnd => Lop,
3901 Right_Opnd => Low_Bound (Rop)));
3902 Analyze_And_Resolve (N, Rtyp);
3903
3904 return;
3905 end if;
3906 end;
3907
3908 -- For all other cases of an explicit range, nothing to be done
3909
3910 return;
3911
3912 -- Here right operand is a subtype mark
3913
3914 else
3915 declare
3916 Typ : Entity_Id := Etype (Rop);
3917 Is_Acc : constant Boolean := Is_Access_Type (Typ);
3918 Obj : Node_Id := Lop;
3919 Cond : Node_Id := Empty;
3920
3921 begin
3922 Remove_Side_Effects (Obj);
3923
3924 -- For tagged type, do tagged membership operation
3925
3926 if Is_Tagged_Type (Typ) then
3927
3928 -- No expansion will be performed when VM_Target, as the VM
3929 -- back-ends will handle the membership tests directly (tags
3930 -- are not explicitly represented in Java objects, so the
3931 -- normal tagged membership expansion is not what we want).
3932
3933 if VM_Target = No_VM then
3934 Rewrite (N, Tagged_Membership (N));
3935 Analyze_And_Resolve (N, Rtyp);
3936 end if;
3937
3938 return;
3939
3940 -- If type is scalar type, rewrite as x in t'first .. t'last.
3941 -- This reason we do this is that the bounds may have the wrong
3942 -- type if they come from the original type definition.
3943
3944 elsif Is_Scalar_Type (Typ) then
3945 Rewrite (Rop,
3946 Make_Range (Loc,
3947 Low_Bound =>
3948 Make_Attribute_Reference (Loc,
3949 Attribute_Name => Name_First,
3950 Prefix => New_Reference_To (Typ, Loc)),
3951
3952 High_Bound =>
3953 Make_Attribute_Reference (Loc,
3954 Attribute_Name => Name_Last,
3955 Prefix => New_Reference_To (Typ, Loc))));
3956 Analyze_And_Resolve (N, Rtyp);
3957 return;
3958
3959 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3960 -- a membership test if the subtype mark denotes a constrained
3961 -- Unchecked_Union subtype and the expression lacks inferable
3962 -- discriminants.
3963
3964 elsif Is_Unchecked_Union (Base_Type (Typ))
3965 and then Is_Constrained (Typ)
3966 and then not Has_Inferable_Discriminants (Lop)
3967 then
3968 Insert_Action (N,
3969 Make_Raise_Program_Error (Loc,
3970 Reason => PE_Unchecked_Union_Restriction));
3971
3972 -- Prevent Gigi from generating incorrect code by rewriting
3973 -- the test as a standard False.
3974
3975 Rewrite (N,
3976 New_Occurrence_Of (Standard_False, Loc));
3977
3978 return;
3979 end if;
3980
3981 -- Here we have a non-scalar type
3982
3983 if Is_Acc then
3984 Typ := Designated_Type (Typ);
3985 end if;
3986
3987 if not Is_Constrained (Typ) then
3988 Rewrite (N,
3989 New_Reference_To (Standard_True, Loc));
3990 Analyze_And_Resolve (N, Rtyp);
3991
3992 -- For the constrained array case, we have to check the
3993 -- subscripts for an exact match if the lengths are
3994 -- non-zero (the lengths must match in any case).
3995
3996 elsif Is_Array_Type (Typ) then
3997
3998 Check_Subscripts : declare
3999 function Construct_Attribute_Reference
4000 (E : Node_Id;
4001 Nam : Name_Id;
4002 Dim : Nat) return Node_Id;
4003 -- Build attribute reference E'Nam(Dim)
4004
4005 -----------------------------------
4006 -- Construct_Attribute_Reference --
4007 -----------------------------------
4008
4009 function Construct_Attribute_Reference
4010 (E : Node_Id;
4011 Nam : Name_Id;
4012 Dim : Nat) return Node_Id
4013 is
4014 begin
4015 return
4016 Make_Attribute_Reference (Loc,
4017 Prefix => E,
4018 Attribute_Name => Nam,
4019 Expressions => New_List (
4020 Make_Integer_Literal (Loc, Dim)));
4021 end Construct_Attribute_Reference;
4022
4023 -- Start processing for Check_Subscripts
4024
4025 begin
4026 for J in 1 .. Number_Dimensions (Typ) loop
4027 Evolve_And_Then (Cond,
4028 Make_Op_Eq (Loc,
4029 Left_Opnd =>
4030 Construct_Attribute_Reference
4031 (Duplicate_Subexpr_No_Checks (Obj),
4032 Name_First, J),
4033 Right_Opnd =>
4034 Construct_Attribute_Reference
4035 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
4036
4037 Evolve_And_Then (Cond,
4038 Make_Op_Eq (Loc,
4039 Left_Opnd =>
4040 Construct_Attribute_Reference
4041 (Duplicate_Subexpr_No_Checks (Obj),
4042 Name_Last, J),
4043 Right_Opnd =>
4044 Construct_Attribute_Reference
4045 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
4046 end loop;
4047
4048 if Is_Acc then
4049 Cond :=
4050 Make_Or_Else (Loc,
4051 Left_Opnd =>
4052 Make_Op_Eq (Loc,
4053 Left_Opnd => Obj,
4054 Right_Opnd => Make_Null (Loc)),
4055 Right_Opnd => Cond);
4056 end if;
4057
4058 Rewrite (N, Cond);
4059 Analyze_And_Resolve (N, Rtyp);
4060 end Check_Subscripts;
4061
4062 -- These are the cases where constraint checks may be
4063 -- required, e.g. records with possible discriminants
4064
4065 else
4066 -- Expand the test into a series of discriminant comparisons.
4067 -- The expression that is built is the negation of the one
4068 -- that is used for checking discriminant constraints.
4069
4070 Obj := Relocate_Node (Left_Opnd (N));
4071
4072 if Has_Discriminants (Typ) then
4073 Cond := Make_Op_Not (Loc,
4074 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
4075
4076 if Is_Acc then
4077 Cond := Make_Or_Else (Loc,
4078 Left_Opnd =>
4079 Make_Op_Eq (Loc,
4080 Left_Opnd => Obj,
4081 Right_Opnd => Make_Null (Loc)),
4082 Right_Opnd => Cond);
4083 end if;
4084
4085 else
4086 Cond := New_Occurrence_Of (Standard_True, Loc);
4087 end if;
4088
4089 Rewrite (N, Cond);
4090 Analyze_And_Resolve (N, Rtyp);
4091 end if;
4092 end;
4093 end if;
4094 end Expand_N_In;
4095
4096 --------------------------------
4097 -- Expand_N_Indexed_Component --
4098 --------------------------------
4099
4100 procedure Expand_N_Indexed_Component (N : Node_Id) is
4101 Loc : constant Source_Ptr := Sloc (N);
4102 Typ : constant Entity_Id := Etype (N);
4103 P : constant Node_Id := Prefix (N);
4104 T : constant Entity_Id := Etype (P);
4105
4106 begin
4107 -- A special optimization, if we have an indexed component that
4108 -- is selecting from a slice, then we can eliminate the slice,
4109 -- since, for example, x (i .. j)(k) is identical to x(k). The
4110 -- only difference is the range check required by the slice. The
4111 -- range check for the slice itself has already been generated.
4112 -- The range check for the subscripting operation is ensured
4113 -- by converting the subject to the subtype of the slice.
4114
4115 -- This optimization not only generates better code, avoiding
4116 -- slice messing especially in the packed case, but more importantly
4117 -- bypasses some problems in handling this peculiar case, for
4118 -- example, the issue of dealing specially with object renamings.
4119
4120 if Nkind (P) = N_Slice then
4121 Rewrite (N,
4122 Make_Indexed_Component (Loc,
4123 Prefix => Prefix (P),
4124 Expressions => New_List (
4125 Convert_To
4126 (Etype (First_Index (Etype (P))),
4127 First (Expressions (N))))));
4128 Analyze_And_Resolve (N, Typ);
4129 return;
4130 end if;
4131
4132 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4133 -- function, then additional actuals must be passed.
4134
4135 if Ada_Version >= Ada_05
4136 and then Is_Build_In_Place_Function_Call (P)
4137 then
4138 Make_Build_In_Place_Call_In_Anonymous_Context (P);
4139 end if;
4140
4141 -- If the prefix is an access type, then we unconditionally rewrite
4142 -- if as an explicit deference. This simplifies processing for several
4143 -- cases, including packed array cases and certain cases in which
4144 -- checks must be generated. We used to try to do this only when it
4145 -- was necessary, but it cleans up the code to do it all the time.
4146
4147 if Is_Access_Type (T) then
4148 Insert_Explicit_Dereference (P);
4149 Analyze_And_Resolve (P, Designated_Type (T));
4150 end if;
4151
4152 -- Generate index and validity checks
4153
4154 Generate_Index_Checks (N);
4155
4156 if Validity_Checks_On and then Validity_Check_Subscripts then
4157 Apply_Subscript_Validity_Checks (N);
4158 end if;
4159
4160 -- All done for the non-packed case
4161
4162 if not Is_Packed (Etype (Prefix (N))) then
4163 return;
4164 end if;
4165
4166 -- For packed arrays that are not bit-packed (i.e. the case of an array
4167 -- with one or more index types with a non-contiguous enumeration type),
4168 -- we can always use the normal packed element get circuit.
4169
4170 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
4171 Expand_Packed_Element_Reference (N);
4172 return;
4173 end if;
4174
4175 -- For a reference to a component of a bit packed array, we have to
4176 -- convert it to a reference to the corresponding Packed_Array_Type.
4177 -- We only want to do this for simple references, and not for:
4178
4179 -- Left side of assignment, or prefix of left side of assignment,
4180 -- or prefix of the prefix, to handle packed arrays of packed arrays,
4181 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4182
4183 -- Renaming objects in renaming associations
4184 -- This case is handled when a use of the renamed variable occurs
4185
4186 -- Actual parameters for a procedure call
4187 -- This case is handled in Exp_Ch6.Expand_Actuals
4188
4189 -- The second expression in a 'Read attribute reference
4190
4191 -- The prefix of an address or size attribute reference
4192
4193 -- The following circuit detects these exceptions
4194
4195 declare
4196 Child : Node_Id := N;
4197 Parnt : Node_Id := Parent (N);
4198
4199 begin
4200 loop
4201 if Nkind (Parnt) = N_Unchecked_Expression then
4202 null;
4203
4204 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
4205 N_Procedure_Call_Statement)
4206 or else (Nkind (Parnt) = N_Parameter_Association
4207 and then
4208 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
4209 then
4210 return;
4211
4212 elsif Nkind (Parnt) = N_Attribute_Reference
4213 and then (Attribute_Name (Parnt) = Name_Address
4214 or else
4215 Attribute_Name (Parnt) = Name_Size)
4216 and then Prefix (Parnt) = Child
4217 then
4218 return;
4219
4220 elsif Nkind (Parnt) = N_Assignment_Statement
4221 and then Name (Parnt) = Child
4222 then
4223 return;
4224
4225 -- If the expression is an index of an indexed component,
4226 -- it must be expanded regardless of context.
4227
4228 elsif Nkind (Parnt) = N_Indexed_Component
4229 and then Child /= Prefix (Parnt)
4230 then
4231 Expand_Packed_Element_Reference (N);
4232 return;
4233
4234 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
4235 and then Name (Parent (Parnt)) = Parnt
4236 then
4237 return;
4238
4239 elsif Nkind (Parnt) = N_Attribute_Reference
4240 and then Attribute_Name (Parnt) = Name_Read
4241 and then Next (First (Expressions (Parnt))) = Child
4242 then
4243 return;
4244
4245 elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
4246 and then Prefix (Parnt) = Child
4247 then
4248 null;
4249
4250 else
4251 Expand_Packed_Element_Reference (N);
4252 return;
4253 end if;
4254
4255 -- Keep looking up tree for unchecked expression, or if we are
4256 -- the prefix of a possible assignment left side.
4257
4258 Child := Parnt;
4259 Parnt := Parent (Child);
4260 end loop;
4261 end;
4262 end Expand_N_Indexed_Component;
4263
4264 ---------------------
4265 -- Expand_N_Not_In --
4266 ---------------------
4267
4268 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
4269 -- can be done. This avoids needing to duplicate this expansion code.
4270
4271 procedure Expand_N_Not_In (N : Node_Id) is
4272 Loc : constant Source_Ptr := Sloc (N);
4273 Typ : constant Entity_Id := Etype (N);
4274 Cfs : constant Boolean := Comes_From_Source (N);
4275
4276 begin
4277 Rewrite (N,
4278 Make_Op_Not (Loc,
4279 Right_Opnd =>
4280 Make_In (Loc,
4281 Left_Opnd => Left_Opnd (N),
4282 Right_Opnd => Right_Opnd (N))));
4283
4284 -- We want this to appear as coming from source if original does (see
4285 -- transformations in Expand_N_In).
4286
4287 Set_Comes_From_Source (N, Cfs);
4288 Set_Comes_From_Source (Right_Opnd (N), Cfs);
4289
4290 -- Now analyze transformed node
4291
4292 Analyze_And_Resolve (N, Typ);
4293 end Expand_N_Not_In;
4294
4295 -------------------
4296 -- Expand_N_Null --
4297 -------------------
4298
4299 -- The only replacement required is for the case of a null of type
4300 -- that is an access to protected subprogram. We represent such
4301 -- access values as a record, and so we must replace the occurrence
4302 -- of null by the equivalent record (with a null address and a null
4303 -- pointer in it), so that the backend creates the proper value.
4304
4305 procedure Expand_N_Null (N : Node_Id) is
4306 Loc : constant Source_Ptr := Sloc (N);
4307 Typ : constant Entity_Id := Etype (N);
4308 Agg : Node_Id;
4309
4310 begin
4311 if Is_Access_Protected_Subprogram_Type (Typ) then
4312 Agg :=
4313 Make_Aggregate (Loc,
4314 Expressions => New_List (
4315 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
4316 Make_Null (Loc)));
4317
4318 Rewrite (N, Agg);
4319 Analyze_And_Resolve (N, Equivalent_Type (Typ));
4320
4321 -- For subsequent semantic analysis, the node must retain its
4322 -- type. Gigi in any case replaces this type by the corresponding
4323 -- record type before processing the node.
4324
4325 Set_Etype (N, Typ);
4326 end if;
4327
4328 exception
4329 when RE_Not_Available =>
4330 return;
4331 end Expand_N_Null;
4332
4333 ---------------------
4334 -- Expand_N_Op_Abs --
4335 ---------------------
4336
4337 procedure Expand_N_Op_Abs (N : Node_Id) is
4338 Loc : constant Source_Ptr := Sloc (N);
4339 Expr : constant Node_Id := Right_Opnd (N);
4340
4341 begin
4342 Unary_Op_Validity_Checks (N);
4343
4344 -- Deal with software overflow checking
4345
4346 if not Backend_Overflow_Checks_On_Target
4347 and then Is_Signed_Integer_Type (Etype (N))
4348 and then Do_Overflow_Check (N)
4349 then
4350 -- The only case to worry about is when the argument is
4351 -- equal to the largest negative number, so what we do is
4352 -- to insert the check:
4353
4354 -- [constraint_error when Expr = typ'Base'First]
4355
4356 -- with the usual Duplicate_Subexpr use coding for expr
4357
4358 Insert_Action (N,
4359 Make_Raise_Constraint_Error (Loc,
4360 Condition =>
4361 Make_Op_Eq (Loc,
4362 Left_Opnd => Duplicate_Subexpr (Expr),
4363 Right_Opnd =>
4364 Make_Attribute_Reference (Loc,
4365 Prefix =>
4366 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
4367 Attribute_Name => Name_First)),
4368 Reason => CE_Overflow_Check_Failed));
4369 end if;
4370
4371 -- Vax floating-point types case
4372
4373 if Vax_Float (Etype (N)) then
4374 Expand_Vax_Arith (N);
4375 end if;
4376 end Expand_N_Op_Abs;
4377
4378 ---------------------
4379 -- Expand_N_Op_Add --
4380 ---------------------
4381
4382 procedure Expand_N_Op_Add (N : Node_Id) is
4383 Typ : constant Entity_Id := Etype (N);
4384
4385 begin
4386 Binary_Op_Validity_Checks (N);
4387
4388 -- N + 0 = 0 + N = N for integer types
4389
4390 if Is_Integer_Type (Typ) then
4391 if Compile_Time_Known_Value (Right_Opnd (N))
4392 and then Expr_Value (Right_Opnd (N)) = Uint_0
4393 then
4394 Rewrite (N, Left_Opnd (N));
4395 return;
4396
4397 elsif Compile_Time_Known_Value (Left_Opnd (N))
4398 and then Expr_Value (Left_Opnd (N)) = Uint_0
4399 then
4400 Rewrite (N, Right_Opnd (N));
4401 return;
4402 end if;
4403 end if;
4404
4405 -- Arithmetic overflow checks for signed integer/fixed point types
4406
4407 if Is_Signed_Integer_Type (Typ)
4408 or else Is_Fixed_Point_Type (Typ)
4409 then
4410 Apply_Arithmetic_Overflow_Check (N);
4411 return;
4412
4413 -- Vax floating-point types case
4414
4415 elsif Vax_Float (Typ) then
4416 Expand_Vax_Arith (N);
4417 end if;
4418 end Expand_N_Op_Add;
4419
4420 ---------------------
4421 -- Expand_N_Op_And --
4422 ---------------------
4423
4424 procedure Expand_N_Op_And (N : Node_Id) is
4425 Typ : constant Entity_Id := Etype (N);
4426
4427 begin
4428 Binary_Op_Validity_Checks (N);
4429
4430 if Is_Array_Type (Etype (N)) then
4431 Expand_Boolean_Operator (N);
4432
4433 elsif Is_Boolean_Type (Etype (N)) then
4434 Adjust_Condition (Left_Opnd (N));
4435 Adjust_Condition (Right_Opnd (N));
4436 Set_Etype (N, Standard_Boolean);
4437 Adjust_Result_Type (N, Typ);
4438 end if;
4439 end Expand_N_Op_And;
4440
4441 ------------------------
4442 -- Expand_N_Op_Concat --
4443 ------------------------
4444
4445 Max_Available_String_Operands : Int := -1;
4446 -- This is initialized the first time this routine is called. It records
4447 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4448 -- available in the run-time:
4449 --
4450 -- 0 None available
4451 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
4452 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4453 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4454 -- 5 All routines including RE_Str_Concat_5 available
4455
4456 Char_Concat_Available : Boolean;
4457 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4458 -- all three are available, False if any one of these is unavailable.
4459
4460 procedure Expand_N_Op_Concat (N : Node_Id) is
4461 Opnds : List_Id;
4462 -- List of operands to be concatenated
4463
4464 Opnd : Node_Id;
4465 -- Single operand for concatenation
4466
4467 Cnode : Node_Id;
4468 -- Node which is to be replaced by the result of concatenating
4469 -- the nodes in the list Opnds.
4470
4471 Atyp : Entity_Id;
4472 -- Array type of concatenation result type
4473
4474 Ctyp : Entity_Id;
4475 -- Component type of concatenation represented by Cnode
4476
4477 begin
4478 -- Initialize global variables showing run-time status
4479
4480 if Max_Available_String_Operands < 1 then
4481
4482 -- See what routines are available and set max operand count
4483 -- according to the highest count available in the run-time.
4484
4485 if not RTE_Available (RE_Str_Concat) then
4486 Max_Available_String_Operands := 0;
4487
4488 elsif not RTE_Available (RE_Str_Concat_3) then
4489 Max_Available_String_Operands := 2;
4490
4491 elsif not RTE_Available (RE_Str_Concat_4) then
4492 Max_Available_String_Operands := 3;
4493
4494 elsif not RTE_Available (RE_Str_Concat_5) then
4495 Max_Available_String_Operands := 4;
4496
4497 else
4498 Max_Available_String_Operands := 5;
4499 end if;
4500
4501 Char_Concat_Available :=
4502 RTE_Available (RE_Str_Concat_CC)
4503 and then
4504 RTE_Available (RE_Str_Concat_CS)
4505 and then
4506 RTE_Available (RE_Str_Concat_SC);
4507 end if;
4508
4509 -- Ensure validity of both operands
4510
4511 Binary_Op_Validity_Checks (N);
4512
4513 -- If we are the left operand of a concatenation higher up the
4514 -- tree, then do nothing for now, since we want to deal with a
4515 -- series of concatenations as a unit.
4516
4517 if Nkind (Parent (N)) = N_Op_Concat
4518 and then N = Left_Opnd (Parent (N))
4519 then
4520 return;
4521 end if;
4522
4523 -- We get here with a concatenation whose left operand may be a
4524 -- concatenation itself with a consistent type. We need to process
4525 -- these concatenation operands from left to right, which means
4526 -- from the deepest node in the tree to the highest node.
4527
4528 Cnode := N;
4529 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
4530 Cnode := Left_Opnd (Cnode);
4531 end loop;
4532
4533 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
4534 -- nodes above, so now we process bottom up, doing the operations. We
4535 -- gather a string that is as long as possible up to five operands
4536
4537 -- The outer loop runs more than once if there are more than five
4538 -- concatenations of type Standard.String, the most we handle for
4539 -- this case, or if more than one concatenation type is involved.
4540
4541 Outer : loop
4542 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
4543 Set_Parent (Opnds, N);
4544
4545 -- The inner loop gathers concatenation operands. We gather any
4546 -- number of these in the non-string case, or if no concatenation
4547 -- routines are available for string (since in that case we will
4548 -- treat string like any other non-string case). Otherwise we only
4549 -- gather as many operands as can be handled by the available
4550 -- procedures in the run-time library (normally 5, but may be
4551 -- less for the configurable run-time case).
4552
4553 Inner : while Cnode /= N
4554 and then (Base_Type (Etype (Cnode)) /= Standard_String
4555 or else
4556 Max_Available_String_Operands = 0
4557 or else
4558 List_Length (Opnds) <
4559 Max_Available_String_Operands)
4560 and then Base_Type (Etype (Cnode)) =
4561 Base_Type (Etype (Parent (Cnode)))
4562 loop
4563 Cnode := Parent (Cnode);
4564 Append (Right_Opnd (Cnode), Opnds);
4565 end loop Inner;
4566
4567 -- Here we process the collected operands. First we convert
4568 -- singleton operands to singleton aggregates. This is skipped
4569 -- however for the case of two operands of type String, since
4570 -- we have special routines for these cases.
4571
4572 Atyp := Base_Type (Etype (Cnode));
4573 Ctyp := Base_Type (Component_Type (Etype (Cnode)));
4574
4575 if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
4576 or else not Char_Concat_Available
4577 then
4578 Opnd := First (Opnds);
4579 loop
4580 if Base_Type (Etype (Opnd)) = Ctyp then
4581 Rewrite (Opnd,
4582 Make_Aggregate (Sloc (Cnode),
4583 Expressions => New_List (Relocate_Node (Opnd))));
4584 Analyze_And_Resolve (Opnd, Atyp);
4585 end if;
4586
4587 Next (Opnd);
4588 exit when No (Opnd);
4589 end loop;
4590 end if;
4591
4592 -- Now call appropriate continuation routine
4593
4594 if Atyp = Standard_String
4595 and then Max_Available_String_Operands > 0
4596 then
4597 Expand_Concatenate_String (Cnode, Opnds);
4598 else
4599 Expand_Concatenate_Other (Cnode, Opnds);
4600 end if;
4601
4602 exit Outer when Cnode = N;
4603 Cnode := Parent (Cnode);
4604 end loop Outer;
4605 end Expand_N_Op_Concat;
4606
4607 ------------------------
4608 -- Expand_N_Op_Divide --
4609 ------------------------
4610
4611 procedure Expand_N_Op_Divide (N : Node_Id) is
4612 Loc : constant Source_Ptr := Sloc (N);
4613 Lopnd : constant Node_Id := Left_Opnd (N);
4614 Ropnd : constant Node_Id := Right_Opnd (N);
4615 Ltyp : constant Entity_Id := Etype (Lopnd);
4616 Rtyp : constant Entity_Id := Etype (Ropnd);
4617 Typ : Entity_Id := Etype (N);
4618 Rknow : constant Boolean := Is_Integer_Type (Typ)
4619 and then
4620 Compile_Time_Known_Value (Ropnd);
4621 Rval : Uint;
4622
4623 begin
4624 Binary_Op_Validity_Checks (N);
4625
4626 if Rknow then
4627 Rval := Expr_Value (Ropnd);
4628 end if;
4629
4630 -- N / 1 = N for integer types
4631
4632 if Rknow and then Rval = Uint_1 then
4633 Rewrite (N, Lopnd);
4634 return;
4635 end if;
4636
4637 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4638 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4639 -- operand is an unsigned integer, as required for this to work.
4640
4641 if Nkind (Ropnd) = N_Op_Expon
4642 and then Is_Power_Of_2_For_Shift (Ropnd)
4643
4644 -- We cannot do this transformation in configurable run time mode if we
4645 -- have 64-bit -- integers and long shifts are not available.
4646
4647 and then
4648 (Esize (Ltyp) <= 32
4649 or else Support_Long_Shifts_On_Target)
4650 then
4651 Rewrite (N,
4652 Make_Op_Shift_Right (Loc,
4653 Left_Opnd => Lopnd,
4654 Right_Opnd =>
4655 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
4656 Analyze_And_Resolve (N, Typ);
4657 return;
4658 end if;
4659
4660 -- Do required fixup of universal fixed operation
4661
4662 if Typ = Universal_Fixed then
4663 Fixup_Universal_Fixed_Operation (N);
4664 Typ := Etype (N);
4665 end if;
4666
4667 -- Divisions with fixed-point results
4668
4669 if Is_Fixed_Point_Type (Typ) then
4670
4671 -- No special processing if Treat_Fixed_As_Integer is set,
4672 -- since from a semantic point of view such operations are
4673 -- simply integer operations and will be treated that way.
4674
4675 if not Treat_Fixed_As_Integer (N) then
4676 if Is_Integer_Type (Rtyp) then
4677 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
4678 else
4679 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
4680 end if;
4681 end if;
4682
4683 -- Other cases of division of fixed-point operands. Again we
4684 -- exclude the case where Treat_Fixed_As_Integer is set.
4685
4686 elsif (Is_Fixed_Point_Type (Ltyp) or else
4687 Is_Fixed_Point_Type (Rtyp))
4688 and then not Treat_Fixed_As_Integer (N)
4689 then
4690 if Is_Integer_Type (Typ) then
4691 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
4692 else
4693 pragma Assert (Is_Floating_Point_Type (Typ));
4694 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
4695 end if;
4696
4697 -- Mixed-mode operations can appear in a non-static universal
4698 -- context, in which case the integer argument must be converted
4699 -- explicitly.
4700
4701 elsif Typ = Universal_Real
4702 and then Is_Integer_Type (Rtyp)
4703 then
4704 Rewrite (Ropnd,
4705 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
4706
4707 Analyze_And_Resolve (Ropnd, Universal_Real);
4708
4709 elsif Typ = Universal_Real
4710 and then Is_Integer_Type (Ltyp)
4711 then
4712 Rewrite (Lopnd,
4713 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
4714
4715 Analyze_And_Resolve (Lopnd, Universal_Real);
4716
4717 -- Non-fixed point cases, do integer zero divide and overflow checks
4718
4719 elsif Is_Integer_Type (Typ) then
4720 Apply_Divide_Check (N);
4721
4722 -- Check for 64-bit division available, or long shifts if the divisor
4723 -- is a small power of 2 (since such divides will be converted into
4724 -- long shifts.
4725
4726 if Esize (Ltyp) > 32
4727 and then not Support_64_Bit_Divides_On_Target
4728 and then
4729 (not Rknow
4730 or else not Support_Long_Shifts_On_Target
4731 or else (Rval /= Uint_2 and then
4732 Rval /= Uint_4 and then
4733 Rval /= Uint_8 and then
4734 Rval /= Uint_16 and then
4735 Rval /= Uint_32 and then
4736 Rval /= Uint_64))
4737 then
4738 Error_Msg_CRT ("64-bit division", N);
4739 end if;
4740
4741 -- Deal with Vax_Float
4742
4743 elsif Vax_Float (Typ) then
4744 Expand_Vax_Arith (N);
4745 return;
4746 end if;
4747 end Expand_N_Op_Divide;
4748
4749 --------------------
4750 -- Expand_N_Op_Eq --
4751 --------------------
4752
4753 procedure Expand_N_Op_Eq (N : Node_Id) is
4754 Loc : constant Source_Ptr := Sloc (N);
4755 Typ : constant Entity_Id := Etype (N);
4756 Lhs : constant Node_Id := Left_Opnd (N);
4757 Rhs : constant Node_Id := Right_Opnd (N);
4758 Bodies : constant List_Id := New_List;
4759 A_Typ : constant Entity_Id := Etype (Lhs);
4760
4761 Typl : Entity_Id := A_Typ;
4762 Op_Name : Entity_Id;
4763 Prim : Elmt_Id;
4764
4765 procedure Build_Equality_Call (Eq : Entity_Id);
4766 -- If a constructed equality exists for the type or for its parent,
4767 -- build and analyze call, adding conversions if the operation is
4768 -- inherited.
4769
4770 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
4771 -- Determines whether a type has a subcomponent of an unconstrained
4772 -- Unchecked_Union subtype. Typ is a record type.
4773
4774 -------------------------
4775 -- Build_Equality_Call --
4776 -------------------------
4777
4778 procedure Build_Equality_Call (Eq : Entity_Id) is
4779 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
4780 L_Exp : Node_Id := Relocate_Node (Lhs);
4781 R_Exp : Node_Id := Relocate_Node (Rhs);
4782
4783 begin
4784 if Base_Type (Op_Type) /= Base_Type (A_Typ)
4785 and then not Is_Class_Wide_Type (A_Typ)
4786 then
4787 L_Exp := OK_Convert_To (Op_Type, L_Exp);
4788 R_Exp := OK_Convert_To (Op_Type, R_Exp);
4789 end if;
4790
4791 -- If we have an Unchecked_Union, we need to add the inferred
4792 -- discriminant values as actuals in the function call. At this
4793 -- point, the expansion has determined that both operands have
4794 -- inferable discriminants.
4795
4796 if Is_Unchecked_Union (Op_Type) then
4797 declare
4798 Lhs_Type : constant Node_Id := Etype (L_Exp);
4799 Rhs_Type : constant Node_Id := Etype (R_Exp);
4800 Lhs_Discr_Val : Node_Id;
4801 Rhs_Discr_Val : Node_Id;
4802
4803 begin
4804 -- Per-object constrained selected components require special
4805 -- attention. If the enclosing scope of the component is an
4806 -- Unchecked_Union, we cannot reference its discriminants
4807 -- directly. This is why we use the two extra parameters of
4808 -- the equality function of the enclosing Unchecked_Union.
4809
4810 -- type UU_Type (Discr : Integer := 0) is
4811 -- . . .
4812 -- end record;
4813 -- pragma Unchecked_Union (UU_Type);
4814
4815 -- 1. Unchecked_Union enclosing record:
4816
4817 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4818 -- . . .
4819 -- Comp : UU_Type (Discr);
4820 -- . . .
4821 -- end Enclosing_UU_Type;
4822 -- pragma Unchecked_Union (Enclosing_UU_Type);
4823
4824 -- Obj1 : Enclosing_UU_Type;
4825 -- Obj2 : Enclosing_UU_Type (1);
4826
4827 -- [. . .] Obj1 = Obj2 [. . .]
4828
4829 -- Generated code:
4830
4831 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4832
4833 -- A and B are the formal parameters of the equality function
4834 -- of Enclosing_UU_Type. The function always has two extra
4835 -- formals to capture the inferred discriminant values.
4836
4837 -- 2. Non-Unchecked_Union enclosing record:
4838
4839 -- type
4840 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4841 -- is record
4842 -- . . .
4843 -- Comp : UU_Type (Discr);
4844 -- . . .
4845 -- end Enclosing_Non_UU_Type;
4846
4847 -- Obj1 : Enclosing_Non_UU_Type;
4848 -- Obj2 : Enclosing_Non_UU_Type (1);
4849
4850 -- ... Obj1 = Obj2 ...
4851
4852 -- Generated code:
4853
4854 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4855 -- obj1.discr, obj2.discr)) then
4856
4857 -- In this case we can directly reference the discriminants of
4858 -- the enclosing record.
4859
4860 -- Lhs of equality
4861
4862 if Nkind (Lhs) = N_Selected_Component
4863 and then Has_Per_Object_Constraint
4864 (Entity (Selector_Name (Lhs)))
4865 then
4866 -- Enclosing record is an Unchecked_Union, use formal A
4867
4868 if Is_Unchecked_Union (Scope
4869 (Entity (Selector_Name (Lhs))))
4870 then
4871 Lhs_Discr_Val :=
4872 Make_Identifier (Loc,
4873 Chars => Name_A);
4874
4875 -- Enclosing record is of a non-Unchecked_Union type, it is
4876 -- possible to reference the discriminant.
4877
4878 else
4879 Lhs_Discr_Val :=
4880 Make_Selected_Component (Loc,
4881 Prefix => Prefix (Lhs),
4882 Selector_Name =>
4883 New_Copy
4884 (Get_Discriminant_Value
4885 (First_Discriminant (Lhs_Type),
4886 Lhs_Type,
4887 Stored_Constraint (Lhs_Type))));
4888 end if;
4889
4890 -- Comment needed here ???
4891
4892 else
4893 -- Infer the discriminant value
4894
4895 Lhs_Discr_Val :=
4896 New_Copy
4897 (Get_Discriminant_Value
4898 (First_Discriminant (Lhs_Type),
4899 Lhs_Type,
4900 Stored_Constraint (Lhs_Type)));
4901 end if;
4902
4903 -- Rhs of equality
4904
4905 if Nkind (Rhs) = N_Selected_Component
4906 and then Has_Per_Object_Constraint
4907 (Entity (Selector_Name (Rhs)))
4908 then
4909 if Is_Unchecked_Union
4910 (Scope (Entity (Selector_Name (Rhs))))
4911 then
4912 Rhs_Discr_Val :=
4913 Make_Identifier (Loc,
4914 Chars => Name_B);
4915
4916 else
4917 Rhs_Discr_Val :=
4918 Make_Selected_Component (Loc,
4919 Prefix => Prefix (Rhs),
4920 Selector_Name =>
4921 New_Copy (Get_Discriminant_Value (
4922 First_Discriminant (Rhs_Type),
4923 Rhs_Type,
4924 Stored_Constraint (Rhs_Type))));
4925
4926 end if;
4927 else
4928 Rhs_Discr_Val :=
4929 New_Copy (Get_Discriminant_Value (
4930 First_Discriminant (Rhs_Type),
4931 Rhs_Type,
4932 Stored_Constraint (Rhs_Type)));
4933
4934 end if;
4935
4936 Rewrite (N,
4937 Make_Function_Call (Loc,
4938 Name => New_Reference_To (Eq, Loc),
4939 Parameter_Associations => New_List (
4940 L_Exp,
4941 R_Exp,
4942 Lhs_Discr_Val,
4943 Rhs_Discr_Val)));
4944 end;
4945
4946 -- Normal case, not an unchecked union
4947
4948 else
4949 Rewrite (N,
4950 Make_Function_Call (Loc,
4951 Name => New_Reference_To (Eq, Loc),
4952 Parameter_Associations => New_List (L_Exp, R_Exp)));
4953 end if;
4954
4955 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4956 end Build_Equality_Call;
4957
4958 ------------------------------------
4959 -- Has_Unconstrained_UU_Component --
4960 ------------------------------------
4961
4962 function Has_Unconstrained_UU_Component
4963 (Typ : Node_Id) return Boolean
4964 is
4965 Tdef : constant Node_Id :=
4966 Type_Definition (Declaration_Node (Base_Type (Typ)));
4967 Clist : Node_Id;
4968 Vpart : Node_Id;
4969
4970 function Component_Is_Unconstrained_UU
4971 (Comp : Node_Id) return Boolean;
4972 -- Determines whether the subtype of the component is an
4973 -- unconstrained Unchecked_Union.
4974
4975 function Variant_Is_Unconstrained_UU
4976 (Variant : Node_Id) return Boolean;
4977 -- Determines whether a component of the variant has an unconstrained
4978 -- Unchecked_Union subtype.
4979
4980 -----------------------------------
4981 -- Component_Is_Unconstrained_UU --
4982 -----------------------------------
4983
4984 function Component_Is_Unconstrained_UU
4985 (Comp : Node_Id) return Boolean
4986 is
4987 begin
4988 if Nkind (Comp) /= N_Component_Declaration then
4989 return False;
4990 end if;
4991
4992 declare
4993 Sindic : constant Node_Id :=
4994 Subtype_Indication (Component_Definition (Comp));
4995
4996 begin
4997 -- Unconstrained nominal type. In the case of a constraint
4998 -- present, the node kind would have been N_Subtype_Indication.
4999
5000 if Nkind (Sindic) = N_Identifier then
5001 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
5002 end if;
5003
5004 return False;
5005 end;
5006 end Component_Is_Unconstrained_UU;
5007
5008 ---------------------------------
5009 -- Variant_Is_Unconstrained_UU --
5010 ---------------------------------
5011
5012 function Variant_Is_Unconstrained_UU
5013 (Variant : Node_Id) return Boolean
5014 is
5015 Clist : constant Node_Id := Component_List (Variant);
5016
5017 begin
5018 if Is_Empty_List (Component_Items (Clist)) then
5019 return False;
5020 end if;
5021
5022 -- We only need to test one component
5023
5024 declare
5025 Comp : Node_Id := First (Component_Items (Clist));
5026
5027 begin
5028 while Present (Comp) loop
5029 if Component_Is_Unconstrained_UU (Comp) then
5030 return True;
5031 end if;
5032
5033 Next (Comp);
5034 end loop;
5035 end;
5036
5037 -- None of the components withing the variant were of
5038 -- unconstrained Unchecked_Union type.
5039
5040 return False;
5041 end Variant_Is_Unconstrained_UU;
5042
5043 -- Start of processing for Has_Unconstrained_UU_Component
5044
5045 begin
5046 if Null_Present (Tdef) then
5047 return False;
5048 end if;
5049
5050 Clist := Component_List (Tdef);
5051 Vpart := Variant_Part (Clist);
5052
5053 -- Inspect available components
5054
5055 if Present (Component_Items (Clist)) then
5056 declare
5057 Comp : Node_Id := First (Component_Items (Clist));
5058
5059 begin
5060 while Present (Comp) loop
5061
5062 -- One component is sufficient
5063
5064 if Component_Is_Unconstrained_UU (Comp) then
5065 return True;
5066 end if;
5067
5068 Next (Comp);
5069 end loop;
5070 end;
5071 end if;
5072
5073 -- Inspect available components withing variants
5074
5075 if Present (Vpart) then
5076 declare
5077 Variant : Node_Id := First (Variants (Vpart));
5078
5079 begin
5080 while Present (Variant) loop
5081
5082 -- One component within a variant is sufficient
5083
5084 if Variant_Is_Unconstrained_UU (Variant) then
5085 return True;
5086 end if;
5087
5088 Next (Variant);
5089 end loop;
5090 end;
5091 end if;
5092
5093 -- Neither the available components, nor the components inside the
5094 -- variant parts were of an unconstrained Unchecked_Union subtype.
5095
5096 return False;
5097 end Has_Unconstrained_UU_Component;
5098
5099 -- Start of processing for Expand_N_Op_Eq
5100
5101 begin
5102 Binary_Op_Validity_Checks (N);
5103
5104 if Ekind (Typl) = E_Private_Type then
5105 Typl := Underlying_Type (Typl);
5106 elsif Ekind (Typl) = E_Private_Subtype then
5107 Typl := Underlying_Type (Base_Type (Typl));
5108 else
5109 null;
5110 end if;
5111
5112 -- It may happen in error situations that the underlying type is not
5113 -- set. The error will be detected later, here we just defend the
5114 -- expander code.
5115
5116 if No (Typl) then
5117 return;
5118 end if;
5119
5120 Typl := Base_Type (Typl);
5121
5122 -- Boolean types (requiring handling of non-standard case)
5123
5124 if Is_Boolean_Type (Typl) then
5125 Adjust_Condition (Left_Opnd (N));
5126 Adjust_Condition (Right_Opnd (N));
5127 Set_Etype (N, Standard_Boolean);
5128 Adjust_Result_Type (N, Typ);
5129
5130 -- Array types
5131
5132 elsif Is_Array_Type (Typl) then
5133
5134 -- If we are doing full validity checking, and it is possible for the
5135 -- array elements to be invalid then expand out array comparisons to
5136 -- make sure that we check the array elements.
5137
5138 if Validity_Check_Operands
5139 and then not Is_Known_Valid (Component_Type (Typl))
5140 then
5141 declare
5142 Save_Force_Validity_Checks : constant Boolean :=
5143 Force_Validity_Checks;
5144 begin
5145 Force_Validity_Checks := True;
5146 Rewrite (N,
5147 Expand_Array_Equality
5148 (N,
5149 Relocate_Node (Lhs),
5150 Relocate_Node (Rhs),
5151 Bodies,
5152 Typl));
5153 Insert_Actions (N, Bodies);
5154 Analyze_And_Resolve (N, Standard_Boolean);
5155 Force_Validity_Checks := Save_Force_Validity_Checks;
5156 end;
5157
5158 -- Packed case where both operands are known aligned
5159
5160 elsif Is_Bit_Packed_Array (Typl)
5161 and then not Is_Possibly_Unaligned_Object (Lhs)
5162 and then not Is_Possibly_Unaligned_Object (Rhs)
5163 then
5164 Expand_Packed_Eq (N);
5165
5166 -- Where the component type is elementary we can use a block bit
5167 -- comparison (if supported on the target) exception in the case
5168 -- of floating-point (negative zero issues require element by
5169 -- element comparison), and atomic types (where we must be sure
5170 -- to load elements independently) and possibly unaligned arrays.
5171
5172 elsif Is_Elementary_Type (Component_Type (Typl))
5173 and then not Is_Floating_Point_Type (Component_Type (Typl))
5174 and then not Is_Atomic (Component_Type (Typl))
5175 and then not Is_Possibly_Unaligned_Object (Lhs)
5176 and then not Is_Possibly_Unaligned_Object (Rhs)
5177 and then Support_Composite_Compare_On_Target
5178 then
5179 null;
5180
5181 -- For composite and floating-point cases, expand equality loop
5182 -- to make sure of using proper comparisons for tagged types,
5183 -- and correctly handling the floating-point case.
5184
5185 else
5186 Rewrite (N,
5187 Expand_Array_Equality
5188 (N,
5189 Relocate_Node (Lhs),
5190 Relocate_Node (Rhs),
5191 Bodies,
5192 Typl));
5193 Insert_Actions (N, Bodies, Suppress => All_Checks);
5194 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5195 end if;
5196
5197 -- Record Types
5198
5199 elsif Is_Record_Type (Typl) then
5200
5201 -- For tagged types, use the primitive "="
5202
5203 if Is_Tagged_Type (Typl) then
5204
5205 -- No need to do anything else compiling under restriction
5206 -- No_Dispatching_Calls. During the semantic analysis we
5207 -- already notified such violation.
5208
5209 if Restriction_Active (No_Dispatching_Calls) then
5210 return;
5211 end if;
5212
5213 -- If this is derived from an untagged private type completed
5214 -- with a tagged type, it does not have a full view, so we
5215 -- use the primitive operations of the private type.
5216 -- This check should no longer be necessary when these
5217 -- types receive their full views ???
5218
5219 if Is_Private_Type (A_Typ)
5220 and then not Is_Tagged_Type (A_Typ)
5221 and then Is_Derived_Type (A_Typ)
5222 and then No (Full_View (A_Typ))
5223 then
5224 -- Search for equality operation, checking that the
5225 -- operands have the same type. Note that we must find
5226 -- a matching entry, or something is very wrong!
5227
5228 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
5229
5230 while Present (Prim) loop
5231 exit when Chars (Node (Prim)) = Name_Op_Eq
5232 and then Etype (First_Formal (Node (Prim))) =
5233 Etype (Next_Formal (First_Formal (Node (Prim))))
5234 and then
5235 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5236
5237 Next_Elmt (Prim);
5238 end loop;
5239
5240 pragma Assert (Present (Prim));
5241 Op_Name := Node (Prim);
5242
5243 -- Find the type's predefined equality or an overriding
5244 -- user-defined equality. The reason for not simply calling
5245 -- Find_Prim_Op here is that there may be a user-defined
5246 -- overloaded equality op that precedes the equality that
5247 -- we want, so we have to explicitly search (e.g., there
5248 -- could be an equality with two different parameter types).
5249
5250 else
5251 if Is_Class_Wide_Type (Typl) then
5252 Typl := Root_Type (Typl);
5253 end if;
5254
5255 Prim := First_Elmt (Primitive_Operations (Typl));
5256 while Present (Prim) loop
5257 exit when Chars (Node (Prim)) = Name_Op_Eq
5258 and then Etype (First_Formal (Node (Prim))) =
5259 Etype (Next_Formal (First_Formal (Node (Prim))))
5260 and then
5261 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5262
5263 Next_Elmt (Prim);
5264 end loop;
5265
5266 pragma Assert (Present (Prim));
5267 Op_Name := Node (Prim);
5268 end if;
5269
5270 Build_Equality_Call (Op_Name);
5271
5272 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5273 -- predefined equality operator for a type which has a subcomponent
5274 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5275
5276 elsif Has_Unconstrained_UU_Component (Typl) then
5277 Insert_Action (N,
5278 Make_Raise_Program_Error (Loc,
5279 Reason => PE_Unchecked_Union_Restriction));
5280
5281 -- Prevent Gigi from generating incorrect code by rewriting the
5282 -- equality as a standard False.
5283
5284 Rewrite (N,
5285 New_Occurrence_Of (Standard_False, Loc));
5286
5287 elsif Is_Unchecked_Union (Typl) then
5288
5289 -- If we can infer the discriminants of the operands, we make a
5290 -- call to the TSS equality function.
5291
5292 if Has_Inferable_Discriminants (Lhs)
5293 and then
5294 Has_Inferable_Discriminants (Rhs)
5295 then
5296 Build_Equality_Call
5297 (TSS (Root_Type (Typl), TSS_Composite_Equality));
5298
5299 else
5300 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5301 -- the predefined equality operator for an Unchecked_Union type
5302 -- if either of the operands lack inferable discriminants.
5303
5304 Insert_Action (N,
5305 Make_Raise_Program_Error (Loc,
5306 Reason => PE_Unchecked_Union_Restriction));
5307
5308 -- Prevent Gigi from generating incorrect code by rewriting
5309 -- the equality as a standard False.
5310
5311 Rewrite (N,
5312 New_Occurrence_Of (Standard_False, Loc));
5313
5314 end if;
5315
5316 -- If a type support function is present (for complex cases), use it
5317
5318 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
5319 Build_Equality_Call
5320 (TSS (Root_Type (Typl), TSS_Composite_Equality));
5321
5322 -- Otherwise expand the component by component equality. Note that
5323 -- we never use block-bit comparisons for records, because of the
5324 -- problems with gaps. The backend will often be able to recombine
5325 -- the separate comparisons that we generate here.
5326
5327 else
5328 Remove_Side_Effects (Lhs);
5329 Remove_Side_Effects (Rhs);
5330 Rewrite (N,
5331 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
5332
5333 Insert_Actions (N, Bodies, Suppress => All_Checks);
5334 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5335 end if;
5336 end if;
5337
5338 -- Test if result is known at compile time
5339
5340 Rewrite_Comparison (N);
5341
5342 -- If we still have comparison for Vax_Float, process it
5343
5344 if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then
5345 Expand_Vax_Comparison (N);
5346 return;
5347 end if;
5348 end Expand_N_Op_Eq;
5349
5350 -----------------------
5351 -- Expand_N_Op_Expon --
5352 -----------------------
5353
5354 procedure Expand_N_Op_Expon (N : Node_Id) is
5355 Loc : constant Source_Ptr := Sloc (N);
5356 Typ : constant Entity_Id := Etype (N);
5357 Rtyp : constant Entity_Id := Root_Type (Typ);
5358 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
5359 Bastyp : constant Node_Id := Etype (Base);
5360 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
5361 Exptyp : constant Entity_Id := Etype (Exp);
5362 Ovflo : constant Boolean := Do_Overflow_Check (N);
5363 Expv : Uint;
5364 Xnode : Node_Id;
5365 Temp : Node_Id;
5366 Rent : RE_Id;
5367 Ent : Entity_Id;
5368 Etyp : Entity_Id;
5369
5370 begin
5371 Binary_Op_Validity_Checks (N);
5372
5373 -- If either operand is of a private type, then we have the use of
5374 -- an intrinsic operator, and we get rid of the privateness, by using
5375 -- root types of underlying types for the actual operation. Otherwise
5376 -- the private types will cause trouble if we expand multiplications
5377 -- or shifts etc. We also do this transformation if the result type
5378 -- is different from the base type.
5379
5380 if Is_Private_Type (Etype (Base))
5381 or else
5382 Is_Private_Type (Typ)
5383 or else
5384 Is_Private_Type (Exptyp)
5385 or else
5386 Rtyp /= Root_Type (Bastyp)
5387 then
5388 declare
5389 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
5390 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
5391
5392 begin
5393 Rewrite (N,
5394 Unchecked_Convert_To (Typ,
5395 Make_Op_Expon (Loc,
5396 Left_Opnd => Unchecked_Convert_To (Bt, Base),
5397 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
5398 Analyze_And_Resolve (N, Typ);
5399 return;
5400 end;
5401 end if;
5402
5403 -- Test for case of known right argument
5404
5405 if Compile_Time_Known_Value (Exp) then
5406 Expv := Expr_Value (Exp);
5407
5408 -- We only fold small non-negative exponents. You might think we
5409 -- could fold small negative exponents for the real case, but we
5410 -- can't because we are required to raise Constraint_Error for
5411 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
5412 -- See ACVC test C4A012B.
5413
5414 if Expv >= 0 and then Expv <= 4 then
5415
5416 -- X ** 0 = 1 (or 1.0)
5417
5418 if Expv = 0 then
5419 if Ekind (Typ) in Integer_Kind then
5420 Xnode := Make_Integer_Literal (Loc, Intval => 1);
5421 else
5422 Xnode := Make_Real_Literal (Loc, Ureal_1);
5423 end if;
5424
5425 -- X ** 1 = X
5426
5427 elsif Expv = 1 then
5428 Xnode := Base;
5429
5430 -- X ** 2 = X * X
5431
5432 elsif Expv = 2 then
5433 Xnode :=
5434 Make_Op_Multiply (Loc,
5435 Left_Opnd => Duplicate_Subexpr (Base),
5436 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
5437
5438 -- X ** 3 = X * X * X
5439
5440 elsif Expv = 3 then
5441 Xnode :=
5442 Make_Op_Multiply (Loc,
5443 Left_Opnd =>
5444 Make_Op_Multiply (Loc,
5445 Left_Opnd => Duplicate_Subexpr (Base),
5446 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
5447 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
5448
5449 -- X ** 4 ->
5450 -- En : constant base'type := base * base;
5451 -- ...
5452 -- En * En
5453
5454 else -- Expv = 4
5455 Temp :=
5456 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5457
5458 Insert_Actions (N, New_List (
5459 Make_Object_Declaration (Loc,
5460 Defining_Identifier => Temp,
5461 Constant_Present => True,
5462 Object_Definition => New_Reference_To (Typ, Loc),
5463 Expression =>
5464 Make_Op_Multiply (Loc,
5465 Left_Opnd => Duplicate_Subexpr (Base),
5466 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
5467
5468 Xnode :=
5469 Make_Op_Multiply (Loc,
5470 Left_Opnd => New_Reference_To (Temp, Loc),
5471 Right_Opnd => New_Reference_To (Temp, Loc));
5472 end if;
5473
5474 Rewrite (N, Xnode);
5475 Analyze_And_Resolve (N, Typ);
5476 return;
5477 end if;
5478 end if;
5479
5480 -- Case of (2 ** expression) appearing as an argument of an integer
5481 -- multiplication, or as the right argument of a division of a non-
5482 -- negative integer. In such cases we leave the node untouched, setting
5483 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5484 -- of the higher level node converts it into a shift.
5485
5486 if Nkind (Base) = N_Integer_Literal
5487 and then Intval (Base) = 2
5488 and then Is_Integer_Type (Root_Type (Exptyp))
5489 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
5490 and then Is_Unsigned_Type (Exptyp)
5491 and then not Ovflo
5492 and then Nkind (Parent (N)) in N_Binary_Op
5493 then
5494 declare
5495 P : constant Node_Id := Parent (N);
5496 L : constant Node_Id := Left_Opnd (P);
5497 R : constant Node_Id := Right_Opnd (P);
5498
5499 begin
5500 if (Nkind (P) = N_Op_Multiply
5501 and then
5502 ((Is_Integer_Type (Etype (L)) and then R = N)
5503 or else
5504 (Is_Integer_Type (Etype (R)) and then L = N))
5505 and then not Do_Overflow_Check (P))
5506
5507 or else
5508 (Nkind (P) = N_Op_Divide
5509 and then Is_Integer_Type (Etype (L))
5510 and then Is_Unsigned_Type (Etype (L))
5511 and then R = N
5512 and then not Do_Overflow_Check (P))
5513 then
5514 Set_Is_Power_Of_2_For_Shift (N);
5515 return;
5516 end if;
5517 end;
5518 end if;
5519
5520 -- Fall through if exponentiation must be done using a runtime routine
5521
5522 -- First deal with modular case
5523
5524 if Is_Modular_Integer_Type (Rtyp) then
5525
5526 -- Non-binary case, we call the special exponentiation routine for
5527 -- the non-binary case, converting the argument to Long_Long_Integer
5528 -- and passing the modulus value. Then the result is converted back
5529 -- to the base type.
5530
5531 if Non_Binary_Modulus (Rtyp) then
5532 Rewrite (N,
5533 Convert_To (Typ,
5534 Make_Function_Call (Loc,
5535 Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
5536 Parameter_Associations => New_List (
5537 Convert_To (Standard_Integer, Base),
5538 Make_Integer_Literal (Loc, Modulus (Rtyp)),
5539 Exp))));
5540
5541 -- Binary case, in this case, we call one of two routines, either
5542 -- the unsigned integer case, or the unsigned long long integer
5543 -- case, with a final "and" operation to do the required mod.
5544
5545 else
5546 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
5547 Ent := RTE (RE_Exp_Unsigned);
5548 else
5549 Ent := RTE (RE_Exp_Long_Long_Unsigned);
5550 end if;
5551
5552 Rewrite (N,
5553 Convert_To (Typ,
5554 Make_Op_And (Loc,
5555 Left_Opnd =>
5556 Make_Function_Call (Loc,
5557 Name => New_Reference_To (Ent, Loc),
5558 Parameter_Associations => New_List (
5559 Convert_To (Etype (First_Formal (Ent)), Base),
5560 Exp)),
5561 Right_Opnd =>
5562 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
5563
5564 end if;
5565
5566 -- Common exit point for modular type case
5567
5568 Analyze_And_Resolve (N, Typ);
5569 return;
5570
5571 -- Signed integer cases, done using either Integer or Long_Long_Integer.
5572 -- It is not worth having routines for Short_[Short_]Integer, since for
5573 -- most machines it would not help, and it would generate more code that
5574 -- might need certification when a certified run time is required.
5575
5576 -- In the integer cases, we have two routines, one for when overflow
5577 -- checks are required, and one when they are not required, since there
5578 -- is a real gain in omitting checks on many machines.
5579
5580 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
5581 or else (Rtyp = Base_Type (Standard_Long_Integer)
5582 and then
5583 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
5584 or else (Rtyp = Universal_Integer)
5585 then
5586 Etyp := Standard_Long_Long_Integer;
5587
5588 if Ovflo then
5589 Rent := RE_Exp_Long_Long_Integer;
5590 else
5591 Rent := RE_Exn_Long_Long_Integer;
5592 end if;
5593
5594 elsif Is_Signed_Integer_Type (Rtyp) then
5595 Etyp := Standard_Integer;
5596
5597 if Ovflo then
5598 Rent := RE_Exp_Integer;
5599 else
5600 Rent := RE_Exn_Integer;
5601 end if;
5602
5603 -- Floating-point cases, always done using Long_Long_Float. We do not
5604 -- need separate routines for the overflow case here, since in the case
5605 -- of floating-point, we generate infinities anyway as a rule (either
5606 -- that or we automatically trap overflow), and if there is an infinity
5607 -- generated and a range check is required, the check will fail anyway.
5608
5609 else
5610 pragma Assert (Is_Floating_Point_Type (Rtyp));
5611 Etyp := Standard_Long_Long_Float;
5612 Rent := RE_Exn_Long_Long_Float;
5613 end if;
5614
5615 -- Common processing for integer cases and floating-point cases.
5616 -- If we are in the right type, we can call runtime routine directly
5617
5618 if Typ = Etyp
5619 and then Rtyp /= Universal_Integer
5620 and then Rtyp /= Universal_Real
5621 then
5622 Rewrite (N,
5623 Make_Function_Call (Loc,
5624 Name => New_Reference_To (RTE (Rent), Loc),
5625 Parameter_Associations => New_List (Base, Exp)));
5626
5627 -- Otherwise we have to introduce conversions (conversions are also
5628 -- required in the universal cases, since the runtime routine is
5629 -- typed using one of the standard types.
5630
5631 else
5632 Rewrite (N,
5633 Convert_To (Typ,
5634 Make_Function_Call (Loc,
5635 Name => New_Reference_To (RTE (Rent), Loc),
5636 Parameter_Associations => New_List (
5637 Convert_To (Etyp, Base),
5638 Exp))));
5639 end if;
5640
5641 Analyze_And_Resolve (N, Typ);
5642 return;
5643
5644 exception
5645 when RE_Not_Available =>
5646 return;
5647 end Expand_N_Op_Expon;
5648
5649 --------------------
5650 -- Expand_N_Op_Ge --
5651 --------------------
5652
5653 procedure Expand_N_Op_Ge (N : Node_Id) is
5654 Typ : constant Entity_Id := Etype (N);
5655 Op1 : constant Node_Id := Left_Opnd (N);
5656 Op2 : constant Node_Id := Right_Opnd (N);
5657 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5658
5659 begin
5660 Binary_Op_Validity_Checks (N);
5661
5662 if Is_Array_Type (Typ1) then
5663 Expand_Array_Comparison (N);
5664 return;
5665 end if;
5666
5667 if Is_Boolean_Type (Typ1) then
5668 Adjust_Condition (Op1);
5669 Adjust_Condition (Op2);
5670 Set_Etype (N, Standard_Boolean);
5671 Adjust_Result_Type (N, Typ);
5672 end if;
5673
5674 Rewrite_Comparison (N);
5675
5676 -- If we still have comparison, and Vax_Float type, process it
5677
5678 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5679 Expand_Vax_Comparison (N);
5680 return;
5681 end if;
5682 end Expand_N_Op_Ge;
5683
5684 --------------------
5685 -- Expand_N_Op_Gt --
5686 --------------------
5687
5688 procedure Expand_N_Op_Gt (N : Node_Id) is
5689 Typ : constant Entity_Id := Etype (N);
5690 Op1 : constant Node_Id := Left_Opnd (N);
5691 Op2 : constant Node_Id := Right_Opnd (N);
5692 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5693
5694 begin
5695 Binary_Op_Validity_Checks (N);
5696
5697 if Is_Array_Type (Typ1) then
5698 Expand_Array_Comparison (N);
5699 return;
5700 end if;
5701
5702 if Is_Boolean_Type (Typ1) then
5703 Adjust_Condition (Op1);
5704 Adjust_Condition (Op2);
5705 Set_Etype (N, Standard_Boolean);
5706 Adjust_Result_Type (N, Typ);
5707 end if;
5708
5709 Rewrite_Comparison (N);
5710
5711 -- If we still have comparison, and Vax_Float type, process it
5712
5713 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5714 Expand_Vax_Comparison (N);
5715 return;
5716 end if;
5717 end Expand_N_Op_Gt;
5718
5719 --------------------
5720 -- Expand_N_Op_Le --
5721 --------------------
5722
5723 procedure Expand_N_Op_Le (N : Node_Id) is
5724 Typ : constant Entity_Id := Etype (N);
5725 Op1 : constant Node_Id := Left_Opnd (N);
5726 Op2 : constant Node_Id := Right_Opnd (N);
5727 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5728
5729 begin
5730 Binary_Op_Validity_Checks (N);
5731
5732 if Is_Array_Type (Typ1) then
5733 Expand_Array_Comparison (N);
5734 return;
5735 end if;
5736
5737 if Is_Boolean_Type (Typ1) then
5738 Adjust_Condition (Op1);
5739 Adjust_Condition (Op2);
5740 Set_Etype (N, Standard_Boolean);
5741 Adjust_Result_Type (N, Typ);
5742 end if;
5743
5744 Rewrite_Comparison (N);
5745
5746 -- If we still have comparison, and Vax_Float type, process it
5747
5748 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5749 Expand_Vax_Comparison (N);
5750 return;
5751 end if;
5752 end Expand_N_Op_Le;
5753
5754 --------------------
5755 -- Expand_N_Op_Lt --
5756 --------------------
5757
5758 procedure Expand_N_Op_Lt (N : Node_Id) is
5759 Typ : constant Entity_Id := Etype (N);
5760 Op1 : constant Node_Id := Left_Opnd (N);
5761 Op2 : constant Node_Id := Right_Opnd (N);
5762 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5763
5764 begin
5765 Binary_Op_Validity_Checks (N);
5766
5767 if Is_Array_Type (Typ1) then
5768 Expand_Array_Comparison (N);
5769 return;
5770 end if;
5771
5772 if Is_Boolean_Type (Typ1) then
5773 Adjust_Condition (Op1);
5774 Adjust_Condition (Op2);
5775 Set_Etype (N, Standard_Boolean);
5776 Adjust_Result_Type (N, Typ);
5777 end if;
5778
5779 Rewrite_Comparison (N);
5780
5781 -- If we still have comparison, and Vax_Float type, process it
5782
5783 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5784 Expand_Vax_Comparison (N);
5785 return;
5786 end if;
5787 end Expand_N_Op_Lt;
5788
5789 -----------------------
5790 -- Expand_N_Op_Minus --
5791 -----------------------
5792
5793 procedure Expand_N_Op_Minus (N : Node_Id) is
5794 Loc : constant Source_Ptr := Sloc (N);
5795 Typ : constant Entity_Id := Etype (N);
5796
5797 begin
5798 Unary_Op_Validity_Checks (N);
5799
5800 if not Backend_Overflow_Checks_On_Target
5801 and then Is_Signed_Integer_Type (Etype (N))
5802 and then Do_Overflow_Check (N)
5803 then
5804 -- Software overflow checking expands -expr into (0 - expr)
5805
5806 Rewrite (N,
5807 Make_Op_Subtract (Loc,
5808 Left_Opnd => Make_Integer_Literal (Loc, 0),
5809 Right_Opnd => Right_Opnd (N)));
5810
5811 Analyze_And_Resolve (N, Typ);
5812
5813 -- Vax floating-point types case
5814
5815 elsif Vax_Float (Etype (N)) then
5816 Expand_Vax_Arith (N);
5817 end if;
5818 end Expand_N_Op_Minus;
5819
5820 ---------------------
5821 -- Expand_N_Op_Mod --
5822 ---------------------
5823
5824 procedure Expand_N_Op_Mod (N : Node_Id) is
5825 Loc : constant Source_Ptr := Sloc (N);
5826 Typ : constant Entity_Id := Etype (N);
5827 Left : constant Node_Id := Left_Opnd (N);
5828 Right : constant Node_Id := Right_Opnd (N);
5829 DOC : constant Boolean := Do_Overflow_Check (N);
5830 DDC : constant Boolean := Do_Division_Check (N);
5831
5832 LLB : Uint;
5833 Llo : Uint;
5834 Lhi : Uint;
5835 LOK : Boolean;
5836 Rlo : Uint;
5837 Rhi : Uint;
5838 ROK : Boolean;
5839
5840 pragma Warnings (Off, Lhi);
5841
5842 begin
5843 Binary_Op_Validity_Checks (N);
5844
5845 Determine_Range (Right, ROK, Rlo, Rhi);
5846 Determine_Range (Left, LOK, Llo, Lhi);
5847
5848 -- Convert mod to rem if operands are known non-negative. We do this
5849 -- since it is quite likely that this will improve the quality of code,
5850 -- (the operation now corresponds to the hardware remainder), and it
5851 -- does not seem likely that it could be harmful.
5852
5853 if LOK and then Llo >= 0
5854 and then
5855 ROK and then Rlo >= 0
5856 then
5857 Rewrite (N,
5858 Make_Op_Rem (Sloc (N),
5859 Left_Opnd => Left_Opnd (N),
5860 Right_Opnd => Right_Opnd (N)));
5861
5862 -- Instead of reanalyzing the node we do the analysis manually.
5863 -- This avoids anomalies when the replacement is done in an
5864 -- instance and is epsilon more efficient.
5865
5866 Set_Entity (N, Standard_Entity (S_Op_Rem));
5867 Set_Etype (N, Typ);
5868 Set_Do_Overflow_Check (N, DOC);
5869 Set_Do_Division_Check (N, DDC);
5870 Expand_N_Op_Rem (N);
5871 Set_Analyzed (N);
5872
5873 -- Otherwise, normal mod processing
5874
5875 else
5876 if Is_Integer_Type (Etype (N)) then
5877 Apply_Divide_Check (N);
5878 end if;
5879
5880 -- Apply optimization x mod 1 = 0. We don't really need that with
5881 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5882 -- certainly harmless.
5883
5884 if Is_Integer_Type (Etype (N))
5885 and then Compile_Time_Known_Value (Right)
5886 and then Expr_Value (Right) = Uint_1
5887 then
5888 Rewrite (N, Make_Integer_Literal (Loc, 0));
5889 Analyze_And_Resolve (N, Typ);
5890 return;
5891 end if;
5892
5893 -- Deal with annoying case of largest negative number remainder
5894 -- minus one. Gigi does not handle this case correctly, because
5895 -- it generates a divide instruction which may trap in this case.
5896
5897 -- In fact the check is quite easy, if the right operand is -1,
5898 -- then the mod value is always 0, and we can just ignore the
5899 -- left operand completely in this case.
5900
5901 -- The operand type may be private (e.g. in the expansion of an
5902 -- an intrinsic operation) so we must use the underlying type to
5903 -- get the bounds, and convert the literals explicitly.
5904
5905 LLB :=
5906 Expr_Value
5907 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
5908
5909 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
5910 and then
5911 ((not LOK) or else (Llo = LLB))
5912 then
5913 Rewrite (N,
5914 Make_Conditional_Expression (Loc,
5915 Expressions => New_List (
5916 Make_Op_Eq (Loc,
5917 Left_Opnd => Duplicate_Subexpr (Right),
5918 Right_Opnd =>
5919 Unchecked_Convert_To (Typ,
5920 Make_Integer_Literal (Loc, -1))),
5921 Unchecked_Convert_To (Typ,
5922 Make_Integer_Literal (Loc, Uint_0)),
5923 Relocate_Node (N))));
5924
5925 Set_Analyzed (Next (Next (First (Expressions (N)))));
5926 Analyze_And_Resolve (N, Typ);
5927 end if;
5928 end if;
5929 end Expand_N_Op_Mod;
5930
5931 --------------------------
5932 -- Expand_N_Op_Multiply --
5933 --------------------------
5934
5935 procedure Expand_N_Op_Multiply (N : Node_Id) is
5936 Loc : constant Source_Ptr := Sloc (N);
5937 Lop : constant Node_Id := Left_Opnd (N);
5938 Rop : constant Node_Id := Right_Opnd (N);
5939
5940 Lp2 : constant Boolean :=
5941 Nkind (Lop) = N_Op_Expon
5942 and then Is_Power_Of_2_For_Shift (Lop);
5943
5944 Rp2 : constant Boolean :=
5945 Nkind (Rop) = N_Op_Expon
5946 and then Is_Power_Of_2_For_Shift (Rop);
5947
5948 Ltyp : constant Entity_Id := Etype (Lop);
5949 Rtyp : constant Entity_Id := Etype (Rop);
5950 Typ : Entity_Id := Etype (N);
5951
5952 begin
5953 Binary_Op_Validity_Checks (N);
5954
5955 -- Special optimizations for integer types
5956
5957 if Is_Integer_Type (Typ) then
5958
5959 -- N * 0 = 0 * N = 0 for integer types
5960
5961 if (Compile_Time_Known_Value (Rop)
5962 and then Expr_Value (Rop) = Uint_0)
5963 or else
5964 (Compile_Time_Known_Value (Lop)
5965 and then Expr_Value (Lop) = Uint_0)
5966 then
5967 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
5968 Analyze_And_Resolve (N, Typ);
5969 return;
5970 end if;
5971
5972 -- N * 1 = 1 * N = N for integer types
5973
5974 -- This optimisation is not done if we are going to
5975 -- rewrite the product 1 * 2 ** N to a shift.
5976
5977 if Compile_Time_Known_Value (Rop)
5978 and then Expr_Value (Rop) = Uint_1
5979 and then not Lp2
5980 then
5981 Rewrite (N, Lop);
5982 return;
5983
5984 elsif Compile_Time_Known_Value (Lop)
5985 and then Expr_Value (Lop) = Uint_1
5986 and then not Rp2
5987 then
5988 Rewrite (N, Rop);
5989 return;
5990 end if;
5991 end if;
5992
5993 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5994 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5995 -- operand is an integer, as required for this to work.
5996
5997 if Rp2 then
5998 if Lp2 then
5999
6000 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
6001
6002 Rewrite (N,
6003 Make_Op_Expon (Loc,
6004 Left_Opnd => Make_Integer_Literal (Loc, 2),
6005 Right_Opnd =>
6006 Make_Op_Add (Loc,
6007 Left_Opnd => Right_Opnd (Lop),
6008 Right_Opnd => Right_Opnd (Rop))));
6009 Analyze_And_Resolve (N, Typ);
6010 return;
6011
6012 else
6013 Rewrite (N,
6014 Make_Op_Shift_Left (Loc,
6015 Left_Opnd => Lop,
6016 Right_Opnd =>
6017 Convert_To (Standard_Natural, Right_Opnd (Rop))));
6018 Analyze_And_Resolve (N, Typ);
6019 return;
6020 end if;
6021
6022 -- Same processing for the operands the other way round
6023
6024 elsif Lp2 then
6025 Rewrite (N,
6026 Make_Op_Shift_Left (Loc,
6027 Left_Opnd => Rop,
6028 Right_Opnd =>
6029 Convert_To (Standard_Natural, Right_Opnd (Lop))));
6030 Analyze_And_Resolve (N, Typ);
6031 return;
6032 end if;
6033
6034 -- Do required fixup of universal fixed operation
6035
6036 if Typ = Universal_Fixed then
6037 Fixup_Universal_Fixed_Operation (N);
6038 Typ := Etype (N);
6039 end if;
6040
6041 -- Multiplications with fixed-point results
6042
6043 if Is_Fixed_Point_Type (Typ) then
6044
6045 -- No special processing if Treat_Fixed_As_Integer is set,
6046 -- since from a semantic point of view such operations are
6047 -- simply integer operations and will be treated that way.
6048
6049 if not Treat_Fixed_As_Integer (N) then
6050
6051 -- Case of fixed * integer => fixed
6052
6053 if Is_Integer_Type (Rtyp) then
6054 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
6055
6056 -- Case of integer * fixed => fixed
6057
6058 elsif Is_Integer_Type (Ltyp) then
6059 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
6060
6061 -- Case of fixed * fixed => fixed
6062
6063 else
6064 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
6065 end if;
6066 end if;
6067
6068 -- Other cases of multiplication of fixed-point operands. Again
6069 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
6070
6071 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6072 and then not Treat_Fixed_As_Integer (N)
6073 then
6074 if Is_Integer_Type (Typ) then
6075 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
6076 else
6077 pragma Assert (Is_Floating_Point_Type (Typ));
6078 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
6079 end if;
6080
6081 -- Mixed-mode operations can appear in a non-static universal
6082 -- context, in which case the integer argument must be converted
6083 -- explicitly.
6084
6085 elsif Typ = Universal_Real
6086 and then Is_Integer_Type (Rtyp)
6087 then
6088 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
6089
6090 Analyze_And_Resolve (Rop, Universal_Real);
6091
6092 elsif Typ = Universal_Real
6093 and then Is_Integer_Type (Ltyp)
6094 then
6095 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
6096
6097 Analyze_And_Resolve (Lop, Universal_Real);
6098
6099 -- Non-fixed point cases, check software overflow checking required
6100
6101 elsif Is_Signed_Integer_Type (Etype (N)) then
6102 Apply_Arithmetic_Overflow_Check (N);
6103
6104 -- Deal with VAX float case
6105
6106 elsif Vax_Float (Typ) then
6107 Expand_Vax_Arith (N);
6108 return;
6109 end if;
6110 end Expand_N_Op_Multiply;
6111
6112 --------------------
6113 -- Expand_N_Op_Ne --
6114 --------------------
6115
6116 procedure Expand_N_Op_Ne (N : Node_Id) is
6117 Typ : constant Entity_Id := Etype (Left_Opnd (N));
6118
6119 begin
6120 -- Case of elementary type with standard operator
6121
6122 if Is_Elementary_Type (Typ)
6123 and then Sloc (Entity (N)) = Standard_Location
6124 then
6125 Binary_Op_Validity_Checks (N);
6126
6127 -- Boolean types (requiring handling of non-standard case)
6128
6129 if Is_Boolean_Type (Typ) then
6130 Adjust_Condition (Left_Opnd (N));
6131 Adjust_Condition (Right_Opnd (N));
6132 Set_Etype (N, Standard_Boolean);
6133 Adjust_Result_Type (N, Typ);
6134 end if;
6135
6136 Rewrite_Comparison (N);
6137
6138 -- If we still have comparison for Vax_Float, process it
6139
6140 if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then
6141 Expand_Vax_Comparison (N);
6142 return;
6143 end if;
6144
6145 -- For all cases other than elementary types, we rewrite node as the
6146 -- negation of an equality operation, and reanalyze. The equality to be
6147 -- used is defined in the same scope and has the same signature. This
6148 -- signature must be set explicitly since in an instance it may not have
6149 -- the same visibility as in the generic unit. This avoids duplicating
6150 -- or factoring the complex code for record/array equality tests etc.
6151
6152 else
6153 declare
6154 Loc : constant Source_Ptr := Sloc (N);
6155 Neg : Node_Id;
6156 Ne : constant Entity_Id := Entity (N);
6157
6158 begin
6159 Binary_Op_Validity_Checks (N);
6160
6161 Neg :=
6162 Make_Op_Not (Loc,
6163 Right_Opnd =>
6164 Make_Op_Eq (Loc,
6165 Left_Opnd => Left_Opnd (N),
6166 Right_Opnd => Right_Opnd (N)));
6167 Set_Paren_Count (Right_Opnd (Neg), 1);
6168
6169 if Scope (Ne) /= Standard_Standard then
6170 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
6171 end if;
6172
6173 -- For navigation purposes, the inequality is treated as an
6174 -- implicit reference to the corresponding equality. Preserve the
6175 -- Comes_From_ source flag so that the proper Xref entry is
6176 -- generated.
6177
6178 Preserve_Comes_From_Source (Neg, N);
6179 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
6180 Rewrite (N, Neg);
6181 Analyze_And_Resolve (N, Standard_Boolean);
6182 end;
6183 end if;
6184 end Expand_N_Op_Ne;
6185
6186 ---------------------
6187 -- Expand_N_Op_Not --
6188 ---------------------
6189
6190 -- If the argument is other than a Boolean array type, there is no
6191 -- special expansion required.
6192
6193 -- For the packed case, we call the special routine in Exp_Pakd, except
6194 -- that if the component size is greater than one, we use the standard
6195 -- routine generating a gruesome loop (it is so peculiar to have packed
6196 -- arrays with non-standard Boolean representations anyway, so it does
6197 -- not matter that we do not handle this case efficiently).
6198
6199 -- For the unpacked case (and for the special packed case where we have
6200 -- non standard Booleans, as discussed above), we generate and insert
6201 -- into the tree the following function definition:
6202
6203 -- function Nnnn (A : arr) is
6204 -- B : arr;
6205 -- begin
6206 -- for J in a'range loop
6207 -- B (J) := not A (J);
6208 -- end loop;
6209 -- return B;
6210 -- end Nnnn;
6211
6212 -- Here arr is the actual subtype of the parameter (and hence always
6213 -- constrained). Then we replace the not with a call to this function.
6214
6215 procedure Expand_N_Op_Not (N : Node_Id) is
6216 Loc : constant Source_Ptr := Sloc (N);
6217 Typ : constant Entity_Id := Etype (N);
6218 Opnd : Node_Id;
6219 Arr : Entity_Id;
6220 A : Entity_Id;
6221 B : Entity_Id;
6222 J : Entity_Id;
6223 A_J : Node_Id;
6224 B_J : Node_Id;
6225
6226 Func_Name : Entity_Id;
6227 Loop_Statement : Node_Id;
6228
6229 begin
6230 Unary_Op_Validity_Checks (N);
6231
6232 -- For boolean operand, deal with non-standard booleans
6233
6234 if Is_Boolean_Type (Typ) then
6235 Adjust_Condition (Right_Opnd (N));
6236 Set_Etype (N, Standard_Boolean);
6237 Adjust_Result_Type (N, Typ);
6238 return;
6239 end if;
6240
6241 -- Only array types need any other processing
6242
6243 if not Is_Array_Type (Typ) then
6244 return;
6245 end if;
6246
6247 -- Case of array operand. If bit packed with a component size of 1,
6248 -- handle it in Exp_Pakd if the operand is known to be aligned.
6249
6250 if Is_Bit_Packed_Array (Typ)
6251 and then Component_Size (Typ) = 1
6252 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
6253 then
6254 Expand_Packed_Not (N);
6255 return;
6256 end if;
6257
6258 -- Case of array operand which is not bit-packed. If the context is
6259 -- a safe assignment, call in-place operation, If context is a larger
6260 -- boolean expression in the context of a safe assignment, expansion is
6261 -- done by enclosing operation.
6262
6263 Opnd := Relocate_Node (Right_Opnd (N));
6264 Convert_To_Actual_Subtype (Opnd);
6265 Arr := Etype (Opnd);
6266 Ensure_Defined (Arr, N);
6267 Silly_Boolean_Array_Not_Test (N, Arr);
6268
6269 if Nkind (Parent (N)) = N_Assignment_Statement then
6270 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
6271 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6272 return;
6273
6274 -- Special case the negation of a binary operation
6275
6276 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
6277 and then Safe_In_Place_Array_Op
6278 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
6279 then
6280 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6281 return;
6282 end if;
6283
6284 elsif Nkind (Parent (N)) in N_Binary_Op
6285 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
6286 then
6287 declare
6288 Op1 : constant Node_Id := Left_Opnd (Parent (N));
6289 Op2 : constant Node_Id := Right_Opnd (Parent (N));
6290 Lhs : constant Node_Id := Name (Parent (Parent (N)));
6291
6292 begin
6293 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
6294 if N = Op1
6295 and then Nkind (Op2) = N_Op_Not
6296 then
6297 -- (not A) op (not B) can be reduced to a single call
6298
6299 return;
6300
6301 elsif N = Op2
6302 and then Nkind (Parent (N)) = N_Op_Xor
6303 then
6304 -- A xor (not B) can also be special-cased
6305
6306 return;
6307 end if;
6308 end if;
6309 end;
6310 end if;
6311
6312 A := Make_Defining_Identifier (Loc, Name_uA);
6313 B := Make_Defining_Identifier (Loc, Name_uB);
6314 J := Make_Defining_Identifier (Loc, Name_uJ);
6315
6316 A_J :=
6317 Make_Indexed_Component (Loc,
6318 Prefix => New_Reference_To (A, Loc),
6319 Expressions => New_List (New_Reference_To (J, Loc)));
6320
6321 B_J :=
6322 Make_Indexed_Component (Loc,
6323 Prefix => New_Reference_To (B, Loc),
6324 Expressions => New_List (New_Reference_To (J, Loc)));
6325
6326 Loop_Statement :=
6327 Make_Implicit_Loop_Statement (N,
6328 Identifier => Empty,
6329
6330 Iteration_Scheme =>
6331 Make_Iteration_Scheme (Loc,
6332 Loop_Parameter_Specification =>
6333 Make_Loop_Parameter_Specification (Loc,
6334 Defining_Identifier => J,
6335 Discrete_Subtype_Definition =>
6336 Make_Attribute_Reference (Loc,
6337 Prefix => Make_Identifier (Loc, Chars (A)),
6338 Attribute_Name => Name_Range))),
6339
6340 Statements => New_List (
6341 Make_Assignment_Statement (Loc,
6342 Name => B_J,
6343 Expression => Make_Op_Not (Loc, A_J))));
6344
6345 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
6346 Set_Is_Inlined (Func_Name);
6347
6348 Insert_Action (N,
6349 Make_Subprogram_Body (Loc,
6350 Specification =>
6351 Make_Function_Specification (Loc,
6352 Defining_Unit_Name => Func_Name,
6353 Parameter_Specifications => New_List (
6354 Make_Parameter_Specification (Loc,
6355 Defining_Identifier => A,
6356 Parameter_Type => New_Reference_To (Typ, Loc))),
6357 Result_Definition => New_Reference_To (Typ, Loc)),
6358
6359 Declarations => New_List (
6360 Make_Object_Declaration (Loc,
6361 Defining_Identifier => B,
6362 Object_Definition => New_Reference_To (Arr, Loc))),
6363
6364 Handled_Statement_Sequence =>
6365 Make_Handled_Sequence_Of_Statements (Loc,
6366 Statements => New_List (
6367 Loop_Statement,
6368 Make_Simple_Return_Statement (Loc,
6369 Expression =>
6370 Make_Identifier (Loc, Chars (B)))))));
6371
6372 Rewrite (N,
6373 Make_Function_Call (Loc,
6374 Name => New_Reference_To (Func_Name, Loc),
6375 Parameter_Associations => New_List (Opnd)));
6376
6377 Analyze_And_Resolve (N, Typ);
6378 end Expand_N_Op_Not;
6379
6380 --------------------
6381 -- Expand_N_Op_Or --
6382 --------------------
6383
6384 procedure Expand_N_Op_Or (N : Node_Id) is
6385 Typ : constant Entity_Id := Etype (N);
6386
6387 begin
6388 Binary_Op_Validity_Checks (N);
6389
6390 if Is_Array_Type (Etype (N)) then
6391 Expand_Boolean_Operator (N);
6392
6393 elsif Is_Boolean_Type (Etype (N)) then
6394 Adjust_Condition (Left_Opnd (N));
6395 Adjust_Condition (Right_Opnd (N));
6396 Set_Etype (N, Standard_Boolean);
6397 Adjust_Result_Type (N, Typ);
6398 end if;
6399 end Expand_N_Op_Or;
6400
6401 ----------------------
6402 -- Expand_N_Op_Plus --
6403 ----------------------
6404
6405 procedure Expand_N_Op_Plus (N : Node_Id) is
6406 begin
6407 Unary_Op_Validity_Checks (N);
6408 end Expand_N_Op_Plus;
6409
6410 ---------------------
6411 -- Expand_N_Op_Rem --
6412 ---------------------
6413
6414 procedure Expand_N_Op_Rem (N : Node_Id) is
6415 Loc : constant Source_Ptr := Sloc (N);
6416 Typ : constant Entity_Id := Etype (N);
6417
6418 Left : constant Node_Id := Left_Opnd (N);
6419 Right : constant Node_Id := Right_Opnd (N);
6420
6421 LLB : Uint;
6422 Llo : Uint;
6423 Lhi : Uint;
6424 LOK : Boolean;
6425 Rlo : Uint;
6426 Rhi : Uint;
6427 ROK : Boolean;
6428
6429 pragma Warnings (Off, Lhi);
6430
6431 begin
6432 Binary_Op_Validity_Checks (N);
6433
6434 if Is_Integer_Type (Etype (N)) then
6435 Apply_Divide_Check (N);
6436 end if;
6437
6438 -- Apply optimization x rem 1 = 0. We don't really need that with
6439 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
6440 -- certainly harmless.
6441
6442 if Is_Integer_Type (Etype (N))
6443 and then Compile_Time_Known_Value (Right)
6444 and then Expr_Value (Right) = Uint_1
6445 then
6446 Rewrite (N, Make_Integer_Literal (Loc, 0));
6447 Analyze_And_Resolve (N, Typ);
6448 return;
6449 end if;
6450
6451 -- Deal with annoying case of largest negative number remainder
6452 -- minus one. Gigi does not handle this case correctly, because
6453 -- it generates a divide instruction which may trap in this case.
6454
6455 -- In fact the check is quite easy, if the right operand is -1,
6456 -- then the remainder is always 0, and we can just ignore the
6457 -- left operand completely in this case.
6458
6459 Determine_Range (Right, ROK, Rlo, Rhi);
6460 Determine_Range (Left, LOK, Llo, Lhi);
6461
6462 -- The operand type may be private (e.g. in the expansion of an
6463 -- an intrinsic operation) so we must use the underlying type to
6464 -- get the bounds, and convert the literals explicitly.
6465
6466 LLB :=
6467 Expr_Value
6468 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
6469
6470 -- Now perform the test, generating code only if needed
6471
6472 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
6473 and then
6474 ((not LOK) or else (Llo = LLB))
6475 then
6476 Rewrite (N,
6477 Make_Conditional_Expression (Loc,
6478 Expressions => New_List (
6479 Make_Op_Eq (Loc,
6480 Left_Opnd => Duplicate_Subexpr (Right),
6481 Right_Opnd =>
6482 Unchecked_Convert_To (Typ,
6483 Make_Integer_Literal (Loc, -1))),
6484
6485 Unchecked_Convert_To (Typ,
6486 Make_Integer_Literal (Loc, Uint_0)),
6487
6488 Relocate_Node (N))));
6489
6490 Set_Analyzed (Next (Next (First (Expressions (N)))));
6491 Analyze_And_Resolve (N, Typ);
6492 end if;
6493 end Expand_N_Op_Rem;
6494
6495 -----------------------------
6496 -- Expand_N_Op_Rotate_Left --
6497 -----------------------------
6498
6499 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
6500 begin
6501 Binary_Op_Validity_Checks (N);
6502 end Expand_N_Op_Rotate_Left;
6503
6504 ------------------------------
6505 -- Expand_N_Op_Rotate_Right --
6506 ------------------------------
6507
6508 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
6509 begin
6510 Binary_Op_Validity_Checks (N);
6511 end Expand_N_Op_Rotate_Right;
6512
6513 ----------------------------
6514 -- Expand_N_Op_Shift_Left --
6515 ----------------------------
6516
6517 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
6518 begin
6519 Binary_Op_Validity_Checks (N);
6520 end Expand_N_Op_Shift_Left;
6521
6522 -----------------------------
6523 -- Expand_N_Op_Shift_Right --
6524 -----------------------------
6525
6526 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
6527 begin
6528 Binary_Op_Validity_Checks (N);
6529 end Expand_N_Op_Shift_Right;
6530
6531 ----------------------------------------
6532 -- Expand_N_Op_Shift_Right_Arithmetic --
6533 ----------------------------------------
6534
6535 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
6536 begin
6537 Binary_Op_Validity_Checks (N);
6538 end Expand_N_Op_Shift_Right_Arithmetic;
6539
6540 --------------------------
6541 -- Expand_N_Op_Subtract --
6542 --------------------------
6543
6544 procedure Expand_N_Op_Subtract (N : Node_Id) is
6545 Typ : constant Entity_Id := Etype (N);
6546
6547 begin
6548 Binary_Op_Validity_Checks (N);
6549
6550 -- N - 0 = N for integer types
6551
6552 if Is_Integer_Type (Typ)
6553 and then Compile_Time_Known_Value (Right_Opnd (N))
6554 and then Expr_Value (Right_Opnd (N)) = 0
6555 then
6556 Rewrite (N, Left_Opnd (N));
6557 return;
6558 end if;
6559
6560 -- Arithmetic overflow checks for signed integer/fixed point types
6561
6562 if Is_Signed_Integer_Type (Typ)
6563 or else Is_Fixed_Point_Type (Typ)
6564 then
6565 Apply_Arithmetic_Overflow_Check (N);
6566
6567 -- Vax floating-point types case
6568
6569 elsif Vax_Float (Typ) then
6570 Expand_Vax_Arith (N);
6571 end if;
6572 end Expand_N_Op_Subtract;
6573
6574 ---------------------
6575 -- Expand_N_Op_Xor --
6576 ---------------------
6577
6578 procedure Expand_N_Op_Xor (N : Node_Id) is
6579 Typ : constant Entity_Id := Etype (N);
6580
6581 begin
6582 Binary_Op_Validity_Checks (N);
6583
6584 if Is_Array_Type (Etype (N)) then
6585 Expand_Boolean_Operator (N);
6586
6587 elsif Is_Boolean_Type (Etype (N)) then
6588 Adjust_Condition (Left_Opnd (N));
6589 Adjust_Condition (Right_Opnd (N));
6590 Set_Etype (N, Standard_Boolean);
6591 Adjust_Result_Type (N, Typ);
6592 end if;
6593 end Expand_N_Op_Xor;
6594
6595 ----------------------
6596 -- Expand_N_Or_Else --
6597 ----------------------
6598
6599 -- Expand into conditional expression if Actions present, and also
6600 -- deal with optimizing case of arguments being True or False.
6601
6602 procedure Expand_N_Or_Else (N : Node_Id) is
6603 Loc : constant Source_Ptr := Sloc (N);
6604 Typ : constant Entity_Id := Etype (N);
6605 Left : constant Node_Id := Left_Opnd (N);
6606 Right : constant Node_Id := Right_Opnd (N);
6607 Actlist : List_Id;
6608
6609 begin
6610 -- Deal with non-standard booleans
6611
6612 if Is_Boolean_Type (Typ) then
6613 Adjust_Condition (Left);
6614 Adjust_Condition (Right);
6615 Set_Etype (N, Standard_Boolean);
6616 end if;
6617
6618 -- Check for cases of left argument is True or False
6619
6620 if Nkind (Left) = N_Identifier then
6621
6622 -- If left argument is False, change (False or else Right) to Right.
6623 -- Any actions associated with Right will be executed unconditionally
6624 -- and can thus be inserted into the tree unconditionally.
6625
6626 if Entity (Left) = Standard_False then
6627 if Present (Actions (N)) then
6628 Insert_Actions (N, Actions (N));
6629 end if;
6630
6631 Rewrite (N, Right);
6632 Adjust_Result_Type (N, Typ);
6633 return;
6634
6635 -- If left argument is True, change (True and then Right) to
6636 -- True. In this case we can forget the actions associated with
6637 -- Right, since they will never be executed.
6638
6639 elsif Entity (Left) = Standard_True then
6640 Kill_Dead_Code (Right);
6641 Kill_Dead_Code (Actions (N));
6642 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6643 Adjust_Result_Type (N, Typ);
6644 return;
6645 end if;
6646 end if;
6647
6648 -- If Actions are present, we expand
6649
6650 -- left or else right
6651
6652 -- into
6653
6654 -- if left then True else right end
6655
6656 -- with the actions becoming the Else_Actions of the conditional
6657 -- expression. This conditional expression is then further expanded
6658 -- (and will eventually disappear)
6659
6660 if Present (Actions (N)) then
6661 Actlist := Actions (N);
6662 Rewrite (N,
6663 Make_Conditional_Expression (Loc,
6664 Expressions => New_List (
6665 Left,
6666 New_Occurrence_Of (Standard_True, Loc),
6667 Right)));
6668
6669 Set_Else_Actions (N, Actlist);
6670 Analyze_And_Resolve (N, Standard_Boolean);
6671 Adjust_Result_Type (N, Typ);
6672 return;
6673 end if;
6674
6675 -- No actions present, check for cases of right argument True/False
6676
6677 if Nkind (Right) = N_Identifier then
6678
6679 -- Change (Left or else False) to Left. Note that we know there
6680 -- are no actions associated with the True operand, since we
6681 -- just checked for this case above.
6682
6683 if Entity (Right) = Standard_False then
6684 Rewrite (N, Left);
6685
6686 -- Change (Left or else True) to True, making sure to preserve
6687 -- any side effects associated with the Left operand.
6688
6689 elsif Entity (Right) = Standard_True then
6690 Remove_Side_Effects (Left);
6691 Rewrite
6692 (N, New_Occurrence_Of (Standard_True, Loc));
6693 end if;
6694 end if;
6695
6696 Adjust_Result_Type (N, Typ);
6697 end Expand_N_Or_Else;
6698
6699 -----------------------------------
6700 -- Expand_N_Qualified_Expression --
6701 -----------------------------------
6702
6703 procedure Expand_N_Qualified_Expression (N : Node_Id) is
6704 Operand : constant Node_Id := Expression (N);
6705 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
6706
6707 begin
6708 -- Do validity check if validity checking operands
6709
6710 if Validity_Checks_On
6711 and then Validity_Check_Operands
6712 then
6713 Ensure_Valid (Operand);
6714 end if;
6715
6716 -- Apply possible constraint check
6717
6718 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
6719 end Expand_N_Qualified_Expression;
6720
6721 ---------------------------------
6722 -- Expand_N_Selected_Component --
6723 ---------------------------------
6724
6725 -- If the selector is a discriminant of a concurrent object, rewrite the
6726 -- prefix to denote the corresponding record type.
6727
6728 procedure Expand_N_Selected_Component (N : Node_Id) is
6729 Loc : constant Source_Ptr := Sloc (N);
6730 Par : constant Node_Id := Parent (N);
6731 P : constant Node_Id := Prefix (N);
6732 Ptyp : Entity_Id := Underlying_Type (Etype (P));
6733 Disc : Entity_Id;
6734 New_N : Node_Id;
6735 Dcon : Elmt_Id;
6736
6737 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
6738 -- Gigi needs a temporary for prefixes that depend on a discriminant,
6739 -- unless the context of an assignment can provide size information.
6740 -- Don't we have a general routine that does this???
6741
6742 -----------------------
6743 -- In_Left_Hand_Side --
6744 -----------------------
6745
6746 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
6747 begin
6748 return (Nkind (Parent (Comp)) = N_Assignment_Statement
6749 and then Comp = Name (Parent (Comp)))
6750 or else (Present (Parent (Comp))
6751 and then Nkind (Parent (Comp)) in N_Subexpr
6752 and then In_Left_Hand_Side (Parent (Comp)));
6753 end In_Left_Hand_Side;
6754
6755 -- Start of processing for Expand_N_Selected_Component
6756
6757 begin
6758 -- Insert explicit dereference if required
6759
6760 if Is_Access_Type (Ptyp) then
6761 Insert_Explicit_Dereference (P);
6762 Analyze_And_Resolve (P, Designated_Type (Ptyp));
6763
6764 if Ekind (Etype (P)) = E_Private_Subtype
6765 and then Is_For_Access_Subtype (Etype (P))
6766 then
6767 Set_Etype (P, Base_Type (Etype (P)));
6768 end if;
6769
6770 Ptyp := Etype (P);
6771 end if;
6772
6773 -- Deal with discriminant check required
6774
6775 if Do_Discriminant_Check (N) then
6776
6777 -- Present the discriminant checking function to the backend,
6778 -- so that it can inline the call to the function.
6779
6780 Add_Inlined_Body
6781 (Discriminant_Checking_Func
6782 (Original_Record_Component (Entity (Selector_Name (N)))));
6783
6784 -- Now reset the flag and generate the call
6785
6786 Set_Do_Discriminant_Check (N, False);
6787 Generate_Discriminant_Check (N);
6788 end if;
6789
6790 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6791 -- function, then additional actuals must be passed.
6792
6793 if Ada_Version >= Ada_05
6794 and then Is_Build_In_Place_Function_Call (P)
6795 then
6796 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6797 end if;
6798
6799 -- Gigi cannot handle unchecked conversions that are the prefix of a
6800 -- selected component with discriminants. This must be checked during
6801 -- expansion, because during analysis the type of the selector is not
6802 -- known at the point the prefix is analyzed. If the conversion is the
6803 -- target of an assignment, then we cannot force the evaluation.
6804
6805 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
6806 and then Has_Discriminants (Etype (N))
6807 and then not In_Left_Hand_Side (N)
6808 then
6809 Force_Evaluation (Prefix (N));
6810 end if;
6811
6812 -- Remaining processing applies only if selector is a discriminant
6813
6814 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
6815
6816 -- If the selector is a discriminant of a constrained record type,
6817 -- we may be able to rewrite the expression with the actual value
6818 -- of the discriminant, a useful optimization in some cases.
6819
6820 if Is_Record_Type (Ptyp)
6821 and then Has_Discriminants (Ptyp)
6822 and then Is_Constrained (Ptyp)
6823 then
6824 -- Do this optimization for discrete types only, and not for
6825 -- access types (access discriminants get us into trouble!)
6826
6827 if not Is_Discrete_Type (Etype (N)) then
6828 null;
6829
6830 -- Don't do this on the left hand of an assignment statement.
6831 -- Normally one would think that references like this would
6832 -- not occur, but they do in generated code, and mean that
6833 -- we really do want to assign the discriminant!
6834
6835 elsif Nkind (Par) = N_Assignment_Statement
6836 and then Name (Par) = N
6837 then
6838 null;
6839
6840 -- Don't do this optimization for the prefix of an attribute
6841 -- or the operand of an object renaming declaration since these
6842 -- are contexts where we do not want the value anyway.
6843
6844 elsif (Nkind (Par) = N_Attribute_Reference
6845 and then Prefix (Par) = N)
6846 or else Is_Renamed_Object (N)
6847 then
6848 null;
6849
6850 -- Don't do this optimization if we are within the code for a
6851 -- discriminant check, since the whole point of such a check may
6852 -- be to verify the condition on which the code below depends!
6853
6854 elsif Is_In_Discriminant_Check (N) then
6855 null;
6856
6857 -- Green light to see if we can do the optimization. There is
6858 -- still one condition that inhibits the optimization below
6859 -- but now is the time to check the particular discriminant.
6860
6861 else
6862 -- Loop through discriminants to find the matching
6863 -- discriminant constraint to see if we can copy it.
6864
6865 Disc := First_Discriminant (Ptyp);
6866 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
6867 Discr_Loop : while Present (Dcon) loop
6868
6869 -- Check if this is the matching discriminant
6870
6871 if Disc = Entity (Selector_Name (N)) then
6872
6873 -- Here we have the matching discriminant. Check for
6874 -- the case of a discriminant of a component that is
6875 -- constrained by an outer discriminant, which cannot
6876 -- be optimized away.
6877
6878 if
6879 Denotes_Discriminant
6880 (Node (Dcon), Check_Concurrent => True)
6881 then
6882 exit Discr_Loop;
6883
6884 -- In the context of a case statement, the expression
6885 -- may have the base type of the discriminant, and we
6886 -- need to preserve the constraint to avoid spurious
6887 -- errors on missing cases.
6888
6889 elsif Nkind (Parent (N)) = N_Case_Statement
6890 and then Etype (Node (Dcon)) /= Etype (Disc)
6891 then
6892 Rewrite (N,
6893 Make_Qualified_Expression (Loc,
6894 Subtype_Mark =>
6895 New_Occurrence_Of (Etype (Disc), Loc),
6896 Expression =>
6897 New_Copy_Tree (Node (Dcon))));
6898 Analyze_And_Resolve (N, Etype (Disc));
6899
6900 -- In case that comes out as a static expression,
6901 -- reset it (a selected component is never static).
6902
6903 Set_Is_Static_Expression (N, False);
6904 return;
6905
6906 -- Otherwise we can just copy the constraint, but the
6907 -- result is certainly not static! In some cases the
6908 -- discriminant constraint has been analyzed in the
6909 -- context of the original subtype indication, but for
6910 -- itypes the constraint might not have been analyzed
6911 -- yet, and this must be done now.
6912
6913 else
6914 Rewrite (N, New_Copy_Tree (Node (Dcon)));
6915 Analyze_And_Resolve (N);
6916 Set_Is_Static_Expression (N, False);
6917 return;
6918 end if;
6919 end if;
6920
6921 Next_Elmt (Dcon);
6922 Next_Discriminant (Disc);
6923 end loop Discr_Loop;
6924
6925 -- Note: the above loop should always find a matching
6926 -- discriminant, but if it does not, we just missed an
6927 -- optimization due to some glitch (perhaps a previous
6928 -- error), so ignore.
6929
6930 end if;
6931 end if;
6932
6933 -- The only remaining processing is in the case of a discriminant of
6934 -- a concurrent object, where we rewrite the prefix to denote the
6935 -- corresponding record type. If the type is derived and has renamed
6936 -- discriminants, use corresponding discriminant, which is the one
6937 -- that appears in the corresponding record.
6938
6939 if not Is_Concurrent_Type (Ptyp) then
6940 return;
6941 end if;
6942
6943 Disc := Entity (Selector_Name (N));
6944
6945 if Is_Derived_Type (Ptyp)
6946 and then Present (Corresponding_Discriminant (Disc))
6947 then
6948 Disc := Corresponding_Discriminant (Disc);
6949 end if;
6950
6951 New_N :=
6952 Make_Selected_Component (Loc,
6953 Prefix =>
6954 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
6955 New_Copy_Tree (P)),
6956 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
6957
6958 Rewrite (N, New_N);
6959 Analyze (N);
6960 end if;
6961 end Expand_N_Selected_Component;
6962
6963 --------------------
6964 -- Expand_N_Slice --
6965 --------------------
6966
6967 procedure Expand_N_Slice (N : Node_Id) is
6968 Loc : constant Source_Ptr := Sloc (N);
6969 Typ : constant Entity_Id := Etype (N);
6970 Pfx : constant Node_Id := Prefix (N);
6971 Ptp : Entity_Id := Etype (Pfx);
6972
6973 function Is_Procedure_Actual (N : Node_Id) return Boolean;
6974 -- Check whether the argument is an actual for a procedure call,
6975 -- in which case the expansion of a bit-packed slice is deferred
6976 -- until the call itself is expanded. The reason this is required
6977 -- is that we might have an IN OUT or OUT parameter, and the copy out
6978 -- is essential, and that copy out would be missed if we created a
6979 -- temporary here in Expand_N_Slice. Note that we don't bother
6980 -- to test specifically for an IN OUT or OUT mode parameter, since it
6981 -- is a bit tricky to do, and it is harmless to defer expansion
6982 -- in the IN case, since the call processing will still generate the
6983 -- appropriate copy in operation, which will take care of the slice.
6984
6985 procedure Make_Temporary;
6986 -- Create a named variable for the value of the slice, in
6987 -- cases where the back-end cannot handle it properly, e.g.
6988 -- when packed types or unaligned slices are involved.
6989
6990 -------------------------
6991 -- Is_Procedure_Actual --
6992 -------------------------
6993
6994 function Is_Procedure_Actual (N : Node_Id) return Boolean is
6995 Par : Node_Id := Parent (N);
6996
6997 begin
6998 loop
6999 -- If our parent is a procedure call we can return
7000
7001 if Nkind (Par) = N_Procedure_Call_Statement then
7002 return True;
7003
7004 -- If our parent is a type conversion, keep climbing the
7005 -- tree, since a type conversion can be a procedure actual.
7006 -- Also keep climbing if parameter association or a qualified
7007 -- expression, since these are additional cases that do can
7008 -- appear on procedure actuals.
7009
7010 elsif Nkind_In (Par, N_Type_Conversion,
7011 N_Parameter_Association,
7012 N_Qualified_Expression)
7013 then
7014 Par := Parent (Par);
7015
7016 -- Any other case is not what we are looking for
7017
7018 else
7019 return False;
7020 end if;
7021 end loop;
7022 end Is_Procedure_Actual;
7023
7024 --------------------
7025 -- Make_Temporary --
7026 --------------------
7027
7028 procedure Make_Temporary is
7029 Decl : Node_Id;
7030 Ent : constant Entity_Id :=
7031 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
7032 begin
7033 Decl :=
7034 Make_Object_Declaration (Loc,
7035 Defining_Identifier => Ent,
7036 Object_Definition => New_Occurrence_Of (Typ, Loc));
7037
7038 Set_No_Initialization (Decl);
7039
7040 Insert_Actions (N, New_List (
7041 Decl,
7042 Make_Assignment_Statement (Loc,
7043 Name => New_Occurrence_Of (Ent, Loc),
7044 Expression => Relocate_Node (N))));
7045
7046 Rewrite (N, New_Occurrence_Of (Ent, Loc));
7047 Analyze_And_Resolve (N, Typ);
7048 end Make_Temporary;
7049
7050 -- Start of processing for Expand_N_Slice
7051
7052 begin
7053 -- Special handling for access types
7054
7055 if Is_Access_Type (Ptp) then
7056
7057 Ptp := Designated_Type (Ptp);
7058
7059 Rewrite (Pfx,
7060 Make_Explicit_Dereference (Sloc (N),
7061 Prefix => Relocate_Node (Pfx)));
7062
7063 Analyze_And_Resolve (Pfx, Ptp);
7064 end if;
7065
7066 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7067 -- function, then additional actuals must be passed.
7068
7069 if Ada_Version >= Ada_05
7070 and then Is_Build_In_Place_Function_Call (Pfx)
7071 then
7072 Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
7073 end if;
7074
7075 -- Range checks are potentially also needed for cases involving
7076 -- a slice indexed by a subtype indication, but Do_Range_Check
7077 -- can currently only be set for expressions ???
7078
7079 if not Index_Checks_Suppressed (Ptp)
7080 and then (not Is_Entity_Name (Pfx)
7081 or else not Index_Checks_Suppressed (Entity (Pfx)))
7082 and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
7083
7084 -- Do not enable range check to nodes associated with the frontend
7085 -- expansion of the dispatch table. We first check if Ada.Tags is
7086 -- already loaded to avoid the addition of an undesired dependence
7087 -- on such run-time unit.
7088
7089 and then
7090 (VM_Target /= No_VM
7091 or else not
7092 (RTU_Loaded (Ada_Tags)
7093 and then Nkind (Prefix (N)) = N_Selected_Component
7094 and then Present (Entity (Selector_Name (Prefix (N))))
7095 and then Entity (Selector_Name (Prefix (N))) =
7096 RTE_Record_Component (RE_Prims_Ptr)))
7097 then
7098 Enable_Range_Check (Discrete_Range (N));
7099 end if;
7100
7101 -- The remaining case to be handled is packed slices. We can leave
7102 -- packed slices as they are in the following situations:
7103
7104 -- 1. Right or left side of an assignment (we can handle this
7105 -- situation correctly in the assignment statement expansion).
7106
7107 -- 2. Prefix of indexed component (the slide is optimized away
7108 -- in this case, see the start of Expand_N_Slice.)
7109
7110 -- 3. Object renaming declaration, since we want the name of
7111 -- the slice, not the value.
7112
7113 -- 4. Argument to procedure call, since copy-in/copy-out handling
7114 -- may be required, and this is handled in the expansion of
7115 -- call itself.
7116
7117 -- 5. Prefix of an address attribute (this is an error which
7118 -- is caught elsewhere, and the expansion would interfere
7119 -- with generating the error message).
7120
7121 if not Is_Packed (Typ) then
7122
7123 -- Apply transformation for actuals of a function call,
7124 -- where Expand_Actuals is not used.
7125
7126 if Nkind (Parent (N)) = N_Function_Call
7127 and then Is_Possibly_Unaligned_Slice (N)
7128 then
7129 Make_Temporary;
7130 end if;
7131
7132 elsif Nkind (Parent (N)) = N_Assignment_Statement
7133 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
7134 and then Parent (N) = Name (Parent (Parent (N))))
7135 then
7136 return;
7137
7138 elsif Nkind (Parent (N)) = N_Indexed_Component
7139 or else Is_Renamed_Object (N)
7140 or else Is_Procedure_Actual (N)
7141 then
7142 return;
7143
7144 elsif Nkind (Parent (N)) = N_Attribute_Reference
7145 and then Attribute_Name (Parent (N)) = Name_Address
7146 then
7147 return;
7148
7149 else
7150 Make_Temporary;
7151 end if;
7152 end Expand_N_Slice;
7153
7154 ------------------------------
7155 -- Expand_N_Type_Conversion --
7156 ------------------------------
7157
7158 procedure Expand_N_Type_Conversion (N : Node_Id) is
7159 Loc : constant Source_Ptr := Sloc (N);
7160 Operand : constant Node_Id := Expression (N);
7161 Target_Type : constant Entity_Id := Etype (N);
7162 Operand_Type : Entity_Id := Etype (Operand);
7163
7164 procedure Handle_Changed_Representation;
7165 -- This is called in the case of record and array type conversions
7166 -- to see if there is a change of representation to be handled.
7167 -- Change of representation is actually handled at the assignment
7168 -- statement level, and what this procedure does is rewrite node N
7169 -- conversion as an assignment to temporary. If there is no change
7170 -- of representation, then the conversion node is unchanged.
7171
7172 procedure Real_Range_Check;
7173 -- Handles generation of range check for real target value
7174
7175 -----------------------------------
7176 -- Handle_Changed_Representation --
7177 -----------------------------------
7178
7179 procedure Handle_Changed_Representation is
7180 Temp : Entity_Id;
7181 Decl : Node_Id;
7182 Odef : Node_Id;
7183 Disc : Node_Id;
7184 N_Ix : Node_Id;
7185 Cons : List_Id;
7186
7187 begin
7188 -- Nothing else to do if no change of representation
7189
7190 if Same_Representation (Operand_Type, Target_Type) then
7191 return;
7192
7193 -- The real change of representation work is done by the assignment
7194 -- statement processing. So if this type conversion is appearing as
7195 -- the expression of an assignment statement, nothing needs to be
7196 -- done to the conversion.
7197
7198 elsif Nkind (Parent (N)) = N_Assignment_Statement then
7199 return;
7200
7201 -- Otherwise we need to generate a temporary variable, and do the
7202 -- change of representation assignment into that temporary variable.
7203 -- The conversion is then replaced by a reference to this variable.
7204
7205 else
7206 Cons := No_List;
7207
7208 -- If type is unconstrained we have to add a constraint,
7209 -- copied from the actual value of the left hand side.
7210
7211 if not Is_Constrained (Target_Type) then
7212 if Has_Discriminants (Operand_Type) then
7213 Disc := First_Discriminant (Operand_Type);
7214
7215 if Disc /= First_Stored_Discriminant (Operand_Type) then
7216 Disc := First_Stored_Discriminant (Operand_Type);
7217 end if;
7218
7219 Cons := New_List;
7220 while Present (Disc) loop
7221 Append_To (Cons,
7222 Make_Selected_Component (Loc,
7223 Prefix => Duplicate_Subexpr_Move_Checks (Operand),
7224 Selector_Name =>
7225 Make_Identifier (Loc, Chars (Disc))));
7226 Next_Discriminant (Disc);
7227 end loop;
7228
7229 elsif Is_Array_Type (Operand_Type) then
7230 N_Ix := First_Index (Target_Type);
7231 Cons := New_List;
7232
7233 for J in 1 .. Number_Dimensions (Operand_Type) loop
7234
7235 -- We convert the bounds explicitly. We use an unchecked
7236 -- conversion because bounds checks are done elsewhere.
7237
7238 Append_To (Cons,
7239 Make_Range (Loc,
7240 Low_Bound =>
7241 Unchecked_Convert_To (Etype (N_Ix),
7242 Make_Attribute_Reference (Loc,
7243 Prefix =>
7244 Duplicate_Subexpr_No_Checks
7245 (Operand, Name_Req => True),
7246 Attribute_Name => Name_First,
7247 Expressions => New_List (
7248 Make_Integer_Literal (Loc, J)))),
7249
7250 High_Bound =>
7251 Unchecked_Convert_To (Etype (N_Ix),
7252 Make_Attribute_Reference (Loc,
7253 Prefix =>
7254 Duplicate_Subexpr_No_Checks
7255 (Operand, Name_Req => True),
7256 Attribute_Name => Name_Last,
7257 Expressions => New_List (
7258 Make_Integer_Literal (Loc, J))))));
7259
7260 Next_Index (N_Ix);
7261 end loop;
7262 end if;
7263 end if;
7264
7265 Odef := New_Occurrence_Of (Target_Type, Loc);
7266
7267 if Present (Cons) then
7268 Odef :=
7269 Make_Subtype_Indication (Loc,
7270 Subtype_Mark => Odef,
7271 Constraint =>
7272 Make_Index_Or_Discriminant_Constraint (Loc,
7273 Constraints => Cons));
7274 end if;
7275
7276 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
7277 Decl :=
7278 Make_Object_Declaration (Loc,
7279 Defining_Identifier => Temp,
7280 Object_Definition => Odef);
7281
7282 Set_No_Initialization (Decl, True);
7283
7284 -- Insert required actions. It is essential to suppress checks
7285 -- since we have suppressed default initialization, which means
7286 -- that the variable we create may have no discriminants.
7287
7288 Insert_Actions (N,
7289 New_List (
7290 Decl,
7291 Make_Assignment_Statement (Loc,
7292 Name => New_Occurrence_Of (Temp, Loc),
7293 Expression => Relocate_Node (N))),
7294 Suppress => All_Checks);
7295
7296 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7297 return;
7298 end if;
7299 end Handle_Changed_Representation;
7300
7301 ----------------------
7302 -- Real_Range_Check --
7303 ----------------------
7304
7305 -- Case of conversions to floating-point or fixed-point. If range
7306 -- checks are enabled and the target type has a range constraint,
7307 -- we convert:
7308
7309 -- typ (x)
7310
7311 -- to
7312
7313 -- Tnn : typ'Base := typ'Base (x);
7314 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7315 -- Tnn
7316
7317 -- This is necessary when there is a conversion of integer to float
7318 -- or to fixed-point to ensure that the correct checks are made. It
7319 -- is not necessary for float to float where it is enough to simply
7320 -- set the Do_Range_Check flag.
7321
7322 procedure Real_Range_Check is
7323 Btyp : constant Entity_Id := Base_Type (Target_Type);
7324 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
7325 Hi : constant Node_Id := Type_High_Bound (Target_Type);
7326 Xtyp : constant Entity_Id := Etype (Operand);
7327 Conv : Node_Id;
7328 Tnn : Entity_Id;
7329
7330 begin
7331 -- Nothing to do if conversion was rewritten
7332
7333 if Nkind (N) /= N_Type_Conversion then
7334 return;
7335 end if;
7336
7337 -- Nothing to do if range checks suppressed, or target has the
7338 -- same range as the base type (or is the base type).
7339
7340 if Range_Checks_Suppressed (Target_Type)
7341 or else (Lo = Type_Low_Bound (Btyp)
7342 and then
7343 Hi = Type_High_Bound (Btyp))
7344 then
7345 return;
7346 end if;
7347
7348 -- Nothing to do if expression is an entity on which checks
7349 -- have been suppressed.
7350
7351 if Is_Entity_Name (Operand)
7352 and then Range_Checks_Suppressed (Entity (Operand))
7353 then
7354 return;
7355 end if;
7356
7357 -- Nothing to do if bounds are all static and we can tell that
7358 -- the expression is within the bounds of the target. Note that
7359 -- if the operand is of an unconstrained floating-point type,
7360 -- then we do not trust it to be in range (might be infinite)
7361
7362 declare
7363 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
7364 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
7365
7366 begin
7367 if (not Is_Floating_Point_Type (Xtyp)
7368 or else Is_Constrained (Xtyp))
7369 and then Compile_Time_Known_Value (S_Lo)
7370 and then Compile_Time_Known_Value (S_Hi)
7371 and then Compile_Time_Known_Value (Hi)
7372 and then Compile_Time_Known_Value (Lo)
7373 then
7374 declare
7375 D_Lov : constant Ureal := Expr_Value_R (Lo);
7376 D_Hiv : constant Ureal := Expr_Value_R (Hi);
7377 S_Lov : Ureal;
7378 S_Hiv : Ureal;
7379
7380 begin
7381 if Is_Real_Type (Xtyp) then
7382 S_Lov := Expr_Value_R (S_Lo);
7383 S_Hiv := Expr_Value_R (S_Hi);
7384 else
7385 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
7386 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
7387 end if;
7388
7389 if D_Hiv > D_Lov
7390 and then S_Lov >= D_Lov
7391 and then S_Hiv <= D_Hiv
7392 then
7393 Set_Do_Range_Check (Operand, False);
7394 return;
7395 end if;
7396 end;
7397 end if;
7398 end;
7399
7400 -- For float to float conversions, we are done
7401
7402 if Is_Floating_Point_Type (Xtyp)
7403 and then
7404 Is_Floating_Point_Type (Btyp)
7405 then
7406 return;
7407 end if;
7408
7409 -- Otherwise rewrite the conversion as described above
7410
7411 Conv := Relocate_Node (N);
7412 Rewrite
7413 (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
7414 Set_Etype (Conv, Btyp);
7415
7416 -- Enable overflow except for case of integer to float conversions,
7417 -- where it is never required, since we can never have overflow in
7418 -- this case.
7419
7420 if not Is_Integer_Type (Etype (Operand)) then
7421 Enable_Overflow_Check (Conv);
7422 end if;
7423
7424 Tnn :=
7425 Make_Defining_Identifier (Loc,
7426 Chars => New_Internal_Name ('T'));
7427
7428 Insert_Actions (N, New_List (
7429 Make_Object_Declaration (Loc,
7430 Defining_Identifier => Tnn,
7431 Object_Definition => New_Occurrence_Of (Btyp, Loc),
7432 Expression => Conv),
7433
7434 Make_Raise_Constraint_Error (Loc,
7435 Condition =>
7436 Make_Or_Else (Loc,
7437 Left_Opnd =>
7438 Make_Op_Lt (Loc,
7439 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
7440 Right_Opnd =>
7441 Make_Attribute_Reference (Loc,
7442 Attribute_Name => Name_First,
7443 Prefix =>
7444 New_Occurrence_Of (Target_Type, Loc))),
7445
7446 Right_Opnd =>
7447 Make_Op_Gt (Loc,
7448 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
7449 Right_Opnd =>
7450 Make_Attribute_Reference (Loc,
7451 Attribute_Name => Name_Last,
7452 Prefix =>
7453 New_Occurrence_Of (Target_Type, Loc)))),
7454 Reason => CE_Range_Check_Failed)));
7455
7456 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
7457 Analyze_And_Resolve (N, Btyp);
7458 end Real_Range_Check;
7459
7460 -- Start of processing for Expand_N_Type_Conversion
7461
7462 begin
7463 -- Nothing at all to do if conversion is to the identical type
7464 -- so remove the conversion completely, it is useless.
7465
7466 if Operand_Type = Target_Type then
7467 Rewrite (N, Relocate_Node (Operand));
7468 return;
7469 end if;
7470
7471 -- Nothing to do if this is the second argument of read. This
7472 -- is a "backwards" conversion that will be handled by the
7473 -- specialized code in attribute processing.
7474
7475 if Nkind (Parent (N)) = N_Attribute_Reference
7476 and then Attribute_Name (Parent (N)) = Name_Read
7477 and then Next (First (Expressions (Parent (N)))) = N
7478 then
7479 return;
7480 end if;
7481
7482 -- Here if we may need to expand conversion
7483
7484 -- Do validity check if validity checking operands
7485
7486 if Validity_Checks_On
7487 and then Validity_Check_Operands
7488 then
7489 Ensure_Valid (Operand);
7490 end if;
7491
7492 -- Special case of converting from non-standard boolean type
7493
7494 if Is_Boolean_Type (Operand_Type)
7495 and then (Nonzero_Is_True (Operand_Type))
7496 then
7497 Adjust_Condition (Operand);
7498 Set_Etype (Operand, Standard_Boolean);
7499 Operand_Type := Standard_Boolean;
7500 end if;
7501
7502 -- Case of converting to an access type
7503
7504 if Is_Access_Type (Target_Type) then
7505
7506 -- Apply an accessibility check when the conversion operand is an
7507 -- access parameter (or a renaming thereof), unless conversion was
7508 -- expanded from an unchecked or unrestricted access attribute. Note
7509 -- that other checks may still need to be applied below (such as
7510 -- tagged type checks).
7511
7512 if Is_Entity_Name (Operand)
7513 and then
7514 (Is_Formal (Entity (Operand))
7515 or else
7516 (Present (Renamed_Object (Entity (Operand)))
7517 and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
7518 and then Is_Formal
7519 (Entity (Renamed_Object (Entity (Operand))))))
7520 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
7521 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
7522 or else Attribute_Name (Original_Node (N)) = Name_Access)
7523 then
7524 Apply_Accessibility_Check (Operand, Target_Type);
7525
7526 -- If the level of the operand type is statically deeper
7527 -- then the level of the target type, then force Program_Error.
7528 -- Note that this can only occur for cases where the attribute
7529 -- is within the body of an instantiation (otherwise the
7530 -- conversion will already have been rejected as illegal).
7531 -- Note: warnings are issued by the analyzer for the instance
7532 -- cases.
7533
7534 elsif In_Instance_Body
7535 and then Type_Access_Level (Operand_Type) >
7536 Type_Access_Level (Target_Type)
7537 then
7538 Rewrite (N,
7539 Make_Raise_Program_Error (Sloc (N),
7540 Reason => PE_Accessibility_Check_Failed));
7541 Set_Etype (N, Target_Type);
7542
7543 -- When the operand is a selected access discriminant
7544 -- the check needs to be made against the level of the
7545 -- object denoted by the prefix of the selected name.
7546 -- Force Program_Error for this case as well (this
7547 -- accessibility violation can only happen if within
7548 -- the body of an instantiation).
7549
7550 elsif In_Instance_Body
7551 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
7552 and then Nkind (Operand) = N_Selected_Component
7553 and then Object_Access_Level (Operand) >
7554 Type_Access_Level (Target_Type)
7555 then
7556 Rewrite (N,
7557 Make_Raise_Program_Error (Sloc (N),
7558 Reason => PE_Accessibility_Check_Failed));
7559 Set_Etype (N, Target_Type);
7560 end if;
7561 end if;
7562
7563 -- Case of conversions of tagged types and access to tagged types
7564
7565 -- When needed, that is to say when the expression is class-wide,
7566 -- Add runtime a tag check for (strict) downward conversion by using
7567 -- the membership test, generating:
7568
7569 -- [constraint_error when Operand not in Target_Type'Class]
7570
7571 -- or in the access type case
7572
7573 -- [constraint_error
7574 -- when Operand /= null
7575 -- and then Operand.all not in
7576 -- Designated_Type (Target_Type)'Class]
7577
7578 if (Is_Access_Type (Target_Type)
7579 and then Is_Tagged_Type (Designated_Type (Target_Type)))
7580 or else Is_Tagged_Type (Target_Type)
7581 then
7582 -- Do not do any expansion in the access type case if the
7583 -- parent is a renaming, since this is an error situation
7584 -- which will be caught by Sem_Ch8, and the expansion can
7585 -- interfere with this error check.
7586
7587 if Is_Access_Type (Target_Type)
7588 and then Is_Renamed_Object (N)
7589 then
7590 return;
7591 end if;
7592
7593 -- Otherwise, proceed with processing tagged conversion
7594
7595 declare
7596 Actual_Operand_Type : Entity_Id;
7597 Actual_Target_Type : Entity_Id;
7598
7599 Cond : Node_Id;
7600
7601 begin
7602 if Is_Access_Type (Target_Type) then
7603 Actual_Operand_Type := Designated_Type (Operand_Type);
7604 Actual_Target_Type := Designated_Type (Target_Type);
7605
7606 else
7607 Actual_Operand_Type := Operand_Type;
7608 Actual_Target_Type := Target_Type;
7609 end if;
7610
7611 -- Ada 2005 (AI-251): Handle interface type conversion
7612
7613 if Is_Interface (Actual_Operand_Type) then
7614 Expand_Interface_Conversion (N, Is_Static => False);
7615 return;
7616 end if;
7617
7618 if Is_Class_Wide_Type (Actual_Operand_Type)
7619 and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type
7620 and then Is_Ancestor
7621 (Root_Type (Actual_Operand_Type),
7622 Actual_Target_Type)
7623 and then not Tag_Checks_Suppressed (Actual_Target_Type)
7624 then
7625 -- The conversion is valid for any descendant of the
7626 -- target type
7627
7628 Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
7629
7630 if Is_Access_Type (Target_Type) then
7631 Cond :=
7632 Make_And_Then (Loc,
7633 Left_Opnd =>
7634 Make_Op_Ne (Loc,
7635 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
7636 Right_Opnd => Make_Null (Loc)),
7637
7638 Right_Opnd =>
7639 Make_Not_In (Loc,
7640 Left_Opnd =>
7641 Make_Explicit_Dereference (Loc,
7642 Prefix =>
7643 Duplicate_Subexpr_No_Checks (Operand)),
7644 Right_Opnd =>
7645 New_Reference_To (Actual_Target_Type, Loc)));
7646
7647 else
7648 Cond :=
7649 Make_Not_In (Loc,
7650 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
7651 Right_Opnd =>
7652 New_Reference_To (Actual_Target_Type, Loc));
7653 end if;
7654
7655 Insert_Action (N,
7656 Make_Raise_Constraint_Error (Loc,
7657 Condition => Cond,
7658 Reason => CE_Tag_Check_Failed));
7659
7660 declare
7661 Conv : Node_Id;
7662 begin
7663 Conv :=
7664 Make_Unchecked_Type_Conversion (Loc,
7665 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
7666 Expression => Relocate_Node (Expression (N)));
7667 Rewrite (N, Conv);
7668 Analyze_And_Resolve (N, Target_Type);
7669 end;
7670 end if;
7671 end;
7672
7673 -- Case of other access type conversions
7674
7675 elsif Is_Access_Type (Target_Type) then
7676 Apply_Constraint_Check (Operand, Target_Type);
7677
7678 -- Case of conversions from a fixed-point type
7679
7680 -- These conversions require special expansion and processing, found
7681 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
7682 -- set, since from a semantic point of view, these are simple integer
7683 -- conversions, which do not need further processing.
7684
7685 elsif Is_Fixed_Point_Type (Operand_Type)
7686 and then not Conversion_OK (N)
7687 then
7688 -- We should never see universal fixed at this case, since the
7689 -- expansion of the constituent divide or multiply should have
7690 -- eliminated the explicit mention of universal fixed.
7691
7692 pragma Assert (Operand_Type /= Universal_Fixed);
7693
7694 -- Check for special case of the conversion to universal real
7695 -- that occurs as a result of the use of a round attribute.
7696 -- In this case, the real type for the conversion is taken
7697 -- from the target type of the Round attribute and the
7698 -- result must be marked as rounded.
7699
7700 if Target_Type = Universal_Real
7701 and then Nkind (Parent (N)) = N_Attribute_Reference
7702 and then Attribute_Name (Parent (N)) = Name_Round
7703 then
7704 Set_Rounded_Result (N);
7705 Set_Etype (N, Etype (Parent (N)));
7706 end if;
7707
7708 -- Otherwise do correct fixed-conversion, but skip these if the
7709 -- Conversion_OK flag is set, because from a semantic point of
7710 -- view these are simple integer conversions needing no further
7711 -- processing (the backend will simply treat them as integers)
7712
7713 if not Conversion_OK (N) then
7714 if Is_Fixed_Point_Type (Etype (N)) then
7715 Expand_Convert_Fixed_To_Fixed (N);
7716 Real_Range_Check;
7717
7718 elsif Is_Integer_Type (Etype (N)) then
7719 Expand_Convert_Fixed_To_Integer (N);
7720
7721 else
7722 pragma Assert (Is_Floating_Point_Type (Etype (N)));
7723 Expand_Convert_Fixed_To_Float (N);
7724 Real_Range_Check;
7725 end if;
7726 end if;
7727
7728 -- Case of conversions to a fixed-point type
7729
7730 -- These conversions require special expansion and processing, found
7731 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
7732 -- is set, since from a semantic point of view, these are simple
7733 -- integer conversions, which do not need further processing.
7734
7735 elsif Is_Fixed_Point_Type (Target_Type)
7736 and then not Conversion_OK (N)
7737 then
7738 if Is_Integer_Type (Operand_Type) then
7739 Expand_Convert_Integer_To_Fixed (N);
7740 Real_Range_Check;
7741 else
7742 pragma Assert (Is_Floating_Point_Type (Operand_Type));
7743 Expand_Convert_Float_To_Fixed (N);
7744 Real_Range_Check;
7745 end if;
7746
7747 -- Case of float-to-integer conversions
7748
7749 -- We also handle float-to-fixed conversions with Conversion_OK set
7750 -- since semantically the fixed-point target is treated as though it
7751 -- were an integer in such cases.
7752
7753 elsif Is_Floating_Point_Type (Operand_Type)
7754 and then
7755 (Is_Integer_Type (Target_Type)
7756 or else
7757 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
7758 then
7759 -- One more check here, gcc is still not able to do conversions of
7760 -- this type with proper overflow checking, and so gigi is doing an
7761 -- approximation of what is required by doing floating-point compares
7762 -- with the end-point. But that can lose precision in some cases, and
7763 -- give a wrong result. Converting the operand to Universal_Real is
7764 -- helpful, but still does not catch all cases with 64-bit integers
7765 -- on targets with only 64-bit floats
7766
7767 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
7768 -- Can this code be removed ???
7769
7770 if Do_Range_Check (Operand) then
7771 Rewrite (Operand,
7772 Make_Type_Conversion (Loc,
7773 Subtype_Mark =>
7774 New_Occurrence_Of (Universal_Real, Loc),
7775 Expression =>
7776 Relocate_Node (Operand)));
7777
7778 Set_Etype (Operand, Universal_Real);
7779 Enable_Range_Check (Operand);
7780 Set_Do_Range_Check (Expression (Operand), False);
7781 end if;
7782
7783 -- Case of array conversions
7784
7785 -- Expansion of array conversions, add required length/range checks
7786 -- but only do this if there is no change of representation. For
7787 -- handling of this case, see Handle_Changed_Representation.
7788
7789 elsif Is_Array_Type (Target_Type) then
7790
7791 if Is_Constrained (Target_Type) then
7792 Apply_Length_Check (Operand, Target_Type);
7793 else
7794 Apply_Range_Check (Operand, Target_Type);
7795 end if;
7796
7797 Handle_Changed_Representation;
7798
7799 -- Case of conversions of discriminated types
7800
7801 -- Add required discriminant checks if target is constrained. Again
7802 -- this change is skipped if we have a change of representation.
7803
7804 elsif Has_Discriminants (Target_Type)
7805 and then Is_Constrained (Target_Type)
7806 then
7807 Apply_Discriminant_Check (Operand, Target_Type);
7808 Handle_Changed_Representation;
7809
7810 -- Case of all other record conversions. The only processing required
7811 -- is to check for a change of representation requiring the special
7812 -- assignment processing.
7813
7814 elsif Is_Record_Type (Target_Type) then
7815
7816 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7817 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
7818 -- Union type if the operand lacks inferable discriminants.
7819
7820 if Is_Derived_Type (Operand_Type)
7821 and then Is_Unchecked_Union (Base_Type (Operand_Type))
7822 and then not Is_Constrained (Target_Type)
7823 and then not Is_Unchecked_Union (Base_Type (Target_Type))
7824 and then not Has_Inferable_Discriminants (Operand)
7825 then
7826 -- To prevent Gigi from generating illegal code, we make a
7827 -- Program_Error node, but we give it the target type of the
7828 -- conversion.
7829
7830 declare
7831 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
7832 Reason => PE_Unchecked_Union_Restriction);
7833
7834 begin
7835 Set_Etype (PE, Target_Type);
7836 Rewrite (N, PE);
7837
7838 end;
7839 else
7840 Handle_Changed_Representation;
7841 end if;
7842
7843 -- Case of conversions of enumeration types
7844
7845 elsif Is_Enumeration_Type (Target_Type) then
7846
7847 -- Special processing is required if there is a change of
7848 -- representation (from enumeration representation clauses)
7849
7850 if not Same_Representation (Target_Type, Operand_Type) then
7851
7852 -- Convert: x(y) to x'val (ytyp'val (y))
7853
7854 Rewrite (N,
7855 Make_Attribute_Reference (Loc,
7856 Prefix => New_Occurrence_Of (Target_Type, Loc),
7857 Attribute_Name => Name_Val,
7858 Expressions => New_List (
7859 Make_Attribute_Reference (Loc,
7860 Prefix => New_Occurrence_Of (Operand_Type, Loc),
7861 Attribute_Name => Name_Pos,
7862 Expressions => New_List (Operand)))));
7863
7864 Analyze_And_Resolve (N, Target_Type);
7865 end if;
7866
7867 -- Case of conversions to floating-point
7868
7869 elsif Is_Floating_Point_Type (Target_Type) then
7870 Real_Range_Check;
7871 end if;
7872
7873 -- At this stage, either the conversion node has been transformed
7874 -- into some other equivalent expression, or left as a conversion
7875 -- that can be handled by Gigi. The conversions that Gigi can handle
7876 -- are the following:
7877
7878 -- Conversions with no change of representation or type
7879
7880 -- Numeric conversions involving integer values, floating-point
7881 -- values, and fixed-point values. Fixed-point values are allowed
7882 -- only if Conversion_OK is set, i.e. if the fixed-point values
7883 -- are to be treated as integers.
7884
7885 -- No other conversions should be passed to Gigi
7886
7887 -- Check: are these rules stated in sinfo??? if so, why restate here???
7888
7889 -- The only remaining step is to generate a range check if we still
7890 -- have a type conversion at this stage and Do_Range_Check is set.
7891 -- For now we do this only for conversions of discrete types.
7892
7893 if Nkind (N) = N_Type_Conversion
7894 and then Is_Discrete_Type (Etype (N))
7895 then
7896 declare
7897 Expr : constant Node_Id := Expression (N);
7898 Ftyp : Entity_Id;
7899 Ityp : Entity_Id;
7900
7901 begin
7902 if Do_Range_Check (Expr)
7903 and then Is_Discrete_Type (Etype (Expr))
7904 then
7905 Set_Do_Range_Check (Expr, False);
7906
7907 -- Before we do a range check, we have to deal with treating
7908 -- a fixed-point operand as an integer. The way we do this
7909 -- is simply to do an unchecked conversion to an appropriate
7910 -- integer type large enough to hold the result.
7911
7912 -- This code is not active yet, because we are only dealing
7913 -- with discrete types so far ???
7914
7915 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
7916 and then Treat_Fixed_As_Integer (Expr)
7917 then
7918 Ftyp := Base_Type (Etype (Expr));
7919
7920 if Esize (Ftyp) >= Esize (Standard_Integer) then
7921 Ityp := Standard_Long_Long_Integer;
7922 else
7923 Ityp := Standard_Integer;
7924 end if;
7925
7926 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
7927 end if;
7928
7929 -- Reset overflow flag, since the range check will include
7930 -- dealing with possible overflow, and generate the check
7931 -- If Address is either source or target type, suppress
7932 -- range check to avoid typing anomalies when it is a visible
7933 -- integer type.
7934
7935 Set_Do_Overflow_Check (N, False);
7936 if not Is_Descendent_Of_Address (Etype (Expr))
7937 and then not Is_Descendent_Of_Address (Target_Type)
7938 then
7939 Generate_Range_Check
7940 (Expr, Target_Type, CE_Range_Check_Failed);
7941 end if;
7942 end if;
7943 end;
7944 end if;
7945
7946 -- Final step, if the result is a type conversion involving Vax_Float
7947 -- types, then it is subject for further special processing.
7948
7949 if Nkind (N) = N_Type_Conversion
7950 and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
7951 then
7952 Expand_Vax_Conversion (N);
7953 return;
7954 end if;
7955 end Expand_N_Type_Conversion;
7956
7957 -----------------------------------
7958 -- Expand_N_Unchecked_Expression --
7959 -----------------------------------
7960
7961 -- Remove the unchecked expression node from the tree. It's job was simply
7962 -- to make sure that its constituent expression was handled with checks
7963 -- off, and now that that is done, we can remove it from the tree, and
7964 -- indeed must, since gigi does not expect to see these nodes.
7965
7966 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
7967 Exp : constant Node_Id := Expression (N);
7968
7969 begin
7970 Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
7971 Rewrite (N, Exp);
7972 end Expand_N_Unchecked_Expression;
7973
7974 ----------------------------------------
7975 -- Expand_N_Unchecked_Type_Conversion --
7976 ----------------------------------------
7977
7978 -- If this cannot be handled by Gigi and we haven't already made
7979 -- a temporary for it, do it now.
7980
7981 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
7982 Target_Type : constant Entity_Id := Etype (N);
7983 Operand : constant Node_Id := Expression (N);
7984 Operand_Type : constant Entity_Id := Etype (Operand);
7985
7986 begin
7987 -- If we have a conversion of a compile time known value to a target
7988 -- type and the value is in range of the target type, then we can simply
7989 -- replace the construct by an integer literal of the correct type. We
7990 -- only apply this to integer types being converted. Possibly it may
7991 -- apply in other cases, but it is too much trouble to worry about.
7992
7993 -- Note that we do not do this transformation if the Kill_Range_Check
7994 -- flag is set, since then the value may be outside the expected range.
7995 -- This happens in the Normalize_Scalars case.
7996
7997 -- We also skip this if either the target or operand type is biased
7998 -- because in this case, the unchecked conversion is supposed to
7999 -- preserve the bit pattern, not the integer value.
8000
8001 if Is_Integer_Type (Target_Type)
8002 and then not Has_Biased_Representation (Target_Type)
8003 and then Is_Integer_Type (Operand_Type)
8004 and then not Has_Biased_Representation (Operand_Type)
8005 and then Compile_Time_Known_Value (Operand)
8006 and then not Kill_Range_Check (N)
8007 then
8008 declare
8009 Val : constant Uint := Expr_Value (Operand);
8010
8011 begin
8012 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
8013 and then
8014 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
8015 and then
8016 Val >= Expr_Value (Type_Low_Bound (Target_Type))
8017 and then
8018 Val <= Expr_Value (Type_High_Bound (Target_Type))
8019 then
8020 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
8021
8022 -- If Address is the target type, just set the type
8023 -- to avoid a spurious type error on the literal when
8024 -- Address is a visible integer type.
8025
8026 if Is_Descendent_Of_Address (Target_Type) then
8027 Set_Etype (N, Target_Type);
8028 else
8029 Analyze_And_Resolve (N, Target_Type);
8030 end if;
8031
8032 return;
8033 end if;
8034 end;
8035 end if;
8036
8037 -- Nothing to do if conversion is safe
8038
8039 if Safe_Unchecked_Type_Conversion (N) then
8040 return;
8041 end if;
8042
8043 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8044 -- flag indicates ??? -- more comments needed here)
8045
8046 if Assignment_OK (N) then
8047 null;
8048 else
8049 Force_Evaluation (N);
8050 end if;
8051 end Expand_N_Unchecked_Type_Conversion;
8052
8053 ----------------------------
8054 -- Expand_Record_Equality --
8055 ----------------------------
8056
8057 -- For non-variant records, Equality is expanded when needed into:
8058
8059 -- and then Lhs.Discr1 = Rhs.Discr1
8060 -- and then ...
8061 -- and then Lhs.Discrn = Rhs.Discrn
8062 -- and then Lhs.Cmp1 = Rhs.Cmp1
8063 -- and then ...
8064 -- and then Lhs.Cmpn = Rhs.Cmpn
8065
8066 -- The expression is folded by the back-end for adjacent fields. This
8067 -- function is called for tagged record in only one occasion: for imple-
8068 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8069 -- otherwise the primitive "=" is used directly.
8070
8071 function Expand_Record_Equality
8072 (Nod : Node_Id;
8073 Typ : Entity_Id;
8074 Lhs : Node_Id;
8075 Rhs : Node_Id;
8076 Bodies : List_Id) return Node_Id
8077 is
8078 Loc : constant Source_Ptr := Sloc (Nod);
8079
8080 Result : Node_Id;
8081 C : Entity_Id;
8082
8083 First_Time : Boolean := True;
8084
8085 function Suitable_Element (C : Entity_Id) return Entity_Id;
8086 -- Return the first field to compare beginning with C, skipping the
8087 -- inherited components.
8088
8089 ----------------------
8090 -- Suitable_Element --
8091 ----------------------
8092
8093 function Suitable_Element (C : Entity_Id) return Entity_Id is
8094 begin
8095 if No (C) then
8096 return Empty;
8097
8098 elsif Ekind (C) /= E_Discriminant
8099 and then Ekind (C) /= E_Component
8100 then
8101 return Suitable_Element (Next_Entity (C));
8102
8103 elsif Is_Tagged_Type (Typ)
8104 and then C /= Original_Record_Component (C)
8105 then
8106 return Suitable_Element (Next_Entity (C));
8107
8108 elsif Chars (C) = Name_uController
8109 or else Chars (C) = Name_uTag
8110 then
8111 return Suitable_Element (Next_Entity (C));
8112
8113 elsif Is_Interface (Etype (C)) then
8114 return Suitable_Element (Next_Entity (C));
8115
8116 else
8117 return C;
8118 end if;
8119 end Suitable_Element;
8120
8121 -- Start of processing for Expand_Record_Equality
8122
8123 begin
8124 -- Generates the following code: (assuming that Typ has one Discr and
8125 -- component C2 is also a record)
8126
8127 -- True
8128 -- and then Lhs.Discr1 = Rhs.Discr1
8129 -- and then Lhs.C1 = Rhs.C1
8130 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8131 -- and then ...
8132 -- and then Lhs.Cmpn = Rhs.Cmpn
8133
8134 Result := New_Reference_To (Standard_True, Loc);
8135 C := Suitable_Element (First_Entity (Typ));
8136
8137 while Present (C) loop
8138 declare
8139 New_Lhs : Node_Id;
8140 New_Rhs : Node_Id;
8141 Check : Node_Id;
8142
8143 begin
8144 if First_Time then
8145 First_Time := False;
8146 New_Lhs := Lhs;
8147 New_Rhs := Rhs;
8148 else
8149 New_Lhs := New_Copy_Tree (Lhs);
8150 New_Rhs := New_Copy_Tree (Rhs);
8151 end if;
8152
8153 Check :=
8154 Expand_Composite_Equality (Nod, Etype (C),
8155 Lhs =>
8156 Make_Selected_Component (Loc,
8157 Prefix => New_Lhs,
8158 Selector_Name => New_Reference_To (C, Loc)),
8159 Rhs =>
8160 Make_Selected_Component (Loc,
8161 Prefix => New_Rhs,
8162 Selector_Name => New_Reference_To (C, Loc)),
8163 Bodies => Bodies);
8164
8165 -- If some (sub)component is an unchecked_union, the whole
8166 -- operation will raise program error.
8167
8168 if Nkind (Check) = N_Raise_Program_Error then
8169 Result := Check;
8170 Set_Etype (Result, Standard_Boolean);
8171 exit;
8172 else
8173 Result :=
8174 Make_And_Then (Loc,
8175 Left_Opnd => Result,
8176 Right_Opnd => Check);
8177 end if;
8178 end;
8179
8180 C := Suitable_Element (Next_Entity (C));
8181 end loop;
8182
8183 return Result;
8184 end Expand_Record_Equality;
8185
8186 -------------------------------------
8187 -- Fixup_Universal_Fixed_Operation --
8188 -------------------------------------
8189
8190 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
8191 Conv : constant Node_Id := Parent (N);
8192
8193 begin
8194 -- We must have a type conversion immediately above us
8195
8196 pragma Assert (Nkind (Conv) = N_Type_Conversion);
8197
8198 -- Normally the type conversion gives our target type. The exception
8199 -- occurs in the case of the Round attribute, where the conversion
8200 -- will be to universal real, and our real type comes from the Round
8201 -- attribute (as well as an indication that we must round the result)
8202
8203 if Nkind (Parent (Conv)) = N_Attribute_Reference
8204 and then Attribute_Name (Parent (Conv)) = Name_Round
8205 then
8206 Set_Etype (N, Etype (Parent (Conv)));
8207 Set_Rounded_Result (N);
8208
8209 -- Normal case where type comes from conversion above us
8210
8211 else
8212 Set_Etype (N, Etype (Conv));
8213 end if;
8214 end Fixup_Universal_Fixed_Operation;
8215
8216 ------------------------------
8217 -- Get_Allocator_Final_List --
8218 ------------------------------
8219
8220 function Get_Allocator_Final_List
8221 (N : Node_Id;
8222 T : Entity_Id;
8223 PtrT : Entity_Id) return Entity_Id
8224 is
8225 Loc : constant Source_Ptr := Sloc (N);
8226
8227 Owner : Entity_Id := PtrT;
8228 -- The entity whose finalization list must be used to attach the
8229 -- allocated object.
8230
8231 begin
8232 if Ekind (PtrT) = E_Anonymous_Access_Type then
8233
8234 -- If the context is an access parameter, we need to create a
8235 -- non-anonymous access type in order to have a usable final list,
8236 -- because there is otherwise no pool to which the allocated object
8237 -- can belong. We create both the type and the finalization chain
8238 -- here, because freezing an internal type does not create such a
8239 -- chain. The Final_Chain that is thus created is shared by the
8240 -- access parameter. The access type is tested against the result
8241 -- type of the function to exclude allocators whose type is an
8242 -- anonymous access result type.
8243
8244 if Nkind (Associated_Node_For_Itype (PtrT))
8245 in N_Subprogram_Specification
8246 and then
8247 PtrT /=
8248 Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT)))
8249 then
8250 Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
8251 Insert_Action (N,
8252 Make_Full_Type_Declaration (Loc,
8253 Defining_Identifier => Owner,
8254 Type_Definition =>
8255 Make_Access_To_Object_Definition (Loc,
8256 Subtype_Indication =>
8257 New_Occurrence_Of (T, Loc))));
8258
8259 Build_Final_List (N, Owner);
8260 Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
8261
8262 -- Ada 2005 (AI-318-02): If the context is a return object
8263 -- declaration, then the anonymous return subtype is defined to have
8264 -- the same accessibility level as that of the function's result
8265 -- subtype, which means that we want the scope where the function is
8266 -- declared.
8267
8268 elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration
8269 and then Ekind (Scope (PtrT)) = E_Return_Statement
8270 then
8271 Owner := Scope (Return_Applies_To (Scope (PtrT)));
8272
8273 -- Case of an access discriminant, or (Ada 2005), of an anonymous
8274 -- access component or anonymous access function result: find the
8275 -- final list associated with the scope of the type. (In the
8276 -- anonymous access component kind, a list controller will have
8277 -- been allocated when freezing the record type, and PtrT has an
8278 -- Associated_Final_Chain attribute designating it.)
8279
8280 elsif No (Associated_Final_Chain (PtrT)) then
8281 Owner := Scope (PtrT);
8282 end if;
8283 end if;
8284
8285 return Find_Final_List (Owner);
8286 end Get_Allocator_Final_List;
8287
8288 ---------------------------------
8289 -- Has_Inferable_Discriminants --
8290 ---------------------------------
8291
8292 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
8293
8294 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
8295 -- Determines whether the left-most prefix of a selected component is a
8296 -- formal parameter in a subprogram. Assumes N is a selected component.
8297
8298 --------------------------------
8299 -- Prefix_Is_Formal_Parameter --
8300 --------------------------------
8301
8302 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
8303 Sel_Comp : Node_Id := N;
8304
8305 begin
8306 -- Move to the left-most prefix by climbing up the tree
8307
8308 while Present (Parent (Sel_Comp))
8309 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
8310 loop
8311 Sel_Comp := Parent (Sel_Comp);
8312 end loop;
8313
8314 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
8315 end Prefix_Is_Formal_Parameter;
8316
8317 -- Start of processing for Has_Inferable_Discriminants
8318
8319 begin
8320 -- For identifiers and indexed components, it is sufficient to have a
8321 -- constrained Unchecked_Union nominal subtype.
8322
8323 if Nkind_In (N, N_Identifier, N_Indexed_Component) then
8324 return Is_Unchecked_Union (Base_Type (Etype (N)))
8325 and then
8326 Is_Constrained (Etype (N));
8327
8328 -- For selected components, the subtype of the selector must be a
8329 -- constrained Unchecked_Union. If the component is subject to a
8330 -- per-object constraint, then the enclosing object must have inferable
8331 -- discriminants.
8332
8333 elsif Nkind (N) = N_Selected_Component then
8334 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
8335
8336 -- A small hack. If we have a per-object constrained selected
8337 -- component of a formal parameter, return True since we do not
8338 -- know the actual parameter association yet.
8339
8340 if Prefix_Is_Formal_Parameter (N) then
8341 return True;
8342 end if;
8343
8344 -- Otherwise, check the enclosing object and the selector
8345
8346 return Has_Inferable_Discriminants (Prefix (N))
8347 and then
8348 Has_Inferable_Discriminants (Selector_Name (N));
8349 end if;
8350
8351 -- The call to Has_Inferable_Discriminants will determine whether
8352 -- the selector has a constrained Unchecked_Union nominal type.
8353
8354 return Has_Inferable_Discriminants (Selector_Name (N));
8355
8356 -- A qualified expression has inferable discriminants if its subtype
8357 -- mark is a constrained Unchecked_Union subtype.
8358
8359 elsif Nkind (N) = N_Qualified_Expression then
8360 return Is_Unchecked_Union (Subtype_Mark (N))
8361 and then
8362 Is_Constrained (Subtype_Mark (N));
8363
8364 end if;
8365
8366 return False;
8367 end Has_Inferable_Discriminants;
8368
8369 -------------------------------
8370 -- Insert_Dereference_Action --
8371 -------------------------------
8372
8373 procedure Insert_Dereference_Action (N : Node_Id) is
8374 Loc : constant Source_Ptr := Sloc (N);
8375 Typ : constant Entity_Id := Etype (N);
8376 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
8377 Pnod : constant Node_Id := Parent (N);
8378
8379 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
8380 -- Return true if type of P is derived from Checked_Pool;
8381
8382 -----------------------------
8383 -- Is_Checked_Storage_Pool --
8384 -----------------------------
8385
8386 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
8387 T : Entity_Id;
8388
8389 begin
8390 if No (P) then
8391 return False;
8392 end if;
8393
8394 T := Etype (P);
8395 while T /= Etype (T) loop
8396 if Is_RTE (T, RE_Checked_Pool) then
8397 return True;
8398 else
8399 T := Etype (T);
8400 end if;
8401 end loop;
8402
8403 return False;
8404 end Is_Checked_Storage_Pool;
8405
8406 -- Start of processing for Insert_Dereference_Action
8407
8408 begin
8409 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
8410
8411 if not (Is_Checked_Storage_Pool (Pool)
8412 and then Comes_From_Source (Original_Node (Pnod)))
8413 then
8414 return;
8415 end if;
8416
8417 Insert_Action (N,
8418 Make_Procedure_Call_Statement (Loc,
8419 Name => New_Reference_To (
8420 Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
8421
8422 Parameter_Associations => New_List (
8423
8424 -- Pool
8425
8426 New_Reference_To (Pool, Loc),
8427
8428 -- Storage_Address. We use the attribute Pool_Address,
8429 -- which uses the pointer itself to find the address of
8430 -- the object, and which handles unconstrained arrays
8431 -- properly by computing the address of the template.
8432 -- i.e. the correct address of the corresponding allocation.
8433
8434 Make_Attribute_Reference (Loc,
8435 Prefix => Duplicate_Subexpr_Move_Checks (N),
8436 Attribute_Name => Name_Pool_Address),
8437
8438 -- Size_In_Storage_Elements
8439
8440 Make_Op_Divide (Loc,
8441 Left_Opnd =>
8442 Make_Attribute_Reference (Loc,
8443 Prefix =>
8444 Make_Explicit_Dereference (Loc,
8445 Duplicate_Subexpr_Move_Checks (N)),
8446 Attribute_Name => Name_Size),
8447 Right_Opnd =>
8448 Make_Integer_Literal (Loc, System_Storage_Unit)),
8449
8450 -- Alignment
8451
8452 Make_Attribute_Reference (Loc,
8453 Prefix =>
8454 Make_Explicit_Dereference (Loc,
8455 Duplicate_Subexpr_Move_Checks (N)),
8456 Attribute_Name => Name_Alignment))));
8457
8458 exception
8459 when RE_Not_Available =>
8460 return;
8461 end Insert_Dereference_Action;
8462
8463 ------------------------------
8464 -- Make_Array_Comparison_Op --
8465 ------------------------------
8466
8467 -- This is a hand-coded expansion of the following generic function:
8468
8469 -- generic
8470 -- type elem is (<>);
8471 -- type index is (<>);
8472 -- type a is array (index range <>) of elem;
8473
8474 -- function Gnnn (X : a; Y: a) return boolean is
8475 -- J : index := Y'first;
8476
8477 -- begin
8478 -- if X'length = 0 then
8479 -- return false;
8480
8481 -- elsif Y'length = 0 then
8482 -- return true;
8483
8484 -- else
8485 -- for I in X'range loop
8486 -- if X (I) = Y (J) then
8487 -- if J = Y'last then
8488 -- exit;
8489 -- else
8490 -- J := index'succ (J);
8491 -- end if;
8492
8493 -- else
8494 -- return X (I) > Y (J);
8495 -- end if;
8496 -- end loop;
8497
8498 -- return X'length > Y'length;
8499 -- end if;
8500 -- end Gnnn;
8501
8502 -- Note that since we are essentially doing this expansion by hand, we
8503 -- do not need to generate an actual or formal generic part, just the
8504 -- instantiated function itself.
8505
8506 function Make_Array_Comparison_Op
8507 (Typ : Entity_Id;
8508 Nod : Node_Id) return Node_Id
8509 is
8510 Loc : constant Source_Ptr := Sloc (Nod);
8511
8512 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
8513 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
8514 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
8515 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8516
8517 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
8518
8519 Loop_Statement : Node_Id;
8520 Loop_Body : Node_Id;
8521 If_Stat : Node_Id;
8522 Inner_If : Node_Id;
8523 Final_Expr : Node_Id;
8524 Func_Body : Node_Id;
8525 Func_Name : Entity_Id;
8526 Formals : List_Id;
8527 Length1 : Node_Id;
8528 Length2 : Node_Id;
8529
8530 begin
8531 -- if J = Y'last then
8532 -- exit;
8533 -- else
8534 -- J := index'succ (J);
8535 -- end if;
8536
8537 Inner_If :=
8538 Make_Implicit_If_Statement (Nod,
8539 Condition =>
8540 Make_Op_Eq (Loc,
8541 Left_Opnd => New_Reference_To (J, Loc),
8542 Right_Opnd =>
8543 Make_Attribute_Reference (Loc,
8544 Prefix => New_Reference_To (Y, Loc),
8545 Attribute_Name => Name_Last)),
8546
8547 Then_Statements => New_List (
8548 Make_Exit_Statement (Loc)),
8549
8550 Else_Statements =>
8551 New_List (
8552 Make_Assignment_Statement (Loc,
8553 Name => New_Reference_To (J, Loc),
8554 Expression =>
8555 Make_Attribute_Reference (Loc,
8556 Prefix => New_Reference_To (Index, Loc),
8557 Attribute_Name => Name_Succ,
8558 Expressions => New_List (New_Reference_To (J, Loc))))));
8559
8560 -- if X (I) = Y (J) then
8561 -- if ... end if;
8562 -- else
8563 -- return X (I) > Y (J);
8564 -- end if;
8565
8566 Loop_Body :=
8567 Make_Implicit_If_Statement (Nod,
8568 Condition =>
8569 Make_Op_Eq (Loc,
8570 Left_Opnd =>
8571 Make_Indexed_Component (Loc,
8572 Prefix => New_Reference_To (X, Loc),
8573 Expressions => New_List (New_Reference_To (I, Loc))),
8574
8575 Right_Opnd =>
8576 Make_Indexed_Component (Loc,
8577 Prefix => New_Reference_To (Y, Loc),
8578 Expressions => New_List (New_Reference_To (J, Loc)))),
8579
8580 Then_Statements => New_List (Inner_If),
8581
8582 Else_Statements => New_List (
8583 Make_Simple_Return_Statement (Loc,
8584 Expression =>
8585 Make_Op_Gt (Loc,
8586 Left_Opnd =>
8587 Make_Indexed_Component (Loc,
8588 Prefix => New_Reference_To (X, Loc),
8589 Expressions => New_List (New_Reference_To (I, Loc))),
8590
8591 Right_Opnd =>
8592 Make_Indexed_Component (Loc,
8593 Prefix => New_Reference_To (Y, Loc),
8594 Expressions => New_List (
8595 New_Reference_To (J, Loc)))))));
8596
8597 -- for I in X'range loop
8598 -- if ... end if;
8599 -- end loop;
8600
8601 Loop_Statement :=
8602 Make_Implicit_Loop_Statement (Nod,
8603 Identifier => Empty,
8604
8605 Iteration_Scheme =>
8606 Make_Iteration_Scheme (Loc,
8607 Loop_Parameter_Specification =>
8608 Make_Loop_Parameter_Specification (Loc,
8609 Defining_Identifier => I,
8610 Discrete_Subtype_Definition =>
8611 Make_Attribute_Reference (Loc,
8612 Prefix => New_Reference_To (X, Loc),
8613 Attribute_Name => Name_Range))),
8614
8615 Statements => New_List (Loop_Body));
8616
8617 -- if X'length = 0 then
8618 -- return false;
8619 -- elsif Y'length = 0 then
8620 -- return true;
8621 -- else
8622 -- for ... loop ... end loop;
8623 -- return X'length > Y'length;
8624 -- end if;
8625
8626 Length1 :=
8627 Make_Attribute_Reference (Loc,
8628 Prefix => New_Reference_To (X, Loc),
8629 Attribute_Name => Name_Length);
8630
8631 Length2 :=
8632 Make_Attribute_Reference (Loc,
8633 Prefix => New_Reference_To (Y, Loc),
8634 Attribute_Name => Name_Length);
8635
8636 Final_Expr :=
8637 Make_Op_Gt (Loc,
8638 Left_Opnd => Length1,
8639 Right_Opnd => Length2);
8640
8641 If_Stat :=
8642 Make_Implicit_If_Statement (Nod,
8643 Condition =>
8644 Make_Op_Eq (Loc,
8645 Left_Opnd =>
8646 Make_Attribute_Reference (Loc,
8647 Prefix => New_Reference_To (X, Loc),
8648 Attribute_Name => Name_Length),
8649 Right_Opnd =>
8650 Make_Integer_Literal (Loc, 0)),
8651
8652 Then_Statements =>
8653 New_List (
8654 Make_Simple_Return_Statement (Loc,
8655 Expression => New_Reference_To (Standard_False, Loc))),
8656
8657 Elsif_Parts => New_List (
8658 Make_Elsif_Part (Loc,
8659 Condition =>
8660 Make_Op_Eq (Loc,
8661 Left_Opnd =>
8662 Make_Attribute_Reference (Loc,
8663 Prefix => New_Reference_To (Y, Loc),
8664 Attribute_Name => Name_Length),
8665 Right_Opnd =>
8666 Make_Integer_Literal (Loc, 0)),
8667
8668 Then_Statements =>
8669 New_List (
8670 Make_Simple_Return_Statement (Loc,
8671 Expression => New_Reference_To (Standard_True, Loc))))),
8672
8673 Else_Statements => New_List (
8674 Loop_Statement,
8675 Make_Simple_Return_Statement (Loc,
8676 Expression => Final_Expr)));
8677
8678 -- (X : a; Y: a)
8679
8680 Formals := New_List (
8681 Make_Parameter_Specification (Loc,
8682 Defining_Identifier => X,
8683 Parameter_Type => New_Reference_To (Typ, Loc)),
8684
8685 Make_Parameter_Specification (Loc,
8686 Defining_Identifier => Y,
8687 Parameter_Type => New_Reference_To (Typ, Loc)));
8688
8689 -- function Gnnn (...) return boolean is
8690 -- J : index := Y'first;
8691 -- begin
8692 -- if ... end if;
8693 -- end Gnnn;
8694
8695 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
8696
8697 Func_Body :=
8698 Make_Subprogram_Body (Loc,
8699 Specification =>
8700 Make_Function_Specification (Loc,
8701 Defining_Unit_Name => Func_Name,
8702 Parameter_Specifications => Formals,
8703 Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
8704
8705 Declarations => New_List (
8706 Make_Object_Declaration (Loc,
8707 Defining_Identifier => J,
8708 Object_Definition => New_Reference_To (Index, Loc),
8709 Expression =>
8710 Make_Attribute_Reference (Loc,
8711 Prefix => New_Reference_To (Y, Loc),
8712 Attribute_Name => Name_First))),
8713
8714 Handled_Statement_Sequence =>
8715 Make_Handled_Sequence_Of_Statements (Loc,
8716 Statements => New_List (If_Stat)));
8717
8718 return Func_Body;
8719 end Make_Array_Comparison_Op;
8720
8721 ---------------------------
8722 -- Make_Boolean_Array_Op --
8723 ---------------------------
8724
8725 -- For logical operations on boolean arrays, expand in line the
8726 -- following, replacing 'and' with 'or' or 'xor' where needed:
8727
8728 -- function Annn (A : typ; B: typ) return typ is
8729 -- C : typ;
8730 -- begin
8731 -- for J in A'range loop
8732 -- C (J) := A (J) op B (J);
8733 -- end loop;
8734 -- return C;
8735 -- end Annn;
8736
8737 -- Here typ is the boolean array type
8738
8739 function Make_Boolean_Array_Op
8740 (Typ : Entity_Id;
8741 N : Node_Id) return Node_Id
8742 is
8743 Loc : constant Source_Ptr := Sloc (N);
8744
8745 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
8746 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
8747 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
8748 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8749
8750 A_J : Node_Id;
8751 B_J : Node_Id;
8752 C_J : Node_Id;
8753 Op : Node_Id;
8754
8755 Formals : List_Id;
8756 Func_Name : Entity_Id;
8757 Func_Body : Node_Id;
8758 Loop_Statement : Node_Id;
8759
8760 begin
8761 A_J :=
8762 Make_Indexed_Component (Loc,
8763 Prefix => New_Reference_To (A, Loc),
8764 Expressions => New_List (New_Reference_To (J, Loc)));
8765
8766 B_J :=
8767 Make_Indexed_Component (Loc,
8768 Prefix => New_Reference_To (B, Loc),
8769 Expressions => New_List (New_Reference_To (J, Loc)));
8770
8771 C_J :=
8772 Make_Indexed_Component (Loc,
8773 Prefix => New_Reference_To (C, Loc),
8774 Expressions => New_List (New_Reference_To (J, Loc)));
8775
8776 if Nkind (N) = N_Op_And then
8777 Op :=
8778 Make_Op_And (Loc,
8779 Left_Opnd => A_J,
8780 Right_Opnd => B_J);
8781
8782 elsif Nkind (N) = N_Op_Or then
8783 Op :=
8784 Make_Op_Or (Loc,
8785 Left_Opnd => A_J,
8786 Right_Opnd => B_J);
8787
8788 else
8789 Op :=
8790 Make_Op_Xor (Loc,
8791 Left_Opnd => A_J,
8792 Right_Opnd => B_J);
8793 end if;
8794
8795 Loop_Statement :=
8796 Make_Implicit_Loop_Statement (N,
8797 Identifier => Empty,
8798
8799 Iteration_Scheme =>
8800 Make_Iteration_Scheme (Loc,
8801 Loop_Parameter_Specification =>
8802 Make_Loop_Parameter_Specification (Loc,
8803 Defining_Identifier => J,
8804 Discrete_Subtype_Definition =>
8805 Make_Attribute_Reference (Loc,
8806 Prefix => New_Reference_To (A, Loc),
8807 Attribute_Name => Name_Range))),
8808
8809 Statements => New_List (
8810 Make_Assignment_Statement (Loc,
8811 Name => C_J,
8812 Expression => Op)));
8813
8814 Formals := New_List (
8815 Make_Parameter_Specification (Loc,
8816 Defining_Identifier => A,
8817 Parameter_Type => New_Reference_To (Typ, Loc)),
8818
8819 Make_Parameter_Specification (Loc,
8820 Defining_Identifier => B,
8821 Parameter_Type => New_Reference_To (Typ, Loc)));
8822
8823 Func_Name :=
8824 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8825 Set_Is_Inlined (Func_Name);
8826
8827 Func_Body :=
8828 Make_Subprogram_Body (Loc,
8829 Specification =>
8830 Make_Function_Specification (Loc,
8831 Defining_Unit_Name => Func_Name,
8832 Parameter_Specifications => Formals,
8833 Result_Definition => New_Reference_To (Typ, Loc)),
8834
8835 Declarations => New_List (
8836 Make_Object_Declaration (Loc,
8837 Defining_Identifier => C,
8838 Object_Definition => New_Reference_To (Typ, Loc))),
8839
8840 Handled_Statement_Sequence =>
8841 Make_Handled_Sequence_Of_Statements (Loc,
8842 Statements => New_List (
8843 Loop_Statement,
8844 Make_Simple_Return_Statement (Loc,
8845 Expression => New_Reference_To (C, Loc)))));
8846
8847 return Func_Body;
8848 end Make_Boolean_Array_Op;
8849
8850 ------------------------
8851 -- Rewrite_Comparison --
8852 ------------------------
8853
8854 procedure Rewrite_Comparison (N : Node_Id) is
8855 begin
8856 if Nkind (N) = N_Type_Conversion then
8857 Rewrite_Comparison (Expression (N));
8858 return;
8859
8860 elsif Nkind (N) not in N_Op_Compare then
8861 return;
8862 end if;
8863
8864 declare
8865 Typ : constant Entity_Id := Etype (N);
8866 Op1 : constant Node_Id := Left_Opnd (N);
8867 Op2 : constant Node_Id := Right_Opnd (N);
8868
8869 Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
8870 -- Res indicates if compare outcome can be compile time determined
8871
8872 True_Result : Boolean;
8873 False_Result : Boolean;
8874
8875 begin
8876 case N_Op_Compare (Nkind (N)) is
8877 when N_Op_Eq =>
8878 True_Result := Res = EQ;
8879 False_Result := Res = LT or else Res = GT or else Res = NE;
8880
8881 when N_Op_Ge =>
8882 True_Result := Res in Compare_GE;
8883 False_Result := Res = LT;
8884
8885 if Res = LE
8886 and then Constant_Condition_Warnings
8887 and then Comes_From_Source (Original_Node (N))
8888 and then Nkind (Original_Node (N)) = N_Op_Ge
8889 and then not In_Instance
8890 and then Is_Integer_Type (Etype (Left_Opnd (N)))
8891 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
8892 then
8893 Error_Msg_N
8894 ("can never be greater than, could replace by ""'=""?", N);
8895 end if;
8896
8897 when N_Op_Gt =>
8898 True_Result := Res = GT;
8899 False_Result := Res in Compare_LE;
8900
8901 when N_Op_Lt =>
8902 True_Result := Res = LT;
8903 False_Result := Res in Compare_GE;
8904
8905 when N_Op_Le =>
8906 True_Result := Res in Compare_LE;
8907 False_Result := Res = GT;
8908
8909 if Res = GE
8910 and then Constant_Condition_Warnings
8911 and then Comes_From_Source (Original_Node (N))
8912 and then Nkind (Original_Node (N)) = N_Op_Le
8913 and then not In_Instance
8914 and then Is_Integer_Type (Etype (Left_Opnd (N)))
8915 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
8916 then
8917 Error_Msg_N
8918 ("can never be less than, could replace by ""'=""?", N);
8919 end if;
8920
8921 when N_Op_Ne =>
8922 True_Result := Res = NE or else Res = GT or else Res = LT;
8923 False_Result := Res = EQ;
8924 end case;
8925
8926 if True_Result then
8927 Rewrite (N,
8928 Convert_To (Typ,
8929 New_Occurrence_Of (Standard_True, Sloc (N))));
8930 Analyze_And_Resolve (N, Typ);
8931 Warn_On_Known_Condition (N);
8932
8933 elsif False_Result then
8934 Rewrite (N,
8935 Convert_To (Typ,
8936 New_Occurrence_Of (Standard_False, Sloc (N))));
8937 Analyze_And_Resolve (N, Typ);
8938 Warn_On_Known_Condition (N);
8939 end if;
8940 end;
8941 end Rewrite_Comparison;
8942
8943 ----------------------------
8944 -- Safe_In_Place_Array_Op --
8945 ----------------------------
8946
8947 function Safe_In_Place_Array_Op
8948 (Lhs : Node_Id;
8949 Op1 : Node_Id;
8950 Op2 : Node_Id) return Boolean
8951 is
8952 Target : Entity_Id;
8953
8954 function Is_Safe_Operand (Op : Node_Id) return Boolean;
8955 -- Operand is safe if it cannot overlap part of the target of the
8956 -- operation. If the operand and the target are identical, the operand
8957 -- is safe. The operand can be empty in the case of negation.
8958
8959 function Is_Unaliased (N : Node_Id) return Boolean;
8960 -- Check that N is a stand-alone entity
8961
8962 ------------------
8963 -- Is_Unaliased --
8964 ------------------
8965
8966 function Is_Unaliased (N : Node_Id) return Boolean is
8967 begin
8968 return
8969 Is_Entity_Name (N)
8970 and then No (Address_Clause (Entity (N)))
8971 and then No (Renamed_Object (Entity (N)));
8972 end Is_Unaliased;
8973
8974 ---------------------
8975 -- Is_Safe_Operand --
8976 ---------------------
8977
8978 function Is_Safe_Operand (Op : Node_Id) return Boolean is
8979 begin
8980 if No (Op) then
8981 return True;
8982
8983 elsif Is_Entity_Name (Op) then
8984 return Is_Unaliased (Op);
8985
8986 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
8987 return Is_Unaliased (Prefix (Op));
8988
8989 elsif Nkind (Op) = N_Slice then
8990 return
8991 Is_Unaliased (Prefix (Op))
8992 and then Entity (Prefix (Op)) /= Target;
8993
8994 elsif Nkind (Op) = N_Op_Not then
8995 return Is_Safe_Operand (Right_Opnd (Op));
8996
8997 else
8998 return False;
8999 end if;
9000 end Is_Safe_Operand;
9001
9002 -- Start of processing for Is_Safe_In_Place_Array_Op
9003
9004 begin
9005 -- We skip this processing if the component size is not the
9006 -- same as a system storage unit (since at least for NOT
9007 -- this would cause problems).
9008
9009 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
9010 return False;
9011
9012 -- Cannot do in place stuff on VM_Target since cannot pass addresses
9013
9014 elsif VM_Target /= No_VM then
9015 return False;
9016
9017 -- Cannot do in place stuff if non-standard Boolean representation
9018
9019 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
9020 return False;
9021
9022 elsif not Is_Unaliased (Lhs) then
9023 return False;
9024 else
9025 Target := Entity (Lhs);
9026
9027 return
9028 Is_Safe_Operand (Op1)
9029 and then Is_Safe_Operand (Op2);
9030 end if;
9031 end Safe_In_Place_Array_Op;
9032
9033 -----------------------
9034 -- Tagged_Membership --
9035 -----------------------
9036
9037 -- There are two different cases to consider depending on whether
9038 -- the right operand is a class-wide type or not. If not we just
9039 -- compare the actual tag of the left expr to the target type tag:
9040 --
9041 -- Left_Expr.Tag = Right_Type'Tag;
9042 --
9043 -- If it is a class-wide type we use the RT function CW_Membership which
9044 -- is usually implemented by looking in the ancestor tables contained in
9045 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9046
9047 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9048 -- function IW_Membership which is usually implemented by looking in the
9049 -- table of abstract interface types plus the ancestor table contained in
9050 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9051
9052 function Tagged_Membership (N : Node_Id) return Node_Id is
9053 Left : constant Node_Id := Left_Opnd (N);
9054 Right : constant Node_Id := Right_Opnd (N);
9055 Loc : constant Source_Ptr := Sloc (N);
9056
9057 Left_Type : Entity_Id;
9058 Right_Type : Entity_Id;
9059 Obj_Tag : Node_Id;
9060
9061 begin
9062 Left_Type := Etype (Left);
9063 Right_Type := Etype (Right);
9064
9065 if Is_Class_Wide_Type (Left_Type) then
9066 Left_Type := Root_Type (Left_Type);
9067 end if;
9068
9069 Obj_Tag :=
9070 Make_Selected_Component (Loc,
9071 Prefix => Relocate_Node (Left),
9072 Selector_Name =>
9073 New_Reference_To (First_Tag_Component (Left_Type), Loc));
9074
9075 if Is_Class_Wide_Type (Right_Type) then
9076
9077 -- No need to issue a run-time check if we statically know that the
9078 -- result of this membership test is always true. For example,
9079 -- considering the following declarations:
9080
9081 -- type Iface is interface;
9082 -- type T is tagged null record;
9083 -- type DT is new T and Iface with null record;
9084
9085 -- Obj1 : T;
9086 -- Obj2 : DT;
9087
9088 -- These membership tests are always true:
9089
9090 -- Obj1 in T'Class
9091 -- Obj2 in T'Class;
9092 -- Obj2 in Iface'Class;
9093
9094 -- We do not need to handle cases where the membership is illegal.
9095 -- For example:
9096
9097 -- Obj1 in DT'Class; -- Compile time error
9098 -- Obj1 in Iface'Class; -- Compile time error
9099
9100 if not Is_Class_Wide_Type (Left_Type)
9101 and then (Is_Parent (Etype (Right_Type), Left_Type)
9102 or else (Is_Interface (Etype (Right_Type))
9103 and then Interface_Present_In_Ancestor
9104 (Typ => Left_Type,
9105 Iface => Etype (Right_Type))))
9106 then
9107 return New_Reference_To (Standard_True, Loc);
9108 end if;
9109
9110 -- Ada 2005 (AI-251): Class-wide applied to interfaces
9111
9112 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
9113
9114 -- Support to: "Iface_CW_Typ in Typ'Class"
9115
9116 or else Is_Interface (Left_Type)
9117 then
9118 -- Issue error if IW_Membership operation not available in a
9119 -- configurable run time setting.
9120
9121 if not RTE_Available (RE_IW_Membership) then
9122 Error_Msg_CRT
9123 ("dynamic membership test on interface types", N);
9124 return Empty;
9125 end if;
9126
9127 return
9128 Make_Function_Call (Loc,
9129 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
9130 Parameter_Associations => New_List (
9131 Make_Attribute_Reference (Loc,
9132 Prefix => Obj_Tag,
9133 Attribute_Name => Name_Address),
9134 New_Reference_To (
9135 Node (First_Elmt
9136 (Access_Disp_Table (Root_Type (Right_Type)))),
9137 Loc)));
9138
9139 -- Ada 95: Normal case
9140
9141 else
9142 return
9143 Build_CW_Membership (Loc,
9144 Obj_Tag_Node => Obj_Tag,
9145 Typ_Tag_Node =>
9146 New_Reference_To (
9147 Node (First_Elmt
9148 (Access_Disp_Table (Root_Type (Right_Type)))),
9149 Loc));
9150 end if;
9151
9152 -- Right_Type is not a class-wide type
9153
9154 else
9155 -- No need to check the tag of the object if Right_Typ is abstract
9156
9157 if Is_Abstract_Type (Right_Type) then
9158 return New_Reference_To (Standard_False, Loc);
9159
9160 else
9161 return
9162 Make_Op_Eq (Loc,
9163 Left_Opnd => Obj_Tag,
9164 Right_Opnd =>
9165 New_Reference_To
9166 (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
9167 end if;
9168 end if;
9169 end Tagged_Membership;
9170
9171 ------------------------------
9172 -- Unary_Op_Validity_Checks --
9173 ------------------------------
9174
9175 procedure Unary_Op_Validity_Checks (N : Node_Id) is
9176 begin
9177 if Validity_Checks_On and Validity_Check_Operands then
9178 Ensure_Valid (Right_Opnd (N));
9179 end if;
9180 end Unary_Op_Validity_Checks;
9181
9182 end Exp_Ch4;