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