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