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