]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/exp_ch4.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[multiple changes]
[thirdparty/gcc.git] / gcc / ada / exp_ch4.adb
CommitLineData
70482933
RK		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ C H 4 --
59262ebb 6-- --
70482933
RK		 7-- B o d y --
8-- --
da574a86 9-- Copyright (C) 1992-2014, 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;
6cce2156 34with Exp_Ch2; use Exp_Ch2;
70482933 35with Exp_Ch3; use Exp_Ch3;
20b5d666 36with Exp_Ch6; use Exp_Ch6;
70482933
RK		 37with Exp_Ch7; use Exp_Ch7;
38with Exp_Ch9; use Exp_Ch9;
20b5d666 39with Exp_Disp; use Exp_Disp;
70482933 40with Exp_Fixd; use Exp_Fixd;
437f8c1e 41with Exp_Intr; use Exp_Intr;
70482933
RK		 42with Exp_Pakd; use Exp_Pakd;
43with Exp_Tss; use Exp_Tss;
44with Exp_Util; use Exp_Util;
f02b8bb8 45with Freeze; use Freeze;
70482933 46with Inline; use Inline;
df3e68b1 47with Lib; use Lib;
26bff3d9 48with Namet; use Namet;
70482933
RK		 49with Nlists; use Nlists;
50with Nmake; use Nmake;
51with Opt; use Opt;
25adc5fb 52with Par_SCO; use Par_SCO;
0669bebe
GB		 53with Restrict; use Restrict;
54with Rident; use Rident;
70482933
RK		 55with Rtsfind; use Rtsfind;
56with Sem; use Sem;
a4100e55 57with Sem_Aux; use Sem_Aux;
70482933 58with Sem_Cat; use Sem_Cat;
5d09245e 59with Sem_Ch3; use Sem_Ch3;
11fa950b 60with Sem_Ch8; use Sem_Ch8;
70482933
RK		 61with Sem_Ch13; use Sem_Ch13;
62with Sem_Eval; use Sem_Eval;
63with Sem_Res; use Sem_Res;
64with Sem_Type; use Sem_Type;
65with Sem_Util; use Sem_Util;
07fc65c4 66with Sem_Warn; use Sem_Warn;
70482933 67with Sinfo; use Sinfo;
70482933
RK		 68with Snames; use Snames;
69with Stand; use Stand;
7665e4bd 70with SCIL_LL; use SCIL_LL;
07fc65c4 71with Targparm; use Targparm;
70482933
RK		 72with Tbuild; use Tbuild;
73with Ttypes; use Ttypes;
74with Uintp; use Uintp;
75with Urealp; use Urealp;
76with Validsw; use Validsw;
77
78package body Exp_Ch4 is
79
15ce9ca2
AC		 80 -----------------------
81 -- Local Subprograms --
82 -----------------------
70482933
RK		 83
84 procedure Binary_Op_Validity_Checks (N : Node_Id);
85 pragma Inline (Binary_Op_Validity_Checks);
86 -- Performs validity checks for a binary operator
87
fbf5a39b
AC		 88 procedure Build_Boolean_Array_Proc_Call
89 (N : Node_Id;
90 Op1 : Node_Id;
91 Op2 : Node_Id);
303b4d58 92 -- If a boolean array assignment can be done in place, build call to
fbf5a39b
AC		 93 -- corresponding library procedure.
94
11fa950b
AC		 95 function Current_Anonymous_Master return Entity_Id;
96 -- Return the entity of the heterogeneous finalization master belonging to
97 -- the current unit (either function, package or procedure). This master
98 -- services all anonymous access-to-controlled types. If the current unit
99 -- does not have such master, create one.
df3e68b1 100
26bff3d9
JM		 101 procedure Displace_Allocator_Pointer (N : Node_Id);
102 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
103 -- Expand_Allocator_Expression. Allocating class-wide interface objects
104 -- this routine displaces the pointer to the allocated object to reference
105 -- the component referencing the corresponding secondary dispatch table.
106
fbf5a39b
AC		 107 procedure Expand_Allocator_Expression (N : Node_Id);
108 -- Subsidiary to Expand_N_Allocator, for the case when the expression
109 -- is a qualified expression or an aggregate.
110
70482933
RK		 111 procedure Expand_Array_Comparison (N : Node_Id);
112 -- This routine handles expansion of the comparison operators (N_Op_Lt,
113 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
114 -- code for these operators is similar, differing only in the details of
fbf5a39b
AC		 115 -- the actual comparison call that is made. Special processing (call a
116 -- run-time routine)
70482933
RK		 117
118 function Expand_Array_Equality
119 (Nod : Node_Id;
70482933
RK		 120 Lhs : Node_Id;
121 Rhs : Node_Id;
0da2c8ac
AC		 122 Bodies : List_Id;
123 Typ : Entity_Id) return Node_Id;
70482933 124 -- Expand an array equality into a call to a function implementing this
685094bf
RD		 125 -- equality, and a call to it. Loc is the location for the generated nodes.
126 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
127 -- on which to attach bodies of local functions that are created in the
128 -- process. It is the responsibility of the caller to insert those bodies
129 -- at the right place. Nod provides the Sloc value for the generated code.
130 -- Normally the types used for the generated equality routine are taken
131 -- from Lhs and Rhs. However, in some situations of generated code, the
132 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
133 -- the type to be used for the formal parameters.
70482933
RK		 134
135 procedure Expand_Boolean_Operator (N : Node_Id);
685094bf
RD		 136 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
137 -- case of array type arguments.
70482933 138
5875f8d6
AC		 139 procedure Expand_Short_Circuit_Operator (N : Node_Id);
140 -- Common expansion processing for short-circuit boolean operators
141
456cbfa5 142 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
5707e389
AC		 143 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
144 -- where we allow comparison of "out of range" values.
456cbfa5 145
70482933
RK		 146 function Expand_Composite_Equality
147 (Nod : Node_Id;
148 Typ : Entity_Id;
149 Lhs : Node_Id;
150 Rhs : Node_Id;
2e071734 151 Bodies : List_Id) return Node_Id;
685094bf
RD		 152 -- Local recursive function used to expand equality for nested composite
153 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
d26d790d
AC		 154 -- to attach bodies of local functions that are created in the process. It
155 -- is the responsibility of the caller to insert those bodies at the right
156 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
157 -- the left and right sides for the comparison, and Typ is the type of the
158 -- objects to compare.
70482933 159
fdac1f80
AC		 160 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
161 -- Routine to expand concatenation of a sequence of two or more operands
162 -- (in the list Operands) and replace node Cnode with the result of the
163 -- concatenation. The operands can be of any appropriate type, and can
164 -- include both arrays and singleton elements.
70482933 165
f6194278 166 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
5707e389
AC		 167 -- N is an N_In membership test mode, with the overflow check mode set to
168 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
169 -- integer type. This is a case where top level processing is required to
170 -- handle overflow checks in subtrees.
f6194278 171
70482933 172 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
685094bf
RD		 173 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
174 -- fixed. We do not have such a type at runtime, so the purpose of this
175 -- routine is to find the real type by looking up the tree. We also
176 -- determine if the operation must be rounded.
70482933 177
5d09245e
AC		 178 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
179 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
180 -- discriminants if it has a constrained nominal type, unless the object
181 -- is a component of an enclosing Unchecked_Union object that is subject
182 -- to a per-object constraint and the enclosing object lacks inferable
183 -- discriminants.
184 --
185 -- An expression of an Unchecked_Union type has inferable discriminants
186 -- if it is either a name of an object with inferable discriminants or a
187 -- qualified expression whose subtype mark denotes a constrained subtype.
188
70482933 189 procedure Insert_Dereference_Action (N : Node_Id);
e6f69614
AC		 190 -- N is an expression whose type is an access. When the type of the
191 -- associated storage pool is derived from Checked_Pool, generate a
192 -- call to the 'Dereference' primitive operation.
70482933
RK		 193
194 function Make_Array_Comparison_Op
2e071734
AC		 195 (Typ : Entity_Id;
196 Nod : Node_Id) return Node_Id;
685094bf
RD		 197 -- Comparisons between arrays are expanded in line. This function produces
198 -- the body of the implementation of (a > b), where a and b are one-
199 -- dimensional arrays of some discrete type. The original node is then
200 -- expanded into the appropriate call to this function. Nod provides the
201 -- Sloc value for the generated code.
70482933
RK		 202
203 function Make_Boolean_Array_Op
2e071734
AC		 204 (Typ : Entity_Id;
205 N : Node_Id) return Node_Id;
685094bf
RD		 206 -- Boolean operations on boolean arrays are expanded in line. This function
207 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
208 -- b). It is used only the normal case and not the packed case. The type
209 -- involved, Typ, is the Boolean array type, and the logical operations in
210 -- the body are simple boolean operations. Note that Typ is always a
211 -- constrained type (the caller has ensured this by using
212 -- Convert_To_Actual_Subtype if necessary).
70482933 213
b6b5cca8 214 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
a7f1b24f
RD		 215 -- For signed arithmetic operations when the current overflow mode is
216 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
217 -- as the first thing we do. We then return. We count on the recursive
218 -- apparatus for overflow checks to call us back with an equivalent
219 -- operation that is in CHECKED mode, avoiding a recursive entry into this
220 -- routine, and that is when we will proceed with the expansion of the
221 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
222 -- these optimizations without first making this check, since there may be
223 -- operands further down the tree that are relying on the recursive calls
224 -- triggered by the top level nodes to properly process overflow checking
225 -- and remaining expansion on these nodes. Note that this call back may be
226 -- skipped if the operation is done in Bignum mode but that's fine, since
227 -- the Bignum call takes care of everything.
b6b5cca8 228
0580d807
AC		 229 procedure Optimize_Length_Comparison (N : Node_Id);
230 -- Given an expression, if it is of the form X'Length op N (or the other
231 -- way round), where N is known at compile time to be 0 or 1, and X is a
232 -- simple entity, and op is a comparison operator, optimizes it into a
233 -- comparison of First and Last.
234
b2c28399
AC		 235 procedure Process_Transient_Object
236 (Decl : Node_Id;
237 Rel_Node : Node_Id);
238 -- Subsidiary routine to the expansion of expression_with_actions and if
239 -- expressions. Generate all the necessary code to finalize a transient
240 -- controlled object when the enclosing context is elaborated or evaluated.
241 -- Decl denotes the declaration of the transient controlled object which is
242 -- usually the result of a controlled function call. Rel_Node denotes the
243 -- context, either an expression_with_actions or an if expression.
244
70482933 245 procedure Rewrite_Comparison (N : Node_Id);
20b5d666 246 -- If N is the node for a comparison whose outcome can be determined at
d26dc4b5
AC		 247 -- compile time, then the node N can be rewritten with True or False. If
248 -- the outcome cannot be determined at compile time, the call has no
249 -- effect. If N is a type conversion, then this processing is applied to
250 -- its expression. If N is neither comparison nor a type conversion, the
251 -- call has no effect.
70482933 252
82878151
AC		 253 procedure Tagged_Membership
254 (N : Node_Id;
255 SCIL_Node : out Node_Id;
256 Result : out Node_Id);
70482933
RK		 257 -- Construct the expression corresponding to the tagged membership test.
258 -- Deals with a second operand being (or not) a class-wide type.
259
fbf5a39b 260 function Safe_In_Place_Array_Op
2e071734
AC		 261 (Lhs : Node_Id;
262 Op1 : Node_Id;
263 Op2 : Node_Id) return Boolean;
685094bf
RD		 264 -- In the context of an assignment, where the right-hand side is a boolean
265 -- operation on arrays, check whether operation can be performed in place.
fbf5a39b 266
70482933
RK		 267 procedure Unary_Op_Validity_Checks (N : Node_Id);
268 pragma Inline (Unary_Op_Validity_Checks);
269 -- Performs validity checks for a unary operator
270
271 -------------------------------
272 -- Binary_Op_Validity_Checks --
273 -------------------------------
274
275 procedure Binary_Op_Validity_Checks (N : Node_Id) is
276 begin
277 if Validity_Checks_On and Validity_Check_Operands then
278 Ensure_Valid (Left_Opnd (N));
279 Ensure_Valid (Right_Opnd (N));
280 end if;
281 end Binary_Op_Validity_Checks;
282
fbf5a39b
AC		 283 ------------------------------------
284 -- Build_Boolean_Array_Proc_Call --
285 ------------------------------------
286
287 procedure Build_Boolean_Array_Proc_Call
288 (N : Node_Id;
289 Op1 : Node_Id;
290 Op2 : Node_Id)
291 is
292 Loc : constant Source_Ptr := Sloc (N);
293 Kind : constant Node_Kind := Nkind (Expression (N));
294 Target : constant Node_Id :=
295 Make_Attribute_Reference (Loc,
296 Prefix => Name (N),
297 Attribute_Name => Name_Address);
298
bed8af19 299 Arg1 : Node_Id := Op1;
fbf5a39b
AC		 300 Arg2 : Node_Id := Op2;
301 Call_Node : Node_Id;
302 Proc_Name : Entity_Id;
303
304 begin
305 if Kind = N_Op_Not then
306 if Nkind (Op1) in N_Binary_Op then
307
5e1c00fa 308 -- Use negated version of the binary operators
fbf5a39b
AC		 309
310 if Nkind (Op1) = N_Op_And then
311 Proc_Name := RTE (RE_Vector_Nand);
312
313 elsif Nkind (Op1) = N_Op_Or then
314 Proc_Name := RTE (RE_Vector_Nor);
315
316 else pragma Assert (Nkind (Op1) = N_Op_Xor);
317 Proc_Name := RTE (RE_Vector_Xor);
318 end if;
319
320 Call_Node :=
321 Make_Procedure_Call_Statement (Loc,
322 Name => New_Occurrence_Of (Proc_Name, Loc),
323
324 Parameter_Associations => New_List (
325 Target,
326 Make_Attribute_Reference (Loc,
327 Prefix => Left_Opnd (Op1),
328 Attribute_Name => Name_Address),
329
330 Make_Attribute_Reference (Loc,
331 Prefix => Right_Opnd (Op1),
332 Attribute_Name => Name_Address),
333
334 Make_Attribute_Reference (Loc,
335 Prefix => Left_Opnd (Op1),
336 Attribute_Name => Name_Length)));
337
338 else
339 Proc_Name := RTE (RE_Vector_Not);
340
341 Call_Node :=
342 Make_Procedure_Call_Statement (Loc,
343 Name => New_Occurrence_Of (Proc_Name, Loc),
344 Parameter_Associations => New_List (
345 Target,
346
347 Make_Attribute_Reference (Loc,
348 Prefix => Op1,
349 Attribute_Name => Name_Address),
350
351 Make_Attribute_Reference (Loc,
352 Prefix => Op1,
353 Attribute_Name => Name_Length)));
354 end if;
355
356 else
357 -- We use the following equivalences:
358
359 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
360 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
361 -- (not X) xor (not Y) = X xor Y
362 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
363
364 if Nkind (Op1) = N_Op_Not then
bed8af19
AC		 365 Arg1 := Right_Opnd (Op1);
366 Arg2 := Right_Opnd (Op2);
533369aa 367
fbf5a39b
AC		 368 if Kind = N_Op_And then
369 Proc_Name := RTE (RE_Vector_Nor);
fbf5a39b
AC		 370 elsif Kind = N_Op_Or then
371 Proc_Name := RTE (RE_Vector_Nand);
fbf5a39b
AC		 372 else
373 Proc_Name := RTE (RE_Vector_Xor);
374 end if;
375
376 else
377 if Kind = N_Op_And then
378 Proc_Name := RTE (RE_Vector_And);
fbf5a39b
AC		 379 elsif Kind = N_Op_Or then
380 Proc_Name := RTE (RE_Vector_Or);
fbf5a39b
AC		 381 elsif Nkind (Op2) = N_Op_Not then
382 Proc_Name := RTE (RE_Vector_Nxor);
383 Arg2 := Right_Opnd (Op2);
fbf5a39b
AC		 384 else
385 Proc_Name := RTE (RE_Vector_Xor);
386 end if;
387 end if;
388
389 Call_Node :=
390 Make_Procedure_Call_Statement (Loc,
391 Name => New_Occurrence_Of (Proc_Name, Loc),
392 Parameter_Associations => New_List (
393 Target,
955871d3
AC		 394 Make_Attribute_Reference (Loc,
395 Prefix => Arg1,
396 Attribute_Name => Name_Address),
397 Make_Attribute_Reference (Loc,
398 Prefix => Arg2,
399 Attribute_Name => Name_Address),
400 Make_Attribute_Reference (Loc,
a8ef12e5 401 Prefix => Arg1,
955871d3 402 Attribute_Name => Name_Length)));
fbf5a39b
AC		 403 end if;
404
405 Rewrite (N, Call_Node);
406 Analyze (N);
407
408 exception
409 when RE_Not_Available =>
410 return;
411 end Build_Boolean_Array_Proc_Call;
412
11fa950b
AC		 413 ------------------------------
414 -- Current_Anonymous_Master --
415 ------------------------------
df3e68b1 416
11fa950b 417 function Current_Anonymous_Master return Entity_Id is
2c17ca0a
AC		 418 Decls : List_Id;
419 Loc : Source_Ptr;
420 Subp_Body : Node_Id;
421 Unit_Decl : Node_Id;
422 Unit_Id : Entity_Id;
df3e68b1 423
ca5af305 424 begin
11fa950b
AC		 425 Unit_Id := Cunit_Entity (Current_Sem_Unit);
426
427 -- Find the entity of the current unit
428
429 if Ekind (Unit_Id) = E_Subprogram_Body then
430
431 -- When processing subprogram bodies, the proper scope is always that
432 -- of the spec.
433
434 Subp_Body := Unit_Id;
435 while Present (Subp_Body)
436 and then Nkind (Subp_Body) /= N_Subprogram_Body
437 loop
438 Subp_Body := Parent (Subp_Body);
439 end loop;
440
441 Unit_Id := Corresponding_Spec (Subp_Body);
442 end if;
443
444 Loc := Sloc (Unit_Id);
445 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
446
447 -- Find the declarations list of the current unit
448
449 if Nkind (Unit_Decl) = N_Package_Declaration then
450 Unit_Decl := Specification (Unit_Decl);
451 Decls := Visible_Declarations (Unit_Decl);
df3e68b1 452
ca5af305 453 if No (Decls) then
11fa950b
AC		 454 Decls := New_List (Make_Null_Statement (Loc));
455 Set_Visible_Declarations (Unit_Decl, Decls);
df3e68b1 456
ca5af305 457 elsif Is_Empty_List (Decls) then
11fa950b 458 Append_To (Decls, Make_Null_Statement (Loc));
df3e68b1
HK		 459 end if;
460
ca5af305 461 else
11fa950b 462 Decls := Declarations (Unit_Decl);
f553e7bc 463
ca5af305 464 if No (Decls) then
11fa950b
AC		 465 Decls := New_List (Make_Null_Statement (Loc));
466 Set_Declarations (Unit_Decl, Decls);
df3e68b1 467
ca5af305 468 elsif Is_Empty_List (Decls) then
11fa950b 469 Append_To (Decls, Make_Null_Statement (Loc));
ca5af305 470 end if;
df3e68b1
HK		 471 end if;
472
11fa950b
AC		 473 -- The current unit has an existing anonymous master, traverse its
474 -- declarations and locate the entity.
df3e68b1 475
11fa950b 476 if Has_Anonymous_Master (Unit_Id) then
2c17ca0a
AC		 477 declare
478 Decl : Node_Id;
479 Fin_Mas_Id : Entity_Id;
df3e68b1 480
2c17ca0a
AC		 481 begin
482 Decl := First (Decls);
483 while Present (Decl) loop
df3e68b1 484
2c17ca0a
AC		 485 -- Look for the first variable in the declarations whole type
486 -- is Finalization_Master.
df3e68b1 487
2c17ca0a
AC		 488 if Nkind (Decl) = N_Object_Declaration then
489 Fin_Mas_Id := Defining_Identifier (Decl);
490
491 if Ekind (Fin_Mas_Id) = E_Variable
492 and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
493 then
494 return Fin_Mas_Id;
495 end if;
496 end if;
497
498 Next (Decl);
499 end loop;
500
501 -- The master was not found even though the unit was labeled as
502 -- having one.
df3e68b1 503
2c17ca0a
AC		 504 raise Program_Error;
505 end;
11fa950b
AC		 506
507 -- Create a new anonymous master
508
509 else
510 declare
511 First_Decl : constant Node_Id := First (Decls);
512 Action : Node_Id;
2c17ca0a 513 Fin_Mas_Id : Entity_Id;
df3e68b1 514
11fa950b
AC		 515 begin
516 -- Since the master and its associated initialization is inserted
517 -- at top level, use the scope of the unit when analyzing.
518
519 Push_Scope (Unit_Id);
520
521 -- Create the finalization master
522
523 Fin_Mas_Id :=
524 Make_Defining_Identifier (Loc,
525 Chars => New_External_Name (Chars (Unit_Id), "AM"));
526
527 -- Generate:
528 -- <Fin_Mas_Id> : Finalization_Master;
529
530 Action :=
531 Make_Object_Declaration (Loc,
532 Defining_Identifier => Fin_Mas_Id,
533 Object_Definition =>
e4494292 534 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
11fa950b
AC		 535
536 Insert_Before_And_Analyze (First_Decl, Action);
537
538 -- Mark the unit to prevent the generation of multiple masters
539
540 Set_Has_Anonymous_Master (Unit_Id);
541
542 -- Do not set the base pool and mode of operation on .NET/JVM
543 -- since those targets do not support pools and all VM masters
544 -- are heterogeneous by default.
545
546 if VM_Target = No_VM then
547
548 -- Generate:
549 -- Set_Base_Pool
550 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
551
552 Action :=
553 Make_Procedure_Call_Statement (Loc,
554 Name =>
e4494292 555 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
11fa950b
AC		 556
557 Parameter_Associations => New_List (
e4494292 558 New_Occurrence_Of (Fin_Mas_Id, Loc),
11fa950b
AC		 559 Make_Attribute_Reference (Loc,
560 Prefix =>
e4494292 561 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
11fa950b
AC		 562 Attribute_Name => Name_Unrestricted_Access)));
563
564 Insert_Before_And_Analyze (First_Decl, Action);
565
566 -- Generate:
567 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
568
569 Action :=
570 Make_Procedure_Call_Statement (Loc,
571 Name =>
e4494292 572 New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc),
11fa950b 573 Parameter_Associations => New_List (
e4494292 574 New_Occurrence_Of (Fin_Mas_Id, Loc)));
11fa950b
AC		 575
576 Insert_Before_And_Analyze (First_Decl, Action);
577 end if;
578
579 -- Restore the original state of the scope stack
580
581 Pop_Scope;
582
583 return Fin_Mas_Id;
584 end;
585 end if;
586 end Current_Anonymous_Master;
df3e68b1 587
26bff3d9
JM		 588 --------------------------------
589 -- Displace_Allocator_Pointer --
590 --------------------------------
591
592 procedure Displace_Allocator_Pointer (N : Node_Id) is
593 Loc : constant Source_Ptr := Sloc (N);
594 Orig_Node : constant Node_Id := Original_Node (N);
595 Dtyp : Entity_Id;
596 Etyp : Entity_Id;
597 PtrT : Entity_Id;
598
599 begin
303b4d58
AC		 600 -- Do nothing in case of VM targets: the virtual machine will handle
601 -- interfaces directly.
602
1f110335 603 if not Tagged_Type_Expansion then
303b4d58
AC		 604 return;
605 end if;
606
26bff3d9
JM		 607 pragma Assert (Nkind (N) = N_Identifier
608 and then Nkind (Orig_Node) = N_Allocator);
609
610 PtrT := Etype (Orig_Node);
d6a24cdb 611 Dtyp := Available_View (Designated_Type (PtrT));
26bff3d9
JM		 612 Etyp := Etype (Expression (Orig_Node));
613
533369aa
AC		 614 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
615
26bff3d9
JM		 616 -- If the type of the allocator expression is not an interface type
617 -- we can generate code to reference the record component containing
618 -- the pointer to the secondary dispatch table.
619
620 if not Is_Interface (Etyp) then
621 declare
622 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
623
624 begin
625 -- 1) Get access to the allocated object
626
627 Rewrite (N,
5972791c 628 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
26bff3d9
JM		 629 Set_Etype (N, Etyp);
630 Set_Analyzed (N);
631
632 -- 2) Add the conversion to displace the pointer to reference
633 -- the secondary dispatch table.
634
635 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
636 Analyze_And_Resolve (N, Dtyp);
637
638 -- 3) The 'access to the secondary dispatch table will be used
639 -- as the value returned by the allocator.
640
641 Rewrite (N,
642 Make_Attribute_Reference (Loc,
643 Prefix => Relocate_Node (N),
644 Attribute_Name => Name_Access));
645 Set_Etype (N, Saved_Typ);
646 Set_Analyzed (N);
647 end;
648
649 -- If the type of the allocator expression is an interface type we
650 -- generate a run-time call to displace "this" to reference the
651 -- component containing the pointer to the secondary dispatch table
652 -- or else raise Constraint_Error if the actual object does not
533369aa 653 -- implement the target interface. This case corresponds to the
26bff3d9
JM		 654 -- following example:
655
8fc789c8 656 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
26bff3d9
JM		 657 -- begin
658 -- return new Iface_2'Class'(Obj);
659 -- end Op;
660
661 else
662 Rewrite (N,
663 Unchecked_Convert_To (PtrT,
664 Make_Function_Call (Loc,
e4494292 665 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
26bff3d9
JM		 666 Parameter_Associations => New_List (
667 Unchecked_Convert_To (RTE (RE_Address),
668 Relocate_Node (N)),
669
670 New_Occurrence_Of
671 (Elists.Node
672 (First_Elmt
673 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
674 Loc)))));
675 Analyze_And_Resolve (N, PtrT);
676 end if;
677 end if;
678 end Displace_Allocator_Pointer;
679
fbf5a39b
AC		 680 ---------------------------------
681 -- Expand_Allocator_Expression --
682 ---------------------------------
683
684 procedure Expand_Allocator_Expression (N : Node_Id) is
f02b8bb8
RD		 685 Loc : constant Source_Ptr := Sloc (N);
686 Exp : constant Node_Id := Expression (Expression (N));
f02b8bb8
RD		 687 PtrT : constant Entity_Id := Etype (N);
688 DesigT : constant Entity_Id := Designated_Type (PtrT);
26bff3d9
JM		 689
690 procedure Apply_Accessibility_Check
691 (Ref : Node_Id;
692 Built_In_Place : Boolean := False);
693 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
685094bf
RD		 694 -- type, generate an accessibility check to verify that the level of the
695 -- type of the created object is not deeper than the level of the access
50878404 696 -- type. If the type of the qualified expression is class-wide, then
685094bf
RD		 697 -- always generate the check (except in the case where it is known to be
698 -- unnecessary, see comment below). Otherwise, only generate the check
699 -- if the level of the qualified expression type is statically deeper
700 -- than the access type.
701 --
702 -- Although the static accessibility will generally have been performed
703 -- as a legality check, it won't have been done in cases where the
704 -- allocator appears in generic body, so a run-time check is needed in
705 -- general. One special case is when the access type is declared in the
706 -- same scope as the class-wide allocator, in which case the check can
707 -- never fail, so it need not be generated.
708 --
709 -- As an open issue, there seem to be cases where the static level
710 -- associated with the class-wide object's underlying type is not
711 -- sufficient to perform the proper accessibility check, such as for
712 -- allocators in nested subprograms or accept statements initialized by
713 -- class-wide formals when the actual originates outside at a deeper
714 -- static level. The nested subprogram case might require passing
715 -- accessibility levels along with class-wide parameters, and the task
716 -- case seems to be an actual gap in the language rules that needs to
717 -- be fixed by the ARG. ???
26bff3d9
JM		 718
719 -------------------------------
720 -- Apply_Accessibility_Check --
721 -------------------------------
722
723 procedure Apply_Accessibility_Check
724 (Ref : Node_Id;
725 Built_In_Place : Boolean := False)
726 is
a98838ff
HK		 727 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
728 Cond : Node_Id;
729 Fin_Call : Node_Id;
730 Free_Stmt : Node_Id;
731 Obj_Ref : Node_Id;
732 Stmts : List_Id;
26bff3d9
JM		 733
734 begin
0791fbe9 735 if Ada_Version >= Ada_2005
26bff3d9 736 and then Is_Class_Wide_Type (DesigT)
a98838ff 737 and then (Tagged_Type_Expansion or else VM_Target /= No_VM)
3217f71e 738 and then not Scope_Suppress.Suppress (Accessibility_Check)
26bff3d9
JM		 739 and then
740 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
741 or else
742 (Is_Class_Wide_Type (Etype (Exp))
743 and then Scope (PtrT) /= Current_Scope))
744 then
e761d11c 745 -- If the allocator was built in place, Ref is already a reference
26bff3d9 746 -- to the access object initialized to the result of the allocator
e761d11c
AC		 747 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
748 -- Remove_Side_Effects for cases where the build-in-place call may
749 -- still be the prefix of the reference (to avoid generating
750 -- duplicate calls). Otherwise, it is the entity associated with
751 -- the object containing the address of the allocated object.
26bff3d9
JM		 752
753 if Built_In_Place then
e761d11c 754 Remove_Side_Effects (Ref);
a98838ff 755 Obj_Ref := New_Copy_Tree (Ref);
26bff3d9 756 else
e4494292 757 Obj_Ref := New_Occurrence_Of (Ref, Loc);
50878404
AC		 758 end if;
759
b6c8e5be
AC		 760 -- For access to interface types we must generate code to displace
761 -- the pointer to the base of the object since the subsequent code
762 -- references components located in the TSD of the object (which
763 -- is associated with the primary dispatch table --see a-tags.ads)
764 -- and also generates code invoking Free, which requires also a
765 -- reference to the base of the unallocated object.
766
cc6f5d75 767 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
b6c8e5be
AC		 768 Obj_Ref :=
769 Unchecked_Convert_To (Etype (Obj_Ref),
770 Make_Function_Call (Loc,
662c2ad4
RD		 771 Name =>
772 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
b6c8e5be
AC		 773 Parameter_Associations => New_List (
774 Unchecked_Convert_To (RTE (RE_Address),
775 New_Copy_Tree (Obj_Ref)))));
776 end if;
777
50878404
AC		 778 -- Step 1: Create the object clean up code
779
780 Stmts := New_List;
781
a98838ff
HK		 782 -- Deallocate the object if the accessibility check fails. This
783 -- is done only on targets or profiles that support deallocation.
784
785 -- Free (Obj_Ref);
786
787 if RTE_Available (RE_Free) then
788 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
789 Set_Storage_Pool (Free_Stmt, Pool_Id);
790
791 Append_To (Stmts, Free_Stmt);
792
793 -- The target or profile cannot deallocate objects
794
795 else
796 Free_Stmt := Empty;
797 end if;
798
799 -- Finalize the object if applicable. Generate:
a530b8bb
AC		 800
801 -- [Deep_]Finalize (Obj_Ref.all);
802
2cbac6c6 803 if Needs_Finalization (DesigT) then
a98838ff 804 Fin_Call :=
cc6f5d75
AC		 805 Make_Final_Call
806 (Obj_Ref =>
807 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
808 Typ => DesigT);
a98838ff
HK		 809
810 -- When the target or profile supports deallocation, wrap the
811 -- finalization call in a block to ensure proper deallocation
812 -- even if finalization fails. Generate:
813
814 -- begin
815 -- <Fin_Call>
816 -- exception
817 -- when others =>
818 -- <Free_Stmt>
819 -- raise;
820 -- end;
821
822 if Present (Free_Stmt) then
823 Fin_Call :=
824 Make_Block_Statement (Loc,
825 Handled_Statement_Sequence =>
826 Make_Handled_Sequence_Of_Statements (Loc,
827 Statements => New_List (Fin_Call),
828
829 Exception_Handlers => New_List (
830 Make_Exception_Handler (Loc,
831 Exception_Choices => New_List (
832 Make_Others_Choice (Loc)),
833
834 Statements => New_List (
835 New_Copy_Tree (Free_Stmt),
836 Make_Raise_Statement (Loc))))));
837 end if;
838
839 Prepend_To (Stmts, Fin_Call);
f46faa08
AC		 840 end if;
841
50878404
AC		 842 -- Signal the accessibility failure through a Program_Error
843
844 Append_To (Stmts,
845 Make_Raise_Program_Error (Loc,
e4494292 846 Condition => New_Occurrence_Of (Standard_True, Loc),
50878404
AC		 847 Reason => PE_Accessibility_Check_Failed));
848
849 -- Step 2: Create the accessibility comparison
850
851 -- Generate:
852 -- Ref'Tag
853
b6c8e5be
AC		 854 Obj_Ref :=
855 Make_Attribute_Reference (Loc,
856 Prefix => Obj_Ref,
857 Attribute_Name => Name_Tag);
f46faa08 858
50878404
AC		 859 -- For tagged types, determine the accessibility level by looking
860 -- at the type specific data of the dispatch table. Generate:
861
862 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
863
f46faa08 864 if Tagged_Type_Expansion then
50878404 865 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
f46faa08 866
50878404
AC		 867 -- Use a runtime call to determine the accessibility level when
868 -- compiling on virtual machine targets. Generate:
f46faa08 869
50878404 870 -- Get_Access_Level (Ref'Tag)
f46faa08
AC		 871
872 else
50878404
AC		 873 Cond :=
874 Make_Function_Call (Loc,
875 Name =>
e4494292 876 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
50878404 877 Parameter_Associations => New_List (Obj_Ref));
26bff3d9
JM		 878 end if;
879
50878404
AC		 880 Cond :=
881 Make_Op_Gt (Loc,
882 Left_Opnd => Cond,
883 Right_Opnd =>
884 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
885
886 -- Due to the complexity and side effects of the check, utilize an
887 -- if statement instead of the regular Program_Error circuitry.
888
26bff3d9 889 Insert_Action (N,
8b1011c0 890 Make_Implicit_If_Statement (N,
50878404
AC		 891 Condition => Cond,
892 Then_Statements => Stmts));
26bff3d9
JM		 893 end if;
894 end Apply_Accessibility_Check;
895
896 -- Local variables
897
df3e68b1
HK		 898 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
899 Indic : constant Node_Id := Subtype_Mark (Expression (N));
900 T : constant Entity_Id := Entity (Indic);
901 Node : Node_Id;
902 Tag_Assign : Node_Id;
903 Temp : Entity_Id;
904 Temp_Decl : Node_Id;
fbf5a39b 905
d26dc4b5
AC		 906 TagT : Entity_Id := Empty;
907 -- Type used as source for tag assignment
908
909 TagR : Node_Id := Empty;
910 -- Target reference for tag assignment
911
26bff3d9
JM		 912 -- Start of processing for Expand_Allocator_Expression
913
fbf5a39b 914 begin
3bfb3c03
JM		 915 -- Handle call to C++ constructor
916
917 if Is_CPP_Constructor_Call (Exp) then
918 Make_CPP_Constructor_Call_In_Allocator
919 (Allocator => N,
920 Function_Call => Exp);
921 return;
922 end if;
923
885c4871 924 -- In the case of an Ada 2012 allocator whose initial value comes from a
63585f75
SB		 925 -- function call, pass "the accessibility level determined by the point
926 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
927 -- Expand_Call but it couldn't be done there (because the Etype of the
928 -- allocator wasn't set then) so we generate the parameter here. See
929 -- the Boolean variable Defer in (a block within) Expand_Call.
930
931 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
932 declare
933 Subp : Entity_Id;
934
935 begin
936 if Nkind (Name (Exp)) = N_Explicit_Dereference then
937 Subp := Designated_Type (Etype (Prefix (Name (Exp))));
938 else
939 Subp := Entity (Name (Exp));
940 end if;
941
57a3fca9
AC		 942 Subp := Ultimate_Alias (Subp);
943
63585f75
SB		 944 if Present (Extra_Accessibility_Of_Result (Subp)) then
945 Add_Extra_Actual_To_Call
946 (Subprogram_Call => Exp,
947 Extra_Formal => Extra_Accessibility_Of_Result (Subp),
948 Extra_Actual => Dynamic_Accessibility_Level (PtrT));
949 end if;
950 end;
951 end if;
952
f6194278 953 -- Case of tagged type or type requiring finalization
63585f75
SB		 954
955 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
fadcf313 956
685094bf
RD		 957 -- Ada 2005 (AI-318-02): If the initialization expression is a call
958 -- to a build-in-place function, then access to the allocated object
959 -- must be passed to the function. Currently we limit such functions
960 -- to those with constrained limited result subtypes, but eventually
961 -- we plan to expand the allowed forms of functions that are treated
962 -- as build-in-place.
20b5d666 963
0791fbe9 964 if Ada_Version >= Ada_2005
20b5d666
JM		 965 and then Is_Build_In_Place_Function_Call (Exp)
966 then
967 Make_Build_In_Place_Call_In_Allocator (N, Exp);
26bff3d9
JM		 968 Apply_Accessibility_Check (N, Built_In_Place => True);
969 return;
20b5d666
JM		 970 end if;
971
ca5af305
AC		 972 -- Actions inserted before:
973 -- Temp : constant ptr_T := new T'(Expression);
974 -- Temp._tag = T'tag; -- when not class-wide
975 -- [Deep_]Adjust (Temp.all);
fbf5a39b 976
ca5af305 977 -- We analyze by hand the new internal allocator to avoid any
6b6041ec 978 -- recursion and inappropriate call to Initialize.
7324bf49 979
20b5d666
JM		 980 -- We don't want to remove side effects when the expression must be
981 -- built in place. In the case of a build-in-place function call,
982 -- that could lead to a duplication of the call, which was already
983 -- substituted for the allocator.
984
26bff3d9 985 if not Aggr_In_Place then
fbf5a39b
AC		 986 Remove_Side_Effects (Exp);
987 end if;
988
e86a3a7e 989 Temp := Make_Temporary (Loc, 'P', N);
fbf5a39b
AC		 990
991 -- For a class wide allocation generate the following code:
992
993 -- type Equiv_Record is record ... end record;
994 -- implicit subtype CW is <Class_Wide_Subytpe>;
995 -- temp : PtrT := new CW'(CW!(expr));
996
997 if Is_Class_Wide_Type (T) then
998 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
999
26bff3d9
JM		 1000 -- Ada 2005 (AI-251): If the expression is a class-wide interface
1001 -- object we generate code to move up "this" to reference the
1002 -- base of the object before allocating the new object.
1003
1004 -- Note that Exp'Address is recursively expanded into a call
1005 -- to Base_Address (Exp.Tag)
1006
1007 if Is_Class_Wide_Type (Etype (Exp))
1008 and then Is_Interface (Etype (Exp))
1f110335 1009 and then Tagged_Type_Expansion
26bff3d9
JM		 1010 then
1011 Set_Expression
1012 (Expression (N),
1013 Unchecked_Convert_To (Entity (Indic),
1014 Make_Explicit_Dereference (Loc,
1015 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
1016 Make_Attribute_Reference (Loc,
1017 Prefix => Exp,
1018 Attribute_Name => Name_Address)))));
26bff3d9
JM		 1019 else
1020 Set_Expression
1021 (Expression (N),
1022 Unchecked_Convert_To (Entity (Indic), Exp));
1023 end if;
fbf5a39b
AC		 1024
1025 Analyze_And_Resolve (Expression (N), Entity (Indic));
1026 end if;
1027
df3e68b1 1028 -- Processing for allocators returning non-interface types
fbf5a39b 1029
26bff3d9
JM		 1030 if not Is_Interface (Directly_Designated_Type (PtrT)) then
1031 if Aggr_In_Place then
df3e68b1 1032 Temp_Decl :=
26bff3d9
JM		 1033 Make_Object_Declaration (Loc,
1034 Defining_Identifier => Temp,
e4494292 1035 Object_Definition => New_Occurrence_Of (PtrT, Loc),
26bff3d9
JM		 1036 Expression =>
1037 Make_Allocator (Loc,
df3e68b1 1038 Expression =>
e4494292 1039 New_Occurrence_Of (Etype (Exp), Loc)));
fbf5a39b 1040
fad0600d
AC		 1041 -- Copy the Comes_From_Source flag for the allocator we just
1042 -- built, since logically this allocator is a replacement of
1043 -- the original allocator node. This is for proper handling of
1044 -- restriction No_Implicit_Heap_Allocations.
1045
26bff3d9 1046 Set_Comes_From_Source
df3e68b1 1047 (Expression (Temp_Decl), Comes_From_Source (N));
fbf5a39b 1048
df3e68b1
HK		 1049 Set_No_Initialization (Expression (Temp_Decl));
1050 Insert_Action (N, Temp_Decl);
fbf5a39b 1051
ca5af305 1052 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
df3e68b1 1053 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
fad0600d 1054
d3f70b35 1055 -- Attach the object to the associated finalization master.
deb8dacc
HK		 1056 -- This is done manually on .NET/JVM since those compilers do
1057 -- no support pools and can't benefit from internally generated
1058 -- Allocate / Deallocate procedures.
1059
1060 if VM_Target /= No_VM
1061 and then Is_Controlled (DesigT)
d3f70b35 1062 and then Present (Finalization_Master (PtrT))
deb8dacc
HK		 1063 then
1064 Insert_Action (N,
cc6f5d75
AC		 1065 Make_Attach_Call
1066 (Obj_Ref => New_Occurrence_Of (Temp, Loc),
1067 Ptr_Typ => PtrT));
deb8dacc
HK		 1068 end if;
1069
26bff3d9
JM		 1070 else
1071 Node := Relocate_Node (N);
1072 Set_Analyzed (Node);
df3e68b1
HK		 1073
1074 Temp_Decl :=
26bff3d9
JM		 1075 Make_Object_Declaration (Loc,
1076 Defining_Identifier => Temp,
1077 Constant_Present => True,
e4494292 1078 Object_Definition => New_Occurrence_Of (PtrT, Loc),
df3e68b1
HK		 1079 Expression => Node);
1080
1081 Insert_Action (N, Temp_Decl);
ca5af305 1082 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
deb8dacc 1083
d3f70b35 1084 -- Attach the object to the associated finalization master.
deb8dacc
HK		 1085 -- This is done manually on .NET/JVM since those compilers do
1086 -- no support pools and can't benefit from internally generated
1087 -- Allocate / Deallocate procedures.
1088
1089 if VM_Target /= No_VM
1090 and then Is_Controlled (DesigT)
d3f70b35 1091 and then Present (Finalization_Master (PtrT))
deb8dacc
HK		 1092 then
1093 Insert_Action (N,
cc6f5d75
AC		 1094 Make_Attach_Call
1095 (Obj_Ref => New_Occurrence_Of (Temp, Loc),
1096 Ptr_Typ => PtrT));
deb8dacc 1097 end if;
fbf5a39b
AC		 1098 end if;
1099
26bff3d9
JM		 1100 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1101 -- interface type. In this case we use the type of the qualified
1102 -- expression to allocate the object.
1103
fbf5a39b 1104 else
26bff3d9 1105 declare
191fcb3a 1106 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
26bff3d9 1107 New_Decl : Node_Id;
fbf5a39b 1108
26bff3d9
JM		 1109 begin
1110 New_Decl :=
1111 Make_Full_Type_Declaration (Loc,
1112 Defining_Identifier => Def_Id,
cc6f5d75 1113 Type_Definition =>
26bff3d9
JM		 1114 Make_Access_To_Object_Definition (Loc,
1115 All_Present => True,
1116 Null_Exclusion_Present => False,
0929eaeb
AC		 1117 Constant_Present =>
1118 Is_Access_Constant (Etype (N)),
26bff3d9 1119 Subtype_Indication =>
e4494292 1120 New_Occurrence_Of (Etype (Exp), Loc)));
26bff3d9
JM		 1121
1122 Insert_Action (N, New_Decl);
1123
df3e68b1
HK		 1124 -- Inherit the allocation-related attributes from the original
1125 -- access type.
26bff3d9 1126
24d4b3d5
AC		 1127 Set_Finalization_Master
1128 (Def_Id, Finalization_Master (PtrT));
df3e68b1 1129
24d4b3d5
AC		 1130 Set_Associated_Storage_Pool
1131 (Def_Id, Associated_Storage_Pool (PtrT));
758c442c 1132
26bff3d9
JM		 1133 -- Declare the object using the previous type declaration
1134
1135 if Aggr_In_Place then
df3e68b1 1136 Temp_Decl :=
26bff3d9
JM		 1137 Make_Object_Declaration (Loc,
1138 Defining_Identifier => Temp,
e4494292 1139 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
26bff3d9
JM		 1140 Expression =>
1141 Make_Allocator (Loc,
e4494292 1142 New_Occurrence_Of (Etype (Exp), Loc)));
26bff3d9 1143
fad0600d
AC		 1144 -- Copy the Comes_From_Source flag for the allocator we just
1145 -- built, since logically this allocator is a replacement of
1146 -- the original allocator node. This is for proper handling
1147 -- of restriction No_Implicit_Heap_Allocations.
1148
26bff3d9 1149 Set_Comes_From_Source
df3e68b1 1150 (Expression (Temp_Decl), Comes_From_Source (N));
26bff3d9 1151
df3e68b1
HK		 1152 Set_No_Initialization (Expression (Temp_Decl));
1153 Insert_Action (N, Temp_Decl);
26bff3d9 1154
ca5af305 1155 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
df3e68b1 1156 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
26bff3d9 1157
26bff3d9
JM		 1158 else
1159 Node := Relocate_Node (N);
1160 Set_Analyzed (Node);
df3e68b1
HK		 1161
1162 Temp_Decl :=
26bff3d9
JM		 1163 Make_Object_Declaration (Loc,
1164 Defining_Identifier => Temp,
1165 Constant_Present => True,
e4494292 1166 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
df3e68b1
HK		 1167 Expression => Node);
1168
1169 Insert_Action (N, Temp_Decl);
ca5af305 1170 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
26bff3d9
JM		 1171 end if;
1172
1173 -- Generate an additional object containing the address of the
1174 -- returned object. The type of this second object declaration
685094bf
RD		 1175 -- is the correct type required for the common processing that
1176 -- is still performed by this subprogram. The displacement of
1177 -- this pointer to reference the component associated with the
1178 -- interface type will be done at the end of common processing.
26bff3d9
JM		 1179
1180 New_Decl :=
1181 Make_Object_Declaration (Loc,
243cae0a 1182 Defining_Identifier => Make_Temporary (Loc, 'P'),
e4494292 1183 Object_Definition => New_Occurrence_Of (PtrT, Loc),
243cae0a 1184 Expression =>
df3e68b1 1185 Unchecked_Convert_To (PtrT,
e4494292 1186 New_Occurrence_Of (Temp, Loc)));
26bff3d9
JM		 1187
1188 Insert_Action (N, New_Decl);
1189
df3e68b1
HK		 1190 Temp_Decl := New_Decl;
1191 Temp := Defining_Identifier (New_Decl);
26bff3d9 1192 end;
758c442c
GD		 1193 end if;
1194
26bff3d9
JM		 1195 Apply_Accessibility_Check (Temp);
1196
1197 -- Generate the tag assignment
1198
1199 -- Suppress the tag assignment when VM_Target because VM tags are
1200 -- represented implicitly in objects.
1201
1f110335 1202 if not Tagged_Type_Expansion then
26bff3d9 1203 null;
fbf5a39b 1204
26bff3d9
JM		 1205 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1206 -- interface objects because in this case the tag does not change.
d26dc4b5 1207
26bff3d9
JM		 1208 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1209 pragma Assert (Is_Class_Wide_Type
1210 (Directly_Designated_Type (Etype (N))));
d26dc4b5
AC		 1211 null;
1212
1213 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1214 TagT := T;
e4494292 1215 TagR := New_Occurrence_Of (Temp, Loc);
d26dc4b5
AC		 1216
1217 elsif Is_Private_Type (T)
1218 and then Is_Tagged_Type (Underlying_Type (T))
fbf5a39b 1219 then
d26dc4b5 1220 TagT := Underlying_Type (T);
dfd99a80
TQ		 1221 TagR :=
1222 Unchecked_Convert_To (Underlying_Type (T),
1223 Make_Explicit_Dereference (Loc,
e4494292 1224 Prefix => New_Occurrence_Of (Temp, Loc)));
d26dc4b5
AC		 1225 end if;
1226
1227 if Present (TagT) then
38171f43
AC		 1228 declare
1229 Full_T : constant Entity_Id := Underlying_Type (TagT);
e4494292 1230
38171f43
AC		 1231 begin
1232 Tag_Assign :=
1233 Make_Assignment_Statement (Loc,
cc6f5d75 1234 Name =>
38171f43 1235 Make_Selected_Component (Loc,
cc6f5d75 1236 Prefix => TagR,
38171f43 1237 Selector_Name =>
e4494292
RD		 1238 New_Occurrence_Of
1239 (First_Tag_Component (Full_T), Loc)),
1240
38171f43
AC		 1241 Expression =>
1242 Unchecked_Convert_To (RTE (RE_Tag),
e4494292 1243 New_Occurrence_Of
38171f43
AC		 1244 (Elists.Node
1245 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1246 end;
fbf5a39b
AC		 1247
1248 -- The previous assignment has to be done in any case
1249
1250 Set_Assignment_OK (Name (Tag_Assign));
1251 Insert_Action (N, Tag_Assign);
fbf5a39b
AC		 1252 end if;
1253
533369aa
AC		 1254 if Needs_Finalization (DesigT) and then Needs_Finalization (T) then
1255
df3e68b1
HK		 1256 -- Generate an Adjust call if the object will be moved. In Ada
1257 -- 2005, the object may be inherently limited, in which case
1258 -- there is no Adjust procedure, and the object is built in
1259 -- place. In Ada 95, the object can be limited but not
1260 -- inherently limited if this allocator came from a return
1261 -- statement (we're allocating the result on the secondary
1262 -- stack). In that case, the object will be moved, so we _do_
1263 -- want to Adjust.
1264
1265 if not Aggr_In_Place
51245e2d 1266 and then not Is_Limited_View (T)
df3e68b1
HK		 1267 then
1268 Insert_Action (N,
fbf5a39b 1269
533369aa
AC		 1270 -- An unchecked conversion is needed in the classwide case
1271 -- because the designated type can be an ancestor of the
1272 -- subtype mark of the allocator.
fbf5a39b 1273
533369aa
AC		 1274 Make_Adjust_Call
1275 (Obj_Ref =>
1276 Unchecked_Convert_To (T,
1277 Make_Explicit_Dereference (Loc,
e4494292 1278 Prefix => New_Occurrence_Of (Temp, Loc))),
533369aa 1279 Typ => T));
df3e68b1 1280 end if;
b254da66
AC		 1281
1282 -- Generate:
1283 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1284
2bfa5484 1285 -- Do not generate this call in the following cases:
c5f5123f 1286
2bfa5484
HK		 1287 -- * .NET/JVM - these targets do not support address arithmetic
1288 -- and unchecked conversion, key elements of Finalize_Address.
c5f5123f 1289
2bfa5484
HK		 1290 -- * CodePeer mode - TSS primitive Finalize_Address is not
1291 -- created in this mode.
b254da66
AC		 1292
1293 if VM_Target = No_VM
1294 and then not CodePeer_Mode
1295 and then Present (Finalization_Master (PtrT))
f7bb41af
AC		 1296 and then Present (Temp_Decl)
1297 and then Nkind (Expression (Temp_Decl)) = N_Allocator
b254da66
AC		 1298 then
1299 Insert_Action (N,
1300 Make_Set_Finalize_Address_Call
1301 (Loc => Loc,
1302 Typ => T,
1303 Ptr_Typ => PtrT));
1304 end if;
fbf5a39b
AC		 1305 end if;
1306
e4494292 1307 Rewrite (N, New_Occurrence_Of (Temp, Loc));
fbf5a39b
AC		 1308 Analyze_And_Resolve (N, PtrT);
1309
685094bf
RD		 1310 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1311 -- component containing the secondary dispatch table of the interface
1312 -- type.
26bff3d9
JM		 1313
1314 if Is_Interface (Directly_Designated_Type (PtrT)) then
1315 Displace_Allocator_Pointer (N);
1316 end if;
1317
fbf5a39b 1318 elsif Aggr_In_Place then
e86a3a7e 1319 Temp := Make_Temporary (Loc, 'P', N);
df3e68b1 1320 Temp_Decl :=
fbf5a39b
AC		 1321 Make_Object_Declaration (Loc,
1322 Defining_Identifier => Temp,
e4494292 1323 Object_Definition => New_Occurrence_Of (PtrT, Loc),
df3e68b1
HK		 1324 Expression =>
1325 Make_Allocator (Loc,
e4494292 1326 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
fbf5a39b 1327
fad0600d
AC		 1328 -- Copy the Comes_From_Source flag for the allocator we just built,
1329 -- since logically this allocator is a replacement of the original
1330 -- allocator node. This is for proper handling of restriction
1331 -- No_Implicit_Heap_Allocations.
1332
fbf5a39b 1333 Set_Comes_From_Source
df3e68b1
HK		 1334 (Expression (Temp_Decl), Comes_From_Source (N));
1335
1336 Set_No_Initialization (Expression (Temp_Decl));
1337 Insert_Action (N, Temp_Decl);
1338
ca5af305 1339 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
df3e68b1 1340 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
fbf5a39b 1341
d3f70b35
AC		 1342 -- Attach the object to the associated finalization master. Thisis
1343 -- done manually on .NET/JVM since those compilers do no support
deb8dacc
HK		 1344 -- pools and cannot benefit from internally generated Allocate and
1345 -- Deallocate procedures.
1346
1347 if VM_Target /= No_VM
1348 and then Is_Controlled (DesigT)
d3f70b35 1349 and then Present (Finalization_Master (PtrT))
deb8dacc
HK		 1350 then
1351 Insert_Action (N,
243cae0a 1352 Make_Attach_Call
e4494292 1353 (Obj_Ref => New_Occurrence_Of (Temp, Loc),
243cae0a 1354 Ptr_Typ => PtrT));
deb8dacc
HK		 1355 end if;
1356
e4494292 1357 Rewrite (N, New_Occurrence_Of (Temp, Loc));
fbf5a39b
AC		 1358 Analyze_And_Resolve (N, PtrT);
1359
533369aa 1360 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
51e4c4b9
AC		 1361 Install_Null_Excluding_Check (Exp);
1362
f02b8bb8 1363 elsif Is_Access_Type (DesigT)
fbf5a39b
AC		 1364 and then Nkind (Exp) = N_Allocator
1365 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1366 then
0da2c8ac 1367 -- Apply constraint to designated subtype indication
fbf5a39b 1368
cc6f5d75
AC		 1369 Apply_Constraint_Check
1370 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
fbf5a39b
AC		 1371
1372 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1373
1374 -- Propagate constraint_error to enclosing allocator
1375
1376 Rewrite (Exp, New_Copy (Expression (Exp)));
1377 end if;
1df4f514 1378
fbf5a39b 1379 else
14f0f659
AC		 1380 Build_Allocate_Deallocate_Proc (N, True);
1381
36c73552
AC		 1382 -- If we have:
1383 -- type A is access T1;
1384 -- X : A := new T2'(...);
1385 -- T1 and T2 can be different subtypes, and we might need to check
1386 -- both constraints. First check against the type of the qualified
1387 -- expression.
1388
1389 Apply_Constraint_Check (Exp, T, No_Sliding => True);
fbf5a39b 1390
d79e621a 1391 if Do_Range_Check (Exp) then
d79e621a
GD		 1392 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1393 end if;
1394
685094bf
RD		 1395 -- A check is also needed in cases where the designated subtype is
1396 -- constrained and differs from the subtype given in the qualified
1397 -- expression. Note that the check on the qualified expression does
1398 -- not allow sliding, but this check does (a relaxation from Ada 83).
fbf5a39b 1399
f02b8bb8 1400 if Is_Constrained (DesigT)
9450205a 1401 and then not Subtypes_Statically_Match (T, DesigT)
fbf5a39b
AC		 1402 then
1403 Apply_Constraint_Check
f02b8bb8 1404 (Exp, DesigT, No_Sliding => False);
d79e621a
GD		 1405
1406 if Do_Range_Check (Exp) then
d79e621a
GD		 1407 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1408 end if;
f02b8bb8
RD		 1409 end if;
1410
685094bf
RD		 1411 -- For an access to unconstrained packed array, GIGI needs to see an
1412 -- expression with a constrained subtype in order to compute the
1413 -- proper size for the allocator.
f02b8bb8
RD		 1414
1415 if Is_Array_Type (T)
1416 and then not Is_Constrained (T)
1417 and then Is_Packed (T)
1418 then
1419 declare
191fcb3a 1420 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
f02b8bb8
RD		 1421 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1422 begin
1423 Insert_Action (Exp,
1424 Make_Subtype_Declaration (Loc,
1425 Defining_Identifier => ConstrT,
25ebc085
AC		 1426 Subtype_Indication =>
1427 Make_Subtype_From_Expr (Internal_Exp, T)));
f02b8bb8
RD		 1428 Freeze_Itype (ConstrT, Exp);
1429 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1430 end;
fbf5a39b 1431 end if;
f02b8bb8 1432
685094bf
RD		 1433 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1434 -- to a build-in-place function, then access to the allocated object
1435 -- must be passed to the function. Currently we limit such functions
1436 -- to those with constrained limited result subtypes, but eventually
1437 -- we plan to expand the allowed forms of functions that are treated
1438 -- as build-in-place.
20b5d666 1439
0791fbe9 1440 if Ada_Version >= Ada_2005
20b5d666
JM		 1441 and then Is_Build_In_Place_Function_Call (Exp)
1442 then
1443 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1444 end if;
fbf5a39b
AC		 1445 end if;
1446
1447 exception
1448 when RE_Not_Available =>
1449 return;
1450 end Expand_Allocator_Expression;
1451
70482933
RK		 1452 -----------------------------
1453 -- Expand_Array_Comparison --
1454 -----------------------------
1455
685094bf
RD		 1456 -- Expansion is only required in the case of array types. For the unpacked
1457 -- case, an appropriate runtime routine is called. For packed cases, and
1458 -- also in some other cases where a runtime routine cannot be called, the
1459 -- form of the expansion is:
70482933
RK		 1460
1461 -- [body for greater_nn; boolean_expression]
1462
1463 -- The body is built by Make_Array_Comparison_Op, and the form of the
1464 -- Boolean expression depends on the operator involved.
1465
1466 procedure Expand_Array_Comparison (N : Node_Id) is
1467 Loc : constant Source_Ptr := Sloc (N);
1468 Op1 : Node_Id := Left_Opnd (N);
1469 Op2 : Node_Id := Right_Opnd (N);
1470 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
fbf5a39b 1471 Ctyp : constant Entity_Id := Component_Type (Typ1);
70482933
RK		 1472
1473 Expr : Node_Id;
1474 Func_Body : Node_Id;
1475 Func_Name : Entity_Id;
1476
fbf5a39b
AC		 1477 Comp : RE_Id;
1478
9bc43c53
AC		 1479 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1480 -- True for byte addressable target
91b1417d 1481
fbf5a39b 1482 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
685094bf
RD		 1483 -- Returns True if the length of the given operand is known to be less
1484 -- than 4. Returns False if this length is known to be four or greater
1485 -- or is not known at compile time.
fbf5a39b
AC		 1486
1487 ------------------------
1488 -- Length_Less_Than_4 --
1489 ------------------------
1490
1491 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1492 Otyp : constant Entity_Id := Etype (Opnd);
1493
1494 begin
1495 if Ekind (Otyp) = E_String_Literal_Subtype then
1496 return String_Literal_Length (Otyp) < 4;
1497
1498 else
1499 declare
1500 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1501 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1502 Hi : constant Node_Id := Type_High_Bound (Ityp);
1503 Lov : Uint;
1504 Hiv : Uint;
1505
1506 begin
1507 if Compile_Time_Known_Value (Lo) then
1508 Lov := Expr_Value (Lo);
1509 else
1510 return False;
1511 end if;
1512
1513 if Compile_Time_Known_Value (Hi) then
1514 Hiv := Expr_Value (Hi);
1515 else
1516 return False;
1517 end if;
1518
1519 return Hiv < Lov + 3;
1520 end;
1521 end if;
1522 end Length_Less_Than_4;
1523
1524 -- Start of processing for Expand_Array_Comparison
1525
70482933 1526 begin
fbf5a39b
AC		 1527 -- Deal first with unpacked case, where we can call a runtime routine
1528 -- except that we avoid this for targets for which are not addressable
26bff3d9 1529 -- by bytes, and for the JVM/CIL, since they do not support direct
fbf5a39b
AC		 1530 -- addressing of array components.
1531
1532 if not Is_Bit_Packed_Array (Typ1)
9bc43c53 1533 and then Byte_Addressable
26bff3d9 1534 and then VM_Target = No_VM
fbf5a39b
AC		 1535 then
1536 -- The call we generate is:
1537
1538 -- Compare_Array_xn[_Unaligned]
1539 -- (left'address, right'address, left'length, right'length) <op> 0
1540
1541 -- x = U for unsigned, S for signed
1542 -- n = 8,16,32,64 for component size
1543 -- Add _Unaligned if length < 4 and component size is 8.
1544 -- <op> is the standard comparison operator
1545
1546 if Component_Size (Typ1) = 8 then
1547 if Length_Less_Than_4 (Op1)
1548 or else
1549 Length_Less_Than_4 (Op2)
1550 then
1551 if Is_Unsigned_Type (Ctyp) then
1552 Comp := RE_Compare_Array_U8_Unaligned;
1553 else
1554 Comp := RE_Compare_Array_S8_Unaligned;
1555 end if;
1556
1557 else
1558 if Is_Unsigned_Type (Ctyp) then
1559 Comp := RE_Compare_Array_U8;
1560 else
1561 Comp := RE_Compare_Array_S8;
1562 end if;
1563 end if;
1564
1565 elsif Component_Size (Typ1) = 16 then
1566 if Is_Unsigned_Type (Ctyp) then
1567 Comp := RE_Compare_Array_U16;
1568 else
1569 Comp := RE_Compare_Array_S16;
1570 end if;
1571
1572 elsif Component_Size (Typ1) = 32 then
1573 if Is_Unsigned_Type (Ctyp) then
1574 Comp := RE_Compare_Array_U32;
1575 else
1576 Comp := RE_Compare_Array_S32;
1577 end if;
1578
1579 else pragma Assert (Component_Size (Typ1) = 64);
1580 if Is_Unsigned_Type (Ctyp) then
1581 Comp := RE_Compare_Array_U64;
1582 else
1583 Comp := RE_Compare_Array_S64;
1584 end if;
1585 end if;
1586
1587 Remove_Side_Effects (Op1, Name_Req => True);
1588 Remove_Side_Effects (Op2, Name_Req => True);
1589
1590 Rewrite (Op1,
1591 Make_Function_Call (Sloc (Op1),
1592 Name => New_Occurrence_Of (RTE (Comp), Loc),
1593
1594 Parameter_Associations => New_List (
1595 Make_Attribute_Reference (Loc,
1596 Prefix => Relocate_Node (Op1),
1597 Attribute_Name => Name_Address),
1598
1599 Make_Attribute_Reference (Loc,
1600 Prefix => Relocate_Node (Op2),
1601 Attribute_Name => Name_Address),
1602
1603 Make_Attribute_Reference (Loc,
1604 Prefix => Relocate_Node (Op1),
1605 Attribute_Name => Name_Length),
1606
1607 Make_Attribute_Reference (Loc,
1608 Prefix => Relocate_Node (Op2),
1609 Attribute_Name => Name_Length))));
1610
1611 Rewrite (Op2,
1612 Make_Integer_Literal (Sloc (Op2),
1613 Intval => Uint_0));
1614
1615 Analyze_And_Resolve (Op1, Standard_Integer);
1616 Analyze_And_Resolve (Op2, Standard_Integer);
1617 return;
1618 end if;
1619
1620 -- Cases where we cannot make runtime call
1621
70482933
RK		 1622 -- For (a <= b) we convert to not (a > b)
1623
1624 if Chars (N) = Name_Op_Le then
1625 Rewrite (N,
1626 Make_Op_Not (Loc,
1627 Right_Opnd =>
1628 Make_Op_Gt (Loc,
1629 Left_Opnd => Op1,
1630 Right_Opnd => Op2)));
1631 Analyze_And_Resolve (N, Standard_Boolean);
1632 return;
1633
1634 -- For < the Boolean expression is
1635 -- greater__nn (op2, op1)
1636
1637 elsif Chars (N) = Name_Op_Lt then
1638 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1639
1640 -- Switch operands
1641
1642 Op1 := Right_Opnd (N);
1643 Op2 := Left_Opnd (N);
1644
1645 -- For (a >= b) we convert to not (a < b)
1646
1647 elsif Chars (N) = Name_Op_Ge then
1648 Rewrite (N,
1649 Make_Op_Not (Loc,
1650 Right_Opnd =>
1651 Make_Op_Lt (Loc,
1652 Left_Opnd => Op1,
1653 Right_Opnd => Op2)));
1654 Analyze_And_Resolve (N, Standard_Boolean);
1655 return;
1656
1657 -- For > the Boolean expression is
1658 -- greater__nn (op1, op2)
1659
1660 else
1661 pragma Assert (Chars (N) = Name_Op_Gt);
1662 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1663 end if;
1664
1665 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1666 Expr :=
1667 Make_Function_Call (Loc,
e4494292 1668 Name => New_Occurrence_Of (Func_Name, Loc),
70482933
RK		 1669 Parameter_Associations => New_List (Op1, Op2));
1670
1671 Insert_Action (N, Func_Body);
1672 Rewrite (N, Expr);
1673 Analyze_And_Resolve (N, Standard_Boolean);
1674
fbf5a39b
AC		 1675 exception
1676 when RE_Not_Available =>
1677 return;
70482933
RK		 1678 end Expand_Array_Comparison;
1679
1680 ---------------------------
1681 -- Expand_Array_Equality --
1682 ---------------------------
1683
685094bf
RD		 1684 -- Expand an equality function for multi-dimensional arrays. Here is an
1685 -- example of such a function for Nb_Dimension = 2
70482933 1686
0da2c8ac 1687 -- function Enn (A : atyp; B : btyp) return boolean is
70482933 1688 -- begin
fbf5a39b
AC		 1689 -- if (A'length (1) = 0 or else A'length (2) = 0)
1690 -- and then
1691 -- (B'length (1) = 0 or else B'length (2) = 0)
1692 -- then
1693 -- return True; -- RM 4.5.2(22)
1694 -- end if;
0da2c8ac 1695
fbf5a39b
AC		 1696 -- if A'length (1) /= B'length (1)
1697 -- or else
1698 -- A'length (2) /= B'length (2)
1699 -- then
1700 -- return False; -- RM 4.5.2(23)
1701 -- end if;
0da2c8ac 1702
fbf5a39b 1703 -- declare
523456db
AC		 1704 -- A1 : Index_T1 := A'first (1);
1705 -- B1 : Index_T1 := B'first (1);
fbf5a39b 1706 -- begin
523456db 1707 -- loop
fbf5a39b 1708 -- declare
523456db
AC		 1709 -- A2 : Index_T2 := A'first (2);
1710 -- B2 : Index_T2 := B'first (2);
fbf5a39b 1711 -- begin
523456db 1712 -- loop
fbf5a39b
AC		 1713 -- if A (A1, A2) /= B (B1, B2) then
1714 -- return False;
70482933 1715 -- end if;
0da2c8ac 1716
523456db
AC		 1717 -- exit when A2 = A'last (2);
1718 -- A2 := Index_T2'succ (A2);
0da2c8ac 1719 -- B2 := Index_T2'succ (B2);
70482933 1720 -- end loop;
fbf5a39b 1721 -- end;
0da2c8ac 1722
523456db
AC		 1723 -- exit when A1 = A'last (1);
1724 -- A1 := Index_T1'succ (A1);
0da2c8ac 1725 -- B1 := Index_T1'succ (B1);
70482933 1726 -- end loop;
fbf5a39b 1727 -- end;
0da2c8ac 1728
70482933
RK		 1729 -- return true;
1730 -- end Enn;
1731
685094bf
RD		 1732 -- Note on the formal types used (atyp and btyp). If either of the arrays
1733 -- is of a private type, we use the underlying type, and do an unchecked
1734 -- conversion of the actual. If either of the arrays has a bound depending
1735 -- on a discriminant, then we use the base type since otherwise we have an
1736 -- escaped discriminant in the function.
0da2c8ac 1737
685094bf
RD		 1738 -- If both arrays are constrained and have the same bounds, we can generate
1739 -- a loop with an explicit iteration scheme using a 'Range attribute over
1740 -- the first array.
523456db 1741
70482933
RK		 1742 function Expand_Array_Equality
1743 (Nod : Node_Id;
70482933
RK		 1744 Lhs : Node_Id;
1745 Rhs : Node_Id;
0da2c8ac
AC		 1746 Bodies : List_Id;
1747 Typ : Entity_Id) return Node_Id
70482933
RK		 1748 is
1749 Loc : constant Source_Ptr := Sloc (Nod);
fbf5a39b
AC		 1750 Decls : constant List_Id := New_List;
1751 Index_List1 : constant List_Id := New_List;
1752 Index_List2 : constant List_Id := New_List;
1753
1754 Actuals : List_Id;
1755 Formals : List_Id;
1756 Func_Name : Entity_Id;
1757 Func_Body : Node_Id;
70482933
RK		 1758
1759 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1760 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1761
0da2c8ac
AC		 1762 Ltyp : Entity_Id;
1763 Rtyp : Entity_Id;
1764 -- The parameter types to be used for the formals
1765
fbf5a39b
AC		 1766 function Arr_Attr
1767 (Arr : Entity_Id;
1768 Nam : Name_Id;
2e071734 1769 Num : Int) return Node_Id;
5e1c00fa 1770 -- This builds the attribute reference Arr'Nam (Expr)
fbf5a39b 1771
70482933 1772 function Component_Equality (Typ : Entity_Id) return Node_Id;
685094bf 1773 -- Create one statement to compare corresponding components, designated
3b42c566 1774 -- by a full set of indexes.
70482933 1775
0da2c8ac 1776 function Get_Arg_Type (N : Node_Id) return Entity_Id;
685094bf
RD		 1777 -- Given one of the arguments, computes the appropriate type to be used
1778 -- for that argument in the corresponding function formal
0da2c8ac 1779
fbf5a39b 1780 function Handle_One_Dimension
70482933 1781 (N : Int;
2e071734 1782 Index : Node_Id) return Node_Id;
0da2c8ac 1783 -- This procedure returns the following code
fbf5a39b
AC		 1784 --
1785 -- declare
523456db 1786 -- Bn : Index_T := B'First (N);
fbf5a39b 1787 -- begin
523456db 1788 -- loop
fbf5a39b 1789 -- xxx
523456db
AC		 1790 -- exit when An = A'Last (N);
1791 -- An := Index_T'Succ (An)
0da2c8ac 1792 -- Bn := Index_T'Succ (Bn)
fbf5a39b
AC		 1793 -- end loop;
1794 -- end;
1795 --
3b42c566 1796 -- If both indexes are constrained and identical, the procedure
523456db
AC		 1797 -- returns a simpler loop:
1798 --
1799 -- for An in A'Range (N) loop
1800 -- xxx
1801 -- end loop
0da2c8ac 1802 --
523456db 1803 -- N is the dimension for which we are generating a loop. Index is the
685094bf
RD		 1804 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1805 -- xxx statement is either the loop or declare for the next dimension
1806 -- or if this is the last dimension the comparison of corresponding
1807 -- components of the arrays.
fbf5a39b 1808 --
685094bf 1809 -- The actual way the code works is to return the comparison of
a90bd866 1810 -- corresponding components for the N+1 call. That's neater.
fbf5a39b
AC		 1811
1812 function Test_Empty_Arrays return Node_Id;
1813 -- This function constructs the test for both arrays being empty
1814 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1815 -- and then
1816 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1817
1818 function Test_Lengths_Correspond return Node_Id;
685094bf
RD		 1819 -- This function constructs the test for arrays having different lengths
1820 -- in at least one index position, in which case the resulting code is:
fbf5a39b
AC		 1821
1822 -- A'length (1) /= B'length (1)
1823 -- or else
1824 -- A'length (2) /= B'length (2)
1825 -- or else
1826 -- ...
1827
1828 --------------
1829 -- Arr_Attr --
1830 --------------
1831
1832 function Arr_Attr
1833 (Arr : Entity_Id;
1834 Nam : Name_Id;
2e071734 1835 Num : Int) return Node_Id
fbf5a39b
AC		 1836 is
1837 begin
1838 return
1839 Make_Attribute_Reference (Loc,
cc6f5d75
AC		 1840 Attribute_Name => Nam,
1841 Prefix => New_Occurrence_Of (Arr, Loc),
1842 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
fbf5a39b 1843 end Arr_Attr;
70482933
RK		 1844
1845 ------------------------
1846 -- Component_Equality --
1847 ------------------------
1848
1849 function Component_Equality (Typ : Entity_Id) return Node_Id is
1850 Test : Node_Id;
1851 L, R : Node_Id;
1852
1853 begin
1854 -- if a(i1...) /= b(j1...) then return false; end if;
1855
1856 L :=
1857 Make_Indexed_Component (Loc,
7675ad4f 1858 Prefix => Make_Identifier (Loc, Chars (A)),
70482933
RK		 1859 Expressions => Index_List1);
1860
1861 R :=
1862 Make_Indexed_Component (Loc,
7675ad4f 1863 Prefix => Make_Identifier (Loc, Chars (B)),
70482933
RK		 1864 Expressions => Index_List2);
1865
1866 Test := Expand_Composite_Equality
1867 (Nod, Component_Type (Typ), L, R, Decls);
1868
a9d8907c
JM		 1869 -- If some (sub)component is an unchecked_union, the whole operation
1870 -- will raise program error.
8aceda64
AC		 1871
1872 if Nkind (Test) = N_Raise_Program_Error then
a9d8907c
JM		 1873
1874 -- This node is going to be inserted at a location where a
685094bf
RD		 1875 -- statement is expected: clear its Etype so analysis will set
1876 -- it to the expected Standard_Void_Type.
a9d8907c
JM		 1877
1878 Set_Etype (Test, Empty);
8aceda64
AC		 1879 return Test;
1880
1881 else
1882 return
1883 Make_Implicit_If_Statement (Nod,
cc6f5d75 1884 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
8aceda64 1885 Then_Statements => New_List (
d766cee3 1886 Make_Simple_Return_Statement (Loc,
8aceda64
AC		 1887 Expression => New_Occurrence_Of (Standard_False, Loc))));
1888 end if;
70482933
RK		 1889 end Component_Equality;
1890
0da2c8ac
AC		 1891 ------------------
1892 -- Get_Arg_Type --
1893 ------------------
1894
1895 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1896 T : Entity_Id;
1897 X : Node_Id;
1898
1899 begin
1900 T := Etype (N);
1901
1902 if No (T) then
1903 return Typ;
1904
1905 else
1906 T := Underlying_Type (T);
1907
1908 X := First_Index (T);
1909 while Present (X) loop
761f7dcb
AC		 1910 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1911 or else
1912 Denotes_Discriminant (Type_High_Bound (Etype (X)))
0da2c8ac
AC		 1913 then
1914 T := Base_Type (T);
1915 exit;
1916 end if;
1917
1918 Next_Index (X);
1919 end loop;
1920
1921 return T;
1922 end if;
1923 end Get_Arg_Type;
1924
fbf5a39b
AC		 1925 --------------------------
1926 -- Handle_One_Dimension --
1927 ---------------------------
70482933 1928
fbf5a39b 1929 function Handle_One_Dimension
70482933 1930 (N : Int;
2e071734 1931 Index : Node_Id) return Node_Id
70482933 1932 is
0da2c8ac 1933 Need_Separate_Indexes : constant Boolean :=
761f7dcb 1934 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
0da2c8ac 1935 -- If the index types are identical, and we are working with
685094bf
RD		 1936 -- constrained types, then we can use the same index for both
1937 -- of the arrays.
0da2c8ac 1938
191fcb3a 1939 An : constant Entity_Id := Make_Temporary (Loc, 'A');
0da2c8ac
AC		 1940
1941 Bn : Entity_Id;
1942 Index_T : Entity_Id;
1943 Stm_List : List_Id;
1944 Loop_Stm : Node_Id;
70482933
RK		 1945
1946 begin
0da2c8ac
AC		 1947 if N > Number_Dimensions (Ltyp) then
1948 return Component_Equality (Ltyp);
fbf5a39b 1949 end if;
70482933 1950
0da2c8ac
AC		 1951 -- Case where we generate a loop
1952
1953 Index_T := Base_Type (Etype (Index));
1954
1955 if Need_Separate_Indexes then
191fcb3a 1956 Bn := Make_Temporary (Loc, 'B');
0da2c8ac
AC		 1957 else
1958 Bn := An;
1959 end if;
70482933 1960
e4494292
RD		 1961 Append (New_Occurrence_Of (An, Loc), Index_List1);
1962 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
70482933 1963
0da2c8ac
AC		 1964 Stm_List := New_List (
1965 Handle_One_Dimension (N + 1, Next_Index (Index)));
70482933 1966
0da2c8ac 1967 if Need_Separate_Indexes then
a9d8907c 1968
3b42c566 1969 -- Generate guard for loop, followed by increments of indexes
523456db
AC		 1970
1971 Append_To (Stm_List,
1972 Make_Exit_Statement (Loc,
1973 Condition =>
1974 Make_Op_Eq (Loc,
cc6f5d75 1975 Left_Opnd => New_Occurrence_Of (An, Loc),
523456db
AC		 1976 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1977
1978 Append_To (Stm_List,
1979 Make_Assignment_Statement (Loc,
e4494292 1980 Name => New_Occurrence_Of (An, Loc),
523456db
AC		 1981 Expression =>
1982 Make_Attribute_Reference (Loc,
e4494292 1983 Prefix => New_Occurrence_Of (Index_T, Loc),
523456db 1984 Attribute_Name => Name_Succ,
e4494292
RD		 1985 Expressions => New_List (
1986 New_Occurrence_Of (An, Loc)))));
523456db 1987
0da2c8ac
AC		 1988 Append_To (Stm_List,
1989 Make_Assignment_Statement (Loc,
e4494292 1990 Name => New_Occurrence_Of (Bn, Loc),
0da2c8ac
AC		 1991 Expression =>
1992 Make_Attribute_Reference (Loc,
e4494292 1993 Prefix => New_Occurrence_Of (Index_T, Loc),
0da2c8ac 1994 Attribute_Name => Name_Succ,
e4494292
RD		 1995 Expressions => New_List (
1996 New_Occurrence_Of (Bn, Loc)))));
0da2c8ac
AC		 1997 end if;
1998
a9d8907c
JM		 1999 -- If separate indexes, we need a declare block for An and Bn, and a
2000 -- loop without an iteration scheme.
0da2c8ac
AC		 2001
2002 if Need_Separate_Indexes then
523456db
AC		 2003 Loop_Stm :=
2004 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
2005
0da2c8ac
AC		 2006 return
2007 Make_Block_Statement (Loc,
2008 Declarations => New_List (
523456db
AC		 2009 Make_Object_Declaration (Loc,
2010 Defining_Identifier => An,
e4494292 2011 Object_Definition => New_Occurrence_Of (Index_T, Loc),
523456db
AC		 2012 Expression => Arr_Attr (A, Name_First, N)),
2013
0da2c8ac
AC		 2014 Make_Object_Declaration (Loc,
2015 Defining_Identifier => Bn,
e4494292 2016 Object_Definition => New_Occurrence_Of (Index_T, Loc),
0da2c8ac 2017 Expression => Arr_Attr (B, Name_First, N))),
523456db 2018
0da2c8ac
AC		 2019 Handled_Statement_Sequence =>
2020 Make_Handled_Sequence_Of_Statements (Loc,
2021 Statements => New_List (Loop_Stm)));
2022
523456db
AC		 2023 -- If no separate indexes, return loop statement with explicit
2024 -- iteration scheme on its own
0da2c8ac
AC		 2025
2026 else
523456db
AC		 2027 Loop_Stm :=
2028 Make_Implicit_Loop_Statement (Nod,
2029 Statements => Stm_List,
2030 Iteration_Scheme =>
2031 Make_Iteration_Scheme (Loc,
2032 Loop_Parameter_Specification =>
2033 Make_Loop_Parameter_Specification (Loc,
2034 Defining_Identifier => An,
2035 Discrete_Subtype_Definition =>
2036 Arr_Attr (A, Name_Range, N))));
0da2c8ac
AC		 2037 return Loop_Stm;
2038 end if;
fbf5a39b
AC		 2039 end Handle_One_Dimension;
2040
2041 -----------------------
2042 -- Test_Empty_Arrays --
2043 -----------------------
2044
2045 function Test_Empty_Arrays return Node_Id is
2046 Alist : Node_Id;
2047 Blist : Node_Id;
2048
2049 Atest : Node_Id;
2050 Btest : Node_Id;
70482933 2051
fbf5a39b
AC		 2052 begin
2053 Alist := Empty;
2054 Blist := Empty;
0da2c8ac 2055 for J in 1 .. Number_Dimensions (Ltyp) loop
fbf5a39b
AC		 2056 Atest :=
2057 Make_Op_Eq (Loc,
2058 Left_Opnd => Arr_Attr (A, Name_Length, J),
2059 Right_Opnd => Make_Integer_Literal (Loc, 0));
2060
2061 Btest :=
2062 Make_Op_Eq (Loc,
2063 Left_Opnd => Arr_Attr (B, Name_Length, J),
2064 Right_Opnd => Make_Integer_Literal (Loc, 0));
2065
2066 if No (Alist) then
2067 Alist := Atest;
2068 Blist := Btest;
70482933 2069
fbf5a39b
AC		 2070 else
2071 Alist :=
2072 Make_Or_Else (Loc,
2073 Left_Opnd => Relocate_Node (Alist),
2074 Right_Opnd => Atest);
2075
2076 Blist :=
2077 Make_Or_Else (Loc,
2078 Left_Opnd => Relocate_Node (Blist),
2079 Right_Opnd => Btest);
2080 end if;
2081 end loop;
70482933 2082
fbf5a39b
AC		 2083 return
2084 Make_And_Then (Loc,
2085 Left_Opnd => Alist,
2086 Right_Opnd => Blist);
2087 end Test_Empty_Arrays;
70482933 2088
fbf5a39b
AC		 2089 -----------------------------
2090 -- Test_Lengths_Correspond --
2091 -----------------------------
70482933 2092
fbf5a39b
AC		 2093 function Test_Lengths_Correspond return Node_Id is
2094 Result : Node_Id;
2095 Rtest : Node_Id;
2096
2097 begin
2098 Result := Empty;
0da2c8ac 2099 for J in 1 .. Number_Dimensions (Ltyp) loop
fbf5a39b
AC		 2100 Rtest :=
2101 Make_Op_Ne (Loc,
2102 Left_Opnd => Arr_Attr (A, Name_Length, J),
2103 Right_Opnd => Arr_Attr (B, Name_Length, J));
2104
2105 if No (Result) then
2106 Result := Rtest;
2107 else
2108 Result :=
2109 Make_Or_Else (Loc,
2110 Left_Opnd => Relocate_Node (Result),
2111 Right_Opnd => Rtest);
2112 end if;
2113 end loop;
2114
2115 return Result;
2116 end Test_Lengths_Correspond;
70482933
RK		 2117
2118 -- Start of processing for Expand_Array_Equality
2119
2120 begin
0da2c8ac
AC		 2121 Ltyp := Get_Arg_Type (Lhs);
2122 Rtyp := Get_Arg_Type (Rhs);
2123
685094bf
RD		 2124 -- For now, if the argument types are not the same, go to the base type,
2125 -- since the code assumes that the formals have the same type. This is
2126 -- fixable in future ???
0da2c8ac
AC		 2127
2128 if Ltyp /= Rtyp then
2129 Ltyp := Base_Type (Ltyp);
2130 Rtyp := Base_Type (Rtyp);
2131 pragma Assert (Ltyp = Rtyp);
2132 end if;
2133
2134 -- Build list of formals for function
2135
70482933
RK		 2136 Formals := New_List (
2137 Make_Parameter_Specification (Loc,
2138 Defining_Identifier => A,
e4494292 2139 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
70482933
RK		 2140
2141 Make_Parameter_Specification (Loc,
2142 Defining_Identifier => B,
e4494292 2143 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
70482933 2144
191fcb3a 2145 Func_Name := Make_Temporary (Loc, 'E');
70482933 2146
fbf5a39b 2147 -- Build statement sequence for function
70482933
RK		 2148
2149 Func_Body :=
2150 Make_Subprogram_Body (Loc,
2151 Specification =>
2152 Make_Function_Specification (Loc,
2153 Defining_Unit_Name => Func_Name,
2154 Parameter_Specifications => Formals,
e4494292 2155 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
fbf5a39b
AC		 2156
2157 Declarations => Decls,
2158
70482933
RK		 2159 Handled_Statement_Sequence =>
2160 Make_Handled_Sequence_Of_Statements (Loc,
2161 Statements => New_List (
fbf5a39b
AC		 2162
2163 Make_Implicit_If_Statement (Nod,
cc6f5d75 2164 Condition => Test_Empty_Arrays,
fbf5a39b 2165 Then_Statements => New_List (
d766cee3 2166 Make_Simple_Return_Statement (Loc,
fbf5a39b
AC		 2167 Expression =>
2168 New_Occurrence_Of (Standard_True, Loc)))),
2169
2170 Make_Implicit_If_Statement (Nod,
cc6f5d75 2171 Condition => Test_Lengths_Correspond,
fbf5a39b 2172 Then_Statements => New_List (
d766cee3 2173 Make_Simple_Return_Statement (Loc,
cc6f5d75 2174 Expression => New_Occurrence_Of (Standard_False, Loc)))),
fbf5a39b 2175
0da2c8ac 2176 Handle_One_Dimension (1, First_Index (Ltyp)),
fbf5a39b 2177
d766cee3 2178 Make_Simple_Return_Statement (Loc,
70482933
RK		 2179 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2180
2181 Set_Has_Completion (Func_Name, True);
0da2c8ac 2182 Set_Is_Inlined (Func_Name);
70482933 2183
685094bf
RD		 2184 -- If the array type is distinct from the type of the arguments, it
2185 -- is the full view of a private type. Apply an unchecked conversion
2186 -- to insure that analysis of the call succeeds.
70482933 2187
0da2c8ac
AC		 2188 declare
2189 L, R : Node_Id;
2190
2191 begin
2192 L := Lhs;
2193 R := Rhs;
2194
2195 if No (Etype (Lhs))
2196 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
2197 then
2198 L := OK_Convert_To (Ltyp, Lhs);
2199 end if;
2200
2201 if No (Etype (Rhs))
2202 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
2203 then
2204 R := OK_Convert_To (Rtyp, Rhs);
2205 end if;
2206
2207 Actuals := New_List (L, R);
2208 end;
70482933
RK		 2209
2210 Append_To (Bodies, Func_Body);
2211
2212 return
2213 Make_Function_Call (Loc,
e4494292 2214 Name => New_Occurrence_Of (Func_Name, Loc),
70482933
RK		 2215 Parameter_Associations => Actuals);
2216 end Expand_Array_Equality;
2217
2218 -----------------------------
2219 -- Expand_Boolean_Operator --
2220 -----------------------------
2221
685094bf
RD		 2222 -- Note that we first get the actual subtypes of the operands, since we
2223 -- always want to deal with types that have bounds.
70482933
RK		 2224
2225 procedure Expand_Boolean_Operator (N : Node_Id) is
fbf5a39b 2226 Typ : constant Entity_Id := Etype (N);
70482933
RK		 2227
2228 begin
685094bf
RD		 2229 -- Special case of bit packed array where both operands are known to be
2230 -- properly aligned. In this case we use an efficient run time routine
2231 -- to carry out the operation (see System.Bit_Ops).
a9d8907c
JM		 2232
2233 if Is_Bit_Packed_Array (Typ)
2234 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2235 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2236 then
70482933 2237 Expand_Packed_Boolean_Operator (N);
a9d8907c
JM		 2238 return;
2239 end if;
70482933 2240
a9d8907c
JM		 2241 -- For the normal non-packed case, the general expansion is to build
2242 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2243 -- and then inserting it into the tree. The original operator node is
2244 -- then rewritten as a call to this function. We also use this in the
2245 -- packed case if either operand is a possibly unaligned object.
70482933 2246
a9d8907c
JM		 2247 declare
2248 Loc : constant Source_Ptr := Sloc (N);
2249 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2250 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
2251 Func_Body : Node_Id;
2252 Func_Name : Entity_Id;
fbf5a39b 2253
a9d8907c
JM		 2254 begin
2255 Convert_To_Actual_Subtype (L);
2256 Convert_To_Actual_Subtype (R);
2257 Ensure_Defined (Etype (L), N);
2258 Ensure_Defined (Etype (R), N);
2259 Apply_Length_Check (R, Etype (L));
2260
b4592168
GD		 2261 if Nkind (N) = N_Op_Xor then
2262 Silly_Boolean_Array_Xor_Test (N, Etype (L));
2263 end if;
2264
a9d8907c
JM		 2265 if Nkind (Parent (N)) = N_Assignment_Statement
2266 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2267 then
2268 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
fbf5a39b 2269
a9d8907c
JM		 2270 elsif Nkind (Parent (N)) = N_Op_Not
2271 and then Nkind (N) = N_Op_And
39f0fa29 2272 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
cc6f5d75 2273 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
a9d8907c
JM		 2274 then
2275 return;
2276 else
fbf5a39b 2277
a9d8907c
JM		 2278 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2279 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2280 Insert_Action (N, Func_Body);
70482933 2281
a9d8907c 2282 -- Now rewrite the expression with a call
70482933 2283
a9d8907c
JM		 2284 Rewrite (N,
2285 Make_Function_Call (Loc,
e4494292 2286 Name => New_Occurrence_Of (Func_Name, Loc),
a9d8907c
JM		 2287 Parameter_Associations =>
2288 New_List (
2289 L,
2290 Make_Type_Conversion
e4494292 2291 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
70482933 2292
a9d8907c
JM		 2293 Analyze_And_Resolve (N, Typ);
2294 end if;
2295 end;
70482933
RK		 2296 end Expand_Boolean_Operator;
2297
456cbfa5
AC		 2298 ------------------------------------------------
2299 -- Expand_Compare_Minimize_Eliminate_Overflow --
2300 ------------------------------------------------
2301
2302 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2303 Loc : constant Source_Ptr := Sloc (N);
2304
71fb4dc8
AC		 2305 Result_Type : constant Entity_Id := Etype (N);
2306 -- Capture result type (could be a derived boolean type)
2307
456cbfa5
AC		 2308 Llo, Lhi : Uint;
2309 Rlo, Rhi : Uint;
2310
2311 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2312 -- Entity for Long_Long_Integer'Base
2313
15c94a55 2314 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
a7f1b24f 2315 -- Current overflow checking mode
456cbfa5
AC		 2316
2317 procedure Set_True;
2318 procedure Set_False;
2319 -- These procedures rewrite N with an occurrence of Standard_True or
2320 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2321
2322 ---------------
2323 -- Set_False --
2324 ---------------
2325
2326 procedure Set_False is
2327 begin
2328 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2329 Warn_On_Known_Condition (N);
2330 end Set_False;
2331
2332 --------------
2333 -- Set_True --
2334 --------------
2335
2336 procedure Set_True is
2337 begin
2338 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2339 Warn_On_Known_Condition (N);
2340 end Set_True;
2341
2342 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2343
2344 begin
2345 -- Nothing to do unless we have a comparison operator with operands
2346 -- that are signed integer types, and we are operating in either
2347 -- MINIMIZED or ELIMINATED overflow checking mode.
2348
2349 if Nkind (N) not in N_Op_Compare
2350 or else Check not in Minimized_Or_Eliminated
2351 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2352 then
2353 return;
2354 end if;
2355
2356 -- OK, this is the case we are interested in. First step is to process
2357 -- our operands using the Minimize_Eliminate circuitry which applies
2358 -- this processing to the two operand subtrees.
2359
a7f1b24f 2360 Minimize_Eliminate_Overflows
c7e152b5 2361 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
a7f1b24f 2362 Minimize_Eliminate_Overflows
c7e152b5 2363 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
456cbfa5 2364
65f7ed64
AC		 2365 -- See if the range information decides the result of the comparison.
2366 -- We can only do this if we in fact have full range information (which
2367 -- won't be the case if either operand is bignum at this stage).
456cbfa5 2368
65f7ed64
AC		 2369 if Llo /= No_Uint and then Rlo /= No_Uint then
2370 case N_Op_Compare (Nkind (N)) is
456cbfa5
AC		 2371 when N_Op_Eq =>
2372 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2373 Set_True;
a40ada7e 2374 elsif Llo > Rhi or else Lhi < Rlo then
456cbfa5
AC		 2375 Set_False;
2376 end if;
2377
2378 when N_Op_Ge =>
2379 if Llo >= Rhi then
2380 Set_True;
2381 elsif Lhi < Rlo then
2382 Set_False;
2383 end if;
2384
2385 when N_Op_Gt =>
2386 if Llo > Rhi then
2387 Set_True;
2388 elsif Lhi <= Rlo then
2389 Set_False;
2390 end if;
2391
2392 when N_Op_Le =>
2393 if Llo > Rhi then
2394 Set_False;
2395 elsif Lhi <= Rlo then
2396 Set_True;
2397 end if;
2398
2399 when N_Op_Lt =>
2400 if Llo >= Rhi then
456cbfa5 2401 Set_False;
b6b5cca8
AC		 2402 elsif Lhi < Rlo then
2403 Set_True;
456cbfa5
AC		 2404 end if;
2405
2406 when N_Op_Ne =>
2407 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
456cbfa5 2408 Set_False;
a40ada7e
RD		 2409 elsif Llo > Rhi or else Lhi < Rlo then
2410 Set_True;
456cbfa5 2411 end if;
65f7ed64 2412 end case;
456cbfa5 2413
65f7ed64 2414 -- All done if we did the rewrite
456cbfa5 2415
65f7ed64
AC		 2416 if Nkind (N) not in N_Op_Compare then
2417 return;
2418 end if;
456cbfa5
AC		 2419 end if;
2420
2421 -- Otherwise, time to do the comparison
2422
2423 declare
2424 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2425 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2426
2427 begin
2428 -- If the two operands have the same signed integer type we are
2429 -- all set, nothing more to do. This is the case where either
2430 -- both operands were unchanged, or we rewrote both of them to
2431 -- be Long_Long_Integer.
2432
2433 -- Note: Entity for the comparison may be wrong, but it's not worth
2434 -- the effort to change it, since the back end does not use it.
2435
2436 if Is_Signed_Integer_Type (Ltype)
2437 and then Base_Type (Ltype) = Base_Type (Rtype)
2438 then
2439 return;
2440
2441 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2442
2443 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2444 declare
2445 Left : Node_Id := Left_Opnd (N);
2446 Right : Node_Id := Right_Opnd (N);
2447 -- Bignum references for left and right operands
2448
2449 begin
2450 if not Is_RTE (Ltype, RE_Bignum) then
2451 Left := Convert_To_Bignum (Left);
2452 elsif not Is_RTE (Rtype, RE_Bignum) then
2453 Right := Convert_To_Bignum (Right);
2454 end if;
2455
71fb4dc8 2456 -- We rewrite our node with:
456cbfa5 2457
71fb4dc8
AC		 2458 -- do
2459 -- Bnn : Result_Type;
2460 -- declare
2461 -- M : Mark_Id := SS_Mark;
2462 -- begin
2463 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2464 -- SS_Release (M);
2465 -- end;
2466 -- in
2467 -- Bnn
2468 -- end
456cbfa5
AC		 2469
2470 declare
71fb4dc8 2471 Blk : constant Node_Id := Make_Bignum_Block (Loc);
456cbfa5
AC		 2472 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2473 Ent : RE_Id;
2474
2475 begin
2476 case N_Op_Compare (Nkind (N)) is
2477 when N_Op_Eq => Ent := RE_Big_EQ;
2478 when N_Op_Ge => Ent := RE_Big_GE;
2479 when N_Op_Gt => Ent := RE_Big_GT;
2480 when N_Op_Le => Ent := RE_Big_LE;
2481 when N_Op_Lt => Ent := RE_Big_LT;
2482 when N_Op_Ne => Ent := RE_Big_NE;
2483 end case;
2484
71fb4dc8 2485 -- Insert assignment to Bnn into the bignum block
456cbfa5
AC		 2486
2487 Insert_Before
2488 (First (Statements (Handled_Statement_Sequence (Blk))),
2489 Make_Assignment_Statement (Loc,
2490 Name => New_Occurrence_Of (Bnn, Loc),
2491 Expression =>
2492 Make_Function_Call (Loc,
2493 Name =>
2494 New_Occurrence_Of (RTE (Ent), Loc),
2495 Parameter_Associations => New_List (Left, Right))));
2496
71fb4dc8
AC		 2497 -- Now do the rewrite with expression actions
2498
2499 Rewrite (N,
2500 Make_Expression_With_Actions (Loc,
2501 Actions => New_List (
2502 Make_Object_Declaration (Loc,
2503 Defining_Identifier => Bnn,
2504 Object_Definition =>
2505 New_Occurrence_Of (Result_Type, Loc)),
2506 Blk),
2507 Expression => New_Occurrence_Of (Bnn, Loc)));
2508 Analyze_And_Resolve (N, Result_Type);
456cbfa5
AC		 2509 end;
2510 end;
2511
2512 -- No bignums involved, but types are different, so we must have
2513 -- rewritten one of the operands as a Long_Long_Integer but not
2514 -- the other one.
2515
2516 -- If left operand is Long_Long_Integer, convert right operand
2517 -- and we are done (with a comparison of two Long_Long_Integers).
2518
2519 elsif Ltype = LLIB then
2520 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2521 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2522 return;
2523
2524 -- If right operand is Long_Long_Integer, convert left operand
2525 -- and we are done (with a comparison of two Long_Long_Integers).
2526
2527 -- This is the only remaining possibility
2528
2529 else pragma Assert (Rtype = LLIB);
2530 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2531 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2532 return;
2533 end if;
2534 end;
2535 end Expand_Compare_Minimize_Eliminate_Overflow;
2536
70482933
RK		 2537 -------------------------------
2538 -- Expand_Composite_Equality --
2539 -------------------------------
2540
2541 -- This function is only called for comparing internal fields of composite
2542 -- types when these fields are themselves composites. This is a special
2543 -- case because it is not possible to respect normal Ada visibility rules.
2544
2545 function Expand_Composite_Equality
2546 (Nod : Node_Id;
2547 Typ : Entity_Id;
2548 Lhs : Node_Id;
2549 Rhs : Node_Id;
2e071734 2550 Bodies : List_Id) return Node_Id
70482933
RK		 2551 is
2552 Loc : constant Source_Ptr := Sloc (Nod);
2553 Full_Type : Entity_Id;
2554 Prim : Elmt_Id;
2555 Eq_Op : Entity_Id;
2556
7efc3f2d
AC		 2557 function Find_Primitive_Eq return Node_Id;
2558 -- AI05-0123: Locate primitive equality for type if it exists, and
2559 -- build the corresponding call. If operation is abstract, replace
2560 -- call with an explicit raise. Return Empty if there is no primitive.
2561
2562 -----------------------
2563 -- Find_Primitive_Eq --
2564 -----------------------
2565
2566 function Find_Primitive_Eq return Node_Id is
2567 Prim_E : Elmt_Id;
2568 Prim : Node_Id;
2569
2570 begin
2571 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
2572 while Present (Prim_E) loop
2573 Prim := Node (Prim_E);
2574
2575 -- Locate primitive equality with the right signature
2576
2577 if Chars (Prim) = Name_Op_Eq
2578 and then Etype (First_Formal (Prim)) =
39ade2f9 2579 Etype (Next_Formal (First_Formal (Prim)))
7efc3f2d
AC		 2580 and then Etype (Prim) = Standard_Boolean
2581 then
2582 if Is_Abstract_Subprogram (Prim) then
2583 return
2584 Make_Raise_Program_Error (Loc,
2585 Reason => PE_Explicit_Raise);
2586
2587 else
2588 return
2589 Make_Function_Call (Loc,
e4494292 2590 Name => New_Occurrence_Of (Prim, Loc),
7efc3f2d
AC		 2591 Parameter_Associations => New_List (Lhs, Rhs));
2592 end if;
2593 end if;
2594
2595 Next_Elmt (Prim_E);
2596 end loop;
2597
2598 -- If not found, predefined operation will be used
2599
2600 return Empty;
2601 end Find_Primitive_Eq;
2602
2603 -- Start of processing for Expand_Composite_Equality
2604
70482933
RK		 2605 begin
2606 if Is_Private_Type (Typ) then
2607 Full_Type := Underlying_Type (Typ);
2608 else
2609 Full_Type := Typ;
2610 end if;
2611
ced8450b
ES		 2612 -- If the private type has no completion the context may be the
2613 -- expansion of a composite equality for a composite type with some
2614 -- still incomplete components. The expression will not be analyzed
2615 -- until the enclosing type is completed, at which point this will be
2616 -- properly expanded, unless there is a bona fide completion error.
70482933
RK		 2617
2618 if No (Full_Type) then
ced8450b 2619 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
70482933
RK		 2620 end if;
2621
2622 Full_Type := Base_Type (Full_Type);
2623
da1b76c1
HK		 2624 -- When the base type itself is private, use the full view to expand
2625 -- the composite equality.
2626
2627 if Is_Private_Type (Full_Type) then
2628 Full_Type := Underlying_Type (Full_Type);
2629 end if;
2630
16788d44
RD		 2631 -- Case of array types
2632
70482933
RK		 2633 if Is_Array_Type (Full_Type) then
2634
2635 -- If the operand is an elementary type other than a floating-point
2636 -- type, then we can simply use the built-in block bitwise equality,
2637 -- since the predefined equality operators always apply and bitwise
2638 -- equality is fine for all these cases.
2639
2640 if Is_Elementary_Type (Component_Type (Full_Type))
2641 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2642 then
39ade2f9 2643 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
70482933 2644
685094bf
RD		 2645 -- For composite component types, and floating-point types, use the
2646 -- expansion. This deals with tagged component types (where we use
2647 -- the applicable equality routine) and floating-point, (where we
2648 -- need to worry about negative zeroes), and also the case of any
2649 -- composite type recursively containing such fields.
70482933
RK		 2650
2651 else
0da2c8ac 2652 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
70482933
RK		 2653 end if;
2654
16788d44
RD		 2655 -- Case of tagged record types
2656
70482933
RK		 2657 elsif Is_Tagged_Type (Full_Type) then
2658
2659 -- Call the primitive operation "=" of this type
2660
2661 if Is_Class_Wide_Type (Full_Type) then
2662 Full_Type := Root_Type (Full_Type);
2663 end if;
2664
685094bf
RD		 2665 -- If this is derived from an untagged private type completed with a
2666 -- tagged type, it does not have a full view, so we use the primitive
2667 -- operations of the private type. This check should no longer be
2668 -- necessary when these types receive their full views ???
70482933
RK		 2669
2670 if Is_Private_Type (Typ)
2671 and then not Is_Tagged_Type (Typ)
2672 and then not Is_Controlled (Typ)
2673 and then Is_Derived_Type (Typ)
2674 and then No (Full_View (Typ))
2675 then
2676 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2677 else
2678 Prim := First_Elmt (Primitive_Operations (Full_Type));
2679 end if;
2680
2681 loop
2682 Eq_Op := Node (Prim);
2683 exit when Chars (Eq_Op) = Name_Op_Eq
2684 and then Etype (First_Formal (Eq_Op)) =
e6f69614
AC		 2685 Etype (Next_Formal (First_Formal (Eq_Op)))
2686 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
70482933
RK		 2687 Next_Elmt (Prim);
2688 pragma Assert (Present (Prim));
2689 end loop;
2690
2691 Eq_Op := Node (Prim);
2692
2693 return
2694 Make_Function_Call (Loc,
e4494292 2695 Name => New_Occurrence_Of (Eq_Op, Loc),
70482933
RK		 2696 Parameter_Associations =>
2697 New_List
2698 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2699 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2700
16788d44
RD		 2701 -- Case of untagged record types
2702
70482933 2703 elsif Is_Record_Type (Full_Type) then
fbf5a39b 2704 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
70482933
RK		 2705
2706 if Present (Eq_Op) then
2707 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2708
685094bf
RD		 2709 -- Inherited equality from parent type. Convert the actuals to
2710 -- match signature of operation.
70482933
RK		 2711
2712 declare
fbf5a39b 2713 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
70482933
RK		 2714
2715 begin
2716 return
2717 Make_Function_Call (Loc,
e4494292 2718 Name => New_Occurrence_Of (Eq_Op, Loc),
39ade2f9
AC		 2719 Parameter_Associations => New_List (
2720 OK_Convert_To (T, Lhs),
2721 OK_Convert_To (T, Rhs)));
70482933
RK		 2722 end;
2723
2724 else
5d09245e
AC		 2725 -- Comparison between Unchecked_Union components
2726
2727 if Is_Unchecked_Union (Full_Type) then
2728 declare
2729 Lhs_Type : Node_Id := Full_Type;
2730 Rhs_Type : Node_Id := Full_Type;
2731 Lhs_Discr_Val : Node_Id;
2732 Rhs_Discr_Val : Node_Id;
2733
2734 begin
2735 -- Lhs subtype
2736
2737 if Nkind (Lhs) = N_Selected_Component then
2738 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2739 end if;
2740
2741 -- Rhs subtype
2742
2743 if Nkind (Rhs) = N_Selected_Component then
2744 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2745 end if;
2746
2747 -- Lhs of the composite equality
2748
2749 if Is_Constrained (Lhs_Type) then
2750
685094bf 2751 -- Since the enclosing record type can never be an
5d09245e
AC		 2752 -- Unchecked_Union (this code is executed for records
2753 -- that do not have variants), we may reference its
2754 -- discriminant(s).
2755
2756 if Nkind (Lhs) = N_Selected_Component
533369aa
AC		 2757 and then Has_Per_Object_Constraint
2758 (Entity (Selector_Name (Lhs)))
5d09245e
AC		 2759 then
2760 Lhs_Discr_Val :=
2761 Make_Selected_Component (Loc,
39ade2f9 2762 Prefix => Prefix (Lhs),
5d09245e 2763 Selector_Name =>
39ade2f9
AC		 2764 New_Copy
2765 (Get_Discriminant_Value
2766 (First_Discriminant (Lhs_Type),
2767 Lhs_Type,
2768 Stored_Constraint (Lhs_Type))));
5d09245e
AC		 2769
2770 else
39ade2f9
AC		 2771 Lhs_Discr_Val :=
2772 New_Copy
2773 (Get_Discriminant_Value
2774 (First_Discriminant (Lhs_Type),
2775 Lhs_Type,
2776 Stored_Constraint (Lhs_Type)));
5d09245e
AC		 2777
2778 end if;
2779 else
2780 -- It is not possible to infer the discriminant since
2781 -- the subtype is not constrained.
2782
8aceda64 2783 return
5d09245e 2784 Make_Raise_Program_Error (Loc,
8aceda64 2785 Reason => PE_Unchecked_Union_Restriction);
5d09245e
AC		 2786 end if;
2787
2788 -- Rhs of the composite equality
2789
2790 if Is_Constrained (Rhs_Type) then
2791 if Nkind (Rhs) = N_Selected_Component
39ade2f9
AC		 2792 and then Has_Per_Object_Constraint
2793 (Entity (Selector_Name (Rhs)))
5d09245e
AC		 2794 then
2795 Rhs_Discr_Val :=
2796 Make_Selected_Component (Loc,
39ade2f9 2797 Prefix => Prefix (Rhs),
5d09245e 2798 Selector_Name =>
39ade2f9
AC		 2799 New_Copy
2800 (Get_Discriminant_Value
2801 (First_Discriminant (Rhs_Type),
2802 Rhs_Type,
2803 Stored_Constraint (Rhs_Type))));
5d09245e
AC		 2804
2805 else
39ade2f9
AC		 2806 Rhs_Discr_Val :=
2807 New_Copy
2808 (Get_Discriminant_Value
2809 (First_Discriminant (Rhs_Type),
2810 Rhs_Type,
2811 Stored_Constraint (Rhs_Type)));
5d09245e
AC		 2812
2813 end if;
2814 else
8aceda64 2815 return
5d09245e 2816 Make_Raise_Program_Error (Loc,
8aceda64 2817 Reason => PE_Unchecked_Union_Restriction);
5d09245e
AC		 2818 end if;
2819
2820 -- Call the TSS equality function with the inferred
2821 -- discriminant values.
2822
2823 return
2824 Make_Function_Call (Loc,
e4494292 2825 Name => New_Occurrence_Of (Eq_Op, Loc),
5d09245e
AC		 2826 Parameter_Associations => New_List (
2827 Lhs,
2828 Rhs,
2829 Lhs_Discr_Val,
2830 Rhs_Discr_Val));
2831 end;
d151d6a3 2832
316e3a13
RD		 2833 -- All cases other than comparing Unchecked_Union types
2834
d151d6a3 2835 else
7f1a5156
EB		 2836 declare
2837 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
7f1a5156
EB		 2838 begin
2839 return
2840 Make_Function_Call (Loc,
316e3a13
RD		 2841 Name =>
2842 New_Occurrence_Of (Eq_Op, Loc),
7f1a5156
EB		 2843 Parameter_Associations => New_List (
2844 OK_Convert_To (T, Lhs),
2845 OK_Convert_To (T, Rhs)));
2846 end;
5d09245e 2847 end if;
d151d6a3 2848 end if;
5d09245e 2849
3058f181
BD		 2850 -- Equality composes in Ada 2012 for untagged record types. It also
2851 -- composes for bounded strings, because they are part of the
2852 -- predefined environment. We could make it compose for bounded
2853 -- strings by making them tagged, or by making sure all subcomponents
2854 -- are set to the same value, even when not used. Instead, we have
2855 -- this special case in the compiler, because it's more efficient.
2856
2857 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
5d09245e 2858
08daa782 2859 -- If no TSS has been created for the type, check whether there is
7efc3f2d 2860 -- a primitive equality declared for it.
d151d6a3
AC		 2861
2862 declare
3058f181 2863 Op : constant Node_Id := Find_Primitive_Eq;
d151d6a3
AC		 2864
2865 begin
a1fc903a
AC		 2866 -- Use user-defined primitive if it exists, otherwise use
2867 -- predefined equality.
2868
3058f181
BD		 2869 if Present (Op) then
2870 return Op;
7efc3f2d 2871 else
7efc3f2d
AC		 2872 return Make_Op_Eq (Loc, Lhs, Rhs);
2873 end if;
d151d6a3
AC		 2874 end;
2875
70482933
RK		 2876 else
2877 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2878 end if;
2879
16788d44 2880 -- Non-composite types (always use predefined equality)
70482933 2881
16788d44 2882 else
70482933
RK		 2883 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2884 end if;
2885 end Expand_Composite_Equality;
2886
fdac1f80
AC		 2887 ------------------------
2888 -- Expand_Concatenate --
2889 ------------------------
70482933 2890
fdac1f80
AC		 2891 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2892 Loc : constant Source_Ptr := Sloc (Cnode);
70482933 2893
fdac1f80
AC		 2894 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2895 -- Result type of concatenation
70482933 2896
fdac1f80
AC		 2897 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2898 -- Component type. Elements of this component type can appear as one
2899 -- of the operands of concatenation as well as arrays.
70482933 2900
ecc4ddde
AC		 2901 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2902 -- Index subtype
2903
2904 Ityp : constant Entity_Id := Base_Type (Istyp);
2905 -- Index type. This is the base type of the index subtype, and is used
2906 -- for all computed bounds (which may be out of range of Istyp in the
2907 -- case of null ranges).
70482933 2908
46ff89f3 2909 Artyp : Entity_Id;
fdac1f80
AC		 2910 -- This is the type we use to do arithmetic to compute the bounds and
2911 -- lengths of operands. The choice of this type is a little subtle and
2912 -- is discussed in a separate section at the start of the body code.
70482933 2913
fdac1f80
AC		 2914 Concatenation_Error : exception;
2915 -- Raised if concatenation is sure to raise a CE
70482933 2916
0ac73189
AC		 2917 Result_May_Be_Null : Boolean := True;
2918 -- Reset to False if at least one operand is encountered which is known
2919 -- at compile time to be non-null. Used for handling the special case
2920 -- of setting the high bound to the last operand high bound for a null
2921 -- result, thus ensuring a proper high bound in the super-flat case.
2922
df46b832 2923 N : constant Nat := List_Length (Opnds);
fdac1f80 2924 -- Number of concatenation operands including possibly null operands
df46b832
AC		 2925
2926 NN : Nat := 0;
a29262fd
AC		 2927 -- Number of operands excluding any known to be null, except that the
2928 -- last operand is always retained, in case it provides the bounds for
2929 -- a null result.
2930
2931 Opnd : Node_Id;
2932 -- Current operand being processed in the loop through operands. After
2933 -- this loop is complete, always contains the last operand (which is not
2934 -- the same as Operands (NN), since null operands are skipped).
df46b832
AC		 2935
2936 -- Arrays describing the operands, only the first NN entries of each
2937 -- array are set (NN < N when we exclude known null operands).
2938
2939 Is_Fixed_Length : array (1 .. N) of Boolean;
2940 -- True if length of corresponding operand known at compile time
2941
2942 Operands : array (1 .. N) of Node_Id;
a29262fd
AC		 2943 -- Set to the corresponding entry in the Opnds list (but note that null
2944 -- operands are excluded, so not all entries in the list are stored).
df46b832
AC		 2945
2946 Fixed_Length : array (1 .. N) of Uint;
fdac1f80
AC		 2947 -- Set to length of operand. Entries in this array are set only if the
2948 -- corresponding entry in Is_Fixed_Length is True.
df46b832 2949
0ac73189
AC		 2950 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2951 -- Set to lower bound of operand. Either an integer literal in the case
2952 -- where the bound is known at compile time, else actual lower bound.
2953 -- The operand low bound is of type Ityp.
2954
df46b832
AC		 2955 Var_Length : array (1 .. N) of Entity_Id;
2956 -- Set to an entity of type Natural that contains the length of an
2957 -- operand whose length is not known at compile time. Entries in this
2958 -- array are set only if the corresponding entry in Is_Fixed_Length
46ff89f3 2959 -- is False. The entity is of type Artyp.
df46b832
AC		 2960
2961 Aggr_Length : array (0 .. N) of Node_Id;
fdac1f80
AC		 2962 -- The J'th entry in an expression node that represents the total length
2963 -- of operands 1 through J. It is either an integer literal node, or a
2964 -- reference to a constant entity with the right value, so it is fine
2965 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
46ff89f3 2966 -- entry always is set to zero. The length is of type Artyp.
df46b832
AC		 2967
2968 Low_Bound : Node_Id;
0ac73189
AC		 2969 -- A tree node representing the low bound of the result (of type Ityp).
2970 -- This is either an integer literal node, or an identifier reference to
2971 -- a constant entity initialized to the appropriate value.
2972
88a27b18
AC		 2973 Last_Opnd_Low_Bound : Node_Id;
2974 -- A tree node representing the low bound of the last operand. This
2975 -- need only be set if the result could be null. It is used for the
2976 -- special case of setting the right low bound for a null result.
2977 -- This is of type Ityp.
2978
a29262fd
AC		 2979 Last_Opnd_High_Bound : Node_Id;
2980 -- A tree node representing the high bound of the last operand. This
2981 -- need only be set if the result could be null. It is used for the
2982 -- special case of setting the right high bound for a null result.
2983 -- This is of type Ityp.
2984
0ac73189
AC		 2985 High_Bound : Node_Id;
2986 -- A tree node representing the high bound of the result (of type Ityp)
df46b832
AC		 2987
2988 Result : Node_Id;
0ac73189 2989 -- Result of the concatenation (of type Ityp)
df46b832 2990
d0f8d157 2991 Actions : constant List_Id := New_List;
4c9fe6c7 2992 -- Collect actions to be inserted
d0f8d157 2993
fa969310 2994 Known_Non_Null_Operand_Seen : Boolean;
308e6f3a 2995 -- Set True during generation of the assignments of operands into
fa969310
AC		 2996 -- result once an operand known to be non-null has been seen.
2997
2998 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2999 -- This function makes an N_Integer_Literal node that is returned in
3000 -- analyzed form with the type set to Artyp. Importantly this literal
3001 -- is not flagged as static, so that if we do computations with it that
3002 -- result in statically detected out of range conditions, we will not
3003 -- generate error messages but instead warning messages.
3004
46ff89f3 3005 function To_Artyp (X : Node_Id) return Node_Id;
fdac1f80 3006 -- Given a node of type Ityp, returns the corresponding value of type
76c597a1
AC		 3007 -- Artyp. For non-enumeration types, this is a plain integer conversion.
3008 -- For enum types, the Pos of the value is returned.
fdac1f80
AC		 3009
3010 function To_Ityp (X : Node_Id) return Node_Id;
0ac73189 3011 -- The inverse function (uses Val in the case of enumeration types)
fdac1f80 3012
fa969310
AC		 3013 ------------------------
3014 -- Make_Artyp_Literal --
3015 ------------------------
3016
3017 function Make_Artyp_Literal (Val : Nat) return Node_Id is
3018 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
3019 begin
3020 Set_Etype (Result, Artyp);
3021 Set_Analyzed (Result, True);
3022 Set_Is_Static_Expression (Result, False);
3023 return Result;
3024 end Make_Artyp_Literal;
76c597a1 3025
fdac1f80 3026 --------------
46ff89f3 3027 -- To_Artyp --
fdac1f80
AC		 3028 --------------
3029
46ff89f3 3030 function To_Artyp (X : Node_Id) return Node_Id is
fdac1f80 3031 begin
46ff89f3 3032 if Ityp = Base_Type (Artyp) then
fdac1f80
AC		 3033 return X;
3034
3035 elsif Is_Enumeration_Type (Ityp) then
3036 return
3037 Make_Attribute_Reference (Loc,
3038 Prefix => New_Occurrence_Of (Ityp, Loc),
3039 Attribute_Name => Name_Pos,
3040 Expressions => New_List (X));
3041
3042 else
46ff89f3 3043 return Convert_To (Artyp, X);
fdac1f80 3044 end if;
46ff89f3 3045 end To_Artyp;
fdac1f80
AC		 3046
3047 -------------
3048 -- To_Ityp --
3049 -------------
3050
3051 function To_Ityp (X : Node_Id) return Node_Id is
3052 begin
2fc05e3d 3053 if Is_Enumeration_Type (Ityp) then
fdac1f80
AC		 3054 return
3055 Make_Attribute_Reference (Loc,
3056 Prefix => New_Occurrence_Of (Ityp, Loc),
3057 Attribute_Name => Name_Val,
3058 Expressions => New_List (X));
3059
3060 -- Case where we will do a type conversion
3061
3062 else
76c597a1
AC		 3063 if Ityp = Base_Type (Artyp) then
3064 return X;
fdac1f80 3065 else
76c597a1 3066 return Convert_To (Ityp, X);
fdac1f80
AC		 3067 end if;
3068 end if;
3069 end To_Ityp;
3070
3071 -- Local Declarations
3072
00ba7be8
AC		 3073 Lib_Level_Target : constant Boolean :=
3074 Nkind (Parent (Cnode)) = N_Object_Declaration
3075 and then
3076 Is_Library_Level_Entity (Defining_Identifier (Parent (Cnode)));
3077
3078 -- If the concatenation declares a library level entity, we call the
3079 -- built-in concatenation routines to prevent code bloat, regardless
3080 -- of optimization level. This is space-efficient, and prevent linking
3081 -- problems when units are compiled with different optimizations.
3082
0ac73189
AC		 3083 Opnd_Typ : Entity_Id;
3084 Ent : Entity_Id;
3085 Len : Uint;
3086 J : Nat;
3087 Clen : Node_Id;
3088 Set : Boolean;
70482933 3089
f46faa08
AC		 3090 -- Start of processing for Expand_Concatenate
3091
70482933 3092 begin
fdac1f80
AC		 3093 -- Choose an appropriate computational type
3094
3095 -- We will be doing calculations of lengths and bounds in this routine
3096 -- and computing one from the other in some cases, e.g. getting the high
3097 -- bound by adding the length-1 to the low bound.
3098
3099 -- We can't just use the index type, or even its base type for this
3100 -- purpose for two reasons. First it might be an enumeration type which
308e6f3a
RW		 3101 -- is not suitable for computations of any kind, and second it may
3102 -- simply not have enough range. For example if the index type is
3103 -- -128..+127 then lengths can be up to 256, which is out of range of
3104 -- the type.
fdac1f80
AC		 3105
3106 -- For enumeration types, we can simply use Standard_Integer, this is
3107 -- sufficient since the actual number of enumeration literals cannot
3108 -- possibly exceed the range of integer (remember we will be doing the
0ac73189 3109 -- arithmetic with POS values, not representation values).
fdac1f80
AC		 3110
3111 if Is_Enumeration_Type (Ityp) then
46ff89f3 3112 Artyp := Standard_Integer;
fdac1f80 3113
59262ebb
AC		 3114 -- If index type is Positive, we use the standard unsigned type, to give
3115 -- more room on the top of the range, obviating the need for an overflow
3116 -- check when creating the upper bound. This is needed to avoid junk
3117 -- overflow checks in the common case of String types.
3118
3119 -- ??? Disabled for now
3120
3121 -- elsif Istyp = Standard_Positive then
3122 -- Artyp := Standard_Unsigned;
3123
2fc05e3d
AC		 3124 -- For modular types, we use a 32-bit modular type for types whose size
3125 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3126 -- identity type, and for larger unsigned types we use 64-bits.
fdac1f80 3127
2fc05e3d 3128 elsif Is_Modular_Integer_Type (Ityp) then
ecc4ddde 3129 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
46ff89f3 3130 Artyp := Standard_Unsigned;
ecc4ddde 3131 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
46ff89f3 3132 Artyp := Ityp;
fdac1f80 3133 else
46ff89f3 3134 Artyp := RTE (RE_Long_Long_Unsigned);
fdac1f80
AC		 3135 end if;
3136
2fc05e3d 3137 -- Similar treatment for signed types
fdac1f80
AC		 3138
3139 else
ecc4ddde 3140 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
46ff89f3 3141 Artyp := Standard_Integer;
ecc4ddde 3142 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
46ff89f3 3143 Artyp := Ityp;
fdac1f80 3144 else
46ff89f3 3145 Artyp := Standard_Long_Long_Integer;
fdac1f80
AC		 3146 end if;
3147 end if;
3148
fa969310
AC		 3149 -- Supply dummy entry at start of length array
3150
3151 Aggr_Length (0) := Make_Artyp_Literal (0);
3152
fdac1f80 3153 -- Go through operands setting up the above arrays
70482933 3154
df46b832
AC		 3155 J := 1;
3156 while J <= N loop
3157 Opnd := Remove_Head (Opnds);
0ac73189 3158 Opnd_Typ := Etype (Opnd);
fdac1f80
AC		 3159
3160 -- The parent got messed up when we put the operands in a list,
d347f572
AC		 3161 -- so now put back the proper parent for the saved operand, that
3162 -- is to say the concatenation node, to make sure that each operand
3163 -- is seen as a subexpression, e.g. if actions must be inserted.
fdac1f80 3164
d347f572 3165 Set_Parent (Opnd, Cnode);
fdac1f80
AC		 3166
3167 -- Set will be True when we have setup one entry in the array
3168
df46b832
AC		 3169 Set := False;
3170
fdac1f80 3171 -- Singleton element (or character literal) case
df46b832 3172
0ac73189 3173 if Base_Type (Opnd_Typ) = Ctyp then
df46b832
AC		 3174 NN := NN + 1;
3175 Operands (NN) := Opnd;
3176 Is_Fixed_Length (NN) := True;
3177 Fixed_Length (NN) := Uint_1;
0ac73189 3178 Result_May_Be_Null := False;
fdac1f80 3179
a29262fd
AC		 3180 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3181 -- since we know that the result cannot be null).
fdac1f80 3182
0ac73189
AC		 3183 Opnd_Low_Bound (NN) :=
3184 Make_Attribute_Reference (Loc,
e4494292 3185 Prefix => New_Occurrence_Of (Istyp, Loc),
0ac73189
AC		 3186 Attribute_Name => Name_First);
3187
df46b832
AC		 3188 Set := True;
3189
fdac1f80 3190 -- String literal case (can only occur for strings of course)
df46b832
AC		 3191
3192 elsif Nkind (Opnd) = N_String_Literal then
0ac73189 3193 Len := String_Literal_Length (Opnd_Typ);
df46b832 3194
a29262fd
AC		 3195 if Len /= 0 then
3196 Result_May_Be_Null := False;
3197 end if;
3198
88a27b18 3199 -- Capture last operand low and high bound if result could be null
a29262fd
AC		 3200
3201 if J = N and then Result_May_Be_Null then
88a27b18
AC		 3202 Last_Opnd_Low_Bound :=
3203 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3204
a29262fd 3205 Last_Opnd_High_Bound :=
88a27b18 3206 Make_Op_Subtract (Loc,
a29262fd
AC		 3207 Left_Opnd =>
3208 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
59262ebb 3209 Right_Opnd => Make_Integer_Literal (Loc, 1));
a29262fd
AC		 3210 end if;
3211
3212 -- Skip null string literal
fdac1f80 3213
0ac73189 3214 if J < N and then Len = 0 then
df46b832
AC		 3215 goto Continue;
3216 end if;
3217
3218 NN := NN + 1;
3219 Operands (NN) := Opnd;
3220 Is_Fixed_Length (NN) := True;
0ac73189
AC		 3221
3222 -- Set length and bounds
3223
df46b832 3224 Fixed_Length (NN) := Len;
0ac73189
AC		 3225
3226 Opnd_Low_Bound (NN) :=
3227 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3228
df46b832
AC		 3229 Set := True;
3230
3231 -- All other cases
3232
3233 else
3234 -- Check constrained case with known bounds
3235
0ac73189 3236 if Is_Constrained (Opnd_Typ) then
df46b832 3237 declare
df46b832
AC		 3238 Index : constant Node_Id := First_Index (Opnd_Typ);
3239 Indx_Typ : constant Entity_Id := Etype (Index);
3240 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3241 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3242
3243 begin
fdac1f80
AC		 3244 -- Fixed length constrained array type with known at compile
3245 -- time bounds is last case of fixed length operand.
df46b832
AC		 3246
3247 if Compile_Time_Known_Value (Lo)
3248 and then
3249 Compile_Time_Known_Value (Hi)
3250 then
3251 declare
3252 Loval : constant Uint := Expr_Value (Lo);
3253 Hival : constant Uint := Expr_Value (Hi);
3254 Len : constant Uint :=
3255 UI_Max (Hival - Loval + 1, Uint_0);
3256
3257 begin
0ac73189
AC		 3258 if Len > 0 then
3259 Result_May_Be_Null := False;
df46b832 3260 end if;
0ac73189 3261
88a27b18 3262 -- Capture last operand bounds if result could be null
a29262fd
AC		 3263
3264 if J = N and then Result_May_Be_Null then
88a27b18
AC		 3265 Last_Opnd_Low_Bound :=
3266 Convert_To (Ityp,
3267 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3268
a29262fd
AC		 3269 Last_Opnd_High_Bound :=
3270 Convert_To (Ityp,
39ade2f9 3271 Make_Integer_Literal (Loc, Expr_Value (Hi)));
a29262fd
AC		 3272 end if;
3273
3274 -- Exclude null length case unless last operand
0ac73189 3275
a29262fd 3276 if J < N and then Len = 0 then
0ac73189
AC		 3277 goto Continue;
3278 end if;
3279
3280 NN := NN + 1;
3281 Operands (NN) := Opnd;
3282 Is_Fixed_Length (NN) := True;
3283 Fixed_Length (NN) := Len;
3284
39ade2f9
AC		 3285 Opnd_Low_Bound (NN) :=
3286 To_Ityp
3287 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
0ac73189 3288 Set := True;
df46b832
AC		 3289 end;
3290 end if;
3291 end;
3292 end if;
3293
0ac73189
AC		 3294 -- All cases where the length is not known at compile time, or the
3295 -- special case of an operand which is known to be null but has a
3296 -- lower bound other than 1 or is other than a string type.
df46b832
AC		 3297
3298 if not Set then
3299 NN := NN + 1;
0ac73189
AC		 3300
3301 -- Capture operand bounds
3302
3303 Opnd_Low_Bound (NN) :=
3304 Make_Attribute_Reference (Loc,
3305 Prefix =>
3306 Duplicate_Subexpr (Opnd, Name_Req => True),
3307 Attribute_Name => Name_First);
3308
88a27b18
AC		 3309 -- Capture last operand bounds if result could be null
3310
a29262fd 3311 if J = N and Result_May_Be_Null then
88a27b18
AC		 3312 Last_Opnd_Low_Bound :=
3313 Convert_To (Ityp,
3314 Make_Attribute_Reference (Loc,
3315 Prefix =>
3316 Duplicate_Subexpr (Opnd, Name_Req => True),
3317 Attribute_Name => Name_First));
3318
a29262fd
AC		 3319 Last_Opnd_High_Bound :=
3320 Convert_To (Ityp,
3321 Make_Attribute_Reference (Loc,
3322 Prefix =>
3323 Duplicate_Subexpr (Opnd, Name_Req => True),
3324 Attribute_Name => Name_Last));
3325 end if;
0ac73189
AC		 3326
3327 -- Capture length of operand in entity
3328
df46b832
AC		 3329 Operands (NN) := Opnd;
3330 Is_Fixed_Length (NN) := False;
3331
191fcb3a 3332 Var_Length (NN) := Make_Temporary (Loc, 'L');
df46b832 3333
d0f8d157 3334 Append_To (Actions,
df46b832
AC		 3335 Make_Object_Declaration (Loc,
3336 Defining_Identifier => Var_Length (NN),
3337 Constant_Present => True,
39ade2f9 3338 Object_Definition => New_Occurrence_Of (Artyp, Loc),
df46b832
AC		 3339 Expression =>
3340 Make_Attribute_Reference (Loc,
3341 Prefix =>
3342 Duplicate_Subexpr (Opnd, Name_Req => True),
d0f8d157 3343 Attribute_Name => Name_Length)));
df46b832
AC		 3344 end if;
3345 end if;
3346
3347 -- Set next entry in aggregate length array
3348
3349 -- For first entry, make either integer literal for fixed length
0ac73189 3350 -- or a reference to the saved length for variable length.
df46b832
AC		 3351
3352 if NN = 1 then
3353 if Is_Fixed_Length (1) then
39ade2f9 3354 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
df46b832 3355 else
e4494292 3356 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
df46b832
AC		 3357 end if;
3358
3359 -- If entry is fixed length and only fixed lengths so far, make
3360 -- appropriate new integer literal adding new length.
3361
3362 elsif Is_Fixed_Length (NN)
3363 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3364 then
3365 Aggr_Length (NN) :=
3366 Make_Integer_Literal (Loc,
3367 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3368
d0f8d157
AC		 3369 -- All other cases, construct an addition node for the length and
3370 -- create an entity initialized to this length.
df46b832
AC		 3371
3372 else
191fcb3a 3373 Ent := Make_Temporary (Loc, 'L');
df46b832
AC		 3374
3375 if Is_Fixed_Length (NN) then
3376 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3377 else
e4494292 3378 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
df46b832
AC		 3379 end if;
3380
d0f8d157 3381 Append_To (Actions,
df46b832
AC		 3382 Make_Object_Declaration (Loc,
3383 Defining_Identifier => Ent,
3384 Constant_Present => True,
39ade2f9 3385 Object_Definition => New_Occurrence_Of (Artyp, Loc),
df46b832
AC		 3386 Expression =>
3387 Make_Op_Add (Loc,
3388 Left_Opnd => New_Copy (Aggr_Length (NN - 1)),
d0f8d157 3389 Right_Opnd => Clen)));
df46b832 3390
76c597a1 3391 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
df46b832
AC		 3392 end if;
3393
3394 <<Continue>>
3395 J := J + 1;
3396 end loop;
3397
a29262fd 3398 -- If we have only skipped null operands, return the last operand
df46b832
AC		 3399
3400 if NN = 0 then
a29262fd 3401 Result := Opnd;
df46b832
AC		 3402 goto Done;
3403 end if;
3404
3405 -- If we have only one non-null operand, return it and we are done.
3406 -- There is one case in which this cannot be done, and that is when
fdac1f80
AC		 3407 -- the sole operand is of the element type, in which case it must be
3408 -- converted to an array, and the easiest way of doing that is to go
df46b832
AC		 3409 -- through the normal general circuit.
3410
533369aa 3411 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
df46b832
AC		 3412 Result := Operands (1);
3413 goto Done;
3414 end if;
3415
3416 -- Cases where we have a real concatenation
3417
fdac1f80
AC		 3418 -- Next step is to find the low bound for the result array that we
3419 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3420
3421 -- If the ultimate ancestor of the index subtype is a constrained array
3422 -- definition, then the lower bound is that of the index subtype as
3423 -- specified by (RM 4.5.3(6)).
3424
3425 -- The right test here is to go to the root type, and then the ultimate
3426 -- ancestor is the first subtype of this root type.
3427
3428 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
0ac73189 3429 Low_Bound :=
fdac1f80
AC		 3430 Make_Attribute_Reference (Loc,
3431 Prefix =>
3432 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
0ac73189 3433 Attribute_Name => Name_First);
df46b832
AC		 3434
3435 -- If the first operand in the list has known length we know that
3436 -- the lower bound of the result is the lower bound of this operand.
3437
fdac1f80 3438 elsif Is_Fixed_Length (1) then
0ac73189 3439 Low_Bound := Opnd_Low_Bound (1);
df46b832
AC		 3440
3441 -- OK, we don't know the lower bound, we have to build a horrible
9b16cb57 3442 -- if expression node of the form
df46b832
AC		 3443
3444 -- if Cond1'Length /= 0 then
0ac73189 3445 -- Opnd1 low bound
df46b832
AC		 3446 -- else
3447 -- if Opnd2'Length /= 0 then
0ac73189 3448 -- Opnd2 low bound
df46b832
AC		 3449 -- else
3450 -- ...
3451
3452 -- The nesting ends either when we hit an operand whose length is known
3453 -- at compile time, or on reaching the last operand, whose low bound we
3454 -- take unconditionally whether or not it is null. It's easiest to do
3455 -- this with a recursive procedure:
3456
3457 else
3458 declare
3459 function Get_Known_Bound (J : Nat) return Node_Id;
3460 -- Returns the lower bound determined by operands J .. NN
3461
3462 ---------------------
3463 -- Get_Known_Bound --
3464 ---------------------
3465
3466 function Get_Known_Bound (J : Nat) return Node_Id is
df46b832 3467 begin
0ac73189
AC		 3468 if Is_Fixed_Length (J) or else J = NN then
3469 return New_Copy (Opnd_Low_Bound (J));
70482933
RK		 3470
3471 else
df46b832 3472 return
9b16cb57 3473 Make_If_Expression (Loc,
df46b832
AC		 3474 Expressions => New_List (
3475
3476 Make_Op_Ne (Loc,
e4494292
RD		 3477 Left_Opnd =>
3478 New_Occurrence_Of (Var_Length (J), Loc),
3479 Right_Opnd =>
3480 Make_Integer_Literal (Loc, 0)),
df46b832 3481
0ac73189 3482 New_Copy (Opnd_Low_Bound (J)),
df46b832 3483 Get_Known_Bound (J + 1)));
70482933 3484 end if;
df46b832 3485 end Get_Known_Bound;
70482933 3486
df46b832 3487 begin
191fcb3a 3488 Ent := Make_Temporary (Loc, 'L');
df46b832 3489
d0f8d157 3490 Append_To (Actions,
df46b832
AC		 3491 Make_Object_Declaration (Loc,
3492 Defining_Identifier => Ent,
3493 Constant_Present => True,
0ac73189 3494 Object_Definition => New_Occurrence_Of (Ityp, Loc),
d0f8d157 3495 Expression => Get_Known_Bound (1)));
df46b832 3496
e4494292 3497 Low_Bound := New_Occurrence_Of (Ent, Loc);
df46b832
AC		 3498 end;
3499 end if;
70482933 3500
76c597a1
AC		 3501 -- Now we can safely compute the upper bound, normally
3502 -- Low_Bound + Length - 1.
0ac73189
AC		 3503
3504 High_Bound :=
cc6f5d75
AC		 3505 To_Ityp
3506 (Make_Op_Add (Loc,
3507 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3508 Right_Opnd =>
3509 Make_Op_Subtract (Loc,
3510 Left_Opnd => New_Copy (Aggr_Length (NN)),
3511 Right_Opnd => Make_Artyp_Literal (1))));
0ac73189 3512
59262ebb 3513 -- Note that calculation of the high bound may cause overflow in some
bded454f
RD		 3514 -- very weird cases, so in the general case we need an overflow check on
3515 -- the high bound. We can avoid this for the common case of string types
3516 -- and other types whose index is Positive, since we chose a wider range
3517 -- for the arithmetic type.
76c597a1 3518
59262ebb
AC		 3519 if Istyp /= Standard_Positive then
3520 Activate_Overflow_Check (High_Bound);
3521 end if;
76c597a1
AC		 3522
3523 -- Handle the exceptional case where the result is null, in which case
a29262fd
AC		 3524 -- case the bounds come from the last operand (so that we get the proper
3525 -- bounds if the last operand is super-flat).
3526
0ac73189 3527 if Result_May_Be_Null then
88a27b18 3528 Low_Bound :=
9b16cb57 3529 Make_If_Expression (Loc,
88a27b18
AC		 3530 Expressions => New_List (
3531 Make_Op_Eq (Loc,
3532 Left_Opnd => New_Copy (Aggr_Length (NN)),
3533 Right_Opnd => Make_Artyp_Literal (0)),
3534 Last_Opnd_Low_Bound,
3535 Low_Bound));
3536
0ac73189 3537 High_Bound :=
9b16cb57 3538 Make_If_Expression (Loc,
0ac73189
AC		 3539 Expressions => New_List (
3540 Make_Op_Eq (Loc,
3541 Left_Opnd => New_Copy (Aggr_Length (NN)),
fa969310 3542 Right_Opnd => Make_Artyp_Literal (0)),
a29262fd 3543 Last_Opnd_High_Bound,
0ac73189
AC		 3544 High_Bound));
3545 end if;
3546
d0f8d157
AC		 3547 -- Here is where we insert the saved up actions
3548
3549 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3550
602a7ec0
AC		 3551 -- Now we construct an array object with appropriate bounds. We mark
3552 -- the target as internal to prevent useless initialization when
e526d0c7
AC		 3553 -- Initialize_Scalars is enabled. Also since this is the actual result
3554 -- entity, we make sure we have debug information for the result.
70482933 3555
191fcb3a 3556 Ent := Make_Temporary (Loc, 'S');
008f6fd3 3557 Set_Is_Internal (Ent);
e526d0c7 3558 Set_Needs_Debug_Info (Ent);
70482933 3559
76c597a1 3560 -- If the bound is statically known to be out of range, we do not want
fa969310
AC		 3561 -- to abort, we want a warning and a runtime constraint error. Note that
3562 -- we have arranged that the result will not be treated as a static
3563 -- constant, so we won't get an illegality during this insertion.
76c597a1 3564
df46b832
AC		 3565 Insert_Action (Cnode,
3566 Make_Object_Declaration (Loc,
3567 Defining_Identifier => Ent,
df46b832
AC		 3568 Object_Definition =>
3569 Make_Subtype_Indication (Loc,
fdac1f80 3570 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
df46b832
AC		 3571 Constraint =>
3572 Make_Index_Or_Discriminant_Constraint (Loc,
3573 Constraints => New_List (
3574 Make_Range (Loc,
0ac73189
AC		 3575 Low_Bound => Low_Bound,
3576 High_Bound => High_Bound))))),
df46b832
AC		 3577 Suppress => All_Checks);
3578
d1f453b7
RD		 3579 -- If the result of the concatenation appears as the initializing
3580 -- expression of an object declaration, we can just rename the
3581 -- result, rather than copying it.
3582
3583 Set_OK_To_Rename (Ent);
3584
76c597a1
AC		 3585 -- Catch the static out of range case now
3586
3587 if Raises_Constraint_Error (High_Bound) then
3588 raise Concatenation_Error;
3589 end if;
3590
df46b832
AC		 3591 -- Now we will generate the assignments to do the actual concatenation
3592
bded454f
RD		 3593 -- There is one case in which we will not do this, namely when all the
3594 -- following conditions are met:
3595
3596 -- The result type is Standard.String
3597
3598 -- There are nine or fewer retained (non-null) operands
3599
ffec8e81 3600 -- The optimization level is -O0
bded454f
RD		 3601
3602 -- The corresponding System.Concat_n.Str_Concat_n routine is
3603 -- available in the run time.
3604
3605 -- The debug flag gnatd.c is not set
3606
3607 -- If all these conditions are met then we generate a call to the
3608 -- relevant concatenation routine. The purpose of this is to avoid
3609 -- undesirable code bloat at -O0.
3610
3611 if Atyp = Standard_String
3612 and then NN in 2 .. 9
00ba7be8 3613 and then (Lib_Level_Target
62a64085 3614 or else ((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
cc6f5d75 3615 and then not Debug_Flag_Dot_C))
bded454f
RD		 3616 then
3617 declare
3618 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3619 (RE_Str_Concat_2,
3620 RE_Str_Concat_3,
3621 RE_Str_Concat_4,
3622 RE_Str_Concat_5,
3623 RE_Str_Concat_6,
3624 RE_Str_Concat_7,
3625 RE_Str_Concat_8,
3626 RE_Str_Concat_9);
3627
3628 begin
3629 if RTE_Available (RR (NN)) then
3630 declare
3631 Opnds : constant List_Id :=
3632 New_List (New_Occurrence_Of (Ent, Loc));
3633
3634 begin
3635 for J in 1 .. NN loop
3636 if Is_List_Member (Operands (J)) then
3637 Remove (Operands (J));
3638 end if;
3639
3640 if Base_Type (Etype (Operands (J))) = Ctyp then
3641 Append_To (Opnds,
3642 Make_Aggregate (Loc,
3643 Component_Associations => New_List (
3644 Make_Component_Association (Loc,
3645 Choices => New_List (
3646 Make_Integer_Literal (Loc, 1)),
3647 Expression => Operands (J)))));
3648
3649 else
3650 Append_To (Opnds, Operands (J));
3651 end if;
3652 end loop;
3653
3654 Insert_Action (Cnode,
3655 Make_Procedure_Call_Statement (Loc,
e4494292 3656 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
bded454f
RD		 3657 Parameter_Associations => Opnds));
3658
e4494292 3659 Result := New_Occurrence_Of (Ent, Loc);
bded454f
RD		 3660 goto Done;
3661 end;
3662 end if;
3663 end;
3664 end if;
3665
3666 -- Not special case so generate the assignments
3667
76c597a1
AC		 3668 Known_Non_Null_Operand_Seen := False;
3669
df46b832
AC		 3670 for J in 1 .. NN loop
3671 declare
3672 Lo : constant Node_Id :=
3673 Make_Op_Add (Loc,
46ff89f3 3674 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
df46b832
AC		 3675 Right_Opnd => Aggr_Length (J - 1));
3676
3677 Hi : constant Node_Id :=
3678 Make_Op_Add (Loc,
46ff89f3 3679 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
df46b832
AC		 3680 Right_Opnd =>
3681 Make_Op_Subtract (Loc,
3682 Left_Opnd => Aggr_Length (J),
fa969310 3683 Right_Opnd => Make_Artyp_Literal (1)));
70482933 3684
df46b832 3685 begin
fdac1f80
AC		 3686 -- Singleton case, simple assignment
3687
3688 if Base_Type (Etype (Operands (J))) = Ctyp then
76c597a1 3689 Known_Non_Null_Operand_Seen := True;
df46b832
AC		 3690 Insert_Action (Cnode,
3691 Make_Assignment_Statement (Loc,
3692 Name =>
3693 Make_Indexed_Component (Loc,
3694 Prefix => New_Occurrence_Of (Ent, Loc),
fdac1f80 3695 Expressions => New_List (To_Ityp (Lo))),
df46b832
AC		 3696 Expression => Operands (J)),
3697 Suppress => All_Checks);
70482933 3698
76c597a1
AC		 3699 -- Array case, slice assignment, skipped when argument is fixed
3700 -- length and known to be null.
fdac1f80 3701
76c597a1
AC		 3702 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3703 declare
3704 Assign : Node_Id :=
3705 Make_Assignment_Statement (Loc,
3706 Name =>
3707 Make_Slice (Loc,
3708 Prefix =>
3709 New_Occurrence_Of (Ent, Loc),
3710 Discrete_Range =>
3711 Make_Range (Loc,
3712 Low_Bound => To_Ityp (Lo),
3713 High_Bound => To_Ityp (Hi))),
3714 Expression => Operands (J));
3715 begin
3716 if Is_Fixed_Length (J) then
3717 Known_Non_Null_Operand_Seen := True;
3718
3719 elsif not Known_Non_Null_Operand_Seen then
3720
3721 -- Here if operand length is not statically known and no
3722 -- operand known to be non-null has been processed yet.
3723 -- If operand length is 0, we do not need to perform the
3724 -- assignment, and we must avoid the evaluation of the
3725 -- high bound of the slice, since it may underflow if the
3726 -- low bound is Ityp'First.
3727
3728 Assign :=
3729 Make_Implicit_If_Statement (Cnode,
39ade2f9 3730 Condition =>
76c597a1 3731 Make_Op_Ne (Loc,
39ade2f9 3732 Left_Opnd =>
76c597a1
AC		 3733 New_Occurrence_Of (Var_Length (J), Loc),
3734 Right_Opnd => Make_Integer_Literal (Loc, 0)),
39ade2f9 3735 Then_Statements => New_List (Assign));
76c597a1 3736 end if;
fa969310 3737
76c597a1
AC		 3738 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3739 end;
df46b832
AC		 3740 end if;
3741 end;
3742 end loop;
70482933 3743
0ac73189
AC		 3744 -- Finally we build the result, which is a reference to the array object
3745
e4494292 3746 Result := New_Occurrence_Of (Ent, Loc);
70482933 3747
df46b832
AC		 3748 <<Done>>
3749 Rewrite (Cnode, Result);
fdac1f80
AC		 3750 Analyze_And_Resolve (Cnode, Atyp);
3751
3752 exception
3753 when Concatenation_Error =>
76c597a1
AC		 3754
3755 -- Kill warning generated for the declaration of the static out of
3756 -- range high bound, and instead generate a Constraint_Error with
3757 -- an appropriate specific message.
3758
3759 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3760 Apply_Compile_Time_Constraint_Error
3761 (N => Cnode,
324ac540 3762 Msg => "concatenation result upper bound out of range??",
76c597a1 3763 Reason => CE_Range_Check_Failed);
fdac1f80 3764 end Expand_Concatenate;
70482933 3765
f6194278
RD		 3766 ---------------------------------------------------
3767 -- Expand_Membership_Minimize_Eliminate_Overflow --
3768 ---------------------------------------------------
3769
3770 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3771 pragma Assert (Nkind (N) = N_In);
3772 -- Despite the name, this routine applies only to N_In, not to
3773 -- N_Not_In. The latter is always rewritten as not (X in Y).
3774
71fb4dc8
AC		 3775 Result_Type : constant Entity_Id := Etype (N);
3776 -- Capture result type, may be a derived boolean type
3777
b6b5cca8
AC		 3778 Loc : constant Source_Ptr := Sloc (N);
3779 Lop : constant Node_Id := Left_Opnd (N);
3780 Rop : constant Node_Id := Right_Opnd (N);
3781
3782 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3783 -- is thus tempting to capture these values, but due to the rewrites
3784 -- that occur as a result of overflow checking, these values change
3785 -- as we go along, and it is safe just to always use Etype explicitly.
f6194278
RD		 3786
3787 Restype : constant Entity_Id := Etype (N);
3788 -- Save result type
3789
3790 Lo, Hi : Uint;
d8192289 3791 -- Bounds in Minimize calls, not used currently
f6194278
RD		 3792
3793 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3794 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3795
3796 begin
a7f1b24f 3797 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
f6194278
RD		 3798
3799 -- If right operand is a subtype name, and the subtype name has no
3800 -- predicate, then we can just replace the right operand with an
3801 -- explicit range T'First .. T'Last, and use the explicit range code.
3802
b6b5cca8
AC		 3803 if Nkind (Rop) /= N_Range
3804 and then No (Predicate_Function (Etype (Rop)))
3805 then
3806 declare
3807 Rtyp : constant Entity_Id := Etype (Rop);
3808 begin
3809 Rewrite (Rop,
3810 Make_Range (Loc,
cc6f5d75 3811 Low_Bound =>
b6b5cca8
AC		 3812 Make_Attribute_Reference (Loc,
3813 Attribute_Name => Name_First,
e4494292 3814 Prefix => New_Occurrence_Of (Rtyp, Loc)),
b6b5cca8
AC		 3815 High_Bound =>
3816 Make_Attribute_Reference (Loc,
3817 Attribute_Name => Name_Last,
e4494292 3818 Prefix => New_Occurrence_Of (Rtyp, Loc))));
b6b5cca8
AC		 3819 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3820 end;
f6194278
RD		 3821 end if;
3822
3823 -- Here for the explicit range case. Note that the bounds of the range
3824 -- have not been processed for minimized or eliminated checks.
3825
3826 if Nkind (Rop) = N_Range then
a7f1b24f 3827 Minimize_Eliminate_Overflows
b6b5cca8 3828 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
a7f1b24f 3829 Minimize_Eliminate_Overflows
c7e152b5 3830 (High_Bound (Rop), Lo, Hi, Top_Level => False);
f6194278
RD		 3831
3832 -- We have A in B .. C, treated as A >= B and then A <= C
3833
3834 -- Bignum case
3835
b6b5cca8 3836 if Is_RTE (Etype (Lop), RE_Bignum)
f6194278
RD		 3837 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3838 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3839 then
3840 declare
3841 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3842 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
71fb4dc8
AC		 3843 L : constant Entity_Id :=
3844 Make_Defining_Identifier (Loc, Name_uL);
f6194278
RD		 3845 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3846 Lbound : constant Node_Id :=
3847 Convert_To_Bignum (Low_Bound (Rop));
3848 Hbound : constant Node_Id :=
3849 Convert_To_Bignum (High_Bound (Rop));
3850
71fb4dc8
AC		 3851 -- Now we rewrite the membership test node to look like
3852
3853 -- do
3854 -- Bnn : Result_Type;
3855 -- declare
3856 -- M : Mark_Id := SS_Mark;
3857 -- L : Bignum := Lopnd;
3858 -- begin
3859 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3860 -- SS_Release (M);
3861 -- end;
3862 -- in
3863 -- Bnn
3864 -- end
f6194278
RD		 3865
3866 begin
71fb4dc8
AC		 3867 -- Insert declaration of L into declarations of bignum block
3868
f6194278
RD		 3869 Insert_After
3870 (Last (Declarations (Blk)),
3871 Make_Object_Declaration (Loc,
71fb4dc8 3872 Defining_Identifier => L,
f6194278
RD		 3873 Object_Definition =>
3874 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3875 Expression => Lopnd));
3876
71fb4dc8
AC		 3877 -- Insert assignment to Bnn into expressions of bignum block
3878
f6194278
RD		 3879 Insert_Before
3880 (First (Statements (Handled_Statement_Sequence (Blk))),
3881 Make_Assignment_Statement (Loc,
3882 Name => New_Occurrence_Of (Bnn, Loc),
3883 Expression =>
3884 Make_And_Then (Loc,
cc6f5d75 3885 Left_Opnd =>
f6194278
RD		 3886 Make_Function_Call (Loc,
3887 Name =>
3888 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
71fb4dc8
AC		 3889 Parameter_Associations => New_List (
3890 New_Occurrence_Of (L, Loc),
3891 Lbound)),
cc6f5d75 3892
f6194278
RD		 3893 Right_Opnd =>
3894 Make_Function_Call (Loc,
3895 Name =>
71fb4dc8
AC		 3896 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3897 Parameter_Associations => New_List (
3898 New_Occurrence_Of (L, Loc),
3899 Hbound)))));
f6194278 3900
71fb4dc8 3901 -- Now rewrite the node
f6194278 3902
71fb4dc8
AC		 3903 Rewrite (N,
3904 Make_Expression_With_Actions (Loc,
3905 Actions => New_List (
3906 Make_Object_Declaration (Loc,
3907 Defining_Identifier => Bnn,
3908 Object_Definition =>
3909 New_Occurrence_Of (Result_Type, Loc)),
3910 Blk),
3911 Expression => New_Occurrence_Of (Bnn, Loc)));
3912 Analyze_And_Resolve (N, Result_Type);
f6194278
RD		 3913 return;
3914 end;
3915
3916 -- Here if no bignums around
3917
3918 else
3919 -- Case where types are all the same
3920
b6b5cca8 3921 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
f6194278 3922 and then
b6b5cca8 3923 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
f6194278
RD		 3924 then
3925 null;
3926
3927 -- If types are not all the same, it means that we have rewritten
3928 -- at least one of them to be of type Long_Long_Integer, and we
3929 -- will convert the other operands to Long_Long_Integer.
3930
3931 else
3932 Convert_To_And_Rewrite (LLIB, Lop);
71fb4dc8
AC		 3933 Set_Analyzed (Lop, False);
3934 Analyze_And_Resolve (Lop, LLIB);
3935
3936 -- For the right operand, avoid unnecessary recursion into
3937 -- this routine, we know that overflow is not possible.
f6194278
RD		 3938
3939 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3940 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3941 Set_Analyzed (Rop, False);
71fb4dc8 3942 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
f6194278
RD		 3943 end if;
3944
3945 -- Now the three operands are of the same signed integer type,
b6b5cca8
AC		 3946 -- so we can use the normal expansion routine for membership,
3947 -- setting the flag to prevent recursion into this procedure.
f6194278
RD		 3948
3949 Set_No_Minimize_Eliminate (N);
3950 Expand_N_In (N);
3951 end if;
3952
3953 -- Right operand is a subtype name and the subtype has a predicate. We
f6636994
AC		 3954 -- have to make sure the predicate is checked, and for that we need to
3955 -- use the standard N_In circuitry with appropriate types.
f6194278
RD		 3956
3957 else
b6b5cca8 3958 pragma Assert (Present (Predicate_Function (Etype (Rop))));
f6194278
RD		 3959
3960 -- If types are "right", just call Expand_N_In preventing recursion
3961
b6b5cca8 3962 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
f6194278
RD		 3963 Set_No_Minimize_Eliminate (N);
3964 Expand_N_In (N);
3965
3966 -- Bignum case
3967
b6b5cca8 3968 elsif Is_RTE (Etype (Lop), RE_Bignum) then
f6194278 3969
71fb4dc8 3970 -- For X in T, we want to rewrite our node as
f6194278 3971
71fb4dc8
AC		 3972 -- do
3973 -- Bnn : Result_Type;
f6194278 3974
71fb4dc8
AC		 3975 -- declare
3976 -- M : Mark_Id := SS_Mark;
3977 -- Lnn : Long_Long_Integer'Base
3978 -- Nnn : Bignum;
f6194278 3979
71fb4dc8
AC		 3980 -- begin
3981 -- Nnn := X;
3982
3983 -- if not Bignum_In_LLI_Range (Nnn) then
3984 -- Bnn := False;
3985 -- else
3986 -- Lnn := From_Bignum (Nnn);
3987 -- Bnn :=
3988 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3989 -- and then T'Base (Lnn) in T;
3990 -- end if;
cc6f5d75
AC		 3991
3992 -- SS_Release (M);
71fb4dc8
AC		 3993 -- end
3994 -- in
3995 -- Bnn
3996 -- end
f6194278 3997
f6636994 3998 -- A bit gruesome, but there doesn't seem to be a simpler way
f6194278
RD		 3999
4000 declare
b6b5cca8
AC		 4001 Blk : constant Node_Id := Make_Bignum_Block (Loc);
4002 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
4003 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
4004 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
71fb4dc8
AC		 4005 T : constant Entity_Id := Etype (Rop);
4006 TB : constant Entity_Id := Base_Type (T);
b6b5cca8 4007 Nin : Node_Id;
f6194278
RD		 4008
4009 begin
71fb4dc8 4010 -- Mark the last membership operation to prevent recursion
f6194278
RD		 4011
4012 Nin :=
4013 Make_In (Loc,
f6636994
AC		 4014 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
4015 Right_Opnd => New_Occurrence_Of (T, Loc));
f6194278
RD		 4016 Set_No_Minimize_Eliminate (Nin);
4017
4018 -- Now decorate the block
4019
4020 Insert_After
4021 (Last (Declarations (Blk)),
4022 Make_Object_Declaration (Loc,
4023 Defining_Identifier => Lnn,
4024 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
4025
4026 Insert_After
4027 (Last (Declarations (Blk)),
4028 Make_Object_Declaration (Loc,
4029 Defining_Identifier => Nnn,
4030 Object_Definition =>
4031 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
4032
4033 Insert_List_Before
4034 (First (Statements (Handled_Statement_Sequence (Blk))),
4035 New_List (
4036 Make_Assignment_Statement (Loc,
4037 Name => New_Occurrence_Of (Nnn, Loc),
4038 Expression => Relocate_Node (Lop)),
4039
8b1011c0 4040 Make_Implicit_If_Statement (N,
f6194278 4041 Condition =>
71fb4dc8
AC		 4042 Make_Op_Not (Loc,
4043 Right_Opnd =>
4044 Make_Function_Call (Loc,
4045 Name =>
4046 New_Occurrence_Of
4047 (RTE (RE_Bignum_In_LLI_Range), Loc),
4048 Parameter_Associations => New_List (
4049 New_Occurrence_Of (Nnn, Loc)))),
f6194278
RD		 4050
4051 Then_Statements => New_List (
4052 Make_Assignment_Statement (Loc,
4053 Name => New_Occurrence_Of (Bnn, Loc),
4054 Expression =>
4055 New_Occurrence_Of (Standard_False, Loc))),
4056
4057 Else_Statements => New_List (
4058 Make_Assignment_Statement (Loc,
4059 Name => New_Occurrence_Of (Lnn, Loc),
4060 Expression =>
4061 Make_Function_Call (Loc,
4062 Name =>
4063 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4064 Parameter_Associations => New_List (
4065 New_Occurrence_Of (Nnn, Loc)))),
4066
4067 Make_Assignment_Statement (Loc,
71fb4dc8 4068 Name => New_Occurrence_Of (Bnn, Loc),
f6194278
RD		 4069 Expression =>
4070 Make_And_Then (Loc,
71fb4dc8 4071 Left_Opnd =>
f6194278 4072 Make_In (Loc,
71fb4dc8 4073 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
f6194278 4074 Right_Opnd =>
71fb4dc8
AC		 4075 Make_Range (Loc,
4076 Low_Bound =>
4077 Convert_To (LLIB,
4078 Make_Attribute_Reference (Loc,
4079 Attribute_Name => Name_First,
4080 Prefix =>
4081 New_Occurrence_Of (TB, Loc))),
4082
4083 High_Bound =>
4084 Convert_To (LLIB,
4085 Make_Attribute_Reference (Loc,
4086 Attribute_Name => Name_Last,
4087 Prefix =>
4088 New_Occurrence_Of (TB, Loc))))),
4089
f6194278
RD		 4090 Right_Opnd => Nin))))));
4091
71fb4dc8 4092 -- Now we can do the rewrite
f6194278 4093
71fb4dc8
AC		 4094 Rewrite (N,
4095 Make_Expression_With_Actions (Loc,
4096 Actions => New_List (
4097 Make_Object_Declaration (Loc,
4098 Defining_Identifier => Bnn,
4099 Object_Definition =>
4100 New_Occurrence_Of (Result_Type, Loc)),
4101 Blk),
4102 Expression => New_Occurrence_Of (Bnn, Loc)));
4103 Analyze_And_Resolve (N, Result_Type);
f6194278
RD		 4104 return;
4105 end;
4106
4107 -- Not bignum case, but types don't match (this means we rewrote the
b6b5cca8 4108 -- left operand to be Long_Long_Integer).
f6194278
RD		 4109
4110 else
b6b5cca8 4111 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
f6194278 4112
71fb4dc8
AC		 4113 -- We rewrite the membership test as (where T is the type with
4114 -- the predicate, i.e. the type of the right operand)
f6194278 4115
71fb4dc8
AC		 4116 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4117 -- and then T'Base (Lop) in T
f6194278
RD		 4118
4119 declare
71fb4dc8
AC		 4120 T : constant Entity_Id := Etype (Rop);
4121 TB : constant Entity_Id := Base_Type (T);
f6194278
RD		 4122 Nin : Node_Id;
4123
4124 begin
4125 -- The last membership test is marked to prevent recursion
4126
4127 Nin :=
4128 Make_In (Loc,
71fb4dc8
AC		 4129 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
4130 Right_Opnd => New_Occurrence_Of (T, Loc));
f6194278
RD		 4131 Set_No_Minimize_Eliminate (Nin);
4132
4133 -- Now do the rewrite
4134
4135 Rewrite (N,
4136 Make_And_Then (Loc,
71fb4dc8 4137 Left_Opnd =>
f6194278
RD		 4138 Make_In (Loc,
4139 Left_Opnd => Lop,
4140 Right_Opnd =>
71fb4dc8
AC		 4141 Make_Range (Loc,
4142 Low_Bound =>
4143 Convert_To (LLIB,
4144 Make_Attribute_Reference (Loc,
4145 Attribute_Name => Name_First,
cc6f5d75
AC		 4146 Prefix =>
4147 New_Occurrence_Of (TB, Loc))),
71fb4dc8
AC		 4148 High_Bound =>
4149 Convert_To (LLIB,
4150 Make_Attribute_Reference (Loc,
4151 Attribute_Name => Name_Last,
cc6f5d75
AC		 4152 Prefix =>
4153 New_Occurrence_Of (TB, Loc))))),
f6194278 4154 Right_Opnd => Nin));
71fb4dc8
AC		 4155 Set_Analyzed (N, False);
4156 Analyze_And_Resolve (N, Restype);
f6194278
RD		 4157 end;
4158 end if;
4159 end if;
4160 end Expand_Membership_Minimize_Eliminate_Overflow;
4161
70482933
RK		 4162 ------------------------
4163 -- Expand_N_Allocator --
4164 ------------------------
4165
4166 procedure Expand_N_Allocator (N : Node_Id) is
8b1011c0
AC		 4167 Etyp : constant Entity_Id := Etype (Expression (N));
4168 Loc : constant Source_Ptr := Sloc (N);
4169 PtrT : constant Entity_Id := Etype (N);
70482933 4170
26bff3d9
JM		 4171 procedure Rewrite_Coextension (N : Node_Id);
4172 -- Static coextensions have the same lifetime as the entity they
8fc789c8 4173 -- constrain. Such occurrences can be rewritten as aliased objects
26bff3d9 4174 -- and their unrestricted access used instead of the coextension.
0669bebe 4175
8aec446b 4176 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
507ed3fd
AC		 4177 -- Given a constrained array type E, returns a node representing the
4178 -- code to compute the size in storage elements for the given type.
205c14b0 4179 -- This is done without using the attribute (which malfunctions for
507ed3fd 4180 -- large sizes ???)
8aec446b 4181
26bff3d9
JM		 4182 -------------------------
4183 -- Rewrite_Coextension --
4184 -------------------------
4185
4186 procedure Rewrite_Coextension (N : Node_Id) is
e5a22243
AC		 4187 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4188 Temp_Decl : Node_Id;
26bff3d9 4189
df3e68b1 4190 begin
26bff3d9
JM		 4191 -- Generate:
4192 -- Cnn : aliased Etyp;
4193
df3e68b1
HK		 4194 Temp_Decl :=
4195 Make_Object_Declaration (Loc,
4196 Defining_Identifier => Temp_Id,
243cae0a
AC		 4197 Aliased_Present => True,
4198 Object_Definition => New_Occurrence_Of (Etyp, Loc));
26bff3d9 4199
26bff3d9 4200 if Nkind (Expression (N)) = N_Qualified_Expression then
df3e68b1 4201 Set_Expression (Temp_Decl, Expression (Expression (N)));
0669bebe 4202 end if;
26bff3d9 4203
e5a22243 4204 Insert_Action (N, Temp_Decl);
26bff3d9
JM		 4205 Rewrite (N,
4206 Make_Attribute_Reference (Loc,
243cae0a 4207 Prefix => New_Occurrence_Of (Temp_Id, Loc),
26bff3d9
JM		 4208 Attribute_Name => Name_Unrestricted_Access));
4209
4210 Analyze_And_Resolve (N, PtrT);
4211 end Rewrite_Coextension;
0669bebe 4212
8aec446b
AC		 4213 ------------------------------
4214 -- Size_In_Storage_Elements --
4215 ------------------------------
4216
4217 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4218 begin
4219 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4220 -- However, the reason for the existence of this function is
4221 -- to construct a test for sizes too large, which means near the
4222 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4223 -- is that we get overflows when sizes are greater than 2**31.
4224
507ed3fd 4225 -- So what we end up doing for array types is to use the expression:
8aec446b
AC		 4226
4227 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4228
46202729 4229 -- which avoids this problem. All this is a bit bogus, but it does
8aec446b
AC		 4230 -- mean we catch common cases of trying to allocate arrays that
4231 -- are too large, and which in the absence of a check results in
4232 -- undetected chaos ???
4233
ce532f42
AC		 4234 -- Note in particular that this is a pessimistic estimate in the
4235 -- case of packed array types, where an array element might occupy
4236 -- just a fraction of a storage element???
4237
507ed3fd
AC		 4238 declare
4239 Len : Node_Id;
4240 Res : Node_Id;
8aec446b 4241
507ed3fd
AC		 4242 begin
4243 for J in 1 .. Number_Dimensions (E) loop
4244 Len :=
4245 Make_Attribute_Reference (Loc,
4246 Prefix => New_Occurrence_Of (E, Loc),
4247 Attribute_Name => Name_Length,
243cae0a 4248 Expressions => New_List (Make_Integer_Literal (Loc, J)));
8aec446b 4249
507ed3fd
AC		 4250 if J = 1 then
4251 Res := Len;
8aec446b 4252
507ed3fd
AC		 4253 else
4254 Res :=
4255 Make_Op_Multiply (Loc,
4256 Left_Opnd => Res,
4257 Right_Opnd => Len);
4258 end if;
4259 end loop;
8aec446b 4260
8aec446b 4261 return
507ed3fd
AC		 4262 Make_Op_Multiply (Loc,
4263 Left_Opnd => Len,
4264 Right_Opnd =>
4265 Make_Attribute_Reference (Loc,
4266 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4267 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4268 end;
8aec446b
AC		 4269 end Size_In_Storage_Elements;
4270
8b1011c0
AC		 4271 -- Local variables
4272
70861157 4273 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
8b1011c0
AC		 4274 Desig : Entity_Id;
4275 Nod : Node_Id;
4276 Pool : Entity_Id;
4277 Rel_Typ : Entity_Id;
4278 Temp : Entity_Id;
4279
0669bebe
GB		 4280 -- Start of processing for Expand_N_Allocator
4281
70482933
RK		 4282 begin
4283 -- RM E.2.3(22). We enforce that the expected type of an allocator
4284 -- shall not be a remote access-to-class-wide-limited-private type
4285
4286 -- Why is this being done at expansion time, seems clearly wrong ???
4287
4288 Validate_Remote_Access_To_Class_Wide_Type (N);
4289
ca5af305
AC		 4290 -- Processing for anonymous access-to-controlled types. These access
4291 -- types receive a special finalization master which appears in the
4292 -- declarations of the enclosing semantic unit. This expansion is done
84f4072a
JM		 4293 -- now to ensure that any additional types generated by this routine or
4294 -- Expand_Allocator_Expression inherit the proper type attributes.
ca5af305 4295
84f4072a 4296 if (Ekind (PtrT) = E_Anonymous_Access_Type
533369aa 4297 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
ca5af305
AC		 4298 and then Needs_Finalization (Dtyp)
4299 then
8b1011c0
AC		 4300 -- Detect the allocation of an anonymous controlled object where the
4301 -- type of the context is named. For example:
4302
4303 -- procedure Proc (Ptr : Named_Access_Typ);
4304 -- Proc (new Designated_Typ);
4305
4306 -- Regardless of the anonymous-to-named access type conversion, the
4307 -- lifetime of the object must be associated with the named access
0088ba92 4308 -- type. Use the finalization-related attributes of this type.
8b1011c0
AC		 4309
4310 if Nkind_In (Parent (N), N_Type_Conversion,
4311 N_Unchecked_Type_Conversion)
4312 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4313 E_Access_Type,
4314 E_General_Access_Type)
4315 then
4316 Rel_Typ := Etype (Parent (N));
4317 else
4318 Rel_Typ := Empty;
4319 end if;
4320
b254da66
AC		 4321 -- Anonymous access-to-controlled types allocate on the global pool.
4322 -- Do not set this attribute on .NET/JVM since those targets do not
24d4b3d5 4323 -- support pools. Note that this is a "root type only" attribute.
ca5af305 4324
bde73c6b 4325 if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
8b1011c0 4326 if Present (Rel_Typ) then
7a5b62b0 4327 Set_Associated_Storage_Pool
24d4b3d5 4328 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
8b1011c0 4329 else
7a5b62b0 4330 Set_Associated_Storage_Pool
24d4b3d5 4331 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
8b1011c0 4332 end if;
ca5af305
AC		 4333 end if;
4334
4335 -- The finalization master must be inserted and analyzed as part of
5114f3ff 4336 -- the current semantic unit. Note that the master is updated when
24d4b3d5
AC		 4337 -- analysis changes current units. Note that this is a "root type
4338 -- only" attribute.
ca5af305 4339
5114f3ff 4340 if Present (Rel_Typ) then
24d4b3d5
AC		 4341 Set_Finalization_Master
4342 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
5114f3ff 4343 else
24d4b3d5
AC		 4344 Set_Finalization_Master
4345 (Root_Type (PtrT), Current_Anonymous_Master);
ca5af305
AC		 4346 end if;
4347 end if;
4348
4349 -- Set the storage pool and find the appropriate version of Allocate to
8417f4b2
AC		 4350 -- call. Do not overwrite the storage pool if it is already set, which
4351 -- can happen for build-in-place function returns (see
200b7162 4352 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
70482933 4353
200b7162
BD		 4354 if No (Storage_Pool (N)) then
4355 Pool := Associated_Storage_Pool (Root_Type (PtrT));
70482933 4356
200b7162
BD		 4357 if Present (Pool) then
4358 Set_Storage_Pool (N, Pool);
fbf5a39b 4359
200b7162
BD		 4360 if Is_RTE (Pool, RE_SS_Pool) then
4361 if VM_Target = No_VM then
4362 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4363 end if;
fbf5a39b 4364
a8551b5f
AC		 4365 -- In the case of an allocator for a simple storage pool, locate
4366 -- and save a reference to the pool type's Allocate routine.
4367
4368 elsif Present (Get_Rep_Pragma
f6205414 4369 (Etype (Pool), Name_Simple_Storage_Pool_Type))
a8551b5f
AC		 4370 then
4371 declare
a8551b5f 4372 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
260359e3 4373 Alloc_Op : Entity_Id;
a8551b5f 4374 begin
260359e3 4375 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
a8551b5f
AC		 4376 while Present (Alloc_Op) loop
4377 if Scope (Alloc_Op) = Scope (Pool_Type)
4378 and then Present (First_Formal (Alloc_Op))
4379 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4380 then
4381 Set_Procedure_To_Call (N, Alloc_Op);
a8551b5f 4382 exit;
260359e3
AC		 4383 else
4384 Alloc_Op := Homonym (Alloc_Op);
a8551b5f 4385 end if;
a8551b5f
AC		 4386 end loop;
4387 end;
4388
200b7162
BD		 4389 elsif Is_Class_Wide_Type (Etype (Pool)) then
4390 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4391
4392 else
4393 Set_Procedure_To_Call (N,
4394 Find_Prim_Op (Etype (Pool), Name_Allocate));
4395 end if;
70482933
RK		 4396 end if;
4397 end if;
4398
685094bf
RD		 4399 -- Under certain circumstances we can replace an allocator by an access
4400 -- to statically allocated storage. The conditions, as noted in AARM
4401 -- 3.10 (10c) are as follows:
70482933
RK		 4402
4403 -- Size and initial value is known at compile time
4404 -- Access type is access-to-constant
4405
fbf5a39b
AC		 4406 -- The allocator is not part of a constraint on a record component,
4407 -- because in that case the inserted actions are delayed until the
4408 -- record declaration is fully analyzed, which is too late for the
4409 -- analysis of the rewritten allocator.
4410
70482933
RK		 4411 if Is_Access_Constant (PtrT)
4412 and then Nkind (Expression (N)) = N_Qualified_Expression
4413 and then Compile_Time_Known_Value (Expression (Expression (N)))
243cae0a
AC		 4414 and then Size_Known_At_Compile_Time
4415 (Etype (Expression (Expression (N))))
fbf5a39b 4416 and then not Is_Record_Type (Current_Scope)
70482933
RK		 4417 then
4418 -- Here we can do the optimization. For the allocator
4419
4420 -- new x'(y)
4421
4422 -- We insert an object declaration
4423
4424 -- Tnn : aliased x := y;
4425
685094bf
RD		 4426 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4427 -- marked as requiring static allocation.
70482933 4428
df3e68b1 4429 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
70482933
RK		 4430 Desig := Subtype_Mark (Expression (N));
4431
4432 -- If context is constrained, use constrained subtype directly,
8fc789c8 4433 -- so that the constant is not labelled as having a nominally
70482933
RK		 4434 -- unconstrained subtype.
4435
0da2c8ac
AC		 4436 if Entity (Desig) = Base_Type (Dtyp) then
4437 Desig := New_Occurrence_Of (Dtyp, Loc);
70482933
RK		 4438 end if;
4439
4440 Insert_Action (N,
4441 Make_Object_Declaration (Loc,
4442 Defining_Identifier => Temp,
4443 Aliased_Present => True,
4444 Constant_Present => Is_Access_Constant (PtrT),
4445 Object_Definition => Desig,
4446 Expression => Expression (Expression (N))));
4447
4448 Rewrite (N,
4449 Make_Attribute_Reference (Loc,
243cae0a 4450 Prefix => New_Occurrence_Of (Temp, Loc),
70482933
RK		 4451 Attribute_Name => Name_Unrestricted_Access));
4452
4453 Analyze_And_Resolve (N, PtrT);
4454
685094bf 4455 -- We set the variable as statically allocated, since we don't want
a90bd866 4456 -- it going on the stack of the current procedure.
70482933
RK		 4457
4458 Set_Is_Statically_Allocated (Temp);
4459 return;
4460 end if;
4461
0669bebe
GB		 4462 -- Same if the allocator is an access discriminant for a local object:
4463 -- instead of an allocator we create a local value and constrain the
308e6f3a 4464 -- enclosing object with the corresponding access attribute.
0669bebe 4465
26bff3d9
JM		 4466 if Is_Static_Coextension (N) then
4467 Rewrite_Coextension (N);
0669bebe
GB		 4468 return;
4469 end if;
4470
8aec446b
AC		 4471 -- Check for size too large, we do this because the back end misses
4472 -- proper checks here and can generate rubbish allocation calls when
4473 -- we are near the limit. We only do this for the 32-bit address case
4474 -- since that is from a practical point of view where we see a problem.
4475
4476 if System_Address_Size = 32
4477 and then not Storage_Checks_Suppressed (PtrT)
4478 and then not Storage_Checks_Suppressed (Dtyp)
4479 and then not Storage_Checks_Suppressed (Etyp)
4480 then
4481 -- The check we want to generate should look like
4482
4483 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4484 -- raise Storage_Error;
4485 -- end if;
4486
308e6f3a 4487 -- where 3.5 gigabytes is a constant large enough to accommodate any
507ed3fd
AC		 4488 -- reasonable request for. But we can't do it this way because at
4489 -- least at the moment we don't compute this attribute right, and
4490 -- can silently give wrong results when the result gets large. Since
4491 -- this is all about large results, that's bad, so instead we only
205c14b0 4492 -- apply the check for constrained arrays, and manually compute the
507ed3fd 4493 -- value of the attribute ???
8aec446b 4494
507ed3fd
AC		 4495 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
4496 Insert_Action (N,
4497 Make_Raise_Storage_Error (Loc,
4498 Condition =>
4499 Make_Op_Gt (Loc,
4500 Left_Opnd => Size_In_Storage_Elements (Etyp),
4501 Right_Opnd =>
243cae0a 4502 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
507ed3fd
AC		 4503 Reason => SE_Object_Too_Large));
4504 end if;
8aec446b
AC		 4505 end if;
4506
b3b26ace
AC		 4507 -- If no storage pool has been specified and we have the restriction
4508 -- No_Standard_Allocators_After_Elaboration is present, then generate
4509 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4510
4511 if Nkind (N) = N_Allocator
4512 and then No (Storage_Pool (N))
4513 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4514 then
4515 Insert_Action (N,
4516 Make_Procedure_Call_Statement (Loc,
4517 Name =>
4518 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4519 end if;
4520
0da2c8ac 4521 -- Handle case of qualified expression (other than optimization above)
cac5a801
AC		 4522 -- First apply constraint checks, because the bounds or discriminants
4523 -- in the aggregate might not match the subtype mark in the allocator.
0da2c8ac 4524
70482933 4525 if Nkind (Expression (N)) = N_Qualified_Expression then
cac5a801
AC		 4526 Apply_Constraint_Check
4527 (Expression (Expression (N)), Etype (Expression (N)));
4528
fbf5a39b 4529 Expand_Allocator_Expression (N);
26bff3d9
JM		 4530 return;
4531 end if;
fbf5a39b 4532
26bff3d9
JM		 4533 -- If the allocator is for a type which requires initialization, and
4534 -- there is no initial value (i.e. operand is a subtype indication
685094bf
RD		 4535 -- rather than a qualified expression), then we must generate a call to
4536 -- the initialization routine using an expressions action node:
70482933 4537
26bff3d9 4538 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
70482933 4539
26bff3d9
JM		 4540 -- Here ptr_T is the pointer type for the allocator, and T is the
4541 -- subtype of the allocator. A special case arises if the designated
4542 -- type of the access type is a task or contains tasks. In this case
4543 -- the call to Init (Temp.all ...) is replaced by code that ensures
4544 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
6be44a9a 4545 -- for details). In addition, if the type T is a task type, then the
26bff3d9 4546 -- first argument to Init must be converted to the task record type.
70482933 4547
26bff3d9 4548 declare
df3e68b1
HK		 4549 T : constant Entity_Id := Entity (Expression (N));
4550 Args : List_Id;
4551 Decls : List_Id;
4552 Decl : Node_Id;
4553 Discr : Elmt_Id;
4554 Init : Entity_Id;
4555 Init_Arg1 : Node_Id;
4556 Temp_Decl : Node_Id;
4557 Temp_Type : Entity_Id;
70482933 4558
26bff3d9
JM		 4559 begin
4560 if No_Initialization (N) then
df3e68b1
HK		 4561
4562 -- Even though this might be a simple allocation, create a custom
deb8dacc
HK		 4563 -- Allocate if the context requires it. Since .NET/JVM compilers
4564 -- do not support pools, this step is skipped.
df3e68b1 4565
deb8dacc 4566 if VM_Target = No_VM
d3f70b35 4567 and then Present (Finalization_Master (PtrT))
deb8dacc 4568 then
df3e68b1 4569 Build_Allocate_Deallocate_Proc
ca5af305 4570 (N => N,
df3e68b1
HK		 4571 Is_Allocate => True);
4572 end if;
70482933 4573
26bff3d9 4574 -- Case of no initialization procedure present
70482933 4575
26bff3d9 4576 elsif not Has_Non_Null_Base_Init_Proc (T) then
70482933 4577
26bff3d9 4578 -- Case of simple initialization required
70482933 4579
26bff3d9 4580 if Needs_Simple_Initialization (T) then
b4592168 4581 Check_Restriction (No_Default_Initialization, N);
26bff3d9
JM		 4582 Rewrite (Expression (N),
4583 Make_Qualified_Expression (Loc,
4584 Subtype_Mark => New_Occurrence_Of (T, Loc),
b4592168 4585 Expression => Get_Simple_Init_Val (T, N)));
70482933 4586
26bff3d9
JM		 4587 Analyze_And_Resolve (Expression (Expression (N)), T);
4588 Analyze_And_Resolve (Expression (N), T);
4589 Set_Paren_Count (Expression (Expression (N)), 1);
4590 Expand_N_Allocator (N);
70482933 4591
26bff3d9 4592 -- No initialization required
70482933
RK		 4593
4594 else
26bff3d9
JM		 4595 null;
4596 end if;
70482933 4597
26bff3d9 4598 -- Case of initialization procedure present, must be called
70482933 4599
26bff3d9 4600 else
b4592168 4601 Check_Restriction (No_Default_Initialization, N);
70482933 4602
b4592168
GD		 4603 if not Restriction_Active (No_Default_Initialization) then
4604 Init := Base_Init_Proc (T);
4605 Nod := N;
191fcb3a 4606 Temp := Make_Temporary (Loc, 'P');
70482933 4607
b4592168 4608 -- Construct argument list for the initialization routine call
70482933 4609
df3e68b1 4610 Init_Arg1 :=
b4592168 4611 Make_Explicit_Dereference (Loc,
df3e68b1 4612 Prefix =>
e4494292 4613 New_Occurrence_Of (Temp, Loc));
df3e68b1
HK		 4614
4615 Set_Assignment_OK (Init_Arg1);
b4592168 4616 Temp_Type := PtrT;
26bff3d9 4617
b4592168
GD		 4618 -- The initialization procedure expects a specific type. if the
4619 -- context is access to class wide, indicate that the object
4620 -- being allocated has the right specific type.
70482933 4621
b4592168 4622 if Is_Class_Wide_Type (Dtyp) then
df3e68b1 4623 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
b4592168 4624 end if;
70482933 4625
b4592168
GD		 4626 -- If designated type is a concurrent type or if it is private
4627 -- type whose definition is a concurrent type, the first
4628 -- argument in the Init routine has to be unchecked conversion
4629 -- to the corresponding record type. If the designated type is
243cae0a 4630 -- a derived type, also convert the argument to its root type.
20b5d666 4631
b4592168 4632 if Is_Concurrent_Type (T) then
df3e68b1
HK		 4633 Init_Arg1 :=
4634 Unchecked_Convert_To (
4635 Corresponding_Record_Type (T), Init_Arg1);
70482933 4636
b4592168
GD		 4637 elsif Is_Private_Type (T)
4638 and then Present (Full_View (T))
4639 and then Is_Concurrent_Type (Full_View (T))
4640 then
df3e68b1 4641 Init_Arg1 :=
b4592168 4642 Unchecked_Convert_To
df3e68b1 4643 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
70482933 4644
b4592168
GD		 4645 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
4646 declare
4647 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
df3e68b1 4648
b4592168 4649 begin
df3e68b1
HK		 4650 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
4651 Set_Etype (Init_Arg1, Ftyp);
b4592168
GD		 4652 end;
4653 end if;
70482933 4654
df3e68b1 4655 Args := New_List (Init_Arg1);
70482933 4656
b4592168
GD		 4657 -- For the task case, pass the Master_Id of the access type as
4658 -- the value of the _Master parameter, and _Chain as the value
4659 -- of the _Chain parameter (_Chain will be defined as part of
4660 -- the generated code for the allocator).
70482933 4661
b4592168
GD		 4662 -- In Ada 2005, the context may be a function that returns an
4663 -- anonymous access type. In that case the Master_Id has been
4664 -- created when expanding the function declaration.
70482933 4665
b4592168
GD		 4666 if Has_Task (T) then
4667 if No (Master_Id (Base_Type (PtrT))) then
70482933 4668
b4592168
GD		 4669 -- The designated type was an incomplete type, and the
4670 -- access type did not get expanded. Salvage it now.
70482933 4671
b941ae65 4672 if not Restriction_Active (No_Task_Hierarchy) then
3d67b239
AC		 4673 if Present (Parent (Base_Type (PtrT))) then
4674 Expand_N_Full_Type_Declaration
4675 (Parent (Base_Type (PtrT)));
4676
0d5fbf52
AC		 4677 -- The only other possibility is an itype. For this
4678 -- case, the master must exist in the context. This is
4679 -- the case when the allocator initializes an access
4680 -- component in an init-proc.
3d67b239 4681
0d5fbf52 4682 else
3d67b239
AC		 4683 pragma Assert (Is_Itype (PtrT));
4684 Build_Master_Renaming (PtrT, N);
4685 end if;
b941ae65 4686 end if;
b4592168 4687 end if;
70482933 4688
b4592168
GD		 4689 -- If the context of the allocator is a declaration or an
4690 -- assignment, we can generate a meaningful image for it,
4691 -- even though subsequent assignments might remove the
4692 -- connection between task and entity. We build this image
4693 -- when the left-hand side is a simple variable, a simple
4694 -- indexed assignment or a simple selected component.
4695
4696 if Nkind (Parent (N)) = N_Assignment_Statement then
4697 declare
4698 Nam : constant Node_Id := Name (Parent (N));
4699
4700 begin
4701 if Is_Entity_Name (Nam) then
4702 Decls :=
4703 Build_Task_Image_Decls
4704 (Loc,
4705 New_Occurrence_Of
4706 (Entity (Nam), Sloc (Nam)), T);
4707
243cae0a
AC		 4708 elsif Nkind_In (Nam, N_Indexed_Component,
4709 N_Selected_Component)
b4592168
GD		 4710 and then Is_Entity_Name (Prefix (Nam))
4711 then
4712 Decls :=
4713 Build_Task_Image_Decls
4714 (Loc, Nam, Etype (Prefix (Nam)));
4715 else
4716 Decls := Build_Task_Image_Decls (Loc, T, T);
4717 end if;
4718 end;
70482933 4719
b4592168
GD		 4720 elsif Nkind (Parent (N)) = N_Object_Declaration then
4721 Decls :=
4722 Build_Task_Image_Decls
4723 (Loc, Defining_Identifier (Parent (N)), T);
70482933 4724
b4592168
GD		 4725 else
4726 Decls := Build_Task_Image_Decls (Loc, T, T);
4727 end if;
26bff3d9 4728
87dc09cb 4729 if Restriction_Active (No_Task_Hierarchy) then
3c1ecd7e
AC		 4730 Append_To (Args,
4731 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
87dc09cb
AC		 4732 else
4733 Append_To (Args,
e4494292 4734 New_Occurrence_Of
87dc09cb
AC		 4735 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
4736 end if;
4737
b4592168 4738 Append_To (Args, Make_Identifier (Loc, Name_uChain));
26bff3d9 4739
b4592168
GD		 4740 Decl := Last (Decls);
4741 Append_To (Args,
4742 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
26bff3d9 4743
87dc09cb 4744 -- Has_Task is false, Decls not used
26bff3d9 4745
b4592168
GD		 4746 else
4747 Decls := No_List;
26bff3d9
JM		 4748 end if;
4749
b4592168
GD		 4750 -- Add discriminants if discriminated type
4751
4752 declare
4753 Dis : Boolean := False;
4754 Typ : Entity_Id;
4755
4756 begin
4757 if Has_Discriminants (T) then
4758 Dis := True;
4759 Typ := T;
4760
4761 elsif Is_Private_Type (T)
4762 and then Present (Full_View (T))
4763 and then Has_Discriminants (Full_View (T))
20b5d666 4764 then
b4592168
GD		 4765 Dis := True;
4766 Typ := Full_View (T);
20b5d666 4767 end if;
70482933 4768
b4592168 4769 if Dis then
26bff3d9 4770
b4592168 4771 -- If the allocated object will be constrained by the
685094bf
RD		 4772 -- default values for discriminants, then build a subtype
4773 -- with those defaults, and change the allocated subtype
4774 -- to that. Note that this happens in fewer cases in Ada
4775 -- 2005 (AI-363).
26bff3d9 4776
b4592168
GD		 4777 if not Is_Constrained (Typ)
4778 and then Present (Discriminant_Default_Value
df3e68b1 4779 (First_Discriminant (Typ)))
0791fbe9 4780 and then (Ada_Version < Ada_2005
cc96a1b8 4781 or else not
0fbcb11c
ES		 4782 Object_Type_Has_Constrained_Partial_View
4783 (Typ, Current_Scope))
20b5d666 4784 then
b4592168 4785 Typ := Build_Default_Subtype (Typ, N);
e4494292 4786 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
20b5d666
JM		 4787 end if;
4788
b4592168
GD		 4789 Discr := First_Elmt (Discriminant_Constraint (Typ));
4790 while Present (Discr) loop
4791 Nod := Node (Discr);
4792 Append (New_Copy_Tree (Node (Discr)), Args);
20b5d666 4793
b4592168
GD		 4794 -- AI-416: when the discriminant constraint is an
4795 -- anonymous access type make sure an accessibility
4796 -- check is inserted if necessary (3.10.2(22.q/2))
20b5d666 4797
0791fbe9 4798 if Ada_Version >= Ada_2005
b4592168
GD		 4799 and then
4800 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
4801 then
e84e11ba
GD		 4802 Apply_Accessibility_Check
4803 (Nod, Typ, Insert_Node => Nod);
b4592168 4804 end if;
20b5d666 4805
b4592168
GD		 4806 Next_Elmt (Discr);
4807 end loop;
4808 end if;
4809 end;
70482933 4810
4b985e20 4811 -- We set the allocator as analyzed so that when we analyze
9b16cb57
RD		 4812 -- the if expression node, we do not get an unwanted recursive
4813 -- expansion of the allocator expression.
70482933 4814
b4592168
GD		 4815 Set_Analyzed (N, True);
4816 Nod := Relocate_Node (N);
70482933 4817
b4592168 4818 -- Here is the transformation:
ca5af305
AC		 4819 -- input: new Ctrl_Typ
4820 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4821 -- Ctrl_TypIP (Temp.all, ...);
4822 -- [Deep_]Initialize (Temp.all);
70482933 4823
ca5af305
AC		 4824 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4825 -- is the subtype of the allocator.
70482933 4826
b4592168
GD		 4827 Temp_Decl :=
4828 Make_Object_Declaration (Loc,
4829 Defining_Identifier => Temp,
4830 Constant_Present => True,
e4494292 4831 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
b4592168 4832 Expression => Nod);
70482933 4833
b4592168
GD		 4834 Set_Assignment_OK (Temp_Decl);
4835 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
70482933 4836
ca5af305 4837 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
df3e68b1 4838
b4592168
GD		 4839 -- If the designated type is a task type or contains tasks,
4840 -- create block to activate created tasks, and insert
4841 -- declaration for Task_Image variable ahead of call.
70482933 4842
b4592168
GD		 4843 if Has_Task (T) then
4844 declare
4845 L : constant List_Id := New_List;
4846 Blk : Node_Id;
4847 begin
4848 Build_Task_Allocate_Block (L, Nod, Args);
4849 Blk := Last (L);
4850 Insert_List_Before (First (Declarations (Blk)), Decls);
4851 Insert_Actions (N, L);
4852 end;
70482933 4853
b4592168
GD		 4854 else
4855 Insert_Action (N,
4856 Make_Procedure_Call_Statement (Loc,
e4494292 4857 Name => New_Occurrence_Of (Init, Loc),
b4592168
GD		 4858 Parameter_Associations => Args));
4859 end if;
70482933 4860
048e5cef 4861 if Needs_Finalization (T) then
70482933 4862
df3e68b1
HK		 4863 -- Generate:
4864 -- [Deep_]Initialize (Init_Arg1);
70482933 4865
df3e68b1 4866 Insert_Action (N,
243cae0a
AC		 4867 Make_Init_Call
4868 (Obj_Ref => New_Copy_Tree (Init_Arg1),
4869 Typ => T));
b4592168 4870
b254da66 4871 if Present (Finalization_Master (PtrT)) then
deb8dacc 4872
b254da66
AC		 4873 -- Special processing for .NET/JVM, the allocated object
4874 -- is attached to the finalization master. Generate:
deb8dacc 4875
b254da66 4876 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
deb8dacc 4877
b254da66
AC		 4878 -- Types derived from [Limited_]Controlled are the only
4879 -- ones considered since they have fields Prev and Next.
4880
e0c32166
AC		 4881 if VM_Target /= No_VM then
4882 if Is_Controlled (T) then
4883 Insert_Action (N,
4884 Make_Attach_Call
4885 (Obj_Ref => New_Copy_Tree (Init_Arg1),
4886 Ptr_Typ => PtrT));
4887 end if;
b254da66
AC		 4888
4889 -- Default case, generate:
4890
4891 -- Set_Finalize_Address
4892 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4893
5114f3ff
AC		 4894 -- Do not generate this call in CodePeer mode, as TSS
4895 -- primitive Finalize_Address is not created in this
4896 -- mode.
b254da66 4897
5114f3ff 4898 elsif not CodePeer_Mode then
b254da66
AC		 4899 Insert_Action (N,
4900 Make_Set_Finalize_Address_Call
4901 (Loc => Loc,
4902 Typ => T,
4903 Ptr_Typ => PtrT));
4904 end if;
b4592168 4905 end if;
70482933
RK		 4906 end if;
4907
e4494292 4908 Rewrite (N, New_Occurrence_Of (Temp, Loc));
b4592168
GD		 4909 Analyze_And_Resolve (N, PtrT);
4910 end if;
26bff3d9
JM		 4911 end if;
4912 end;
f82944b7 4913
26bff3d9
JM		 4914 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4915 -- object that has been rewritten as a reference, we displace "this"
4916 -- to reference properly its secondary dispatch table.
4917
533369aa 4918 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
26bff3d9 4919 Displace_Allocator_Pointer (N);
f82944b7
JM		 4920 end if;
4921
fbf5a39b
AC		 4922 exception
4923 when RE_Not_Available =>
4924 return;
70482933
RK		 4925 end Expand_N_Allocator;
4926
4927 -----------------------
4928 -- Expand_N_And_Then --
4929 -----------------------
4930
5875f8d6
AC		 4931 procedure Expand_N_And_Then (N : Node_Id)
4932 renames Expand_Short_Circuit_Operator;
70482933 4933
19d846a0
RD		 4934 ------------------------------
4935 -- Expand_N_Case_Expression --
4936 ------------------------------
4937
4938 procedure Expand_N_Case_Expression (N : Node_Id) is
4939 Loc : constant Source_Ptr := Sloc (N);
4940 Typ : constant Entity_Id := Etype (N);
4941 Cstmt : Node_Id;
27a8f150 4942 Decl : Node_Id;
19d846a0
RD		 4943 Tnn : Entity_Id;
4944 Pnn : Entity_Id;
4945 Actions : List_Id;
4946 Ttyp : Entity_Id;
4947 Alt : Node_Id;
4948 Fexp : Node_Id;
4949
4950 begin
b6b5cca8
AC		 4951 -- Check for MINIMIZED/ELIMINATED overflow mode
4952
4953 if Minimized_Eliminated_Overflow_Check (N) then
4b1c4f20
RD		 4954 Apply_Arithmetic_Overflow_Check (N);
4955 return;
4956 end if;
4957
ff1f1705
AC		 4958 -- If the case expression is a predicate specification, do not
4959 -- expand, because it will be converted to the proper predicate
4960 -- form when building the predicate function.
4961
4962 if Ekind_In (Current_Scope, E_Function, E_Procedure)
4963 and then Is_Predicate_Function (Current_Scope)
4964 then
4965 return;
4966 end if;
4967
19d846a0
RD		 4968 -- We expand
4969
4970 -- case X is when A => AX, when B => BX ...
4971
4972 -- to
4973
4974 -- do
4975 -- Tnn : typ;
4976 -- case X is
4977 -- when A =>
4978 -- Tnn := AX;
4979 -- when B =>
4980 -- Tnn := BX;
4981 -- ...
4982 -- end case;
4983 -- in Tnn end;
4984
4985 -- However, this expansion is wrong for limited types, and also
4986 -- wrong for unconstrained types (since the bounds may not be the
4987 -- same in all branches). Furthermore it involves an extra copy
4988 -- for large objects. So we take care of this by using the following
2492305b 4989 -- modified expansion for non-elementary types:
19d846a0
RD		 4990
4991 -- do
4992 -- type Pnn is access all typ;
4993 -- Tnn : Pnn;
4994 -- case X is
4995 -- when A =>
4996 -- T := AX'Unrestricted_Access;
4997 -- when B =>
4998 -- T := BX'Unrestricted_Access;
4999 -- ...
5000 -- end case;
5001 -- in Tnn.all end;
5002
5003 Cstmt :=
5004 Make_Case_Statement (Loc,
5005 Expression => Expression (N),
5006 Alternatives => New_List);
5007
414c6563
AC		 5008 -- Preserve the original context for which the case statement is being
5009 -- generated. This is needed by the finalization machinery to prevent
5010 -- the premature finalization of controlled objects found within the
5011 -- case statement.
5012
5013 Set_From_Conditional_Expression (Cstmt);
5014
19d846a0
RD		 5015 Actions := New_List;
5016
5017 -- Scalar case
5018
2492305b 5019 if Is_Elementary_Type (Typ) then
19d846a0
RD		 5020 Ttyp := Typ;
5021
5022 else
5023 Pnn := Make_Temporary (Loc, 'P');
5024 Append_To (Actions,
5025 Make_Full_Type_Declaration (Loc,
5026 Defining_Identifier => Pnn,
11d59a86 5027 Type_Definition =>
19d846a0 5028 Make_Access_To_Object_Definition (Loc,
11d59a86 5029 All_Present => True,
e4494292 5030 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
19d846a0
RD		 5031 Ttyp := Pnn;
5032 end if;
5033
5034 Tnn := Make_Temporary (Loc, 'T');
27a8f150
AC		 5035
5036 -- Create declaration for target of expression, and indicate that it
5037 -- does not require initialization.
5038
11d59a86
AC		 5039 Decl :=
5040 Make_Object_Declaration (Loc,
19d846a0 5041 Defining_Identifier => Tnn,
27a8f150
AC		 5042 Object_Definition => New_Occurrence_Of (Ttyp, Loc));
5043 Set_No_Initialization (Decl);
5044 Append_To (Actions, Decl);
19d846a0
RD		 5045
5046 -- Now process the alternatives
5047
5048 Alt := First (Alternatives (N));
5049 while Present (Alt) loop
5050 declare
eaed0c37
AC		 5051 Aexp : Node_Id := Expression (Alt);
5052 Aloc : constant Source_Ptr := Sloc (Aexp);
5053 Stats : List_Id;
19d846a0
RD		 5054
5055 begin
eaed0c37
AC		 5056 -- As described above, take Unrestricted_Access for case of non-
5057 -- scalar types, to avoid big copies, and special cases.
05dbd302 5058
2492305b 5059 if not Is_Elementary_Type (Typ) then
19d846a0
RD		 5060 Aexp :=
5061 Make_Attribute_Reference (Aloc,
5062 Prefix => Relocate_Node (Aexp),
5063 Attribute_Name => Name_Unrestricted_Access);
5064 end if;
5065
eaed0c37
AC		 5066 Stats := New_List (
5067 Make_Assignment_Statement (Aloc,
5068 Name => New_Occurrence_Of (Tnn, Loc),
5069 Expression => Aexp));
5070
5071 -- Propagate declarations inserted in the node by Insert_Actions
5072 -- (for example, temporaries generated to remove side effects).
5073 -- These actions must remain attached to the alternative, given
5074 -- that they are generated by the corresponding expression.
5075
5076 if Present (Sinfo.Actions (Alt)) then
5077 Prepend_List (Sinfo.Actions (Alt), Stats);
5078 end if;
5079
19d846a0
RD		 5080 Append_To
5081 (Alternatives (Cstmt),
5082 Make_Case_Statement_Alternative (Sloc (Alt),
5083 Discrete_Choices => Discrete_Choices (Alt),
eaed0c37 5084 Statements => Stats));
19d846a0
RD		 5085 end;
5086
5087 Next (Alt);
5088 end loop;
5089
5090 Append_To (Actions, Cstmt);
5091
5092 -- Construct and return final expression with actions
5093
2492305b 5094 if Is_Elementary_Type (Typ) then
19d846a0
RD		 5095 Fexp := New_Occurrence_Of (Tnn, Loc);
5096 else
5097 Fexp :=
5098 Make_Explicit_Dereference (Loc,
5099 Prefix => New_Occurrence_Of (Tnn, Loc));
5100 end if;
5101
5102 Rewrite (N,
5103 Make_Expression_With_Actions (Loc,
5104 Expression => Fexp,
5105 Actions => Actions));
5106
5107 Analyze_And_Resolve (N, Typ);
5108 end Expand_N_Case_Expression;
5109
9b16cb57
RD		 5110 -----------------------------------
5111 -- Expand_N_Explicit_Dereference --
5112 -----------------------------------
5113
5114 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5115 begin
5116 -- Insert explicit dereference call for the checked storage pool case
5117
5118 Insert_Dereference_Action (Prefix (N));
5119
5120 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5121 -- we set the atomic sync flag.
5122
5123 if Is_Atomic (Etype (N))
5124 and then not Atomic_Synchronization_Disabled (Etype (N))
5125 then
5126 Activate_Atomic_Synchronization (N);
5127 end if;
5128 end Expand_N_Explicit_Dereference;
5129
5130 --------------------------------------
5131 -- Expand_N_Expression_With_Actions --
5132 --------------------------------------
5133
5134 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
3a845e07 5135
4c7e0990 5136 function Process_Action (Act : Node_Id) return Traverse_Result;
b2c28399
AC		 5137 -- Inspect and process a single action of an expression_with_actions for
5138 -- transient controlled objects. If such objects are found, the routine
5139 -- generates code to clean them up when the context of the expression is
5140 -- evaluated or elaborated.
9b16cb57 5141
4c7e0990
AC		 5142 --------------------
5143 -- Process_Action --
5144 --------------------
5145
5146 function Process_Action (Act : Node_Id) return Traverse_Result is
4c7e0990
AC		 5147 begin
5148 if Nkind (Act) = N_Object_Declaration
5149 and then Is_Finalizable_Transient (Act, N)
5150 then
b2c28399
AC		 5151 Process_Transient_Object (Act, N);
5152 return Abandon;
9b16cb57 5153
4c7e0990
AC		 5154 -- Avoid processing temporary function results multiple times when
5155 -- dealing with nested expression_with_actions.
9b16cb57 5156
4c7e0990
AC		 5157 elsif Nkind (Act) = N_Expression_With_Actions then
5158 return Abandon;
5159
b2c28399
AC		 5160 -- Do not process temporary function results in loops. This is done
5161 -- by Expand_N_Loop_Statement and Build_Finalizer.
4c7e0990
AC		 5162
5163 elsif Nkind (Act) = N_Loop_Statement then
5164 return Abandon;
9b16cb57
RD		 5165 end if;
5166
4c7e0990
AC		 5167 return OK;
5168 end Process_Action;
9b16cb57 5169
4c7e0990 5170 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
9b16cb57
RD		 5171
5172 -- Local variables
5173
4c7e0990 5174 Act : Node_Id;
9b16cb57
RD		 5175
5176 -- Start of processing for Expand_N_Expression_With_Actions
5177
5178 begin
e0f63680
AC		 5179 -- Process the actions as described above
5180
4c7e0990 5181 Act := First (Actions (N));
e0f63680
AC		 5182 while Present (Act) loop
5183 Process_Single_Action (Act);
5184 Next (Act);
5185 end loop;
5186
ebdaa81b 5187 -- Deal with case where there are no actions. In this case we simply
5a521b8a 5188 -- rewrite the node with its expression since we don't need the actions
ebdaa81b
AC		 5189 -- and the specification of this node does not allow a null action list.
5190
5a521b8a
AC		 5191 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5192 -- the expanded tree and relying on being able to retrieve the original
5193 -- tree in cases like this. This raises a whole lot of issues of whether
5194 -- we have problems elsewhere, which will be addressed in the future???
5195
e0f63680 5196 if Is_Empty_List (Actions (N)) then
5a521b8a 5197 Rewrite (N, Relocate_Node (Expression (N)));
ebdaa81b 5198 end if;
9b16cb57
RD		 5199 end Expand_N_Expression_With_Actions;
5200
5201 ----------------------------
5202 -- Expand_N_If_Expression --
5203 ----------------------------
70482933 5204
4b985e20 5205 -- Deal with limited types and condition actions
70482933 5206
9b16cb57 5207 procedure Expand_N_If_Expression (N : Node_Id) is
b2c28399
AC		 5208 procedure Process_Actions (Actions : List_Id);
5209 -- Inspect and process a single action list of an if expression for
5210 -- transient controlled objects. If such objects are found, the routine
5211 -- generates code to clean them up when the context of the expression is
5212 -- evaluated or elaborated.
3cebd1c0 5213
b2c28399
AC		 5214 ---------------------
5215 -- Process_Actions --
5216 ---------------------
3cebd1c0 5217
b2c28399
AC		 5218 procedure Process_Actions (Actions : List_Id) is
5219 Act : Node_Id;
3cebd1c0
AC		 5220
5221 begin
b2c28399
AC		 5222 Act := First (Actions);
5223 while Present (Act) loop
5224 if Nkind (Act) = N_Object_Declaration
5225 and then Is_Finalizable_Transient (Act, N)
5226 then
5227 Process_Transient_Object (Act, N);
5228 end if;
3cebd1c0 5229
b2c28399
AC		 5230 Next (Act);
5231 end loop;
5232 end Process_Actions;
3cebd1c0
AC		 5233
5234 -- Local variables
5235
70482933
RK		 5236 Loc : constant Source_Ptr := Sloc (N);
5237 Cond : constant Node_Id := First (Expressions (N));
5238 Thenx : constant Node_Id := Next (Cond);
5239 Elsex : constant Node_Id := Next (Thenx);
5240 Typ : constant Entity_Id := Etype (N);
c471e2da 5241
3cebd1c0 5242 Actions : List_Id;
602a7ec0
AC		 5243 Cnn : Entity_Id;
5244 Decl : Node_Id;
3cebd1c0 5245 Expr : Node_Id;
602a7ec0
AC		 5246 New_If : Node_Id;
5247 New_N : Node_Id;
b2c28399 5248 Ptr_Typ : Entity_Id;
70482933 5249
a53c5613
AC		 5250 -- Start of processing for Expand_N_If_Expression
5251
70482933 5252 begin
b6b5cca8
AC		 5253 -- Check for MINIMIZED/ELIMINATED overflow mode
5254
5255 if Minimized_Eliminated_Overflow_Check (N) then
5256 Apply_Arithmetic_Overflow_Check (N);
5257 return;
5258 end if;
5259
602a7ec0 5260 -- Fold at compile time if condition known. We have already folded
9b16cb57
RD		 5261 -- static if expressions, but it is possible to fold any case in which
5262 -- the condition is known at compile time, even though the result is
5263 -- non-static.
602a7ec0
AC		 5264
5265 -- Note that we don't do the fold of such cases in Sem_Elab because
5266 -- it can cause infinite loops with the expander adding a conditional
5267 -- expression, and Sem_Elab circuitry removing it repeatedly.
5268
5269 if Compile_Time_Known_Value (Cond) then
5270 if Is_True (Expr_Value (Cond)) then
cc6f5d75 5271 Expr := Thenx;
602a7ec0
AC		 5272 Actions := Then_Actions (N);
5273 else
cc6f5d75 5274 Expr := Elsex;
602a7ec0
AC		 5275 Actions := Else_Actions (N);
5276 end if;
5277
5278 Remove (Expr);
ae77c68b
AC		 5279
5280 if Present (Actions) then
ae77c68b
AC		 5281 Rewrite (N,
5282 Make_Expression_With_Actions (Loc,
5283 Expression => Relocate_Node (Expr),
5284 Actions => Actions));
5285 Analyze_And_Resolve (N, Typ);
ae77c68b
AC		 5286 else
5287 Rewrite (N, Relocate_Node (Expr));
5288 end if;
602a7ec0
AC		 5289
5290 -- Note that the result is never static (legitimate cases of static
9b16cb57 5291 -- if expressions were folded in Sem_Eval).
602a7ec0
AC		 5292
5293 Set_Is_Static_Expression (N, False);
5294 return;
5295 end if;
5296
113a9fb6
AC		 5297 -- If the type is limited, and the back end does not handle limited
5298 -- types, then we expand as follows to avoid the possibility of
5299 -- improper copying.
ac7120ce 5300
c471e2da
AC		 5301 -- type Ptr is access all Typ;
5302 -- Cnn : Ptr;
ac7120ce
RD		 5303 -- if cond then
5304 -- <<then actions>>
5305 -- Cnn := then-expr'Unrestricted_Access;
5306 -- else
5307 -- <<else actions>>
5308 -- Cnn := else-expr'Unrestricted_Access;
5309 -- end if;
5310
9b16cb57 5311 -- and replace the if expression by a reference to Cnn.all.
ac7120ce 5312
305caf42
AC		 5313 -- This special case can be skipped if the back end handles limited
5314 -- types properly and ensures that no incorrect copies are made.
5315
5316 if Is_By_Reference_Type (Typ)
5317 and then not Back_End_Handles_Limited_Types
5318 then
b2c28399
AC		 5319 -- When the "then" or "else" expressions involve controlled function
5320 -- calls, generated temporaries are chained on the corresponding list
5321 -- of actions. These temporaries need to be finalized after the if
5322 -- expression is evaluated.
3cebd1c0 5323
b2c28399
AC		 5324 Process_Actions (Then_Actions (N));
5325 Process_Actions (Else_Actions (N));
3cebd1c0 5326
b2c28399
AC		 5327 -- Generate:
5328 -- type Ann is access all Typ;
3cebd1c0 5329
b2c28399 5330 Ptr_Typ := Make_Temporary (Loc, 'A');
3cebd1c0 5331
b2c28399
AC		 5332 Insert_Action (N,
5333 Make_Full_Type_Declaration (Loc,
5334 Defining_Identifier => Ptr_Typ,
5335 Type_Definition =>
5336 Make_Access_To_Object_Definition (Loc,
5337 All_Present => True,
e4494292 5338 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
3cebd1c0 5339
b2c28399
AC		 5340 -- Generate:
5341 -- Cnn : Ann;
3cebd1c0 5342
b2c28399 5343 Cnn := Make_Temporary (Loc, 'C', N);
3cebd1c0 5344
b2c28399
AC		 5345 Decl :=
5346 Make_Object_Declaration (Loc,
5347 Defining_Identifier => Cnn,
5348 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
3cebd1c0 5349
b2c28399
AC		 5350 -- Generate:
5351 -- if Cond then
5352 -- Cnn := <Thenx>'Unrestricted_Access;
5353 -- else
5354 -- Cnn := <Elsex>'Unrestricted_Access;
5355 -- end if;
3cebd1c0 5356
b2c28399
AC		 5357 New_If :=
5358 Make_Implicit_If_Statement (N,
5359 Condition => Relocate_Node (Cond),
5360 Then_Statements => New_List (
5361 Make_Assignment_Statement (Sloc (Thenx),
e4494292 5362 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
b2c28399
AC		 5363 Expression =>
5364 Make_Attribute_Reference (Loc,
5365 Prefix => Relocate_Node (Thenx),
5366 Attribute_Name => Name_Unrestricted_Access))),
3cebd1c0 5367
b2c28399
AC		 5368 Else_Statements => New_List (
5369 Make_Assignment_Statement (Sloc (Elsex),
e4494292 5370 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
b2c28399
AC		 5371 Expression =>
5372 Make_Attribute_Reference (Loc,
5373 Prefix => Relocate_Node (Elsex),
5374 Attribute_Name => Name_Unrestricted_Access))));
3cebd1c0 5375
414c6563
AC		 5376 -- Preserve the original context for which the if statement is being
5377 -- generated. This is needed by the finalization machinery to prevent
5378 -- the premature finalization of controlled objects found within the
5379 -- if statement.
5380
5381 Set_From_Conditional_Expression (New_If);
5382
5383 New_N :=
5384 Make_Explicit_Dereference (Loc,
5385 Prefix => New_Occurrence_Of (Cnn, Loc));
fb1949a0 5386
113a9fb6
AC		 5387 -- If the result is an unconstrained array and the if expression is in a
5388 -- context other than the initializing expression of the declaration of
5389 -- an object, then we pull out the if expression as follows:
5390
5391 -- Cnn : constant typ := if-expression
5392
5393 -- and then replace the if expression with an occurrence of Cnn. This
5394 -- avoids the need in the back end to create on-the-fly variable length
5395 -- temporaries (which it cannot do!)
5396
5397 -- Note that the test for being in an object declaration avoids doing an
5398 -- unnecessary expansion, and also avoids infinite recursion.
5399
5400 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
5401 and then (Nkind (Parent (N)) /= N_Object_Declaration
5402 or else Expression (Parent (N)) /= N)
5403 then
5404 declare
5405 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5406 begin
5407 Insert_Action (N,
5408 Make_Object_Declaration (Loc,
5409 Defining_Identifier => Cnn,
5410 Constant_Present => True,
5411 Object_Definition => New_Occurrence_Of (Typ, Loc),
5412 Expression => Relocate_Node (N),
5413 Has_Init_Expression => True));
5414
5415 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
5416 return;
5417 end;
5418
c471e2da
AC		 5419 -- For other types, we only need to expand if there are other actions
5420 -- associated with either branch.
5421
5422 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
c471e2da 5423
0812b84e 5424 -- We now wrap the actions into the appropriate expression
fb1949a0 5425
0812b84e
AC		 5426 if Present (Then_Actions (N)) then
5427 Rewrite (Thenx,
b2c28399
AC		 5428 Make_Expression_With_Actions (Sloc (Thenx),
5429 Actions => Then_Actions (N),
5430 Expression => Relocate_Node (Thenx)));
5431
0812b84e
AC		 5432 Set_Then_Actions (N, No_List);
5433 Analyze_And_Resolve (Thenx, Typ);
5434 end if;
305caf42 5435
0812b84e
AC		 5436 if Present (Else_Actions (N)) then
5437 Rewrite (Elsex,
b2c28399
AC		 5438 Make_Expression_With_Actions (Sloc (Elsex),
5439 Actions => Else_Actions (N),
5440 Expression => Relocate_Node (Elsex)));
5441
0812b84e
AC		 5442 Set_Else_Actions (N, No_List);
5443 Analyze_And_Resolve (Elsex, Typ);
305caf42
AC		 5444 end if;
5445
0812b84e
AC		 5446 return;
5447
b2c28399
AC		 5448 -- If no actions then no expansion needed, gigi will handle it using the
5449 -- same approach as a C conditional expression.
305caf42
AC		 5450
5451 else
c471e2da
AC		 5452 return;
5453 end if;
5454
305caf42
AC		 5455 -- Fall through here for either the limited expansion, or the case of
5456 -- inserting actions for non-limited types. In both these cases, we must
5457 -- move the SLOC of the parent If statement to the newly created one and
3fc5d116
RD		 5458 -- change it to the SLOC of the expression which, after expansion, will
5459 -- correspond to what is being evaluated.
c471e2da 5460
533369aa 5461 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
c471e2da
AC		 5462 Set_Sloc (New_If, Sloc (Parent (N)));
5463 Set_Sloc (Parent (N), Loc);
5464 end if;
70482933 5465
3fc5d116
RD		 5466 -- Make sure Then_Actions and Else_Actions are appropriately moved
5467 -- to the new if statement.
5468
c471e2da
AC		 5469 if Present (Then_Actions (N)) then
5470 Insert_List_Before
5471 (First (Then_Statements (New_If)), Then_Actions (N));
70482933 5472 end if;
c471e2da
AC		 5473
5474 if Present (Else_Actions (N)) then
5475 Insert_List_Before
5476 (First (Else_Statements (New_If)), Else_Actions (N));
5477 end if;
5478
5479 Insert_Action (N, Decl);
5480 Insert_Action (N, New_If);
5481 Rewrite (N, New_N);
5482 Analyze_And_Resolve (N, Typ);
9b16cb57 5483 end Expand_N_If_Expression;
35a1c212 5484
70482933
RK		 5485 -----------------
5486 -- Expand_N_In --
5487 -----------------
5488
5489 procedure Expand_N_In (N : Node_Id) is
7324bf49 5490 Loc : constant Source_Ptr := Sloc (N);
4818e7b9 5491 Restyp : constant Entity_Id := Etype (N);
7324bf49
AC		 5492 Lop : constant Node_Id := Left_Opnd (N);
5493 Rop : constant Node_Id := Right_Opnd (N);
5494 Static : constant Boolean := Is_OK_Static_Expression (N);
70482933 5495
4818e7b9
RD		 5496 Ltyp : Entity_Id;
5497 Rtyp : Entity_Id;
5498
630d30e9
RD		 5499 procedure Substitute_Valid_Check;
5500 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5501 -- test for the left operand being in range of its subtype.
5502
5503 ----------------------------
5504 -- Substitute_Valid_Check --
5505 ----------------------------
5506
5507 procedure Substitute_Valid_Check is
5508 begin
c7532b2d
AC		 5509 Rewrite (N,
5510 Make_Attribute_Reference (Loc,
5511 Prefix => Relocate_Node (Lop),
5512 Attribute_Name => Name_Valid));
630d30e9 5513
c7532b2d 5514 Analyze_And_Resolve (N, Restyp);
630d30e9 5515
acad3c0a
AC		 5516 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5517 -- in which case, this usage makes sense, and in any case, we have
5518 -- actually eliminated the danger of optimization above.
5519
a7f1b24f 5520 if Overflow_Check_Mode not in Minimized_Or_Eliminated then
324ac540
AC		 5521 Error_Msg_N
5522 ("??explicit membership test may be optimized away", N);
acad3c0a 5523 Error_Msg_N -- CODEFIX
324ac540 5524 ("\??use ''Valid attribute instead", N);
acad3c0a
AC		 5525 end if;
5526
c7532b2d 5527 return;
630d30e9
RD		 5528 end Substitute_Valid_Check;
5529
5530 -- Start of processing for Expand_N_In
5531
70482933 5532 begin
308e6f3a 5533 -- If set membership case, expand with separate procedure
4818e7b9 5534
197e4514 5535 if Present (Alternatives (N)) then
a3068ca6 5536 Expand_Set_Membership (N);
197e4514
AC		 5537 return;
5538 end if;
5539
4818e7b9
RD		 5540 -- Not set membership, proceed with expansion
5541
5542 Ltyp := Etype (Left_Opnd (N));
5543 Rtyp := Etype (Right_Opnd (N));
5544
5707e389 5545 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
f6194278
RD		 5546 -- type, then expand with a separate procedure. Note the use of the
5547 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5548
a7f1b24f 5549 if Overflow_Check_Mode in Minimized_Or_Eliminated
f6194278
RD		 5550 and then Is_Signed_Integer_Type (Ltyp)
5551 and then not No_Minimize_Eliminate (N)
5552 then
5553 Expand_Membership_Minimize_Eliminate_Overflow (N);
5554 return;
5555 end if;
5556
630d30e9
RD		 5557 -- Check case of explicit test for an expression in range of its
5558 -- subtype. This is suspicious usage and we replace it with a 'Valid
b6b5cca8 5559 -- test and give a warning for scalar types.
630d30e9 5560
4818e7b9 5561 if Is_Scalar_Type (Ltyp)
b6b5cca8
AC		 5562
5563 -- Only relevant for source comparisons
5564
5565 and then Comes_From_Source (N)
5566
5567 -- In floating-point this is a standard way to check for finite values
5568 -- and using 'Valid would typically be a pessimization.
5569
4818e7b9 5570 and then not Is_Floating_Point_Type (Ltyp)
b6b5cca8
AC		 5571
5572 -- Don't give the message unless right operand is a type entity and
5573 -- the type of the left operand matches this type. Note that this
5574 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5575 -- checks have changed the type of the left operand.
5576
630d30e9 5577 and then Nkind (Rop) in N_Has_Entity
4818e7b9 5578 and then Ltyp = Entity (Rop)
b6b5cca8
AC		 5579
5580 -- Skip in VM mode, where we have no sense of invalid values. The
5581 -- warning still seems relevant, but not important enough to worry.
5582
26bff3d9 5583 and then VM_Target = No_VM
b6b5cca8
AC		 5584
5585 -- Skip this for predicated types, where such expressions are a
5586 -- reasonable way of testing if something meets the predicate.
5587
3d6db7f8 5588 and then not Present (Predicate_Function (Ltyp))
630d30e9
RD		 5589 then
5590 Substitute_Valid_Check;
5591 return;
5592 end if;
5593
20b5d666
JM		 5594 -- Do validity check on operands
5595
5596 if Validity_Checks_On and Validity_Check_Operands then
5597 Ensure_Valid (Left_Opnd (N));
5598 Validity_Check_Range (Right_Opnd (N));
5599 end if;
5600
630d30e9 5601 -- Case of explicit range
fbf5a39b
AC		 5602
5603 if Nkind (Rop) = N_Range then
5604 declare
630d30e9
RD		 5605 Lo : constant Node_Id := Low_Bound (Rop);
5606 Hi : constant Node_Id := High_Bound (Rop);
5607
5608 Lo_Orig : constant Node_Id := Original_Node (Lo);
5609 Hi_Orig : constant Node_Id := Original_Node (Hi);
5610
c800f862
RD		 5611 Lcheck : Compare_Result;
5612 Ucheck : Compare_Result;
fbf5a39b 5613
d766cee3
RD		 5614 Warn1 : constant Boolean :=
5615 Constant_Condition_Warnings
c800f862
RD		 5616 and then Comes_From_Source (N)
5617 and then not In_Instance;
d766cee3 5618 -- This must be true for any of the optimization warnings, we
9a0ddeee
AC		 5619 -- clearly want to give them only for source with the flag on. We
5620 -- also skip these warnings in an instance since it may be the
5621 -- case that different instantiations have different ranges.
d766cee3
RD		 5622
5623 Warn2 : constant Boolean :=
5624 Warn1
5625 and then Nkind (Original_Node (Rop)) = N_Range
5626 and then Is_Integer_Type (Etype (Lo));
5627 -- For the case where only one bound warning is elided, we also
5628 -- insist on an explicit range and an integer type. The reason is
5629 -- that the use of enumeration ranges including an end point is
9a0ddeee
AC		 5630 -- common, as is the use of a subtype name, one of whose bounds is
5631 -- the same as the type of the expression.
d766cee3 5632
fbf5a39b 5633 begin
c95e0edc 5634 -- If test is explicit x'First .. x'Last, replace by valid check
630d30e9 5635
e606088a
AC		 5636 -- Could use some individual comments for this complex test ???
5637
d766cee3 5638 if Is_Scalar_Type (Ltyp)
b6b5cca8
AC		 5639
5640 -- And left operand is X'First where X matches left operand
5641 -- type (this eliminates cases of type mismatch, including
5642 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5643 -- type of the left operand.
5644
630d30e9
RD		 5645 and then Nkind (Lo_Orig) = N_Attribute_Reference
5646 and then Attribute_Name (Lo_Orig) = Name_First
5647 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
d766cee3 5648 and then Entity (Prefix (Lo_Orig)) = Ltyp
b6b5cca8 5649
cc6f5d75 5650 -- Same tests for right operand
b6b5cca8 5651
630d30e9
RD		 5652 and then Nkind (Hi_Orig) = N_Attribute_Reference
5653 and then Attribute_Name (Hi_Orig) = Name_Last
5654 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
d766cee3 5655 and then Entity (Prefix (Hi_Orig)) = Ltyp
b6b5cca8
AC		 5656
5657 -- Relevant only for source cases
5658
630d30e9 5659 and then Comes_From_Source (N)
b6b5cca8
AC		 5660
5661 -- Omit for VM cases, where we don't have invalid values
5662
26bff3d9 5663 and then VM_Target = No_VM
630d30e9
RD		 5664 then
5665 Substitute_Valid_Check;
4818e7b9 5666 goto Leave;
630d30e9
RD		 5667 end if;
5668
d766cee3
RD		 5669 -- If bounds of type are known at compile time, and the end points
5670 -- are known at compile time and identical, this is another case
5671 -- for substituting a valid test. We only do this for discrete
5672 -- types, since it won't arise in practice for float types.
5673
5674 if Comes_From_Source (N)
5675 and then Is_Discrete_Type (Ltyp)
5676 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
5677 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
5678 and then Compile_Time_Known_Value (Lo)
5679 and then Compile_Time_Known_Value (Hi)
5680 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
5681 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
94eefd2e 5682
f6194278
RD		 5683 -- Kill warnings in instances, since they may be cases where we
5684 -- have a test in the generic that makes sense with some types
5685 -- and not with other types.
94eefd2e
RD		 5686
5687 and then not In_Instance
d766cee3
RD		 5688 then
5689 Substitute_Valid_Check;
4818e7b9 5690 goto Leave;
d766cee3
RD		 5691 end if;
5692
9a0ddeee
AC		 5693 -- If we have an explicit range, do a bit of optimization based on
5694 -- range analysis (we may be able to kill one or both checks).
630d30e9 5695
c800f862
RD		 5696 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
5697 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
5698
630d30e9
RD		 5699 -- If either check is known to fail, replace result by False since
5700 -- the other check does not matter. Preserve the static flag for
5701 -- legality checks, because we are constant-folding beyond RM 4.9.
fbf5a39b
AC		 5702
5703 if Lcheck = LT or else Ucheck = GT then
c800f862 5704 if Warn1 then
685bc70f
AC		 5705 Error_Msg_N ("?c?range test optimized away", N);
5706 Error_Msg_N ("\?c?value is known to be out of range", N);
d766cee3
RD		 5707 end if;
5708
e4494292 5709 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
4818e7b9 5710 Analyze_And_Resolve (N, Restyp);
7324bf49 5711 Set_Is_Static_Expression (N, Static);
4818e7b9 5712 goto Leave;
fbf5a39b 5713
685094bf
RD		 5714 -- If both checks are known to succeed, replace result by True,
5715 -- since we know we are in range.
fbf5a39b
AC		 5716
5717 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
c800f862 5718 if Warn1 then
685bc70f
AC		 5719 Error_Msg_N ("?c?range test optimized away", N);
5720 Error_Msg_N ("\?c?value is known to be in range", N);
d766cee3
RD		 5721 end if;
5722
e4494292 5723 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4818e7b9 5724 Analyze_And_Resolve (N, Restyp);
7324bf49 5725 Set_Is_Static_Expression (N, Static);
4818e7b9 5726 goto Leave;
fbf5a39b 5727
d766cee3
RD		 5728 -- If lower bound check succeeds and upper bound check is not
5729 -- known to succeed or fail, then replace the range check with
5730 -- a comparison against the upper bound.
fbf5a39b
AC		 5731
5732 elsif Lcheck in Compare_GE then
94eefd2e 5733 if Warn2 and then not In_Instance then
324ac540
AC		 5734 Error_Msg_N ("??lower bound test optimized away", Lo);
5735 Error_Msg_N ("\??value is known to be in range", Lo);
d766cee3
RD		 5736 end if;
5737
fbf5a39b
AC		 5738 Rewrite (N,
5739 Make_Op_Le (Loc,
5740 Left_Opnd => Lop,
5741 Right_Opnd => High_Bound (Rop)));
4818e7b9
RD		 5742 Analyze_And_Resolve (N, Restyp);
5743 goto Leave;
fbf5a39b 5744
d766cee3
RD		 5745 -- If upper bound check succeeds and lower bound check is not
5746 -- known to succeed or fail, then replace the range check with
5747 -- a comparison against the lower bound.
fbf5a39b
AC		 5748
5749 elsif Ucheck in Compare_LE then
94eefd2e 5750 if Warn2 and then not In_Instance then
324ac540
AC		 5751 Error_Msg_N ("??upper bound test optimized away", Hi);
5752 Error_Msg_N ("\??value is known to be in range", Hi);
d766cee3
RD		 5753 end if;
5754
fbf5a39b
AC		 5755 Rewrite (N,
5756 Make_Op_Ge (Loc,
5757 Left_Opnd => Lop,
5758 Right_Opnd => Low_Bound (Rop)));
4818e7b9
RD		 5759 Analyze_And_Resolve (N, Restyp);
5760 goto Leave;
fbf5a39b 5761 end if;
c800f862
RD		 5762
5763 -- We couldn't optimize away the range check, but there is one
5764 -- more issue. If we are checking constant conditionals, then we
5765 -- see if we can determine the outcome assuming everything is
5766 -- valid, and if so give an appropriate warning.
5767
5768 if Warn1 and then not Assume_No_Invalid_Values then
5769 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
5770 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
5771
5772 -- Result is out of range for valid value
5773
5774 if Lcheck = LT or else Ucheck = GT then
ed2233dc 5775 Error_Msg_N
685bc70f 5776 ("?c?value can only be in range if it is invalid", N);
c800f862
RD		 5777
5778 -- Result is in range for valid value
5779
5780 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
ed2233dc 5781 Error_Msg_N
685bc70f 5782 ("?c?value can only be out of range if it is invalid", N);
c800f862
RD		 5783
5784 -- Lower bound check succeeds if value is valid
5785
5786 elsif Warn2 and then Lcheck in Compare_GE then
ed2233dc 5787 Error_Msg_N
685bc70f 5788 ("?c?lower bound check only fails if it is invalid", Lo);
c800f862
RD		 5789
5790 -- Upper bound check succeeds if value is valid
5791
5792 elsif Warn2 and then Ucheck in Compare_LE then
ed2233dc 5793 Error_Msg_N
685bc70f 5794 ("?c?upper bound check only fails for invalid values", Hi);
c800f862
RD		 5795 end if;
5796 end if;
fbf5a39b
AC		 5797 end;
5798
5799 -- For all other cases of an explicit range, nothing to be done
70482933 5800
4818e7b9 5801 goto Leave;
70482933
RK		 5802
5803 -- Here right operand is a subtype mark
5804
5805 else
5806 declare
82878151
AC		 5807 Typ : Entity_Id := Etype (Rop);
5808 Is_Acc : constant Boolean := Is_Access_Type (Typ);
5809 Cond : Node_Id := Empty;
5810 New_N : Node_Id;
5811 Obj : Node_Id := Lop;
5812 SCIL_Node : Node_Id;
70482933
RK		 5813
5814 begin
5815 Remove_Side_Effects (Obj);
5816
5817 -- For tagged type, do tagged membership operation
5818
5819 if Is_Tagged_Type (Typ) then
fbf5a39b 5820
26bff3d9
JM		 5821 -- No expansion will be performed when VM_Target, as the VM
5822 -- back-ends will handle the membership tests directly (tags
5823 -- are not explicitly represented in Java objects, so the
5824 -- normal tagged membership expansion is not what we want).
70482933 5825
1f110335 5826 if Tagged_Type_Expansion then
82878151
AC		 5827 Tagged_Membership (N, SCIL_Node, New_N);
5828 Rewrite (N, New_N);
4818e7b9 5829 Analyze_And_Resolve (N, Restyp);
82878151
AC		 5830
5831 -- Update decoration of relocated node referenced by the
5832 -- SCIL node.
5833
9a0ddeee 5834 if Generate_SCIL and then Present (SCIL_Node) then
7665e4bd 5835 Set_SCIL_Node (N, SCIL_Node);
82878151 5836 end if;
70482933
RK		 5837 end if;
5838
4818e7b9 5839 goto Leave;
70482933 5840
c95e0edc 5841 -- If type is scalar type, rewrite as x in t'First .. t'Last.
70482933 5842 -- This reason we do this is that the bounds may have the wrong
c800f862
RD		 5843 -- type if they come from the original type definition. Also this
5844 -- way we get all the processing above for an explicit range.
70482933 5845
f6194278 5846 -- Don't do this for predicated types, since in this case we
a90bd866 5847 -- want to check the predicate.
c0f136cd 5848
c7532b2d
AC		 5849 elsif Is_Scalar_Type (Typ) then
5850 if No (Predicate_Function (Typ)) then
5851 Rewrite (Rop,
5852 Make_Range (Loc,
5853 Low_Bound =>
5854 Make_Attribute_Reference (Loc,
5855 Attribute_Name => Name_First,
e4494292 5856 Prefix => New_Occurrence_Of (Typ, Loc)),
c7532b2d
AC		 5857
5858 High_Bound =>
5859 Make_Attribute_Reference (Loc,
5860 Attribute_Name => Name_Last,
e4494292 5861 Prefix => New_Occurrence_Of (Typ, Loc))));
c7532b2d
AC		 5862 Analyze_And_Resolve (N, Restyp);
5863 end if;
70482933 5864
4818e7b9 5865 goto Leave;
5d09245e
AC		 5866
5867 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5868 -- a membership test if the subtype mark denotes a constrained
5869 -- Unchecked_Union subtype and the expression lacks inferable
5870 -- discriminants.
5871
5872 elsif Is_Unchecked_Union (Base_Type (Typ))
5873 and then Is_Constrained (Typ)
5874 and then not Has_Inferable_Discriminants (Lop)
5875 then
5876 Insert_Action (N,
5877 Make_Raise_Program_Error (Loc,
5878 Reason => PE_Unchecked_Union_Restriction));
5879
9a0ddeee 5880 -- Prevent Gigi from generating incorrect code by rewriting the
f6194278 5881 -- test as False. What is this undocumented thing about ???
5d09245e 5882
9a0ddeee 5883 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
4818e7b9 5884 goto Leave;
70482933
RK		 5885 end if;
5886
fbf5a39b
AC		 5887 -- Here we have a non-scalar type
5888
70482933
RK		 5889 if Is_Acc then
5890 Typ := Designated_Type (Typ);
5891 end if;
5892
5893 if not Is_Constrained (Typ) then
e4494292 5894 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4818e7b9 5895 Analyze_And_Resolve (N, Restyp);
70482933 5896
685094bf
RD		 5897 -- For the constrained array case, we have to check the subscripts
5898 -- for an exact match if the lengths are non-zero (the lengths
5899 -- must match in any case).
70482933
RK		 5900
5901 elsif Is_Array_Type (Typ) then
fbf5a39b 5902 Check_Subscripts : declare
9a0ddeee 5903 function Build_Attribute_Reference
2e071734
AC		 5904 (E : Node_Id;
5905 Nam : Name_Id;
5906 Dim : Nat) return Node_Id;
9a0ddeee 5907 -- Build attribute reference E'Nam (Dim)
70482933 5908
9a0ddeee
AC		 5909 -------------------------------
5910 -- Build_Attribute_Reference --
5911 -------------------------------
fbf5a39b 5912
9a0ddeee 5913 function Build_Attribute_Reference
2e071734
AC		 5914 (E : Node_Id;
5915 Nam : Name_Id;
5916 Dim : Nat) return Node_Id
70482933
RK		 5917 is
5918 begin
5919 return
5920 Make_Attribute_Reference (Loc,
9a0ddeee 5921 Prefix => E,
70482933 5922 Attribute_Name => Nam,
9a0ddeee 5923 Expressions => New_List (
70482933 5924 Make_Integer_Literal (Loc, Dim)));
9a0ddeee 5925 end Build_Attribute_Reference;
70482933 5926
fad0600d 5927 -- Start of processing for Check_Subscripts
fbf5a39b 5928
70482933
RK		 5929 begin
5930 for J in 1 .. Number_Dimensions (Typ) loop
5931 Evolve_And_Then (Cond,
5932 Make_Op_Eq (Loc,
5933 Left_Opnd =>
9a0ddeee 5934 Build_Attribute_Reference
fbf5a39b
AC		 5935 (Duplicate_Subexpr_No_Checks (Obj),
5936 Name_First, J),
70482933 5937 Right_Opnd =>
9a0ddeee 5938 Build_Attribute_Reference
70482933
RK		 5939 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
5940
5941 Evolve_And_Then (Cond,
5942 Make_Op_Eq (Loc,
5943 Left_Opnd =>
9a0ddeee 5944 Build_Attribute_Reference
fbf5a39b
AC		 5945 (Duplicate_Subexpr_No_Checks (Obj),
5946 Name_Last, J),
70482933 5947 Right_Opnd =>
9a0ddeee 5948 Build_Attribute_Reference
70482933
RK		 5949 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
5950 end loop;
5951
5952 if Is_Acc then
fbf5a39b
AC		 5953 Cond :=
5954 Make_Or_Else (Loc,
cc6f5d75 5955 Left_Opnd =>
fbf5a39b
AC		 5956 Make_Op_Eq (Loc,
5957 Left_Opnd => Obj,
5958 Right_Opnd => Make_Null (Loc)),
5959 Right_Opnd => Cond);
70482933
RK		 5960 end if;
5961
5962 Rewrite (N, Cond);
4818e7b9 5963 Analyze_And_Resolve (N, Restyp);
fbf5a39b 5964 end Check_Subscripts;
70482933 5965
685094bf
RD		 5966 -- These are the cases where constraint checks may be required,
5967 -- e.g. records with possible discriminants
70482933
RK		 5968
5969 else
5970 -- Expand the test into a series of discriminant comparisons.
685094bf
RD		 5971 -- The expression that is built is the negation of the one that
5972 -- is used for checking discriminant constraints.
70482933
RK		 5973
5974 Obj := Relocate_Node (Left_Opnd (N));
5975
5976 if Has_Discriminants (Typ) then
5977 Cond := Make_Op_Not (Loc,
5978 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
5979
5980 if Is_Acc then
5981 Cond := Make_Or_Else (Loc,
cc6f5d75 5982 Left_Opnd =>
70482933
RK		 5983 Make_Op_Eq (Loc,
5984 Left_Opnd => Obj,
5985 Right_Opnd => Make_Null (Loc)),
5986 Right_Opnd => Cond);
5987 end if;
5988
5989 else
5990 Cond := New_Occurrence_Of (Standard_True, Loc);
5991 end if;
5992
5993 Rewrite (N, Cond);
4818e7b9 5994 Analyze_And_Resolve (N, Restyp);
70482933 5995 end if;
6cce2156
GD		 5996
5997 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5998 -- expression of an anonymous access type. This can involve an
5999 -- accessibility test and a tagged type membership test in the
6000 -- case of tagged designated types.
6001
6002 if Ada_Version >= Ada_2012
6003 and then Is_Acc
6004 and then Ekind (Ltyp) = E_Anonymous_Access_Type
6005 then
6006 declare
6007 Expr_Entity : Entity_Id := Empty;
6008 New_N : Node_Id;
6009 Param_Level : Node_Id;
6010 Type_Level : Node_Id;
996c8821 6011
6cce2156
GD		 6012 begin
6013 if Is_Entity_Name (Lop) then
6014 Expr_Entity := Param_Entity (Lop);
996c8821 6015
6cce2156
GD		 6016 if not Present (Expr_Entity) then
6017 Expr_Entity := Entity (Lop);
6018 end if;
6019 end if;
6020
6021 -- If a conversion of the anonymous access value to the
6022 -- tested type would be illegal, then the result is False.
6023
6024 if not Valid_Conversion
6025 (Lop, Rtyp, Lop, Report_Errs => False)
6026 then
6027 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6028 Analyze_And_Resolve (N, Restyp);
6029
6030 -- Apply an accessibility check if the access object has an
6031 -- associated access level and when the level of the type is
6032 -- less deep than the level of the access parameter. This
6033 -- only occur for access parameters and stand-alone objects
6034 -- of an anonymous access type.
6035
6036 else
6037 if Present (Expr_Entity)
996c8821
RD		 6038 and then
6039 Present
6040 (Effective_Extra_Accessibility (Expr_Entity))
6041 and then UI_Gt (Object_Access_Level (Lop),
6042 Type_Access_Level (Rtyp))
6cce2156
GD		 6043 then
6044 Param_Level :=
6045 New_Occurrence_Of
d15f9422 6046 (Effective_Extra_Accessibility (Expr_Entity), Loc);
6cce2156
GD		 6047
6048 Type_Level :=
6049 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6050
6051 -- Return True only if the accessibility level of the
6052 -- expression entity is not deeper than the level of
6053 -- the tested access type.
6054
6055 Rewrite (N,
6056 Make_And_Then (Loc,
6057 Left_Opnd => Relocate_Node (N),
6058 Right_Opnd => Make_Op_Le (Loc,
6059 Left_Opnd => Param_Level,
6060 Right_Opnd => Type_Level)));
6061
6062 Analyze_And_Resolve (N);
6063 end if;
6064
6065 -- If the designated type is tagged, do tagged membership
6066 -- operation.
6067
6068 -- *** NOTE: we have to check not null before doing the
6069 -- tagged membership test (but maybe that can be done
6070 -- inside Tagged_Membership?).
6071
6072 if Is_Tagged_Type (Typ) then
6073 Rewrite (N,
6074 Make_And_Then (Loc,
6075 Left_Opnd => Relocate_Node (N),
6076 Right_Opnd =>
6077 Make_Op_Ne (Loc,
6078 Left_Opnd => Obj,
6079 Right_Opnd => Make_Null (Loc))));
6080
6081 -- No expansion will be performed when VM_Target, as
6082 -- the VM back-ends will handle the membership tests
6083 -- directly (tags are not explicitly represented in
6084 -- Java objects, so the normal tagged membership
6085 -- expansion is not what we want).
6086
6087 if Tagged_Type_Expansion then
6088
6089 -- Note that we have to pass Original_Node, because
6090 -- the membership test might already have been
6091 -- rewritten by earlier parts of membership test.
6092
6093 Tagged_Membership
6094 (Original_Node (N), SCIL_Node, New_N);
6095
6096 -- Update decoration of relocated node referenced
6097 -- by the SCIL node.
6098
6099 if Generate_SCIL and then Present (SCIL_Node) then
6100 Set_SCIL_Node (New_N, SCIL_Node);
6101 end if;
6102
6103 Rewrite (N,
6104 Make_And_Then (Loc,
6105 Left_Opnd => Relocate_Node (N),
6106 Right_Opnd => New_N));
6107
6108 Analyze_And_Resolve (N, Restyp);
6109 end if;
6110 end if;
6111 end if;
6112 end;
6113 end if;
70482933
RK		 6114 end;
6115 end if;
4818e7b9
RD		 6116
6117 -- At this point, we have done the processing required for the basic
6118 -- membership test, but not yet dealt with the predicate.
6119
6120 <<Leave>>
6121
c7532b2d
AC		 6122 -- If a predicate is present, then we do the predicate test, but we
6123 -- most certainly want to omit this if we are within the predicate
a90bd866 6124 -- function itself, since otherwise we have an infinite recursion.
3d6db7f8
GD		 6125 -- The check should also not be emitted when testing against a range
6126 -- (the check is only done when the right operand is a subtype; see
6127 -- RM12-4.5.2 (28.1/3-30/3)).
4818e7b9 6128
c7532b2d
AC		 6129 declare
6130 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
4818e7b9 6131
c7532b2d
AC		 6132 begin
6133 if Present (PFunc)
6134 and then Current_Scope /= PFunc
3d6db7f8 6135 and then Nkind (Rop) /= N_Range
c7532b2d
AC		 6136 then
6137 Rewrite (N,
6138 Make_And_Then (Loc,
6139 Left_Opnd => Relocate_Node (N),
fc142f63 6140 Right_Opnd => Make_Predicate_Call (Rtyp, Lop, Mem => True)));
4818e7b9 6141
c7532b2d 6142 -- Analyze new expression, mark left operand as analyzed to
b2009d46
AC		 6143 -- avoid infinite recursion adding predicate calls. Similarly,
6144 -- suppress further range checks on the call.
4818e7b9 6145
c7532b2d 6146 Set_Analyzed (Left_Opnd (N));
b2009d46 6147 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4818e7b9 6148
c7532b2d
AC		 6149 -- All done, skip attempt at compile time determination of result
6150
6151 return;
6152 end if;
6153 end;
70482933
RK		 6154 end Expand_N_In;
6155
6156 --------------------------------
6157 -- Expand_N_Indexed_Component --
6158 --------------------------------
6159
6160 procedure Expand_N_Indexed_Component (N : Node_Id) is
6161 Loc : constant Source_Ptr := Sloc (N);
6162 Typ : constant Entity_Id := Etype (N);
6163 P : constant Node_Id := Prefix (N);
6164 T : constant Entity_Id := Etype (P);
5972791c 6165 Atp : Entity_Id;
70482933
RK		 6166
6167 begin
685094bf
RD		 6168 -- A special optimization, if we have an indexed component that is
6169 -- selecting from a slice, then we can eliminate the slice, since, for
6170 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6171 -- the range check required by the slice. The range check for the slice
6172 -- itself has already been generated. The range check for the
6173 -- subscripting operation is ensured by converting the subject to
6174 -- the subtype of the slice.
6175
6176 -- This optimization not only generates better code, avoiding slice
6177 -- messing especially in the packed case, but more importantly bypasses
6178 -- some problems in handling this peculiar case, for example, the issue
6179 -- of dealing specially with object renamings.
70482933 6180
45ec05e1
RD		 6181 if Nkind (P) = N_Slice
6182
6183 -- This optimization is disabled for CodePeer because it can transform
6184 -- an index-check constraint_error into a range-check constraint_error
6185 -- and CodePeer cares about that distinction.
6186
6187 and then not CodePeer_Mode
6188 then
70482933
RK		 6189 Rewrite (N,
6190 Make_Indexed_Component (Loc,
cc6f5d75 6191 Prefix => Prefix (P),
70482933
RK		 6192 Expressions => New_List (
6193 Convert_To
6194 (Etype (First_Index (Etype (P))),
6195 First (Expressions (N))))));
6196 Analyze_And_Resolve (N, Typ);
6197 return;
6198 end if;
6199
b4592168
GD		 6200 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6201 -- function, then additional actuals must be passed.
6202
0791fbe9 6203 if Ada_Version >= Ada_2005
b4592168
GD		 6204 and then Is_Build_In_Place_Function_Call (P)
6205 then
6206 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6207 end if;
6208
685094bf 6209 -- If the prefix is an access type, then we unconditionally rewrite if
09494c32 6210 -- as an explicit dereference. This simplifies processing for several
685094bf
RD		 6211 -- cases, including packed array cases and certain cases in which checks
6212 -- must be generated. We used to try to do this only when it was
6213 -- necessary, but it cleans up the code to do it all the time.
70482933
RK		 6214
6215 if Is_Access_Type (T) then
2717634d 6216 Insert_Explicit_Dereference (P);
70482933 6217 Analyze_And_Resolve (P, Designated_Type (T));
5972791c
AC		 6218 Atp := Designated_Type (T);
6219 else
6220 Atp := T;
70482933
RK		 6221 end if;
6222
fbf5a39b
AC		 6223 -- Generate index and validity checks
6224
6225 Generate_Index_Checks (N);
6226
70482933
RK		 6227 if Validity_Checks_On and then Validity_Check_Subscripts then
6228 Apply_Subscript_Validity_Checks (N);
6229 end if;
6230
5972791c
AC		 6231 -- If selecting from an array with atomic components, and atomic sync
6232 -- is not suppressed for this array type, set atomic sync flag.
6233
6234 if (Has_Atomic_Components (Atp)
6235 and then not Atomic_Synchronization_Disabled (Atp))
6236 or else (Is_Atomic (Typ)
6237 and then not Atomic_Synchronization_Disabled (Typ))
6238 then
4c318253 6239 Activate_Atomic_Synchronization (N);
5972791c
AC		 6240 end if;
6241
70482933
RK		 6242 -- All done for the non-packed case
6243
6244 if not Is_Packed (Etype (Prefix (N))) then
6245 return;
6246 end if;
6247
6248 -- For packed arrays that are not bit-packed (i.e. the case of an array
8fc789c8 6249 -- with one or more index types with a non-contiguous enumeration type),
70482933
RK		 6250 -- we can always use the normal packed element get circuit.
6251
6252 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6253 Expand_Packed_Element_Reference (N);
6254 return;
6255 end if;
6256
8ca597af
RD		 6257 -- For a reference to a component of a bit packed array, we convert it
6258 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6259 -- want to do this for simple references, and not for:
70482933 6260
685094bf
RD		 6261 -- Left side of assignment, or prefix of left side of assignment, or
6262 -- prefix of the prefix, to handle packed arrays of packed arrays,
70482933
RK		 6263 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6264
6265 -- Renaming objects in renaming associations
6266 -- This case is handled when a use of the renamed variable occurs
6267
6268 -- Actual parameters for a procedure call
6269 -- This case is handled in Exp_Ch6.Expand_Actuals
6270
6271 -- The second expression in a 'Read attribute reference
6272
47d3b920 6273 -- The prefix of an address or bit or size attribute reference
70482933
RK		 6274
6275 -- The following circuit detects these exceptions
6276
6277 declare
6278 Child : Node_Id := N;
6279 Parnt : Node_Id := Parent (N);
6280
6281 begin
6282 loop
6283 if Nkind (Parnt) = N_Unchecked_Expression then
6284 null;
6285
303b4d58
AC		 6286 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
6287 N_Procedure_Call_Statement)
70482933
RK		 6288 or else (Nkind (Parnt) = N_Parameter_Association
6289 and then
6290 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
6291 then
6292 return;
6293
6294 elsif Nkind (Parnt) = N_Attribute_Reference
b69cd36a
AC		 6295 and then Nam_In (Attribute_Name (Parnt), Name_Address,
6296 Name_Bit,
6297 Name_Size)
70482933
RK		 6298 and then Prefix (Parnt) = Child
6299 then
6300 return;
6301
6302 elsif Nkind (Parnt) = N_Assignment_Statement
6303 and then Name (Parnt) = Child
6304 then
6305 return;
6306
685094bf
RD		 6307 -- If the expression is an index of an indexed component, it must
6308 -- be expanded regardless of context.
fbf5a39b
AC		 6309
6310 elsif Nkind (Parnt) = N_Indexed_Component
6311 and then Child /= Prefix (Parnt)
6312 then
6313 Expand_Packed_Element_Reference (N);
6314 return;
6315
6316 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
6317 and then Name (Parent (Parnt)) = Parnt
6318 then
6319 return;
6320
70482933
RK		 6321 elsif Nkind (Parnt) = N_Attribute_Reference
6322 and then Attribute_Name (Parnt) = Name_Read
6323 and then Next (First (Expressions (Parnt))) = Child
6324 then
6325 return;
6326
303b4d58 6327 elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
533369aa 6328 and then Prefix (Parnt) = Child
70482933
RK		 6329 then
6330 null;
6331
6332 else
6333 Expand_Packed_Element_Reference (N);
6334 return;
6335 end if;
6336
685094bf
RD		 6337 -- Keep looking up tree for unchecked expression, or if we are the
6338 -- prefix of a possible assignment left side.
70482933
RK		 6339
6340 Child := Parnt;
6341 Parnt := Parent (Child);
6342 end loop;
6343 end;
70482933
RK		 6344 end Expand_N_Indexed_Component;
6345
6346 ---------------------
6347 -- Expand_N_Not_In --
6348 ---------------------
6349
6350 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6351 -- can be done. This avoids needing to duplicate this expansion code.
6352
6353 procedure Expand_N_Not_In (N : Node_Id) is
630d30e9
RD		 6354 Loc : constant Source_Ptr := Sloc (N);
6355 Typ : constant Entity_Id := Etype (N);
6356 Cfs : constant Boolean := Comes_From_Source (N);
70482933
RK		 6357
6358 begin
6359 Rewrite (N,
6360 Make_Op_Not (Loc,
6361 Right_Opnd =>
6362 Make_In (Loc,
6363 Left_Opnd => Left_Opnd (N),
d766cee3 6364 Right_Opnd => Right_Opnd (N))));
630d30e9 6365
197e4514
AC		 6366 -- If this is a set membership, preserve list of alternatives
6367
6368 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
6369
d766cee3 6370 -- We want this to appear as coming from source if original does (see
8fc789c8 6371 -- transformations in Expand_N_In).
630d30e9
RD		 6372
6373 Set_Comes_From_Source (N, Cfs);
6374 Set_Comes_From_Source (Right_Opnd (N), Cfs);
6375
8fc789c8 6376 -- Now analyze transformed node
630d30e9 6377
70482933
RK		 6378 Analyze_And_Resolve (N, Typ);
6379 end Expand_N_Not_In;
6380
6381 -------------------
6382 -- Expand_N_Null --
6383 -------------------
6384
a3f2babd
AC		 6385 -- The only replacement required is for the case of a null of a type that
6386 -- is an access to protected subprogram, or a subtype thereof. We represent
6387 -- such access values as a record, and so we must replace the occurrence of
6388 -- null by the equivalent record (with a null address and a null pointer in
6389 -- it), so that the backend creates the proper value.
70482933
RK		 6390
6391 procedure Expand_N_Null (N : Node_Id) is
6392 Loc : constant Source_Ptr := Sloc (N);
a3f2babd 6393 Typ : constant Entity_Id := Base_Type (Etype (N));
70482933
RK		 6394 Agg : Node_Id;
6395
6396 begin
26bff3d9 6397 if Is_Access_Protected_Subprogram_Type (Typ) then
70482933
RK		 6398 Agg :=
6399 Make_Aggregate (Loc,
6400 Expressions => New_List (
6401 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
6402 Make_Null (Loc)));
6403
6404 Rewrite (N, Agg);
6405 Analyze_And_Resolve (N, Equivalent_Type (Typ));
6406
685094bf
RD		 6407 -- For subsequent semantic analysis, the node must retain its type.
6408 -- Gigi in any case replaces this type by the corresponding record
6409 -- type before processing the node.
70482933
RK		 6410
6411 Set_Etype (N, Typ);
6412 end if;
fbf5a39b
AC		 6413
6414 exception
6415 when RE_Not_Available =>
6416 return;
70482933
RK		 6417 end Expand_N_Null;
6418
6419 ---------------------
6420 -- Expand_N_Op_Abs --
6421 ---------------------
6422
6423 procedure Expand_N_Op_Abs (N : Node_Id) is
6424 Loc : constant Source_Ptr := Sloc (N);
cc6f5d75 6425 Expr : constant Node_Id := Right_Opnd (N);
70482933
RK		 6426
6427 begin
6428 Unary_Op_Validity_Checks (N);
6429
b6b5cca8
AC		 6430 -- Check for MINIMIZED/ELIMINATED overflow mode
6431
6432 if Minimized_Eliminated_Overflow_Check (N) then
6433 Apply_Arithmetic_Overflow_Check (N);
6434 return;
6435 end if;
6436
70482933
RK		 6437 -- Deal with software overflow checking
6438
07fc65c4 6439 if not Backend_Overflow_Checks_On_Target
533369aa
AC		 6440 and then Is_Signed_Integer_Type (Etype (N))
6441 and then Do_Overflow_Check (N)
70482933 6442 then
685094bf
RD		 6443 -- The only case to worry about is when the argument is equal to the
6444 -- largest negative number, so what we do is to insert the check:
70482933 6445
fbf5a39b 6446 -- [constraint_error when Expr = typ'Base'First]
70482933
RK		 6447
6448 -- with the usual Duplicate_Subexpr use coding for expr
6449
fbf5a39b
AC		 6450 Insert_Action (N,
6451 Make_Raise_Constraint_Error (Loc,
6452 Condition =>
6453 Make_Op_Eq (Loc,
70482933 6454 Left_Opnd => Duplicate_Subexpr (Expr),
fbf5a39b
AC		 6455 Right_Opnd =>
6456 Make_Attribute_Reference (Loc,
cc6f5d75 6457 Prefix =>
fbf5a39b
AC		 6458 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
6459 Attribute_Name => Name_First)),
6460 Reason => CE_Overflow_Check_Failed));
6461 end if;
70482933
RK		 6462 end Expand_N_Op_Abs;
6463
6464 ---------------------
6465 -- Expand_N_Op_Add --
6466 ---------------------
6467
6468 procedure Expand_N_Op_Add (N : Node_Id) is
6469 Typ : constant Entity_Id := Etype (N);
6470
6471 begin
6472 Binary_Op_Validity_Checks (N);
6473
b6b5cca8
AC		 6474 -- Check for MINIMIZED/ELIMINATED overflow mode
6475
6476 if Minimized_Eliminated_Overflow_Check (N) then
6477 Apply_Arithmetic_Overflow_Check (N);
6478 return;
6479 end if;
6480
70482933
RK		 6481 -- N + 0 = 0 + N = N for integer types
6482
6483 if Is_Integer_Type (Typ) then
6484 if Compile_Time_Known_Value (Right_Opnd (N))
6485 and then Expr_Value (Right_Opnd (N)) = Uint_0
6486 then
6487 Rewrite (N, Left_Opnd (N));
6488 return;
6489
6490 elsif Compile_Time_Known_Value (Left_Opnd (N))
6491 and then Expr_Value (Left_Opnd (N)) = Uint_0
6492 then
6493 Rewrite (N, Right_Opnd (N));
6494 return;
6495 end if;
6496 end if;
6497
fbf5a39b 6498 -- Arithmetic overflow checks for signed integer/fixed point types
70482933 6499
761f7dcb 6500 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
70482933
RK		 6501 Apply_Arithmetic_Overflow_Check (N);
6502 return;
70482933 6503 end if;
dfaff97b
RD		 6504
6505 -- Overflow checks for floating-point if -gnateF mode active
6506
6507 Check_Float_Op_Overflow (N);
70482933
RK		 6508 end Expand_N_Op_Add;
6509
6510 ---------------------
6511 -- Expand_N_Op_And --
6512 ---------------------
6513
6514 procedure Expand_N_Op_And (N : Node_Id) is
6515 Typ : constant Entity_Id := Etype (N);
6516
6517 begin
6518 Binary_Op_Validity_Checks (N);
6519
6520 if Is_Array_Type (Etype (N)) then
6521 Expand_Boolean_Operator (N);
6522
6523 elsif Is_Boolean_Type (Etype (N)) then
f2d10a02
AC		 6524 Adjust_Condition (Left_Opnd (N));
6525 Adjust_Condition (Right_Opnd (N));
6526 Set_Etype (N, Standard_Boolean);
6527 Adjust_Result_Type (N, Typ);
437f8c1e
AC		 6528
6529 elsif Is_Intrinsic_Subprogram (Entity (N)) then
6530 Expand_Intrinsic_Call (N, Entity (N));
6531
70482933
RK		 6532 end if;
6533 end Expand_N_Op_And;
6534
6535 ------------------------
6536 -- Expand_N_Op_Concat --
6537 ------------------------
6538
6539 procedure Expand_N_Op_Concat (N : Node_Id) is
70482933
RK		 6540 Opnds : List_Id;
6541 -- List of operands to be concatenated
6542
70482933 6543 Cnode : Node_Id;
685094bf
RD		 6544 -- Node which is to be replaced by the result of concatenating the nodes
6545 -- in the list Opnds.
70482933 6546
70482933 6547 begin
fbf5a39b
AC		 6548 -- Ensure validity of both operands
6549
70482933
RK		 6550 Binary_Op_Validity_Checks (N);
6551
685094bf
RD		 6552 -- If we are the left operand of a concatenation higher up the tree,
6553 -- then do nothing for now, since we want to deal with a series of
6554 -- concatenations as a unit.
70482933
RK		 6555
6556 if Nkind (Parent (N)) = N_Op_Concat
6557 and then N = Left_Opnd (Parent (N))
6558 then
6559 return;
6560 end if;
6561
6562 -- We get here with a concatenation whose left operand may be a
6563 -- concatenation itself with a consistent type. We need to process
6564 -- these concatenation operands from left to right, which means
6565 -- from the deepest node in the tree to the highest node.
6566
6567 Cnode := N;
6568 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
6569 Cnode := Left_Opnd (Cnode);
6570 end loop;
6571
64425dff
BD		 6572 -- Now Cnode is the deepest concatenation, and its parents are the
6573 -- concatenation nodes above, so now we process bottom up, doing the
64425dff 6574 -- operands.
70482933 6575
df46b832
AC		 6576 -- The outer loop runs more than once if more than one concatenation
6577 -- type is involved.
70482933
RK		 6578
6579 Outer : loop
6580 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
6581 Set_Parent (Opnds, N);
6582
df46b832 6583 -- The inner loop gathers concatenation operands
70482933
RK		 6584
6585 Inner : while Cnode /= N
70482933
RK		 6586 and then Base_Type (Etype (Cnode)) =
6587 Base_Type (Etype (Parent (Cnode)))
6588 loop
6589 Cnode := Parent (Cnode);
6590 Append (Right_Opnd (Cnode), Opnds);
6591 end loop Inner;
6592
43c58950
AC		 6593 -- Note: The following code is a temporary workaround for N731-034
6594 -- and N829-028 and will be kept until the general issue of internal
6595 -- symbol serialization is addressed. The workaround is kept under a
6596 -- debug switch to avoid permiating into the general case.
6597
6598 -- Wrap the node to concatenate into an expression actions node to
6599 -- keep it nicely packaged. This is useful in the case of an assert
6600 -- pragma with a concatenation where we want to be able to delete
6601 -- the concatenation and all its expansion stuff.
6602
6603 if Debug_Flag_Dot_H then
6604 declare
6605 Cnod : constant Node_Id := Relocate_Node (Cnode);
6606 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
6607
6608 begin
6609 -- Note: use Rewrite rather than Replace here, so that for
6610 -- example Why_Not_Static can find the original concatenation
6611 -- node OK!
6612
6613 Rewrite (Cnode,
6614 Make_Expression_With_Actions (Sloc (Cnode),
6615 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
6616 Expression => Cnod));
6617
6618 Expand_Concatenate (Cnod, Opnds);
6619 Analyze_And_Resolve (Cnode, Typ);
6620 end;
6621
6622 -- Default case
6623
6624 else
6625 Expand_Concatenate (Cnode, Opnds);
6626 end if;
70482933
RK		 6627
6628 exit Outer when Cnode = N;
6629 Cnode := Parent (Cnode);
6630 end loop Outer;
6631 end Expand_N_Op_Concat;
6632
6633 ------------------------
6634 -- Expand_N_Op_Divide --
6635 ------------------------
6636
6637 procedure Expand_N_Op_Divide (N : Node_Id) is
f82944b7
JM		 6638 Loc : constant Source_Ptr := Sloc (N);
6639 Lopnd : constant Node_Id := Left_Opnd (N);
6640 Ropnd : constant Node_Id := Right_Opnd (N);
6641 Ltyp : constant Entity_Id := Etype (Lopnd);
6642 Rtyp : constant Entity_Id := Etype (Ropnd);
6643 Typ : Entity_Id := Etype (N);
6644 Rknow : constant Boolean := Is_Integer_Type (Typ)
6645 and then
6646 Compile_Time_Known_Value (Ropnd);
6647 Rval : Uint;
70482933
RK		 6648
6649 begin
6650 Binary_Op_Validity_Checks (N);
6651
b6b5cca8
AC		 6652 -- Check for MINIMIZED/ELIMINATED overflow mode
6653
6654 if Minimized_Eliminated_Overflow_Check (N) then
6655 Apply_Arithmetic_Overflow_Check (N);
6656 return;
6657 end if;
6658
6659 -- Otherwise proceed with expansion of division
6660
f82944b7
JM		 6661 if Rknow then
6662 Rval := Expr_Value (Ropnd);
6663 end if;
6664
70482933
RK		 6665 -- N / 1 = N for integer types
6666
f82944b7
JM		 6667 if Rknow and then Rval = Uint_1 then
6668 Rewrite (N, Lopnd);
70482933
RK		 6669 return;
6670 end if;
6671
6672 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6673 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6674 -- operand is an unsigned integer, as required for this to work.
6675
f82944b7
JM		 6676 if Nkind (Ropnd) = N_Op_Expon
6677 and then Is_Power_Of_2_For_Shift (Ropnd)
fbf5a39b
AC		 6678
6679 -- We cannot do this transformation in configurable run time mode if we
51bf9bdf 6680 -- have 64-bit integers and long shifts are not available.
fbf5a39b 6681
761f7dcb 6682 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
70482933
RK		 6683 then
6684 Rewrite (N,
6685 Make_Op_Shift_Right (Loc,
f82944b7 6686 Left_Opnd => Lopnd,
70482933 6687 Right_Opnd =>
f82944b7 6688 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
70482933
RK		 6689 Analyze_And_Resolve (N, Typ);
6690 return;
6691 end if;
6692
6693 -- Do required fixup of universal fixed operation
6694
6695 if Typ = Universal_Fixed then
6696 Fixup_Universal_Fixed_Operation (N);
6697 Typ := Etype (N);
6698 end if;
6699
6700 -- Divisions with fixed-point results
6701
6702 if Is_Fixed_Point_Type (Typ) then
6703
685094bf
RD		 6704 -- No special processing if Treat_Fixed_As_Integer is set, since
6705 -- from a semantic point of view such operations are simply integer
6706 -- operations and will be treated that way.
70482933
RK		 6707
6708 if not Treat_Fixed_As_Integer (N) then
6709 if Is_Integer_Type (Rtyp) then
6710 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
6711 else
6712 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
6713 end if;
6714 end if;
6715
685094bf
RD		 6716 -- Other cases of division of fixed-point operands. Again we exclude the
6717 -- case where Treat_Fixed_As_Integer is set.
70482933 6718
761f7dcb 6719 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
70482933
RK		 6720 and then not Treat_Fixed_As_Integer (N)
6721 then
6722 if Is_Integer_Type (Typ) then
6723 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
6724 else
6725 pragma Assert (Is_Floating_Point_Type (Typ));
6726 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
6727 end if;
6728
685094bf
RD		 6729 -- Mixed-mode operations can appear in a non-static universal context,
6730 -- in which case the integer argument must be converted explicitly.
70482933 6731
533369aa 6732 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
f82944b7
JM		 6733 Rewrite (Ropnd,
6734 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
70482933 6735
f82944b7 6736 Analyze_And_Resolve (Ropnd, Universal_Real);
70482933 6737
533369aa 6738 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
f82944b7
JM		 6739 Rewrite (Lopnd,
6740 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
70482933 6741
f82944b7 6742 Analyze_And_Resolve (Lopnd, Universal_Real);
70482933 6743
f02b8bb8 6744 -- Non-fixed point cases, do integer zero divide and overflow checks
70482933
RK		 6745
6746 elsif Is_Integer_Type (Typ) then
a91e9ac7 6747 Apply_Divide_Checks (N);
70482933 6748 end if;
dfaff97b
RD		 6749
6750 -- Overflow checks for floating-point if -gnateF mode active
6751
6752 Check_Float_Op_Overflow (N);
70482933
RK		 6753 end Expand_N_Op_Divide;
6754
6755 --------------------
6756 -- Expand_N_Op_Eq --
6757 --------------------
6758
6759 procedure Expand_N_Op_Eq (N : Node_Id) is
fbf5a39b
AC		 6760 Loc : constant Source_Ptr := Sloc (N);
6761 Typ : constant Entity_Id := Etype (N);
6762 Lhs : constant Node_Id := Left_Opnd (N);
6763 Rhs : constant Node_Id := Right_Opnd (N);
6764 Bodies : constant List_Id := New_List;
6765 A_Typ : constant Entity_Id := Etype (Lhs);
6766
70482933
RK		 6767 Typl : Entity_Id := A_Typ;
6768 Op_Name : Entity_Id;
6769 Prim : Elmt_Id;
70482933
RK		 6770
6771 procedure Build_Equality_Call (Eq : Entity_Id);
6772 -- If a constructed equality exists for the type or for its parent,
6773 -- build and analyze call, adding conversions if the operation is
6774 -- inherited.
6775
5d09245e 6776 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
8fc789c8 6777 -- Determines whether a type has a subcomponent of an unconstrained
5d09245e
AC		 6778 -- Unchecked_Union subtype. Typ is a record type.
6779
70482933
RK		 6780 -------------------------
6781 -- Build_Equality_Call --
6782 -------------------------
6783
6784 procedure Build_Equality_Call (Eq : Entity_Id) is
6785 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
cc6f5d75
AC		 6786 L_Exp : Node_Id := Relocate_Node (Lhs);
6787 R_Exp : Node_Id := Relocate_Node (Rhs);
70482933
RK		 6788
6789 begin
dda38714
AC		 6790 -- Adjust operands if necessary to comparison type
6791
70482933
RK		 6792 if Base_Type (Op_Type) /= Base_Type (A_Typ)
6793 and then not Is_Class_Wide_Type (A_Typ)
6794 then
6795 L_Exp := OK_Convert_To (Op_Type, L_Exp);
6796 R_Exp := OK_Convert_To (Op_Type, R_Exp);
6797 end if;
6798
5d09245e
AC		 6799 -- If we have an Unchecked_Union, we need to add the inferred
6800 -- discriminant values as actuals in the function call. At this
6801 -- point, the expansion has determined that both operands have
6802 -- inferable discriminants.
6803
6804 if Is_Unchecked_Union (Op_Type) then
6805 declare
fa1608c2
ES		 6806 Lhs_Type : constant Node_Id := Etype (L_Exp);
6807 Rhs_Type : constant Node_Id := Etype (R_Exp);
6808
6809 Lhs_Discr_Vals : Elist_Id;
6810 -- List of inferred discriminant values for left operand.
6811
6812 Rhs_Discr_Vals : Elist_Id;
6813 -- List of inferred discriminant values for right operand.
6814
6815 Discr : Entity_Id;
5d09245e
AC		 6816
6817 begin
fa1608c2
ES		 6818 Lhs_Discr_Vals := New_Elmt_List;
6819 Rhs_Discr_Vals := New_Elmt_List;
6820
5d09245e
AC		 6821 -- Per-object constrained selected components require special
6822 -- attention. If the enclosing scope of the component is an
f02b8bb8 6823 -- Unchecked_Union, we cannot reference its discriminants
fa1608c2
ES		 6824 -- directly. This is why we use the extra parameters of the
6825 -- equality function of the enclosing Unchecked_Union.
5d09245e
AC		 6826
6827 -- type UU_Type (Discr : Integer := 0) is
6828 -- . . .
6829 -- end record;
6830 -- pragma Unchecked_Union (UU_Type);
6831
6832 -- 1. Unchecked_Union enclosing record:
6833
6834 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6835 -- . . .
6836 -- Comp : UU_Type (Discr);
6837 -- . . .
6838 -- end Enclosing_UU_Type;
6839 -- pragma Unchecked_Union (Enclosing_UU_Type);
6840
6841 -- Obj1 : Enclosing_UU_Type;
6842 -- Obj2 : Enclosing_UU_Type (1);
6843
2717634d 6844 -- [. . .] Obj1 = Obj2 [. . .]
5d09245e
AC		 6845
6846 -- Generated code:
6847
6848 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6849
6850 -- A and B are the formal parameters of the equality function
6851 -- of Enclosing_UU_Type. The function always has two extra
fa1608c2
ES		 6852 -- formals to capture the inferred discriminant values for
6853 -- each discriminant of the type.
5d09245e
AC		 6854
6855 -- 2. Non-Unchecked_Union enclosing record:
6856
6857 -- type
6858 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6859 -- is record
6860 -- . . .
6861 -- Comp : UU_Type (Discr);
6862 -- . . .
6863 -- end Enclosing_Non_UU_Type;
6864
6865 -- Obj1 : Enclosing_Non_UU_Type;
6866 -- Obj2 : Enclosing_Non_UU_Type (1);
6867
630d30e9 6868 -- ... Obj1 = Obj2 ...
5d09245e
AC		 6869
6870 -- Generated code:
6871
6872 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6873 -- obj1.discr, obj2.discr)) then
6874
6875 -- In this case we can directly reference the discriminants of
6876 -- the enclosing record.
6877
fa1608c2 6878 -- Process left operand of equality
5d09245e
AC		 6879
6880 if Nkind (Lhs) = N_Selected_Component
533369aa
AC		 6881 and then
6882 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
5d09245e 6883 then
fa1608c2
ES		 6884 -- If enclosing record is an Unchecked_Union, use formals
6885 -- corresponding to each discriminant. The name of the
6886 -- formal is that of the discriminant, with added suffix,
6887 -- see Exp_Ch3.Build_Record_Equality for details.
5d09245e 6888
dda38714 6889 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
5d09245e 6890 then
fa1608c2
ES		 6891 Discr :=
6892 First_Discriminant
6893 (Scope (Entity (Selector_Name (Lhs))));
6894 while Present (Discr) loop
cc6f5d75
AC		 6895 Append_Elmt
6896 (Make_Identifier (Loc,
6897 Chars => New_External_Name (Chars (Discr), 'A')),
6898 To => Lhs_Discr_Vals);
fa1608c2
ES		 6899 Next_Discriminant (Discr);
6900 end loop;
5d09245e 6901
fa1608c2
ES		 6902 -- If enclosing record is of a non-Unchecked_Union type, it
6903 -- is possible to reference its discriminants directly.
5d09245e
AC		 6904
6905 else
fa1608c2
ES		 6906 Discr := First_Discriminant (Lhs_Type);
6907 while Present (Discr) loop
cc6f5d75
AC		 6908 Append_Elmt
6909 (Make_Selected_Component (Loc,
6910 Prefix => Prefix (Lhs),
6911 Selector_Name =>
6912 New_Copy
6913 (Get_Discriminant_Value (Discr,
6914 Lhs_Type,
6915 Stored_Constraint (Lhs_Type)))),
6916 To => Lhs_Discr_Vals);
fa1608c2
ES		 6917 Next_Discriminant (Discr);
6918 end loop;
5d09245e
AC		 6919 end if;
6920
fa1608c2
ES		 6921 -- Otherwise operand is on object with a constrained type.
6922 -- Infer the discriminant values from the constraint.
5d09245e
AC		 6923
6924 else
fa1608c2
ES		 6925
6926 Discr := First_Discriminant (Lhs_Type);
6927 while Present (Discr) loop
cc6f5d75
AC		 6928 Append_Elmt
6929 (New_Copy
6930 (Get_Discriminant_Value (Discr,
fa1608c2
ES		 6931 Lhs_Type,
6932 Stored_Constraint (Lhs_Type))),
cc6f5d75 6933 To => Lhs_Discr_Vals);
fa1608c2
ES		 6934 Next_Discriminant (Discr);
6935 end loop;
5d09245e
AC		 6936 end if;
6937
fa1608c2 6938 -- Similar processing for right operand of equality
5d09245e
AC		 6939
6940 if Nkind (Rhs) = N_Selected_Component
533369aa
AC		 6941 and then
6942 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
5d09245e 6943 then
5e1c00fa 6944 if Is_Unchecked_Union
cc6f5d75 6945 (Scope (Entity (Selector_Name (Rhs))))
5d09245e 6946 then
fa1608c2
ES		 6947 Discr :=
6948 First_Discriminant
6949 (Scope (Entity (Selector_Name (Rhs))));
6950 while Present (Discr) loop
cc6f5d75
AC		 6951 Append_Elmt
6952 (Make_Identifier (Loc,
6953 Chars => New_External_Name (Chars (Discr), 'B')),
6954 To => Rhs_Discr_Vals);
fa1608c2
ES		 6955 Next_Discriminant (Discr);
6956 end loop;
5d09245e
AC		 6957
6958 else
fa1608c2
ES		 6959 Discr := First_Discriminant (Rhs_Type);
6960 while Present (Discr) loop
cc6f5d75
AC		 6961 Append_Elmt
6962 (Make_Selected_Component (Loc,
6963 Prefix => Prefix (Rhs),
6964 Selector_Name =>
6965 New_Copy (Get_Discriminant_Value
6966 (Discr,
6967 Rhs_Type,
6968 Stored_Constraint (Rhs_Type)))),
6969 To => Rhs_Discr_Vals);
fa1608c2
ES		 6970 Next_Discriminant (Discr);
6971 end loop;
5d09245e 6972 end if;
5d09245e 6973
fa1608c2
ES		 6974 else
6975 Discr := First_Discriminant (Rhs_Type);
6976 while Present (Discr) loop
cc6f5d75
AC		 6977 Append_Elmt
6978 (New_Copy (Get_Discriminant_Value
6979 (Discr,
6980 Rhs_Type,
6981 Stored_Constraint (Rhs_Type))),
6982 To => Rhs_Discr_Vals);
fa1608c2
ES		 6983 Next_Discriminant (Discr);
6984 end loop;
5d09245e
AC		 6985 end if;
6986
fa1608c2
ES		 6987 -- Now merge the list of discriminant values so that values
6988 -- of corresponding discriminants are adjacent.
6989
6990 declare
6991 Params : List_Id;
6992 L_Elmt : Elmt_Id;
6993 R_Elmt : Elmt_Id;
6994
6995 begin
6996 Params := New_List (L_Exp, R_Exp);
6997 L_Elmt := First_Elmt (Lhs_Discr_Vals);
6998 R_Elmt := First_Elmt (Rhs_Discr_Vals);
6999 while Present (L_Elmt) loop
7000 Append_To (Params, Node (L_Elmt));
7001 Append_To (Params, Node (R_Elmt));
7002 Next_Elmt (L_Elmt);
7003 Next_Elmt (R_Elmt);
7004 end loop;
7005
7006 Rewrite (N,
7007 Make_Function_Call (Loc,
e4494292 7008 Name => New_Occurrence_Of (Eq, Loc),
fa1608c2
ES		 7009 Parameter_Associations => Params));
7010 end;
5d09245e
AC		 7011 end;
7012
7013 -- Normal case, not an unchecked union
7014
7015 else
7016 Rewrite (N,
7017 Make_Function_Call (Loc,
e4494292 7018 Name => New_Occurrence_Of (Eq, Loc),
5d09245e
AC		 7019 Parameter_Associations => New_List (L_Exp, R_Exp)));
7020 end if;
70482933
RK		 7021
7022 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7023 end Build_Equality_Call;
7024
5d09245e
AC		 7025 ------------------------------------
7026 -- Has_Unconstrained_UU_Component --
7027 ------------------------------------
7028
7029 function Has_Unconstrained_UU_Component
7030 (Typ : Node_Id) return Boolean
7031 is
7032 Tdef : constant Node_Id :=
57848bf7 7033 Type_Definition (Declaration_Node (Base_Type (Typ)));
5d09245e
AC		 7034 Clist : Node_Id;
7035 Vpart : Node_Id;
7036
7037 function Component_Is_Unconstrained_UU
7038 (Comp : Node_Id) return Boolean;
7039 -- Determines whether the subtype of the component is an
7040 -- unconstrained Unchecked_Union.
7041
7042 function Variant_Is_Unconstrained_UU
7043 (Variant : Node_Id) return Boolean;
7044 -- Determines whether a component of the variant has an unconstrained
7045 -- Unchecked_Union subtype.
7046
7047 -----------------------------------
7048 -- Component_Is_Unconstrained_UU --
7049 -----------------------------------
7050
7051 function Component_Is_Unconstrained_UU
7052 (Comp : Node_Id) return Boolean
7053 is
7054 begin
7055 if Nkind (Comp) /= N_Component_Declaration then
7056 return False;
7057 end if;
7058
7059 declare
7060 Sindic : constant Node_Id :=
7061 Subtype_Indication (Component_Definition (Comp));
7062
7063 begin
7064 -- Unconstrained nominal type. In the case of a constraint
7065 -- present, the node kind would have been N_Subtype_Indication.
7066
7067 if Nkind (Sindic) = N_Identifier then
7068 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7069 end if;
7070
7071 return False;
7072 end;
7073 end Component_Is_Unconstrained_UU;
7074
7075 ---------------------------------
7076 -- Variant_Is_Unconstrained_UU --
7077 ---------------------------------
7078
7079 function Variant_Is_Unconstrained_UU
7080 (Variant : Node_Id) return Boolean
7081 is
7082 Clist : constant Node_Id := Component_List (Variant);
7083
7084 begin
7085 if Is_Empty_List (Component_Items (Clist)) then
7086 return False;
7087 end if;
7088
f02b8bb8
RD		 7089 -- We only need to test one component
7090
5d09245e
AC		 7091 declare
7092 Comp : Node_Id := First (Component_Items (Clist));
7093
7094 begin
7095 while Present (Comp) loop
5d09245e
AC		 7096 if Component_Is_Unconstrained_UU (Comp) then
7097 return True;
7098 end if;
7099
7100 Next (Comp);
7101 end loop;
7102 end;
7103
7104 -- None of the components withing the variant were of
7105 -- unconstrained Unchecked_Union type.
7106
7107 return False;
7108 end Variant_Is_Unconstrained_UU;
7109
7110 -- Start of processing for Has_Unconstrained_UU_Component
7111
7112 begin
7113 if Null_Present (Tdef) then
7114 return False;
7115 end if;
7116
7117 Clist := Component_List (Tdef);
7118 Vpart := Variant_Part (Clist);
7119
7120 -- Inspect available components
7121
7122 if Present (Component_Items (Clist)) then
7123 declare
7124 Comp : Node_Id := First (Component_Items (Clist));
7125
7126 begin
7127 while Present (Comp) loop
7128
8fc789c8 7129 -- One component is sufficient
5d09245e
AC		 7130
7131 if Component_Is_Unconstrained_UU (Comp) then
7132 return True;
7133 end if;
7134
7135 Next (Comp);
7136 end loop;
7137 end;
7138 end if;
7139
7140 -- Inspect available components withing variants
7141
7142 if Present (Vpart) then
7143 declare
7144 Variant : Node_Id := First (Variants (Vpart));
7145
7146 begin
7147 while Present (Variant) loop
7148
8fc789c8 7149 -- One component within a variant is sufficient
5d09245e
AC		 7150
7151 if Variant_Is_Unconstrained_UU (Variant) then
7152 return True;
7153 end if;
7154
7155 Next (Variant);
7156 end loop;
7157 end;
7158 end if;
7159
7160 -- Neither the available components, nor the components inside the
7161 -- variant parts were of an unconstrained Unchecked_Union subtype.
7162
7163 return False;
7164 end Has_Unconstrained_UU_Component;
7165
70482933
RK		 7166 -- Start of processing for Expand_N_Op_Eq
7167
7168 begin
7169 Binary_Op_Validity_Checks (N);
7170
456cbfa5
AC		 7171 -- Deal with private types
7172
70482933
RK		 7173 if Ekind (Typl) = E_Private_Type then
7174 Typl := Underlying_Type (Typl);
70482933
RK		 7175 elsif Ekind (Typl) = E_Private_Subtype then
7176 Typl := Underlying_Type (Base_Type (Typl));
f02b8bb8
RD		 7177 else
7178 null;
70482933
RK		 7179 end if;
7180
7181 -- It may happen in error situations that the underlying type is not
7182 -- set. The error will be detected later, here we just defend the
7183 -- expander code.
7184
7185 if No (Typl) then
7186 return;
7187 end if;
7188
a92230c5
AC		 7189 -- Now get the implementation base type (note that plain Base_Type here
7190 -- might lead us back to the private type, which is not what we want!)
7191
7192 Typl := Implementation_Base_Type (Typl);
70482933 7193
dda38714
AC		 7194 -- Equality between variant records results in a call to a routine
7195 -- that has conditional tests of the discriminant value(s), and hence
7196 -- violates the No_Implicit_Conditionals restriction.
7197
7198 if Has_Variant_Part (Typl) then
7199 declare
7200 Msg : Boolean;
7201
7202 begin
7203 Check_Restriction (Msg, No_Implicit_Conditionals, N);
7204
7205 if Msg then
7206 Error_Msg_N
7207 ("\comparison of variant records tests discriminants", N);
7208 return;
7209 end if;
7210 end;
7211 end if;
7212
456cbfa5 7213 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
60b68e56 7214 -- means we no longer have a comparison operation, we are all done.
456cbfa5
AC		 7215
7216 Expand_Compare_Minimize_Eliminate_Overflow (N);
7217
7218 if Nkind (N) /= N_Op_Eq then
7219 return;
7220 end if;
7221
70482933
RK		 7222 -- Boolean types (requiring handling of non-standard case)
7223
f02b8bb8 7224 if Is_Boolean_Type (Typl) then
70482933
RK		 7225 Adjust_Condition (Left_Opnd (N));
7226 Adjust_Condition (Right_Opnd (N));
7227 Set_Etype (N, Standard_Boolean);
7228 Adjust_Result_Type (N, Typ);
7229
7230 -- Array types
7231
7232 elsif Is_Array_Type (Typl) then
7233
1033834f
RD		 7234 -- If we are doing full validity checking, and it is possible for the
7235 -- array elements to be invalid then expand out array comparisons to
7236 -- make sure that we check the array elements.
fbf5a39b 7237
1033834f
RD		 7238 if Validity_Check_Operands
7239 and then not Is_Known_Valid (Component_Type (Typl))
7240 then
fbf5a39b
AC		 7241 declare
7242 Save_Force_Validity_Checks : constant Boolean :=
7243 Force_Validity_Checks;
7244 begin
7245 Force_Validity_Checks := True;
7246 Rewrite (N,
0da2c8ac
AC		 7247 Expand_Array_Equality
7248 (N,
7249 Relocate_Node (Lhs),
7250 Relocate_Node (Rhs),
7251 Bodies,
7252 Typl));
7253 Insert_Actions (N, Bodies);
fbf5a39b
AC		 7254 Analyze_And_Resolve (N, Standard_Boolean);
7255 Force_Validity_Checks := Save_Force_Validity_Checks;
7256 end;
7257
a9d8907c 7258 -- Packed case where both operands are known aligned
70482933 7259
a9d8907c
JM		 7260 elsif Is_Bit_Packed_Array (Typl)
7261 and then not Is_Possibly_Unaligned_Object (Lhs)
7262 and then not Is_Possibly_Unaligned_Object (Rhs)
7263 then
70482933
RK		 7264 Expand_Packed_Eq (N);
7265
5e1c00fa
RD		 7266 -- Where the component type is elementary we can use a block bit
7267 -- comparison (if supported on the target) exception in the case
7268 -- of floating-point (negative zero issues require element by
7269 -- element comparison), and atomic types (where we must be sure
a9d8907c 7270 -- to load elements independently) and possibly unaligned arrays.
70482933 7271
70482933
RK		 7272 elsif Is_Elementary_Type (Component_Type (Typl))
7273 and then not Is_Floating_Point_Type (Component_Type (Typl))
5e1c00fa 7274 and then not Is_Atomic (Component_Type (Typl))
a9d8907c
JM		 7275 and then not Is_Possibly_Unaligned_Object (Lhs)
7276 and then not Is_Possibly_Unaligned_Object (Rhs)
fbf5a39b 7277 and then Support_Composite_Compare_On_Target
70482933
RK		 7278 then
7279 null;
7280
685094bf
RD		 7281 -- For composite and floating-point cases, expand equality loop to
7282 -- make sure of using proper comparisons for tagged types, and
7283 -- correctly handling the floating-point case.
70482933
RK		 7284
7285 else
7286 Rewrite (N,
0da2c8ac
AC		 7287 Expand_Array_Equality
7288 (N,
7289 Relocate_Node (Lhs),
7290 Relocate_Node (Rhs),
7291 Bodies,
7292 Typl));
70482933
RK		 7293 Insert_Actions (N, Bodies, Suppress => All_Checks);
7294 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7295 end if;
7296
7297 -- Record Types
7298
7299 elsif Is_Record_Type (Typl) then
7300
7301 -- For tagged types, use the primitive "="
7302
7303 if Is_Tagged_Type (Typl) then
7304
0669bebe
GB		 7305 -- No need to do anything else compiling under restriction
7306 -- No_Dispatching_Calls. During the semantic analysis we
7307 -- already notified such violation.
7308
7309 if Restriction_Active (No_Dispatching_Calls) then
7310 return;
7311 end if;
7312
685094bf
RD		 7313 -- If this is derived from an untagged private type completed with
7314 -- a tagged type, it does not have a full view, so we use the
7315 -- primitive operations of the private type. This check should no
7316 -- longer be necessary when these types get their full views???
70482933
RK		 7317
7318 if Is_Private_Type (A_Typ)
7319 and then not Is_Tagged_Type (A_Typ)
7320 and then Is_Derived_Type (A_Typ)
7321 and then No (Full_View (A_Typ))
7322 then
685094bf
RD		 7323 -- Search for equality operation, checking that the operands
7324 -- have the same type. Note that we must find a matching entry,
a90bd866 7325 -- or something is very wrong.
2e071734 7326
70482933
RK		 7327 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
7328
2e071734
AC		 7329 while Present (Prim) loop
7330 exit when Chars (Node (Prim)) = Name_Op_Eq
7331 and then Etype (First_Formal (Node (Prim))) =
7332 Etype (Next_Formal (First_Formal (Node (Prim))))
7333 and then
7334 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7335
70482933 7336 Next_Elmt (Prim);
70482933
RK		 7337 end loop;
7338
2e071734 7339 pragma Assert (Present (Prim));
70482933 7340 Op_Name := Node (Prim);
fbf5a39b
AC		 7341
7342 -- Find the type's predefined equality or an overriding
3dddb11e 7343 -- user-defined equality. The reason for not simply calling
fbf5a39b 7344 -- Find_Prim_Op here is that there may be a user-defined
3dddb11e
ES		 7345 -- overloaded equality op that precedes the equality that we
7346 -- want, so we have to explicitly search (e.g., there could be
7347 -- an equality with two different parameter types).
fbf5a39b 7348
70482933 7349 else
fbf5a39b 7350 if Is_Class_Wide_Type (Typl) then
3dddb11e 7351 Typl := Find_Specific_Type (Typl);
fbf5a39b
AC		 7352 end if;
7353
7354 Prim := First_Elmt (Primitive_Operations (Typl));
fbf5a39b
AC		 7355 while Present (Prim) loop
7356 exit when Chars (Node (Prim)) = Name_Op_Eq
7357 and then Etype (First_Formal (Node (Prim))) =
7358 Etype (Next_Formal (First_Formal (Node (Prim))))
12e0c41c
AC		 7359 and then
7360 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
fbf5a39b
AC		 7361
7362 Next_Elmt (Prim);
fbf5a39b
AC		 7363 end loop;
7364
2e071734 7365 pragma Assert (Present (Prim));
fbf5a39b 7366 Op_Name := Node (Prim);
70482933
RK		 7367 end if;
7368
7369 Build_Equality_Call (Op_Name);
7370
5d09245e
AC		 7371 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7372 -- predefined equality operator for a type which has a subcomponent
7373 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7374
7375 elsif Has_Unconstrained_UU_Component (Typl) then
7376 Insert_Action (N,
7377 Make_Raise_Program_Error (Loc,
7378 Reason => PE_Unchecked_Union_Restriction));
7379
7380 -- Prevent Gigi from generating incorrect code by rewriting the
6cb3037c 7381 -- equality as a standard False. (is this documented somewhere???)
5d09245e
AC		 7382
7383 Rewrite (N,
7384 New_Occurrence_Of (Standard_False, Loc));
7385
7386 elsif Is_Unchecked_Union (Typl) then
7387
7388 -- If we can infer the discriminants of the operands, we make a
7389 -- call to the TSS equality function.
7390
7391 if Has_Inferable_Discriminants (Lhs)
7392 and then
7393 Has_Inferable_Discriminants (Rhs)
7394 then
7395 Build_Equality_Call
7396 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7397
7398 else
7399 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7400 -- the predefined equality operator for an Unchecked_Union type
7401 -- if either of the operands lack inferable discriminants.
7402
7403 Insert_Action (N,
7404 Make_Raise_Program_Error (Loc,
7405 Reason => PE_Unchecked_Union_Restriction));
7406
29ad9ea5
AC		 7407 -- Emit a warning on source equalities only, otherwise the
7408 -- message may appear out of place due to internal use. The
7409 -- warning is unconditional because it is required by the
7410 -- language.
7411
7412 if Comes_From_Source (N) then
7413 Error_Msg_N
facfa165 7414 ("Unchecked_Union discriminants cannot be determined??",
29ad9ea5
AC		 7415 N);
7416 Error_Msg_N
facfa165 7417 ("\Program_Error will be raised for equality operation??",
29ad9ea5
AC		 7418 N);
7419 end if;
7420
5d09245e 7421 -- Prevent Gigi from generating incorrect code by rewriting
6cb3037c 7422 -- the equality as a standard False (documented where???).
5d09245e
AC		 7423
7424 Rewrite (N,
7425 New_Occurrence_Of (Standard_False, Loc));
5d09245e
AC		 7426 end if;
7427
70482933
RK		 7428 -- If a type support function is present (for complex cases), use it
7429
fbf5a39b
AC		 7430 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
7431 Build_Equality_Call
7432 (TSS (Root_Type (Typl), TSS_Composite_Equality));
70482933 7433
8d80ff64
AC		 7434 -- When comparing two Bounded_Strings, use the primitive equality of
7435 -- the root Super_String type.
7436
7437 elsif Is_Bounded_String (Typl) then
7438 Prim :=
7439 First_Elmt (Collect_Primitive_Operations (Root_Type (Typl)));
7440
7441 while Present (Prim) loop
7442 exit when Chars (Node (Prim)) = Name_Op_Eq
7443 and then Etype (First_Formal (Node (Prim))) =
7444 Etype (Next_Formal (First_Formal (Node (Prim))))
7445 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7446
7447 Next_Elmt (Prim);
7448 end loop;
7449
7450 -- A Super_String type should always have a primitive equality
7451
7452 pragma Assert (Present (Prim));
7453 Build_Equality_Call (Node (Prim));
7454
70482933 7455 -- Otherwise expand the component by component equality. Note that
8fc789c8 7456 -- we never use block-bit comparisons for records, because of the
70482933
RK		 7457 -- problems with gaps. The backend will often be able to recombine
7458 -- the separate comparisons that we generate here.
7459
7460 else
7461 Remove_Side_Effects (Lhs);
7462 Remove_Side_Effects (Rhs);
7463 Rewrite (N,
7464 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
7465
7466 Insert_Actions (N, Bodies, Suppress => All_Checks);
7467 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7468 end if;
7469 end if;
7470
d26dc4b5 7471 -- Test if result is known at compile time
70482933 7472
d26dc4b5 7473 Rewrite_Comparison (N);
f02b8bb8 7474
0580d807 7475 Optimize_Length_Comparison (N);
70482933
RK		 7476 end Expand_N_Op_Eq;
7477
7478 -----------------------
7479 -- Expand_N_Op_Expon --
7480 -----------------------
7481
7482 procedure Expand_N_Op_Expon (N : Node_Id) is
7483 Loc : constant Source_Ptr := Sloc (N);
7484 Typ : constant Entity_Id := Etype (N);
7485 Rtyp : constant Entity_Id := Root_Type (Typ);
7486 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
07fc65c4 7487 Bastyp : constant Node_Id := Etype (Base);
70482933
RK		 7488 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
7489 Exptyp : constant Entity_Id := Etype (Exp);
7490 Ovflo : constant Boolean := Do_Overflow_Check (N);
7491 Expv : Uint;
70482933
RK		 7492 Temp : Node_Id;
7493 Rent : RE_Id;
7494 Ent : Entity_Id;
fbf5a39b 7495 Etyp : Entity_Id;
cb42ba5d 7496 Xnode : Node_Id;
70482933
RK		 7497
7498 begin
7499 Binary_Op_Validity_Checks (N);
7500
5114f3ff 7501 -- CodePeer wants to see the unexpanded N_Op_Expon node
8f66cda7 7502
5114f3ff 7503 if CodePeer_Mode then
8f66cda7
AC		 7504 return;
7505 end if;
7506
685094bf
RD		 7507 -- If either operand is of a private type, then we have the use of an
7508 -- intrinsic operator, and we get rid of the privateness, by using root
7509 -- types of underlying types for the actual operation. Otherwise the
7510 -- private types will cause trouble if we expand multiplications or
7511 -- shifts etc. We also do this transformation if the result type is
7512 -- different from the base type.
07fc65c4
GB		 7513
7514 if Is_Private_Type (Etype (Base))
8f66cda7
AC		 7515 or else Is_Private_Type (Typ)
7516 or else Is_Private_Type (Exptyp)
7517 or else Rtyp /= Root_Type (Bastyp)
07fc65c4
GB		 7518 then
7519 declare
7520 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
7521 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
07fc65c4
GB		 7522 begin
7523 Rewrite (N,
7524 Unchecked_Convert_To (Typ,
7525 Make_Op_Expon (Loc,
7526 Left_Opnd => Unchecked_Convert_To (Bt, Base),
7527 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
7528 Analyze_And_Resolve (N, Typ);
7529 return;
7530 end;
7531 end if;
7532
b6b5cca8 7533 -- Check for MINIMIZED/ELIMINATED overflow mode
6cb3037c 7534
b6b5cca8 7535 if Minimized_Eliminated_Overflow_Check (N) then
6cb3037c
AC		 7536 Apply_Arithmetic_Overflow_Check (N);
7537 return;
7538 end if;
7539
cb42ba5d
AC		 7540 -- Test for case of known right argument where we can replace the
7541 -- exponentiation by an equivalent expression using multiplication.
70482933 7542
6c3c671e
AC		 7543 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7544 -- configurable run-time mode, we may not have the exponentiation
7545 -- routine available, and we don't want the legality of the program
7546 -- to depend on how clever the compiler is in knowing values.
7547
7548 if CRT_Safe_Compile_Time_Known_Value (Exp) then
70482933
RK		 7549 Expv := Expr_Value (Exp);
7550
7551 -- We only fold small non-negative exponents. You might think we
7552 -- could fold small negative exponents for the real case, but we
7553 -- can't because we are required to raise Constraint_Error for
7554 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7555 -- See ACVC test C4A012B.
7556
7557 if Expv >= 0 and then Expv <= 4 then
7558
7559 -- X ** 0 = 1 (or 1.0)
7560
7561 if Expv = 0 then
abcbd24c
ST		 7562
7563 -- Call Remove_Side_Effects to ensure that any side effects
7564 -- in the ignored left operand (in particular function calls
7565 -- to user defined functions) are properly executed.
7566
7567 Remove_Side_Effects (Base);
7568
70482933
RK		 7569 if Ekind (Typ) in Integer_Kind then
7570 Xnode := Make_Integer_Literal (Loc, Intval => 1);
7571 else
7572 Xnode := Make_Real_Literal (Loc, Ureal_1);
7573 end if;
7574
7575 -- X ** 1 = X
7576
7577 elsif Expv = 1 then
7578 Xnode := Base;
7579
7580 -- X ** 2 = X * X
7581
7582 elsif Expv = 2 then
7583 Xnode :=
7584 Make_Op_Multiply (Loc,
7585 Left_Opnd => Duplicate_Subexpr (Base),
fbf5a39b 7586 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
70482933
RK		 7587
7588 -- X ** 3 = X * X * X
7589
7590 elsif Expv = 3 then
7591 Xnode :=
7592 Make_Op_Multiply (Loc,
7593 Left_Opnd =>
7594 Make_Op_Multiply (Loc,
7595 Left_Opnd => Duplicate_Subexpr (Base),
fbf5a39b
AC		 7596 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
7597 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
70482933
RK		 7598
7599 -- X ** 4 ->
cb42ba5d
AC		 7600
7601 -- do
70482933 7602 -- En : constant base'type := base * base;
cb42ba5d 7603 -- in
70482933
RK		 7604 -- En * En
7605
cb42ba5d
AC		 7606 else
7607 pragma Assert (Expv = 4);
191fcb3a 7608 Temp := Make_Temporary (Loc, 'E', Base);
70482933 7609
cb42ba5d
AC		 7610 Xnode :=
7611 Make_Expression_With_Actions (Loc,
7612 Actions => New_List (
7613 Make_Object_Declaration (Loc,
7614 Defining_Identifier => Temp,
7615 Constant_Present => True,
e4494292 7616 Object_Definition => New_Occurrence_Of (Typ, Loc),
cb42ba5d
AC		 7617 Expression =>
7618 Make_Op_Multiply (Loc,
7619 Left_Opnd =>
7620 Duplicate_Subexpr (Base),
7621 Right_Opnd =>
7622 Duplicate_Subexpr_No_Checks (Base)))),
7623
70482933
RK		 7624 Expression =>
7625 Make_Op_Multiply (Loc,
e4494292
RD		 7626 Left_Opnd => New_Occurrence_Of (Temp, Loc),
7627 Right_Opnd => New_Occurrence_Of (Temp, Loc)));
70482933
RK		 7628 end if;
7629
7630 Rewrite (N, Xnode);
7631 Analyze_And_Resolve (N, Typ);
7632 return;
7633 end if;
7634 end if;
7635
7636 -- Case of (2 ** expression) appearing as an argument of an integer
7637 -- multiplication, or as the right argument of a division of a non-
fbf5a39b 7638 -- negative integer. In such cases we leave the node untouched, setting
70482933
RK		 7639 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7640 -- of the higher level node converts it into a shift.
7641
51bf9bdf
AC		 7642 -- Another case is 2 ** N in any other context. We simply convert
7643 -- this to 1 * 2 ** N, and then the above transformation applies.
7644
685094bf
RD		 7645 -- Note: this transformation is not applicable for a modular type with
7646 -- a non-binary modulus in the multiplication case, since we get a wrong
7647 -- result if the shift causes an overflow before the modular reduction.
7648
8b4230c8
AC		 7649 -- Note: we used to check that Exptyp was an unsigned type. But that is
7650 -- an unnecessary check, since if Exp is negative, we have a run-time
7651 -- error that is either caught (so we get the right result) or we have
7652 -- suppressed the check, in which case the code is erroneous anyway.
7653
70482933 7654 if Nkind (Base) = N_Integer_Literal
6c3c671e
AC		 7655 and then CRT_Safe_Compile_Time_Known_Value (Base)
7656 and then Expr_Value (Base) = Uint_2
70482933
RK		 7657 and then Is_Integer_Type (Root_Type (Exptyp))
7658 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
70482933 7659 and then not Ovflo
70482933 7660 then
51bf9bdf 7661 -- First the multiply and divide cases
70482933 7662
51bf9bdf
AC		 7663 if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
7664 declare
7665 P : constant Node_Id := Parent (N);
7666 L : constant Node_Id := Left_Opnd (P);
7667 R : constant Node_Id := Right_Opnd (P);
7668
7669 begin
7670 if (Nkind (P) = N_Op_Multiply
7671 and then not Non_Binary_Modulus (Typ)
7672 and then
7673 ((Is_Integer_Type (Etype (L)) and then R = N)
7674 or else
7675 (Is_Integer_Type (Etype (R)) and then L = N))
7676 and then not Do_Overflow_Check (P))
7677 or else
7678 (Nkind (P) = N_Op_Divide
533369aa
AC		 7679 and then Is_Integer_Type (Etype (L))
7680 and then Is_Unsigned_Type (Etype (L))
7681 and then R = N
7682 and then not Do_Overflow_Check (P))
51bf9bdf
AC		 7683 then
7684 Set_Is_Power_Of_2_For_Shift (N);
7685 return;
7686 end if;
7687 end;
7688
7689 -- Now the other cases
7690
7691 elsif not Non_Binary_Modulus (Typ) then
7692 Rewrite (N,
7693 Make_Op_Multiply (Loc,
7694 Left_Opnd => Make_Integer_Literal (Loc, 1),
7695 Right_Opnd => Relocate_Node (N)));
7696 Analyze_And_Resolve (N, Typ);
7697 return;
7698 end if;
70482933
RK		 7699 end if;
7700
07fc65c4
GB		 7701 -- Fall through if exponentiation must be done using a runtime routine
7702
07fc65c4 7703 -- First deal with modular case
70482933
RK		 7704
7705 if Is_Modular_Integer_Type (Rtyp) then
7706
7707 -- Non-binary case, we call the special exponentiation routine for
7708 -- the non-binary case, converting the argument to Long_Long_Integer
7709 -- and passing the modulus value. Then the result is converted back
7710 -- to the base type.
7711
7712 if Non_Binary_Modulus (Rtyp) then
70482933
RK		 7713 Rewrite (N,
7714 Convert_To (Typ,
7715 Make_Function_Call (Loc,
cc6f5d75
AC		 7716 Name =>
7717 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
70482933 7718 Parameter_Associations => New_List (
e9daba51 7719 Convert_To (RTE (RE_Unsigned), Base),
70482933
RK		 7720 Make_Integer_Literal (Loc, Modulus (Rtyp)),
7721 Exp))));
7722
685094bf
RD		 7723 -- Binary case, in this case, we call one of two routines, either the
7724 -- unsigned integer case, or the unsigned long long integer case,
7725 -- with a final "and" operation to do the required mod.
70482933
RK		 7726
7727 else
7728 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
7729 Ent := RTE (RE_Exp_Unsigned);
7730 else
7731 Ent := RTE (RE_Exp_Long_Long_Unsigned);
7732 end if;
7733
7734 Rewrite (N,
7735 Convert_To (Typ,
7736 Make_Op_And (Loc,
cc6f5d75 7737 Left_Opnd =>
70482933 7738 Make_Function_Call (Loc,
cc6f5d75 7739 Name => New_Occurrence_Of (Ent, Loc),
70482933
RK		 7740 Parameter_Associations => New_List (
7741 Convert_To (Etype (First_Formal (Ent)), Base),
7742 Exp)),
7743 Right_Opnd =>
7744 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
7745
7746 end if;
7747
7748 -- Common exit point for modular type case
7749
7750 Analyze_And_Resolve (N, Typ);
7751 return;
7752
fbf5a39b
AC		 7753 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7754 -- It is not worth having routines for Short_[Short_]Integer, since for
7755 -- most machines it would not help, and it would generate more code that
dfd99a80 7756 -- might need certification when a certified run time is required.
70482933 7757
fbf5a39b 7758 -- In the integer cases, we have two routines, one for when overflow
dfd99a80
TQ		 7759 -- checks are required, and one when they are not required, since there
7760 -- is a real gain in omitting checks on many machines.
70482933 7761
fbf5a39b
AC		 7762 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
7763 or else (Rtyp = Base_Type (Standard_Long_Integer)
761f7dcb
AC		 7764 and then
7765 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
7766 or else Rtyp = Universal_Integer
70482933 7767 then
fbf5a39b
AC		 7768 Etyp := Standard_Long_Long_Integer;
7769
ebb6b0bd
AC		 7770 -- Overflow checking is the only choice on the AAMP target, where
7771 -- arithmetic instructions check overflow automatically, so only
7772 -- one version of the exponentiation unit is needed.
7773
1037b0f4 7774 if Ovflo or AAMP_On_Target then
70482933
RK		 7775 Rent := RE_Exp_Long_Long_Integer;
7776 else
7777 Rent := RE_Exn_Long_Long_Integer;
7778 end if;
7779
fbf5a39b
AC		 7780 elsif Is_Signed_Integer_Type (Rtyp) then
7781 Etyp := Standard_Integer;
70482933 7782
ebb6b0bd
AC		 7783 -- Overflow checking is the only choice on the AAMP target, where
7784 -- arithmetic instructions check overflow automatically, so only
7785 -- one version of the exponentiation unit is needed.
7786
1037b0f4 7787 if Ovflo or AAMP_On_Target then
fbf5a39b 7788 Rent := RE_Exp_Integer;
70482933 7789 else
fbf5a39b 7790 Rent := RE_Exn_Integer;
70482933 7791 end if;
fbf5a39b
AC		 7792
7793 -- Floating-point cases, always done using Long_Long_Float. We do not
7794 -- need separate routines for the overflow case here, since in the case
7795 -- of floating-point, we generate infinities anyway as a rule (either
7796 -- that or we automatically trap overflow), and if there is an infinity
7797 -- generated and a range check is required, the check will fail anyway.
7798
7799 else
7800 pragma Assert (Is_Floating_Point_Type (Rtyp));
7801 Etyp := Standard_Long_Long_Float;
7802 Rent := RE_Exn_Long_Long_Float;
70482933
RK		 7803 end if;
7804
7805 -- Common processing for integer cases and floating-point cases.
fbf5a39b 7806 -- If we are in the right type, we can call runtime routine directly
70482933 7807
fbf5a39b 7808 if Typ = Etyp
70482933
RK		 7809 and then Rtyp /= Universal_Integer
7810 and then Rtyp /= Universal_Real
7811 then
7812 Rewrite (N,
7813 Make_Function_Call (Loc,
e4494292 7814 Name => New_Occurrence_Of (RTE (Rent), Loc),
70482933
RK		 7815 Parameter_Associations => New_List (Base, Exp)));
7816
7817 -- Otherwise we have to introduce conversions (conversions are also
fbf5a39b 7818 -- required in the universal cases, since the runtime routine is
1147c704 7819 -- typed using one of the standard types).
70482933
RK		 7820
7821 else
7822 Rewrite (N,
7823 Convert_To (Typ,
7824 Make_Function_Call (Loc,
e4494292 7825 Name => New_Occurrence_Of (RTE (Rent), Loc),
70482933 7826 Parameter_Associations => New_List (
fbf5a39b 7827 Convert_To (Etyp, Base),
70482933
RK		 7828 Exp))));
7829 end if;
7830
7831 Analyze_And_Resolve (N, Typ);
7832 return;
7833
fbf5a39b
AC		 7834 exception
7835 when RE_Not_Available =>
7836 return;
70482933
RK		 7837 end Expand_N_Op_Expon;
7838
7839 --------------------
7840 -- Expand_N_Op_Ge --
7841 --------------------
7842
7843 procedure Expand_N_Op_Ge (N : Node_Id) is
7844 Typ : constant Entity_Id := Etype (N);
7845 Op1 : constant Node_Id := Left_Opnd (N);
7846 Op2 : constant Node_Id := Right_Opnd (N);
7847 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7848
7849 begin
7850 Binary_Op_Validity_Checks (N);
7851
456cbfa5 7852 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
60b68e56 7853 -- means we no longer have a comparison operation, we are all done.
456cbfa5
AC		 7854
7855 Expand_Compare_Minimize_Eliminate_Overflow (N);
7856
7857 if Nkind (N) /= N_Op_Ge then
7858 return;
7859 end if;
7860
7861 -- Array type case
7862
f02b8bb8 7863 if Is_Array_Type (Typ1) then
70482933
RK		 7864 Expand_Array_Comparison (N);
7865 return;
7866 end if;
7867
456cbfa5
AC		 7868 -- Deal with boolean operands
7869
70482933
RK		 7870 if Is_Boolean_Type (Typ1) then
7871 Adjust_Condition (Op1);
7872 Adjust_Condition (Op2);
7873 Set_Etype (N, Standard_Boolean);
7874 Adjust_Result_Type (N, Typ);
7875 end if;
7876
7877 Rewrite_Comparison (N);
f02b8bb8 7878
0580d807 7879 Optimize_Length_Comparison (N);
70482933
RK		 7880 end Expand_N_Op_Ge;
7881
7882 --------------------
7883 -- Expand_N_Op_Gt --
7884 --------------------
7885
7886 procedure Expand_N_Op_Gt (N : Node_Id) is
7887 Typ : constant Entity_Id := Etype (N);
7888 Op1 : constant Node_Id := Left_Opnd (N);
7889 Op2 : constant Node_Id := Right_Opnd (N);
7890 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7891
7892 begin
7893 Binary_Op_Validity_Checks (N);
7894
456cbfa5 7895 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
60b68e56 7896 -- means we no longer have a comparison operation, we are all done.
456cbfa5
AC		 7897
7898 Expand_Compare_Minimize_Eliminate_Overflow (N);
7899
7900 if Nkind (N) /= N_Op_Gt then
7901 return;
7902 end if;
7903
7904 -- Deal with array type operands
7905
f02b8bb8 7906 if Is_Array_Type (Typ1) then
70482933
RK		 7907 Expand_Array_Comparison (N);
7908 return;
7909 end if;
7910
456cbfa5
AC		 7911 -- Deal with boolean type operands
7912
70482933
RK		 7913 if Is_Boolean_Type (Typ1) then
7914 Adjust_Condition (Op1);
7915 Adjust_Condition (Op2);
7916 Set_Etype (N, Standard_Boolean);
7917 Adjust_Result_Type (N, Typ);
7918 end if;
7919
7920 Rewrite_Comparison (N);
f02b8bb8 7921
0580d807 7922 Optimize_Length_Comparison (N);
70482933
RK		 7923 end Expand_N_Op_Gt;
7924
7925 --------------------
7926 -- Expand_N_Op_Le --
7927 --------------------
7928
7929 procedure Expand_N_Op_Le (N : Node_Id) is
7930 Typ : constant Entity_Id := Etype (N);
7931 Op1 : constant Node_Id := Left_Opnd (N);
7932 Op2 : constant Node_Id := Right_Opnd (N);
7933 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7934
7935 begin
7936 Binary_Op_Validity_Checks (N);
7937
456cbfa5 7938 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
60b68e56 7939 -- means we no longer have a comparison operation, we are all done.
456cbfa5
AC		 7940
7941 Expand_Compare_Minimize_Eliminate_Overflow (N);
7942
7943 if Nkind (N) /= N_Op_Le then
7944 return;
7945 end if;
7946
7947 -- Deal with array type operands
7948
f02b8bb8 7949 if Is_Array_Type (Typ1) then
70482933
RK		 7950 Expand_Array_Comparison (N);
7951 return;
7952 end if;
7953
456cbfa5
AC		 7954 -- Deal with Boolean type operands
7955
70482933
RK		 7956 if Is_Boolean_Type (Typ1) then
7957 Adjust_Condition (Op1);
7958 Adjust_Condition (Op2);
7959 Set_Etype (N, Standard_Boolean);
7960 Adjust_Result_Type (N, Typ);
7961 end if;
7962
7963 Rewrite_Comparison (N);
f02b8bb8 7964
0580d807 7965 Optimize_Length_Comparison (N);
70482933
RK		 7966 end Expand_N_Op_Le;
7967
7968 --------------------
7969 -- Expand_N_Op_Lt --
7970 --------------------
7971
7972 procedure Expand_N_Op_Lt (N : Node_Id) is
7973 Typ : constant Entity_Id := Etype (N);
7974 Op1 : constant Node_Id := Left_Opnd (N);
7975 Op2 : constant Node_Id := Right_Opnd (N);
7976 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7977
7978 begin
7979 Binary_Op_Validity_Checks (N);
7980
456cbfa5 7981 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
60b68e56 7982 -- means we no longer have a comparison operation, we are all done.
456cbfa5
AC		 7983
7984 Expand_Compare_Minimize_Eliminate_Overflow (N);
7985
7986 if Nkind (N) /= N_Op_Lt then
7987 return;
7988 end if;
7989
7990 -- Deal with array type operands
7991
f02b8bb8 7992 if Is_Array_Type (Typ1) then
70482933
RK		 7993 Expand_Array_Comparison (N);
7994 return;
7995 end if;
7996
456cbfa5
AC		 7997 -- Deal with Boolean type operands
7998
70482933
RK		 7999 if Is_Boolean_Type (Typ1) then
8000 Adjust_Condition (Op1);
8001 Adjust_Condition (Op2);
8002 Set_Etype (N, Standard_Boolean);
8003 Adjust_Result_Type (N, Typ);
8004 end if;
8005
8006 Rewrite_Comparison (N);
f02b8bb8 8007
0580d807 8008 Optimize_Length_Comparison (N);
70482933
RK		 8009 end Expand_N_Op_Lt;
8010
8011 -----------------------
8012 -- Expand_N_Op_Minus --
8013 -----------------------
8014
8015 procedure Expand_N_Op_Minus (N : Node_Id) is
8016 Loc : constant Source_Ptr := Sloc (N);
8017 Typ : constant Entity_Id := Etype (N);
8018
8019 begin
8020 Unary_Op_Validity_Checks (N);
8021
b6b5cca8
AC		 8022 -- Check for MINIMIZED/ELIMINATED overflow mode
8023
8024 if Minimized_Eliminated_Overflow_Check (N) then
8025 Apply_Arithmetic_Overflow_Check (N);
8026 return;
8027 end if;
8028
07fc65c4 8029 if not Backend_Overflow_Checks_On_Target
70482933
RK		 8030 and then Is_Signed_Integer_Type (Etype (N))
8031 and then Do_Overflow_Check (N)
8032 then
8033 -- Software overflow checking expands -expr into (0 - expr)
8034
8035 Rewrite (N,
8036 Make_Op_Subtract (Loc,
8037 Left_Opnd => Make_Integer_Literal (Loc, 0),
8038 Right_Opnd => Right_Opnd (N)));
8039
8040 Analyze_And_Resolve (N, Typ);
70482933
RK		 8041 end if;
8042 end Expand_N_Op_Minus;
8043
8044 ---------------------
8045 -- Expand_N_Op_Mod --
8046 ---------------------
8047
8048 procedure Expand_N_Op_Mod (N : Node_Id) is
8049 Loc : constant Source_Ptr := Sloc (N);
fbf5a39b 8050 Typ : constant Entity_Id := Etype (N);
70482933
RK		 8051 DDC : constant Boolean := Do_Division_Check (N);
8052
b6b5cca8
AC		 8053 Left : Node_Id;
8054 Right : Node_Id;
8055
70482933
RK		 8056 LLB : Uint;
8057 Llo : Uint;
8058 Lhi : Uint;
8059 LOK : Boolean;
8060 Rlo : Uint;
8061 Rhi : Uint;
8062 ROK : Boolean;
8063
1033834f
RD		 8064 pragma Warnings (Off, Lhi);
8065
70482933
RK		 8066 begin
8067 Binary_Op_Validity_Checks (N);
8068
b6b5cca8
AC		 8069 -- Check for MINIMIZED/ELIMINATED overflow mode
8070
8071 if Minimized_Eliminated_Overflow_Check (N) then
8072 Apply_Arithmetic_Overflow_Check (N);
8073 return;
8074 end if;
8075
9a6dc470
RD		 8076 if Is_Integer_Type (Etype (N)) then
8077 Apply_Divide_Checks (N);
b6b5cca8
AC		 8078
8079 -- All done if we don't have a MOD any more, which can happen as a
8080 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8081
8082 if Nkind (N) /= N_Op_Mod then
8083 return;
8084 end if;
9a6dc470
RD		 8085 end if;
8086
b6b5cca8
AC		 8087 -- Proceed with expansion of mod operator
8088
8089 Left := Left_Opnd (N);
8090 Right := Right_Opnd (N);
8091
5d5e9775
AC		 8092 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
8093 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
70482933 8094
2c9f8c0a
AC		 8095 -- Convert mod to rem if operands are both known to be non-negative, or
8096 -- both known to be non-positive (these are the cases in which rem and
8097 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8098 -- likely that this will improve the quality of code, (the operation now
8099 -- corresponds to the hardware remainder), and it does not seem likely
8100 -- that it could be harmful. It also avoids some cases of the elaborate
8101 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8102
8103 if (LOK and ROK)
8104 and then ((Llo >= 0 and then Rlo >= 0)
cc6f5d75 8105 or else
2c9f8c0a
AC		 8106 (Lhi <= 0 and then Rhi <= 0))
8107 then
70482933
RK		 8108 Rewrite (N,
8109 Make_Op_Rem (Sloc (N),
8110 Left_Opnd => Left_Opnd (N),
8111 Right_Opnd => Right_Opnd (N)));
8112
685094bf
RD		 8113 -- Instead of reanalyzing the node we do the analysis manually. This
8114 -- avoids anomalies when the replacement is done in an instance and
8115 -- is epsilon more efficient.
70482933
RK		 8116
8117 Set_Entity (N, Standard_Entity (S_Op_Rem));
fbf5a39b 8118 Set_Etype (N, Typ);
70482933
RK		 8119 Set_Do_Division_Check (N, DDC);
8120 Expand_N_Op_Rem (N);
8121 Set_Analyzed (N);
2c9f8c0a 8122 return;
70482933
RK		 8123
8124 -- Otherwise, normal mod processing
8125
8126 else
fbf5a39b
AC		 8127 -- Apply optimization x mod 1 = 0. We don't really need that with
8128 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
8129 -- certainly harmless.
8130
8131 if Is_Integer_Type (Etype (N))
8132 and then Compile_Time_Known_Value (Right)
8133 and then Expr_Value (Right) = Uint_1
8134 then
abcbd24c
ST		 8135 -- Call Remove_Side_Effects to ensure that any side effects in
8136 -- the ignored left operand (in particular function calls to
8137 -- user defined functions) are properly executed.
8138
8139 Remove_Side_Effects (Left);
8140
fbf5a39b
AC		 8141 Rewrite (N, Make_Integer_Literal (Loc, 0));
8142 Analyze_And_Resolve (N, Typ);
8143 return;
8144 end if;
8145
2c9f8c0a
AC		 8146 -- If we still have a mod operator and we are in Modify_Tree_For_C
8147 -- mode, and we have a signed integer type, then here is where we do
8148 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8149 -- for the special handling of the annoying case of largest negative
8150 -- number mod minus one.
8151
8152 if Nkind (N) = N_Op_Mod
8153 and then Is_Signed_Integer_Type (Typ)
8154 and then Modify_Tree_For_C
8155 then
8156 -- In the general case, we expand A mod B as
8157
8158 -- Tnn : constant typ := A rem B;
8159 -- ..
8160 -- (if (A >= 0) = (B >= 0) then Tnn
8161 -- elsif Tnn = 0 then 0
8162 -- else Tnn + B)
8163
8164 -- The comparison can be written simply as A >= 0 if we know that
8165 -- B >= 0 which is a very common case.
8166
8167 -- An important optimization is when B is known at compile time
8168 -- to be 2**K for some constant. In this case we can simply AND
8169 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8170 -- and that works for both the positive and negative cases.
8171
8172 declare
8173 P2 : constant Nat := Power_Of_Two (Right);
8174
8175 begin
8176 if P2 /= 0 then
8177 Rewrite (N,
8178 Unchecked_Convert_To (Typ,
8179 Make_Op_And (Loc,
8180 Left_Opnd =>
8181 Unchecked_Convert_To
8182 (Corresponding_Unsigned_Type (Typ), Left),
8183 Right_Opnd =>
8184 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
8185 Analyze_And_Resolve (N, Typ);
8186 return;
8187 end if;
8188 end;
8189
8190 -- Here for the full rewrite
8191
8192 declare
8193 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
8194 Cmp : Node_Id;
8195
8196 begin
8197 Cmp :=
8198 Make_Op_Ge (Loc,
8199 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
8200 Right_Opnd => Make_Integer_Literal (Loc, 0));
8201
8202 if not LOK or else Rlo < 0 then
8203 Cmp :=
8204 Make_Op_Eq (Loc,
8205 Left_Opnd => Cmp,
8206 Right_Opnd =>
8207 Make_Op_Ge (Loc,
8208 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
8209 Right_Opnd => Make_Integer_Literal (Loc, 0)));
8210 end if;
8211
8212 Insert_Action (N,
8213 Make_Object_Declaration (Loc,
8214 Defining_Identifier => Tnn,
8215 Constant_Present => True,
8216 Object_Definition => New_Occurrence_Of (Typ, Loc),
8217 Expression =>
8218 Make_Op_Rem (Loc,
8219 Left_Opnd => Left,
8220 Right_Opnd => Right)));
8221
8222 Rewrite (N,
8223 Make_If_Expression (Loc,
8224 Expressions => New_List (
8225 Cmp,
8226 New_Occurrence_Of (Tnn, Loc),
8227 Make_If_Expression (Loc,
8228 Is_Elsif => True,
8229 Expressions => New_List (
8230 Make_Op_Eq (Loc,
8231 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8232 Right_Opnd => Make_Integer_Literal (Loc, 0)),
8233 Make_Integer_Literal (Loc, 0),
8234 Make_Op_Add (Loc,
8235 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8236 Right_Opnd =>
8237 Duplicate_Subexpr_No_Checks (Right)))))));
8238
8239 Analyze_And_Resolve (N, Typ);
8240 return;
8241 end;
8242 end if;
8243
8244 -- Deal with annoying case of largest negative number mod minus one.
8245 -- Gigi may not handle this case correctly, because on some targets,
8246 -- the mod value is computed using a divide instruction which gives
8247 -- an overflow trap for this case.
b9daa96e
AC		 8248
8249 -- It would be a bit more efficient to figure out which targets
8250 -- this is really needed for, but in practice it is reasonable
8251 -- to do the following special check in all cases, since it means
8252 -- we get a clearer message, and also the overhead is minimal given
8253 -- that division is expensive in any case.
70482933 8254
685094bf
RD		 8255 -- In fact the check is quite easy, if the right operand is -1, then
8256 -- the mod value is always 0, and we can just ignore the left operand
8257 -- completely in this case.
70482933 8258
9a6dc470
RD		 8259 -- This only applies if we still have a mod operator. Skip if we
8260 -- have already rewritten this (e.g. in the case of eliminated
8261 -- overflow checks which have driven us into bignum mode).
fbf5a39b 8262
9a6dc470 8263 if Nkind (N) = N_Op_Mod then
70482933 8264
9a6dc470
RD		 8265 -- The operand type may be private (e.g. in the expansion of an
8266 -- intrinsic operation) so we must use the underlying type to get
8267 -- the bounds, and convert the literals explicitly.
70482933 8268
9a6dc470
RD		 8269 LLB :=
8270 Expr_Value
8271 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
8272
8273 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
761f7dcb 8274 and then ((not LOK) or else (Llo = LLB))
9a6dc470
RD		 8275 then
8276 Rewrite (N,
9b16cb57 8277 Make_If_Expression (Loc,
9a6dc470
RD		 8278 Expressions => New_List (
8279 Make_Op_Eq (Loc,
8280 Left_Opnd => Duplicate_Subexpr (Right),
8281 Right_Opnd =>
8282 Unchecked_Convert_To (Typ,
8283 Make_Integer_Literal (Loc, -1))),
8284 Unchecked_Convert_To (Typ,
8285 Make_Integer_Literal (Loc, Uint_0)),
8286 Relocate_Node (N))));
8287
8288 Set_Analyzed (Next (Next (First (Expressions (N)))));
8289 Analyze_And_Resolve (N, Typ);
8290 end if;
70482933
RK		 8291 end if;
8292 end if;
8293 end Expand_N_Op_Mod;
8294
8295 --------------------------
8296 -- Expand_N_Op_Multiply --
8297 --------------------------
8298
8299 procedure Expand_N_Op_Multiply (N : Node_Id) is
abcbd24c
ST		 8300 Loc : constant Source_Ptr := Sloc (N);
8301 Lop : constant Node_Id := Left_Opnd (N);
8302 Rop : constant Node_Id := Right_Opnd (N);
fbf5a39b 8303
abcbd24c 8304 Lp2 : constant Boolean :=
533369aa 8305 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
abcbd24c 8306 Rp2 : constant Boolean :=
533369aa 8307 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
fbf5a39b 8308
70482933
RK		 8309 Ltyp : constant Entity_Id := Etype (Lop);
8310 Rtyp : constant Entity_Id := Etype (Rop);
8311 Typ : Entity_Id := Etype (N);
8312
8313 begin
8314 Binary_Op_Validity_Checks (N);
8315
b6b5cca8
AC		 8316 -- Check for MINIMIZED/ELIMINATED overflow mode
8317
8318 if Minimized_Eliminated_Overflow_Check (N) then
8319 Apply_Arithmetic_Overflow_Check (N);
8320 return;
8321 end if;
8322
70482933
RK		 8323 -- Special optimizations for integer types
8324
8325 if Is_Integer_Type (Typ) then
8326
abcbd24c 8327 -- N * 0 = 0 for integer types
70482933 8328
abcbd24c
ST		 8329 if Compile_Time_Known_Value (Rop)
8330 and then Expr_Value (Rop) = Uint_0
70482933 8331 then
abcbd24c
ST		 8332 -- Call Remove_Side_Effects to ensure that any side effects in
8333 -- the ignored left operand (in particular function calls to
8334 -- user defined functions) are properly executed.
8335
8336 Remove_Side_Effects (Lop);
8337
8338 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8339 Analyze_And_Resolve (N, Typ);
8340 return;
8341 end if;
8342
8343 -- Similar handling for 0 * N = 0
8344
8345 if Compile_Time_Known_Value (Lop)
8346 and then Expr_Value (Lop) = Uint_0
8347 then
8348 Remove_Side_Effects (Rop);
70482933
RK		 8349 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8350 Analyze_And_Resolve (N, Typ);
8351 return;
8352 end if;
8353
8354 -- N * 1 = 1 * N = N for integer types
8355
fbf5a39b
AC		 8356 -- This optimisation is not done if we are going to
8357 -- rewrite the product 1 * 2 ** N to a shift.
8358
8359 if Compile_Time_Known_Value (Rop)
8360 and then Expr_Value (Rop) = Uint_1
8361 and then not Lp2
70482933 8362 then
fbf5a39b 8363 Rewrite (N, Lop);
70482933
RK		 8364 return;
8365
fbf5a39b
AC		 8366 elsif Compile_Time_Known_Value (Lop)
8367 and then Expr_Value (Lop) = Uint_1
8368 and then not Rp2
70482933 8369 then
fbf5a39b 8370 Rewrite (N, Rop);
70482933
RK		 8371 return;
8372 end if;
8373 end if;
8374
70482933
RK		 8375 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8376 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8377 -- operand is an integer, as required for this to work.
8378
fbf5a39b
AC		 8379 if Rp2 then
8380 if Lp2 then
70482933 8381
fbf5a39b 8382 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
70482933
RK		 8383
8384 Rewrite (N,
8385 Make_Op_Expon (Loc,
8386 Left_Opnd => Make_Integer_Literal (Loc, 2),
8387 Right_Opnd =>
8388 Make_Op_Add (Loc,
8389 Left_Opnd => Right_Opnd (Lop),
8390 Right_Opnd => Right_Opnd (Rop))));
8391 Analyze_And_Resolve (N, Typ);
8392 return;
8393
8394 else
eefe3761
AC		 8395 -- If the result is modular, perform the reduction of the result
8396 -- appropriately.
8397
8398 if Is_Modular_Integer_Type (Typ)
8399 and then not Non_Binary_Modulus (Typ)
8400 then
8401 Rewrite (N,
573e5dd6
RD		 8402 Make_Op_And (Loc,
8403 Left_Opnd =>
8404 Make_Op_Shift_Left (Loc,
8405 Left_Opnd => Lop,
8406 Right_Opnd =>
8407 Convert_To (Standard_Natural, Right_Opnd (Rop))),
8408 Right_Opnd =>
eefe3761 8409 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
573e5dd6 8410
eefe3761
AC		 8411 else
8412 Rewrite (N,
8413 Make_Op_Shift_Left (Loc,
8414 Left_Opnd => Lop,
8415 Right_Opnd =>
8416 Convert_To (Standard_Natural, Right_Opnd (Rop))));
8417 end if;
8418
70482933
RK		 8419 Analyze_And_Resolve (N, Typ);
8420 return;
8421 end if;
8422
8423 -- Same processing for the operands the other way round
8424
fbf5a39b 8425 elsif Lp2 then
eefe3761
AC		 8426 if Is_Modular_Integer_Type (Typ)
8427 and then not Non_Binary_Modulus (Typ)
8428 then
8429 Rewrite (N,
573e5dd6
RD		 8430 Make_Op_And (Loc,
8431 Left_Opnd =>
8432 Make_Op_Shift_Left (Loc,
8433 Left_Opnd => Rop,
8434 Right_Opnd =>
8435 Convert_To (Standard_Natural, Right_Opnd (Lop))),
8436 Right_Opnd =>
8437 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8438
eefe3761
AC		 8439 else
8440 Rewrite (N,
8441 Make_Op_Shift_Left (Loc,
8442 Left_Opnd => Rop,
8443 Right_Opnd =>
8444 Convert_To (Standard_Natural, Right_Opnd (Lop))));
8445 end if;
8446
70482933
RK		 8447 Analyze_And_Resolve (N, Typ);
8448 return;
8449 end if;
8450
8451 -- Do required fixup of universal fixed operation
8452
8453 if Typ = Universal_Fixed then
8454 Fixup_Universal_Fixed_Operation (N);
8455 Typ := Etype (N);
8456 end if;
8457
8458 -- Multiplications with fixed-point results
8459
8460 if Is_Fixed_Point_Type (Typ) then
8461
685094bf
RD		 8462 -- No special processing if Treat_Fixed_As_Integer is set, since from
8463 -- a semantic point of view such operations are simply integer
8464 -- operations and will be treated that way.
70482933
RK		 8465
8466 if not Treat_Fixed_As_Integer (N) then
8467
8468 -- Case of fixed * integer => fixed
8469
8470 if Is_Integer_Type (Rtyp) then
8471 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
8472
8473 -- Case of integer * fixed => fixed
8474
8475 elsif Is_Integer_Type (Ltyp) then
8476 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
8477
8478 -- Case of fixed * fixed => fixed
8479
8480 else
8481 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
8482 end if;
8483 end if;
8484
685094bf
RD		 8485 -- Other cases of multiplication of fixed-point operands. Again we
8486 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
70482933
RK		 8487
8488 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
8489 and then not Treat_Fixed_As_Integer (N)
8490 then
8491 if Is_Integer_Type (Typ) then
8492 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
8493 else
8494 pragma Assert (Is_Floating_Point_Type (Typ));
8495 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
8496 end if;
8497
685094bf
RD		 8498 -- Mixed-mode operations can appear in a non-static universal context,
8499 -- in which case the integer argument must be converted explicitly.
70482933 8500
533369aa 8501 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
70482933 8502 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
70482933
RK		 8503 Analyze_And_Resolve (Rop, Universal_Real);
8504
533369aa 8505 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
70482933 8506 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
70482933
RK		 8507 Analyze_And_Resolve (Lop, Universal_Real);
8508
8509 -- Non-fixed point cases, check software overflow checking required
8510
8511 elsif Is_Signed_Integer_Type (Etype (N)) then
8512 Apply_Arithmetic_Overflow_Check (N);
8513 end if;
dfaff97b
RD		 8514
8515 -- Overflow checks for floating-point if -gnateF mode active
8516
8517 Check_Float_Op_Overflow (N);
70482933
RK		 8518 end Expand_N_Op_Multiply;
8519
8520 --------------------
8521 -- Expand_N_Op_Ne --
8522 --------------------
8523
70482933 8524 procedure Expand_N_Op_Ne (N : Node_Id) is
f02b8bb8 8525 Typ : constant Entity_Id := Etype (Left_Opnd (N));
70482933
RK		 8526
8527 begin
f02b8bb8 8528 -- Case of elementary type with standard operator
70482933 8529
f02b8bb8
RD		 8530 if Is_Elementary_Type (Typ)
8531 and then Sloc (Entity (N)) = Standard_Location
8532 then
8533 Binary_Op_Validity_Checks (N);
70482933 8534
456cbfa5 8535 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
60b68e56 8536 -- means we no longer have a /= operation, we are all done.
456cbfa5
AC		 8537
8538 Expand_Compare_Minimize_Eliminate_Overflow (N);
8539
8540 if Nkind (N) /= N_Op_Ne then
8541 return;
8542 end if;
8543
f02b8bb8 8544 -- Boolean types (requiring handling of non-standard case)
70482933 8545
f02b8bb8
RD		 8546 if Is_Boolean_Type (Typ) then
8547 Adjust_Condition (Left_Opnd (N));
8548 Adjust_Condition (Right_Opnd (N));
8549 Set_Etype (N, Standard_Boolean);
8550 Adjust_Result_Type (N, Typ);
8551 end if;
fbf5a39b 8552
f02b8bb8
RD		 8553 Rewrite_Comparison (N);
8554
f02b8bb8
RD		 8555 -- For all cases other than elementary types, we rewrite node as the
8556 -- negation of an equality operation, and reanalyze. The equality to be
8557 -- used is defined in the same scope and has the same signature. This
8558 -- signature must be set explicitly since in an instance it may not have
8559 -- the same visibility as in the generic unit. This avoids duplicating
8560 -- or factoring the complex code for record/array equality tests etc.
8561
8562 else
8563 declare
8564 Loc : constant Source_Ptr := Sloc (N);
8565 Neg : Node_Id;
8566 Ne : constant Entity_Id := Entity (N);
8567
8568 begin
8569 Binary_Op_Validity_Checks (N);
8570
8571 Neg :=
8572 Make_Op_Not (Loc,
8573 Right_Opnd =>
8574 Make_Op_Eq (Loc,
8575 Left_Opnd => Left_Opnd (N),
8576 Right_Opnd => Right_Opnd (N)));
8577 Set_Paren_Count (Right_Opnd (Neg), 1);
8578
8579 if Scope (Ne) /= Standard_Standard then
8580 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
8581 end if;
8582
4637729f 8583 -- For navigation purposes, we want to treat the inequality as an
f02b8bb8 8584 -- implicit reference to the corresponding equality. Preserve the
4637729f 8585 -- Comes_From_ source flag to generate proper Xref entries.
f02b8bb8
RD		 8586
8587 Preserve_Comes_From_Source (Neg, N);
8588 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
8589 Rewrite (N, Neg);
8590 Analyze_And_Resolve (N, Standard_Boolean);
8591 end;
8592 end if;
0580d807
AC		 8593
8594 Optimize_Length_Comparison (N);
70482933
RK		 8595 end Expand_N_Op_Ne;
8596
8597 ---------------------
8598 -- Expand_N_Op_Not --
8599 ---------------------
8600
685094bf 8601 -- If the argument is other than a Boolean array type, there is no special
7a5b62b0
AC		 8602 -- expansion required, except for dealing with validity checks, and non-
8603 -- standard boolean representations.
70482933 8604
7a5b62b0
AC		 8605 -- For the packed array case, we call the special routine in Exp_Pakd,
8606 -- except that if the component size is greater than one, we use the
8607 -- standard routine generating a gruesome loop (it is so peculiar to have
8608 -- packed arrays with non-standard Boolean representations anyway, so it
8609 -- does not matter that we do not handle this case efficiently).
70482933 8610
7a5b62b0
AC		 8611 -- For the unpacked array case (and for the special packed case where we
8612 -- have non standard Booleans, as discussed above), we generate and insert
8613 -- into the tree the following function definition:
70482933
RK		 8614
8615 -- function Nnnn (A : arr) is
8616 -- B : arr;
8617 -- begin
8618 -- for J in a'range loop
8619 -- B (J) := not A (J);
8620 -- end loop;
8621 -- return B;
8622 -- end Nnnn;
8623
8624 -- Here arr is the actual subtype of the parameter (and hence always
8625 -- constrained). Then we replace the not with a call to this function.
8626
8627 procedure Expand_N_Op_Not (N : Node_Id) is
8628 Loc : constant Source_Ptr := Sloc (N);
8629 Typ : constant Entity_Id := Etype (N);
8630 Opnd : Node_Id;
8631 Arr : Entity_Id;
8632 A : Entity_Id;
8633 B : Entity_Id;
8634 J : Entity_Id;
8635 A_J : Node_Id;
8636 B_J : Node_Id;
8637
8638 Func_Name : Entity_Id;
8639 Loop_Statement : Node_Id;
8640
8641 begin
8642 Unary_Op_Validity_Checks (N);
8643
8644 -- For boolean operand, deal with non-standard booleans
8645
8646 if Is_Boolean_Type (Typ) then
8647 Adjust_Condition (Right_Opnd (N));
8648 Set_Etype (N, Standard_Boolean);
8649 Adjust_Result_Type (N, Typ);
8650 return;
8651 end if;
8652
da94696d 8653 -- Only array types need any other processing
70482933 8654
da94696d 8655 if not Is_Array_Type (Typ) then
70482933
RK		 8656 return;
8657 end if;
8658
a9d8907c
JM		 8659 -- Case of array operand. If bit packed with a component size of 1,
8660 -- handle it in Exp_Pakd if the operand is known to be aligned.
70482933 8661
a9d8907c
JM		 8662 if Is_Bit_Packed_Array (Typ)
8663 and then Component_Size (Typ) = 1
8664 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
8665 then
70482933
RK		 8666 Expand_Packed_Not (N);
8667 return;
8668 end if;
8669
fbf5a39b
AC		 8670 -- Case of array operand which is not bit-packed. If the context is
8671 -- a safe assignment, call in-place operation, If context is a larger
8672 -- boolean expression in the context of a safe assignment, expansion is
8673 -- done by enclosing operation.
70482933
RK		 8674
8675 Opnd := Relocate_Node (Right_Opnd (N));
8676 Convert_To_Actual_Subtype (Opnd);
8677 Arr := Etype (Opnd);
8678 Ensure_Defined (Arr, N);
b4592168 8679 Silly_Boolean_Array_Not_Test (N, Arr);
70482933 8680
fbf5a39b
AC		 8681 if Nkind (Parent (N)) = N_Assignment_Statement then
8682 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
8683 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8684 return;
8685
5e1c00fa 8686 -- Special case the negation of a binary operation
fbf5a39b 8687
303b4d58 8688 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
fbf5a39b 8689 and then Safe_In_Place_Array_Op
303b4d58 8690 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
fbf5a39b
AC		 8691 then
8692 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8693 return;
8694 end if;
8695
8696 elsif Nkind (Parent (N)) in N_Binary_Op
8697 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
8698 then
8699 declare
8700 Op1 : constant Node_Id := Left_Opnd (Parent (N));
8701 Op2 : constant Node_Id := Right_Opnd (Parent (N));
8702 Lhs : constant Node_Id := Name (Parent (Parent (N)));
8703
8704 begin
8705 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
fbf5a39b 8706
aa9a7dd7
AC		 8707 -- (not A) op (not B) can be reduced to a single call
8708
8709 if N = Op1 and then Nkind (Op2) = N_Op_Not then
fbf5a39b
AC		 8710 return;
8711
bed8af19
AC		 8712 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
8713 return;
8714
aa9a7dd7 8715 -- A xor (not B) can also be special-cased
fbf5a39b 8716
aa9a7dd7 8717 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
fbf5a39b
AC		 8718 return;
8719 end if;
8720 end if;
8721 end;
8722 end if;
8723
70482933
RK		 8724 A := Make_Defining_Identifier (Loc, Name_uA);
8725 B := Make_Defining_Identifier (Loc, Name_uB);
8726 J := Make_Defining_Identifier (Loc, Name_uJ);
8727
8728 A_J :=
8729 Make_Indexed_Component (Loc,
e4494292
RD		 8730 Prefix => New_Occurrence_Of (A, Loc),
8731 Expressions => New_List (New_Occurrence_Of (J, Loc)));
70482933
RK		 8732
8733 B_J :=
8734 Make_Indexed_Component (Loc,
e4494292
RD		 8735 Prefix => New_Occurrence_Of (B, Loc),
8736 Expressions => New_List (New_Occurrence_Of (J, Loc)));
70482933
RK		 8737
8738 Loop_Statement :=
8739 Make_Implicit_Loop_Statement (N,
8740 Identifier => Empty,
8741
8742 Iteration_Scheme =>
8743 Make_Iteration_Scheme (Loc,
8744 Loop_Parameter_Specification =>
8745 Make_Loop_Parameter_Specification (Loc,
0d901290 8746 Defining_Identifier => J,
70482933
RK		 8747 Discrete_Subtype_Definition =>
8748 Make_Attribute_Reference (Loc,
0d901290 8749 Prefix => Make_Identifier (Loc, Chars (A)),
70482933
RK		 8750 Attribute_Name => Name_Range))),
8751
8752 Statements => New_List (
8753 Make_Assignment_Statement (Loc,
8754 Name => B_J,
8755 Expression => Make_Op_Not (Loc, A_J))));
8756
191fcb3a 8757 Func_Name := Make_Temporary (Loc, 'N');
70482933
RK		 8758 Set_Is_Inlined (Func_Name);
8759
8760 Insert_Action (N,
8761 Make_Subprogram_Body (Loc,
8762 Specification =>
8763 Make_Function_Specification (Loc,
8764 Defining_Unit_Name => Func_Name,
8765 Parameter_Specifications => New_List (
8766 Make_Parameter_Specification (Loc,
8767 Defining_Identifier => A,
e4494292
RD		 8768 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
8769 Result_Definition => New_Occurrence_Of (Typ, Loc)),
70482933
RK		 8770
8771 Declarations => New_List (
8772 Make_Object_Declaration (Loc,
8773 Defining_Identifier => B,
e4494292 8774 Object_Definition => New_Occurrence_Of (Arr, Loc))),
70482933
RK		 8775
8776 Handled_Statement_Sequence =>
8777 Make_Handled_Sequence_Of_Statements (Loc,
8778 Statements => New_List (
8779 Loop_Statement,
d766cee3 8780 Make_Simple_Return_Statement (Loc,
0d901290 8781 Expression => Make_Identifier (Loc, Chars (B)))))));
70482933
RK		 8782
8783 Rewrite (N,
8784 Make_Function_Call (Loc,
e4494292 8785 Name => New_Occurrence_Of (Func_Name, Loc),
70482933
RK		 8786 Parameter_Associations => New_List (Opnd)));
8787
8788 Analyze_And_Resolve (N, Typ);
8789 end Expand_N_Op_Not;
8790
8791 --------------------
8792 -- Expand_N_Op_Or --
8793 --------------------
8794
8795 procedure Expand_N_Op_Or (N : Node_Id) is
8796 Typ : constant Entity_Id := Etype (N);
8797
8798 begin
8799 Binary_Op_Validity_Checks (N);
8800
8801 if Is_Array_Type (Etype (N)) then
8802 Expand_Boolean_Operator (N);
8803
8804 elsif Is_Boolean_Type (Etype (N)) then
f2d10a02
AC		 8805 Adjust_Condition (Left_Opnd (N));
8806 Adjust_Condition (Right_Opnd (N));
8807 Set_Etype (N, Standard_Boolean);
8808 Adjust_Result_Type (N, Typ);
437f8c1e
AC		 8809
8810 elsif Is_Intrinsic_Subprogram (Entity (N)) then
8811 Expand_Intrinsic_Call (N, Entity (N));
8812
70482933
RK		 8813 end if;
8814 end Expand_N_Op_Or;
8815
8816 ----------------------
8817 -- Expand_N_Op_Plus --
8818 ----------------------
8819
8820 procedure Expand_N_Op_Plus (N : Node_Id) is
8821 begin
8822 Unary_Op_Validity_Checks (N);
b6b5cca8
AC		 8823
8824 -- Check for MINIMIZED/ELIMINATED overflow mode
8825
8826 if Minimized_Eliminated_Overflow_Check (N) then
8827 Apply_Arithmetic_Overflow_Check (N);
8828 return;
8829 end if;
70482933
RK		 8830 end Expand_N_Op_Plus;
8831
8832 ---------------------
8833 -- Expand_N_Op_Rem --
8834 ---------------------
8835
8836 procedure Expand_N_Op_Rem (N : Node_Id) is
8837 Loc : constant Source_Ptr := Sloc (N);
fbf5a39b 8838 Typ : constant Entity_Id := Etype (N);
70482933 8839
b6b5cca8
AC		 8840 Left : Node_Id;
8841 Right : Node_Id;
70482933 8842
5d5e9775
AC		 8843 Lo : Uint;
8844 Hi : Uint;
8845 OK : Boolean;
70482933 8846
5d5e9775
AC		 8847 Lneg : Boolean;
8848 Rneg : Boolean;
8849 -- Set if corresponding operand can be negative
8850
8851 pragma Unreferenced (Hi);
1033834f 8852
70482933
RK		 8853 begin
8854 Binary_Op_Validity_Checks (N);
8855
b6b5cca8
AC		 8856 -- Check for MINIMIZED/ELIMINATED overflow mode
8857
8858 if Minimized_Eliminated_Overflow_Check (N) then
8859 Apply_Arithmetic_Overflow_Check (N);
8860 return;
8861 end if;
8862
70482933 8863 if Is_Integer_Type (Etype (N)) then
a91e9ac7 8864 Apply_Divide_Checks (N);
b6b5cca8
AC		 8865
8866 -- All done if we don't have a REM any more, which can happen as a
8867 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8868
8869 if Nkind (N) /= N_Op_Rem then
8870 return;
8871 end if;
70482933
RK		 8872 end if;
8873
b6b5cca8
AC		 8874 -- Proceed with expansion of REM
8875
8876 Left := Left_Opnd (N);
8877 Right := Right_Opnd (N);
8878
685094bf
RD		 8879 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8880 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8881 -- harmless.
fbf5a39b
AC		 8882
8883 if Is_Integer_Type (Etype (N))
8884 and then Compile_Time_Known_Value (Right)
8885 and then Expr_Value (Right) = Uint_1
8886 then
abcbd24c
ST		 8887 -- Call Remove_Side_Effects to ensure that any side effects in the
8888 -- ignored left operand (in particular function calls to user defined
8889 -- functions) are properly executed.
8890
8891 Remove_Side_Effects (Left);
8892
fbf5a39b
AC		 8893 Rewrite (N, Make_Integer_Literal (Loc, 0));
8894 Analyze_And_Resolve (N, Typ);
8895 return;
8896 end if;
8897
685094bf 8898 -- Deal with annoying case of largest negative number remainder minus
b9daa96e
AC		 8899 -- one. Gigi may not handle this case correctly, because on some
8900 -- targets, the mod value is computed using a divide instruction
8901 -- which gives an overflow trap for this case.
8902
8903 -- It would be a bit more efficient to figure out which targets this
8904 -- is really needed for, but in practice it is reasonable to do the
8905 -- following special check in all cases, since it means we get a clearer
8906 -- message, and also the overhead is minimal given that division is
8907 -- expensive in any case.
70482933 8908
685094bf
RD		 8909 -- In fact the check is quite easy, if the right operand is -1, then
8910 -- the remainder is always 0, and we can just ignore the left operand
8911 -- completely in this case.
70482933 8912
5d5e9775
AC		 8913 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
8914 Lneg := (not OK) or else Lo < 0;
fbf5a39b 8915
5d5e9775
AC		 8916 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
8917 Rneg := (not OK) or else Lo < 0;
fbf5a39b 8918
5d5e9775
AC		 8919 -- We won't mess with trying to find out if the left operand can really
8920 -- be the largest negative number (that's a pain in the case of private
8921 -- types and this is really marginal). We will just assume that we need
8922 -- the test if the left operand can be negative at all.
fbf5a39b 8923
5d5e9775 8924 if Lneg and Rneg then
70482933 8925 Rewrite (N,
9b16cb57 8926 Make_If_Expression (Loc,
70482933
RK		 8927 Expressions => New_List (
8928 Make_Op_Eq (Loc,
0d901290 8929 Left_Opnd => Duplicate_Subexpr (Right),
70482933 8930 Right_Opnd =>
0d901290 8931 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
70482933 8932
fbf5a39b
AC		 8933 Unchecked_Convert_To (Typ,
8934 Make_Integer_Literal (Loc, Uint_0)),
70482933
RK		 8935
8936 Relocate_Node (N))));
8937
8938 Set_Analyzed (Next (Next (First (Expressions (N)))));
8939 Analyze_And_Resolve (N, Typ);
8940 end if;
8941 end Expand_N_Op_Rem;
8942
8943 -----------------------------
8944 -- Expand_N_Op_Rotate_Left --
8945 -----------------------------
8946
8947 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
8948 begin
8949 Binary_Op_Validity_Checks (N);
5216b599
AC		 8950
8951 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
8952 -- so we rewrite in terms of logical shifts
8953
8954 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
8955
8956 -- where Bits is the shift count mod Esize (the mod operation here
8957 -- deals with ludicrous large shift counts, which are apparently OK).
8958
8959 -- What about non-binary modulus ???
8960
8961 declare
8962 Loc : constant Source_Ptr := Sloc (N);
8963 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
8964 Typ : constant Entity_Id := Etype (N);
8965
8966 begin
8967 if Modify_Tree_For_C then
8968 Rewrite (Right_Opnd (N),
8969 Make_Op_Rem (Loc,
8970 Left_Opnd => Relocate_Node (Right_Opnd (N)),
8971 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
8972
8973 Analyze_And_Resolve (Right_Opnd (N), Rtp);
8974
8975 Rewrite (N,
8976 Make_Op_Or (Loc,
8977 Left_Opnd =>
8978 Make_Op_Shift_Left (Loc,
8979 Left_Opnd => Left_Opnd (N),
8980 Right_Opnd => Right_Opnd (N)),
e09a5598 8981
5216b599
AC		 8982 Right_Opnd =>
8983 Make_Op_Shift_Right (Loc,
8984 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
8985 Right_Opnd =>
8986 Make_Op_Subtract (Loc,
8987 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
8988 Right_Opnd =>
8989 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
8990
8991 Analyze_And_Resolve (N, Typ);
8992 end if;
8993 end;
70482933
RK		 8994 end Expand_N_Op_Rotate_Left;
8995
8996 ------------------------------
8997 -- Expand_N_Op_Rotate_Right --
8998 ------------------------------
8999
9000 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
9001 begin
9002 Binary_Op_Validity_Checks (N);
5216b599
AC		 9003
9004 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9005 -- so we rewrite in terms of logical shifts
9006
9007 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9008
9009 -- where Bits is the shift count mod Esize (the mod operation here
9010 -- deals with ludicrous large shift counts, which are apparently OK).
9011
9012 -- What about non-binary modulus ???
9013
9014 declare
9015 Loc : constant Source_Ptr := Sloc (N);
9016 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
9017 Typ : constant Entity_Id := Etype (N);
9018
9019 begin
9020 Rewrite (Right_Opnd (N),
9021 Make_Op_Rem (Loc,
9022 Left_Opnd => Relocate_Node (Right_Opnd (N)),
9023 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
9024
9025 Analyze_And_Resolve (Right_Opnd (N), Rtp);
9026
9027 if Modify_Tree_For_C then
9028 Rewrite (N,
9029 Make_Op_Or (Loc,
9030 Left_Opnd =>
9031 Make_Op_Shift_Right (Loc,
9032 Left_Opnd => Left_Opnd (N),
9033 Right_Opnd => Right_Opnd (N)),
e09a5598 9034
5216b599
AC		 9035 Right_Opnd =>
9036 Make_Op_Shift_Left (Loc,
9037 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9038 Right_Opnd =>
9039 Make_Op_Subtract (Loc,
9040 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9041 Right_Opnd =>
9042 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9043
9044 Analyze_And_Resolve (N, Typ);
9045 end if;
9046 end;
70482933
RK		 9047 end Expand_N_Op_Rotate_Right;
9048
9049 ----------------------------
9050 -- Expand_N_Op_Shift_Left --
9051 ----------------------------
9052
e09a5598
AC		 9053 -- Note: nothing in this routine depends on left as opposed to right shifts
9054 -- so we share the routine for expanding shift right operations.
9055
70482933
RK		 9056 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
9057 begin
9058 Binary_Op_Validity_Checks (N);
e09a5598
AC		 9059
9060 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9061 -- operand is not greater than the word size (since that would not
9062 -- be defined properly by the corresponding C shift operator).
9063
9064 if Modify_Tree_For_C then
9065 declare
9066 Right : constant Node_Id := Right_Opnd (N);
9067 Loc : constant Source_Ptr := Sloc (Right);
9068 Typ : constant Entity_Id := Etype (N);
9069 Siz : constant Uint := Esize (Typ);
9070 Orig : Node_Id;
9071 OK : Boolean;
9072 Lo : Uint;
9073 Hi : Uint;
9074
9075 begin
9076 if Compile_Time_Known_Value (Right) then
9077 if Expr_Value (Right) >= Siz then
9078 Rewrite (N, Make_Integer_Literal (Loc, 0));
9079 Analyze_And_Resolve (N, Typ);
9080 end if;
9081
9082 -- Not compile time known, find range
9083
9084 else
9085 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9086
9087 -- Nothing to do if known to be OK range, otherwise expand
9088
9089 if not OK or else Hi >= Siz then
9090
9091 -- Prevent recursion on copy of shift node
9092
9093 Orig := Relocate_Node (N);
9094 Set_Analyzed (Orig);
9095
9096 -- Now do the rewrite
9097
9098 Rewrite (N,
9099 Make_If_Expression (Loc,
9100 Expressions => New_List (
9101 Make_Op_Ge (Loc,
9102 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
9103 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
9104 Make_Integer_Literal (Loc, 0),
9105 Orig)));
9106 Analyze_And_Resolve (N, Typ);
9107 end if;
9108 end if;
9109 end;
9110 end if;
70482933
RK		 9111 end Expand_N_Op_Shift_Left;
9112
9113 -----------------------------
9114 -- Expand_N_Op_Shift_Right --
9115 -----------------------------
9116
9117 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
9118 begin
e09a5598
AC		 9119 -- Share shift left circuit
9120
9121 Expand_N_Op_Shift_Left (N);
70482933
RK		 9122 end Expand_N_Op_Shift_Right;
9123
9124 ----------------------------------------
9125 -- Expand_N_Op_Shift_Right_Arithmetic --
9126 ----------------------------------------
9127
9128 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
9129 begin
9130 Binary_Op_Validity_Checks (N);
5216b599
AC		 9131
9132 -- If we are in Modify_Tree_For_C mode, there is no shift right
9133 -- arithmetic in C, so we rewrite in terms of logical shifts.
9134
9135 -- Shift_Right (Num, Bits) or
9136 -- (if Num >= Sign
9137 -- then not (Shift_Right (Mask, bits))
9138 -- else 0)
9139
9140 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9141
9142 -- Note: in almost all C compilers it would work to just shift a
9143 -- signed integer right, but it's undefined and we cannot rely on it.
9144
e09a5598
AC		 9145 -- Note: the above works fine for shift counts greater than or equal
9146 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9147 -- generates all 1'bits.
9148
5216b599
AC		 9149 -- What about non-binary modulus ???
9150
9151 declare
9152 Loc : constant Source_Ptr := Sloc (N);
9153 Typ : constant Entity_Id := Etype (N);
9154 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
9155 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
9156 Left : constant Node_Id := Left_Opnd (N);
9157 Right : constant Node_Id := Right_Opnd (N);
9158 Maskx : Node_Id;
9159
9160 begin
9161 if Modify_Tree_For_C then
9162
9163 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9164 -- compile time as a single constant.
9165
9166 if Compile_Time_Known_Value (Right) then
9167 declare
9168 Val : constant Uint := Expr_Value (Right);
9169
9170 begin
9171 if Val >= Esize (Typ) then
9172 Maskx := Make_Integer_Literal (Loc, Mask);
9173
9174 else
9175 Maskx :=
9176 Make_Integer_Literal (Loc,
9177 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
9178 end if;
9179 end;
9180
9181 else
9182 Maskx :=
9183 Make_Op_Not (Loc,
9184 Right_Opnd =>
9185 Make_Op_Shift_Right (Loc,
9186 Left_Opnd => Make_Integer_Literal (Loc, Mask),
9187 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
9188 end if;
9189
9190 -- Now do the rewrite
9191
9192 Rewrite (N,
9193 Make_Op_Or (Loc,
9194 Left_Opnd =>
9195 Make_Op_Shift_Right (Loc,
9196 Left_Opnd => Left,
9197 Right_Opnd => Right),
9198 Right_Opnd =>
9199 Make_If_Expression (Loc,
9200 Expressions => New_List (
9201 Make_Op_Ge (Loc,
9202 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9203 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
9204 Maskx,
9205 Make_Integer_Literal (Loc, 0)))));
9206 Analyze_And_Resolve (N, Typ);
9207 end if;
9208 end;
70482933
RK		 9209 end Expand_N_Op_Shift_Right_Arithmetic;
9210
9211 --------------------------
9212 -- Expand_N_Op_Subtract --
9213 --------------------------
9214
9215 procedure Expand_N_Op_Subtract (N : Node_Id) is
9216 Typ : constant Entity_Id := Etype (N);
9217
9218 begin
9219 Binary_Op_Validity_Checks (N);
9220
b6b5cca8
AC		 9221 -- Check for MINIMIZED/ELIMINATED overflow mode
9222
9223 if Minimized_Eliminated_Overflow_Check (N) then
9224 Apply_Arithmetic_Overflow_Check (N);
9225 return;
9226 end if;
9227
70482933
RK		 9228 -- N - 0 = N for integer types
9229
9230 if Is_Integer_Type (Typ)
9231 and then Compile_Time_Known_Value (Right_Opnd (N))
9232 and then Expr_Value (Right_Opnd (N)) = 0
9233 then
9234 Rewrite (N, Left_Opnd (N));
9235 return;
9236 end if;
9237
8fc789c8 9238 -- Arithmetic overflow checks for signed integer/fixed point types
70482933 9239
761f7dcb 9240 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
70482933 9241 Apply_Arithmetic_Overflow_Check (N);
70482933 9242 end if;
dfaff97b
RD		 9243
9244 -- Overflow checks for floating-point if -gnateF mode active
9245
9246 Check_Float_Op_Overflow (N);
70482933
RK		 9247 end Expand_N_Op_Subtract;
9248
9249 ---------------------
9250 -- Expand_N_Op_Xor --
9251 ---------------------
9252
9253 procedure Expand_N_Op_Xor (N : Node_Id) is
9254 Typ : constant Entity_Id := Etype (N);
9255
9256 begin
9257 Binary_Op_Validity_Checks (N);
9258
9259 if Is_Array_Type (Etype (N)) then
9260 Expand_Boolean_Operator (N);
9261
9262 elsif Is_Boolean_Type (Etype (N)) then
9263 Adjust_Condition (Left_Opnd (N));
9264 Adjust_Condition (Right_Opnd (N));
9265 Set_Etype (N, Standard_Boolean);
9266 Adjust_Result_Type (N, Typ);
437f8c1e
AC		 9267
9268 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9269 Expand_Intrinsic_Call (N, Entity (N));
9270
70482933
RK		 9271 end if;
9272 end Expand_N_Op_Xor;
9273
9274 ----------------------
9275 -- Expand_N_Or_Else --
9276 ----------------------
9277
5875f8d6
AC		 9278 procedure Expand_N_Or_Else (N : Node_Id)
9279 renames Expand_Short_Circuit_Operator;
70482933
RK		 9280
9281 -----------------------------------
9282 -- Expand_N_Qualified_Expression --
9283 -----------------------------------
9284
9285 procedure Expand_N_Qualified_Expression (N : Node_Id) is
9286 Operand : constant Node_Id := Expression (N);
9287 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
9288
9289 begin
f82944b7
JM		 9290 -- Do validity check if validity checking operands
9291
533369aa 9292 if Validity_Checks_On and Validity_Check_Operands then
f82944b7
JM		 9293 Ensure_Valid (Operand);
9294 end if;
9295
9296 -- Apply possible constraint check
9297
70482933 9298 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
d79e621a
GD		 9299
9300 if Do_Range_Check (Operand) then
9301 Set_Do_Range_Check (Operand, False);
9302 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
9303 end if;
70482933
RK		 9304 end Expand_N_Qualified_Expression;
9305
a961aa79
AC		 9306 ------------------------------------
9307 -- Expand_N_Quantified_Expression --
9308 ------------------------------------
9309
c0f136cd
AC		 9310 -- We expand:
9311
9312 -- for all X in range => Cond
a961aa79 9313
c0f136cd 9314 -- into:
a961aa79 9315
c0f136cd
AC		 9316 -- T := True;
9317 -- for X in range loop
9318 -- if not Cond then
9319 -- T := False;
9320 -- exit;
9321 -- end if;
9322 -- end loop;
90c63b09 9323
36504e5f 9324 -- Similarly, an existentially quantified expression:
90c63b09 9325
c0f136cd 9326 -- for some X in range => Cond
90c63b09 9327
c0f136cd 9328 -- becomes:
90c63b09 9329
c0f136cd
AC		 9330 -- T := False;
9331 -- for X in range loop
9332 -- if Cond then
9333 -- T := True;
9334 -- exit;
9335 -- end if;
9336 -- end loop;
90c63b09 9337
c0f136cd
AC		 9338 -- In both cases, the iteration may be over a container in which case it is
9339 -- given by an iterator specification, not a loop parameter specification.
a961aa79 9340
c0f136cd 9341 procedure Expand_N_Quantified_Expression (N : Node_Id) is
804670f1
AC		 9342 Actions : constant List_Id := New_List;
9343 For_All : constant Boolean := All_Present (N);
9344 Iter_Spec : constant Node_Id := Iterator_Specification (N);
9345 Loc : constant Source_Ptr := Sloc (N);
9346 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
9347 Cond : Node_Id;
9348 Flag : Entity_Id;
9349 Scheme : Node_Id;
9350 Stmts : List_Id;
c56a9ba4 9351
a961aa79 9352 begin
804670f1
AC		 9353 -- Create the declaration of the flag which tracks the status of the
9354 -- quantified expression. Generate:
011f9d5d 9355
804670f1 9356 -- Flag : Boolean := (True | False);
011f9d5d 9357
804670f1 9358 Flag := Make_Temporary (Loc, 'T', N);
011f9d5d 9359
804670f1 9360 Append_To (Actions,
90c63b09 9361 Make_Object_Declaration (Loc,
804670f1 9362 Defining_Identifier => Flag,
c0f136cd
AC		 9363 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
9364 Expression =>
804670f1
AC		 9365 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
9366
9367 -- Construct the circuitry which tracks the status of the quantified
9368 -- expression. Generate:
9369
9370 -- if [not] Cond then
9371 -- Flag := (False | True);
9372 -- exit;
9373 -- end if;
a961aa79 9374
c0f136cd 9375 Cond := Relocate_Node (Condition (N));
a961aa79 9376
804670f1 9377 if For_All then
c0f136cd 9378 Cond := Make_Op_Not (Loc, Cond);
a961aa79
AC		 9379 end if;
9380
804670f1 9381 Stmts := New_List (
c0f136cd
AC		 9382 Make_Implicit_If_Statement (N,
9383 Condition => Cond,
9384 Then_Statements => New_List (
9385 Make_Assignment_Statement (Loc,
804670f1 9386 Name => New_Occurrence_Of (Flag, Loc),
c0f136cd 9387 Expression =>
804670f1
AC		 9388 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
9389 Make_Exit_Statement (Loc))));
9390
9391 -- Build the loop equivalent of the quantified expression
c0f136cd 9392
804670f1
AC		 9393 if Present (Iter_Spec) then
9394 Scheme :=
011f9d5d 9395 Make_Iteration_Scheme (Loc,
804670f1 9396 Iterator_Specification => Iter_Spec);
c56a9ba4 9397 else
804670f1 9398 Scheme :=
011f9d5d 9399 Make_Iteration_Scheme (Loc,
804670f1 9400 Loop_Parameter_Specification => Loop_Spec);
c56a9ba4
AC		 9401 end if;
9402
a961aa79
AC		 9403 Append_To (Actions,
9404 Make_Loop_Statement (Loc,
804670f1
AC		 9405 Iteration_Scheme => Scheme,
9406 Statements => Stmts,
c0f136cd 9407 End_Label => Empty));
a961aa79 9408
804670f1
AC		 9409 -- Transform the quantified expression
9410
a961aa79
AC		 9411 Rewrite (N,
9412 Make_Expression_With_Actions (Loc,
804670f1 9413 Expression => New_Occurrence_Of (Flag, Loc),
a961aa79 9414 Actions => Actions));
a961aa79
AC		 9415 Analyze_And_Resolve (N, Standard_Boolean);
9416 end Expand_N_Quantified_Expression;
9417
70482933
RK		 9418 ---------------------------------
9419 -- Expand_N_Selected_Component --
9420 ---------------------------------
9421
70482933
RK		 9422 procedure Expand_N_Selected_Component (N : Node_Id) is
9423 Loc : constant Source_Ptr := Sloc (N);
9424 Par : constant Node_Id := Parent (N);
9425 P : constant Node_Id := Prefix (N);
03eb6036 9426 S : constant Node_Id := Selector_Name (N);
fbf5a39b 9427 Ptyp : Entity_Id := Underlying_Type (Etype (P));
70482933 9428 Disc : Entity_Id;
70482933 9429 New_N : Node_Id;
fbf5a39b 9430 Dcon : Elmt_Id;
d606f1df 9431 Dval : Node_Id;
70482933
RK		 9432
9433 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
9434 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9435 -- unless the context of an assignment can provide size information.
fbf5a39b
AC		 9436 -- Don't we have a general routine that does this???
9437
53f29d4f
AC		 9438 function Is_Subtype_Declaration return Boolean;
9439 -- The replacement of a discriminant reference by its value is required
4317e442
AC		 9440 -- if this is part of the initialization of an temporary generated by a
9441 -- change of representation. This shows up as the construction of a
53f29d4f 9442 -- discriminant constraint for a subtype declared at the same point as
4317e442
AC		 9443 -- the entity in the prefix of the selected component. We recognize this
9444 -- case when the context of the reference is:
9445 -- subtype ST is T(Obj.D);
9446 -- where the entity for Obj comes from source, and ST has the same sloc.
53f29d4f 9447
fbf5a39b
AC		 9448 -----------------------
9449 -- In_Left_Hand_Side --
9450 -----------------------
70482933
RK		 9451
9452 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
9453 begin
fbf5a39b 9454 return (Nkind (Parent (Comp)) = N_Assignment_Statement
90c63b09 9455 and then Comp = Name (Parent (Comp)))
fbf5a39b 9456 or else (Present (Parent (Comp))
90c63b09
AC		 9457 and then Nkind (Parent (Comp)) in N_Subexpr
9458 and then In_Left_Hand_Side (Parent (Comp)));
70482933
RK		 9459 end In_Left_Hand_Side;
9460
53f29d4f
AC		 9461 -----------------------------
9462 -- Is_Subtype_Declaration --
9463 -----------------------------
9464
9465 function Is_Subtype_Declaration return Boolean is
9466 Par : constant Node_Id := Parent (N);
53f29d4f
AC		 9467 begin
9468 return
9469 Nkind (Par) = N_Index_Or_Discriminant_Constraint
9470 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
9471 and then Comes_From_Source (Entity (Prefix (N)))
9472 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
9473 end Is_Subtype_Declaration;
9474
fbf5a39b
AC		 9475 -- Start of processing for Expand_N_Selected_Component
9476
70482933 9477 begin
fbf5a39b
AC		 9478 -- Insert explicit dereference if required
9479
9480 if Is_Access_Type (Ptyp) then
702d2020
AC		 9481
9482 -- First set prefix type to proper access type, in case it currently
9483 -- has a private (non-access) view of this type.
9484
9485 Set_Etype (P, Ptyp);
9486
fbf5a39b 9487 Insert_Explicit_Dereference (P);
e6f69614 9488 Analyze_And_Resolve (P, Designated_Type (Ptyp));
fbf5a39b
AC		 9489
9490 if Ekind (Etype (P)) = E_Private_Subtype
9491 and then Is_For_Access_Subtype (Etype (P))
9492 then
9493 Set_Etype (P, Base_Type (Etype (P)));
9494 end if;
9495
9496 Ptyp := Etype (P);
9497 end if;
9498
9499 -- Deal with discriminant check required
9500
70482933 9501 if Do_Discriminant_Check (N) then
03eb6036
AC		 9502 if Present (Discriminant_Checking_Func
9503 (Original_Record_Component (Entity (S))))
9504 then
9505 -- Present the discriminant checking function to the backend, so
9506 -- that it can inline the call to the function.
9507
9508 Add_Inlined_Body
9509 (Discriminant_Checking_Func
9510 (Original_Record_Component (Entity (S))));
70482933 9511
03eb6036 9512 -- Now reset the flag and generate the call
70482933 9513
03eb6036
AC		 9514 Set_Do_Discriminant_Check (N, False);
9515 Generate_Discriminant_Check (N);
70482933 9516
03eb6036
AC		 9517 -- In the case of Unchecked_Union, no discriminant checking is
9518 -- actually performed.
70482933 9519
03eb6036
AC		 9520 else
9521 Set_Do_Discriminant_Check (N, False);
9522 end if;
70482933
RK		 9523 end if;
9524
b4592168
GD		 9525 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9526 -- function, then additional actuals must be passed.
9527
0791fbe9 9528 if Ada_Version >= Ada_2005
b4592168
GD		 9529 and then Is_Build_In_Place_Function_Call (P)
9530 then
9531 Make_Build_In_Place_Call_In_Anonymous_Context (P);
9532 end if;
9533
fbf5a39b
AC		 9534 -- Gigi cannot handle unchecked conversions that are the prefix of a
9535 -- selected component with discriminants. This must be checked during
9536 -- expansion, because during analysis the type of the selector is not
9537 -- known at the point the prefix is analyzed. If the conversion is the
9538 -- target of an assignment, then we cannot force the evaluation.
70482933
RK		 9539
9540 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
9541 and then Has_Discriminants (Etype (N))
9542 and then not In_Left_Hand_Side (N)
9543 then
9544 Force_Evaluation (Prefix (N));
9545 end if;
9546
9547 -- Remaining processing applies only if selector is a discriminant
9548
9549 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
9550
9551 -- If the selector is a discriminant of a constrained record type,
fbf5a39b
AC		 9552 -- we may be able to rewrite the expression with the actual value
9553 -- of the discriminant, a useful optimization in some cases.
70482933
RK		 9554
9555 if Is_Record_Type (Ptyp)
9556 and then Has_Discriminants (Ptyp)
9557 and then Is_Constrained (Ptyp)
70482933 9558 then
fbf5a39b 9559 -- Do this optimization for discrete types only, and not for
a90bd866 9560 -- access types (access discriminants get us into trouble).
70482933 9561
fbf5a39b
AC		 9562 if not Is_Discrete_Type (Etype (N)) then
9563 null;
9564
9565 -- Don't do this on the left hand of an assignment statement.
0d901290
AC		 9566 -- Normally one would think that references like this would not
9567 -- occur, but they do in generated code, and mean that we really
a90bd866 9568 -- do want to assign the discriminant.
fbf5a39b
AC		 9569
9570 elsif Nkind (Par) = N_Assignment_Statement
9571 and then Name (Par) = N
9572 then
9573 null;
9574
685094bf 9575 -- Don't do this optimization for the prefix of an attribute or
e2534738 9576 -- the name of an object renaming declaration since these are
685094bf 9577 -- contexts where we do not want the value anyway.
fbf5a39b
AC		 9578
9579 elsif (Nkind (Par) = N_Attribute_Reference
533369aa 9580 and then Prefix (Par) = N)
fbf5a39b
AC		 9581 or else Is_Renamed_Object (N)
9582 then
9583 null;
9584
9585 -- Don't do this optimization if we are within the code for a
9586 -- discriminant check, since the whole point of such a check may
a90bd866 9587 -- be to verify the condition on which the code below depends.
fbf5a39b
AC		 9588
9589 elsif Is_In_Discriminant_Check (N) then
9590 null;
9591
9592 -- Green light to see if we can do the optimization. There is
685094bf
RD		 9593 -- still one condition that inhibits the optimization below but
9594 -- now is the time to check the particular discriminant.
fbf5a39b
AC		 9595
9596 else
685094bf
RD		 9597 -- Loop through discriminants to find the matching discriminant
9598 -- constraint to see if we can copy it.
fbf5a39b
AC		 9599
9600 Disc := First_Discriminant (Ptyp);
9601 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
9602 Discr_Loop : while Present (Dcon) loop
d606f1df 9603 Dval := Node (Dcon);
fbf5a39b 9604
bd949ee2
RD		 9605 -- Check if this is the matching discriminant and if the
9606 -- discriminant value is simple enough to make sense to
9607 -- copy. We don't want to copy complex expressions, and
9608 -- indeed to do so can cause trouble (before we put in
9609 -- this guard, a discriminant expression containing an
e7d897b8 9610 -- AND THEN was copied, causing problems for coverage
c228a069 9611 -- analysis tools).
bd949ee2 9612
53f29d4f
AC		 9613 -- However, if the reference is part of the initialization
9614 -- code generated for an object declaration, we must use
9615 -- the discriminant value from the subtype constraint,
9616 -- because the selected component may be a reference to the
9617 -- object being initialized, whose discriminant is not yet
9618 -- set. This only happens in complex cases involving changes
9619 -- or representation.
9620
bd949ee2
RD		 9621 if Disc = Entity (Selector_Name (N))
9622 and then (Is_Entity_Name (Dval)
170b2989
AC		 9623 or else Compile_Time_Known_Value (Dval)
9624 or else Is_Subtype_Declaration)
bd949ee2 9625 then
fbf5a39b
AC		 9626 -- Here we have the matching discriminant. Check for
9627 -- the case of a discriminant of a component that is
9628 -- constrained by an outer discriminant, which cannot
9629 -- be optimized away.
9630
d606f1df
AC		 9631 if Denotes_Discriminant
9632 (Dval, Check_Concurrent => True)
9633 then
9634 exit Discr_Loop;
9635
9636 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
9637 and then
9638 Denotes_Discriminant
9639 (Selector_Name (Original_Node (Dval)), True)
9640 then
9641 exit Discr_Loop;
9642
9643 -- Do not retrieve value if constraint is not static. It
9644 -- is generally not useful, and the constraint may be a
9645 -- rewritten outer discriminant in which case it is in
9646 -- fact incorrect.
9647
9648 elsif Is_Entity_Name (Dval)
d606f1df 9649 and then
533369aa
AC		 9650 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
9651 and then Present (Expression (Parent (Entity (Dval))))
9652 and then not
edab6088 9653 Is_OK_Static_Expression
d606f1df 9654 (Expression (Parent (Entity (Dval))))
fbf5a39b
AC		 9655 then
9656 exit Discr_Loop;
70482933 9657
685094bf
RD		 9658 -- In the context of a case statement, the expression may
9659 -- have the base type of the discriminant, and we need to
9660 -- preserve the constraint to avoid spurious errors on
9661 -- missing cases.
70482933 9662
fbf5a39b 9663 elsif Nkind (Parent (N)) = N_Case_Statement
d606f1df 9664 and then Etype (Dval) /= Etype (Disc)
70482933
RK		 9665 then
9666 Rewrite (N,
9667 Make_Qualified_Expression (Loc,
fbf5a39b
AC		 9668 Subtype_Mark =>
9669 New_Occurrence_Of (Etype (Disc), Loc),
9670 Expression =>
d606f1df 9671 New_Copy_Tree (Dval)));
ffe9aba8 9672 Analyze_And_Resolve (N, Etype (Disc));
fbf5a39b
AC		 9673
9674 -- In case that comes out as a static expression,
9675 -- reset it (a selected component is never static).
9676
9677 Set_Is_Static_Expression (N, False);
9678 return;
9679
9680 -- Otherwise we can just copy the constraint, but the
a90bd866 9681 -- result is certainly not static. In some cases the
ffe9aba8
AC		 9682 -- discriminant constraint has been analyzed in the
9683 -- context of the original subtype indication, but for
9684 -- itypes the constraint might not have been analyzed
9685 -- yet, and this must be done now.
fbf5a39b 9686
70482933 9687 else
d606f1df 9688 Rewrite (N, New_Copy_Tree (Dval));
ffe9aba8 9689 Analyze_And_Resolve (N);
fbf5a39b
AC		 9690 Set_Is_Static_Expression (N, False);
9691 return;
70482933 9692 end if;
70482933
RK		 9693 end if;
9694
fbf5a39b
AC		 9695 Next_Elmt (Dcon);
9696 Next_Discriminant (Disc);
9697 end loop Discr_Loop;
70482933 9698
fbf5a39b
AC		 9699 -- Note: the above loop should always find a matching
9700 -- discriminant, but if it does not, we just missed an
c228a069
AC		 9701 -- optimization due to some glitch (perhaps a previous
9702 -- error), so ignore.
fbf5a39b
AC		 9703
9704 end if;
70482933
RK		 9705 end if;
9706
9707 -- The only remaining processing is in the case of a discriminant of
9708 -- a concurrent object, where we rewrite the prefix to denote the
9709 -- corresponding record type. If the type is derived and has renamed
9710 -- discriminants, use corresponding discriminant, which is the one
9711 -- that appears in the corresponding record.
9712
9713 if not Is_Concurrent_Type (Ptyp) then
9714 return;
9715 end if;
9716
9717 Disc := Entity (Selector_Name (N));
9718
9719 if Is_Derived_Type (Ptyp)
9720 and then Present (Corresponding_Discriminant (Disc))
9721 then
9722 Disc := Corresponding_Discriminant (Disc);
9723 end if;
9724
9725 New_N :=
9726 Make_Selected_Component (Loc,
9727 Prefix =>
9728 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
9729 New_Copy_Tree (P)),
9730 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
9731
9732 Rewrite (N, New_N);
9733 Analyze (N);
9734 end if;
5972791c 9735
73fe1679 9736 -- Set Atomic_Sync_Required if necessary for atomic component
5972791c 9737
73fe1679
AC		 9738 if Nkind (N) = N_Selected_Component then
9739 declare
9740 E : constant Entity_Id := Entity (Selector_Name (N));
9741 Set : Boolean;
9742
9743 begin
9744 -- If component is atomic, but type is not, setting depends on
9745 -- disable/enable state for the component.
9746
9747 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
9748 Set := not Atomic_Synchronization_Disabled (E);
9749
9750 -- If component is not atomic, but its type is atomic, setting
9751 -- depends on disable/enable state for the type.
9752
9753 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9754 Set := not Atomic_Synchronization_Disabled (Etype (E));
9755
9756 -- If both component and type are atomic, we disable if either
9757 -- component or its type have sync disabled.
9758
9759 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9760 Set := (not Atomic_Synchronization_Disabled (E))
9761 and then
9762 (not Atomic_Synchronization_Disabled (Etype (E)));
9763
9764 else
9765 Set := False;
9766 end if;
9767
9768 -- Set flag if required
9769
9770 if Set then
9771 Activate_Atomic_Synchronization (N);
9772 end if;
9773 end;
5972791c 9774 end if;
70482933
RK		 9775 end Expand_N_Selected_Component;
9776
9777 --------------------
9778 -- Expand_N_Slice --
9779 --------------------
9780
9781 procedure Expand_N_Slice (N : Node_Id) is
5ff90f08
AC		 9782 Loc : constant Source_Ptr := Sloc (N);
9783 Typ : constant Entity_Id := Etype (N);
fbf5a39b 9784
81a5b587 9785 function Is_Procedure_Actual (N : Node_Id) return Boolean;
685094bf
RD		 9786 -- Check whether the argument is an actual for a procedure call, in
9787 -- which case the expansion of a bit-packed slice is deferred until the
9788 -- call itself is expanded. The reason this is required is that we might
9789 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9790 -- that copy out would be missed if we created a temporary here in
9791 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9792 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9793 -- is harmless to defer expansion in the IN case, since the call
9794 -- processing will still generate the appropriate copy in operation,
9795 -- which will take care of the slice.
81a5b587 9796
b01bf852 9797 procedure Make_Temporary_For_Slice;
685094bf
RD		 9798 -- Create a named variable for the value of the slice, in cases where
9799 -- the back-end cannot handle it properly, e.g. when packed types or
9800 -- unaligned slices are involved.
fbf5a39b 9801
81a5b587
AC		 9802 -------------------------
9803 -- Is_Procedure_Actual --
9804 -------------------------
9805
9806 function Is_Procedure_Actual (N : Node_Id) return Boolean is
9807 Par : Node_Id := Parent (N);
08aa9a4a 9808
81a5b587 9809 begin
81a5b587 9810 loop
c6a60aa1
RD		 9811 -- If our parent is a procedure call we can return
9812
81a5b587
AC		 9813 if Nkind (Par) = N_Procedure_Call_Statement then
9814 return True;
6b6fcd3e 9815
685094bf
RD		 9816 -- If our parent is a type conversion, keep climbing the tree,
9817 -- since a type conversion can be a procedure actual. Also keep
9818 -- climbing if parameter association or a qualified expression,
9819 -- since these are additional cases that do can appear on
9820 -- procedure actuals.
6b6fcd3e 9821
303b4d58
AC		 9822 elsif Nkind_In (Par, N_Type_Conversion,
9823 N_Parameter_Association,
9824 N_Qualified_Expression)
c6a60aa1 9825 then
81a5b587 9826 Par := Parent (Par);
c6a60aa1
RD		 9827
9828 -- Any other case is not what we are looking for
9829
9830 else
9831 return False;
81a5b587
AC		 9832 end if;
9833 end loop;
81a5b587
AC		 9834 end Is_Procedure_Actual;
9835
b01bf852
AC		 9836 ------------------------------
9837 -- Make_Temporary_For_Slice --
9838 ------------------------------
fbf5a39b 9839
b01bf852 9840 procedure Make_Temporary_For_Slice is
b01bf852 9841 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
5ff90f08 9842 Decl : Node_Id;
13d923cc 9843
fbf5a39b
AC		 9844 begin
9845 Decl :=
9846 Make_Object_Declaration (Loc,
9847 Defining_Identifier => Ent,
9848 Object_Definition => New_Occurrence_Of (Typ, Loc));
9849
9850 Set_No_Initialization (Decl);
9851
9852 Insert_Actions (N, New_List (
9853 Decl,
9854 Make_Assignment_Statement (Loc,
5ff90f08 9855 Name => New_Occurrence_Of (Ent, Loc),
fbf5a39b
AC		 9856 Expression => Relocate_Node (N))));
9857
9858 Rewrite (N, New_Occurrence_Of (Ent, Loc));
9859 Analyze_And_Resolve (N, Typ);
b01bf852 9860 end Make_Temporary_For_Slice;
fbf5a39b 9861
5ff90f08
AC		 9862 -- Local variables
9863
800da977
AC		 9864 Pref : constant Node_Id := Prefix (N);
9865 Pref_Typ : Entity_Id := Etype (Pref);
5ff90f08 9866
fbf5a39b 9867 -- Start of processing for Expand_N_Slice
70482933
RK		 9868
9869 begin
9870 -- Special handling for access types
9871
5ff90f08
AC		 9872 if Is_Access_Type (Pref_Typ) then
9873 Pref_Typ := Designated_Type (Pref_Typ);
70482933 9874
5ff90f08 9875 Rewrite (Pref,
e6f69614 9876 Make_Explicit_Dereference (Sloc (N),
5ff90f08 9877 Prefix => Relocate_Node (Pref)));
70482933 9878
5ff90f08 9879 Analyze_And_Resolve (Pref, Pref_Typ);
70482933
RK		 9880 end if;
9881
b4592168
GD		 9882 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9883 -- function, then additional actuals must be passed.
9884
0791fbe9 9885 if Ada_Version >= Ada_2005
5ff90f08 9886 and then Is_Build_In_Place_Function_Call (Pref)
b4592168 9887 then
5ff90f08 9888 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
b4592168
GD		 9889 end if;
9890
70482933
RK		 9891 -- The remaining case to be handled is packed slices. We can leave
9892 -- packed slices as they are in the following situations:
9893
9894 -- 1. Right or left side of an assignment (we can handle this
9895 -- situation correctly in the assignment statement expansion).
9896
685094bf
RD		 9897 -- 2. Prefix of indexed component (the slide is optimized away in this
9898 -- case, see the start of Expand_N_Slice.)
70482933 9899
685094bf
RD		 9900 -- 3. Object renaming declaration, since we want the name of the
9901 -- slice, not the value.
70482933 9902
685094bf
RD		 9903 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9904 -- be required, and this is handled in the expansion of call
9905 -- itself.
70482933 9906
685094bf
RD		 9907 -- 5. Prefix of an address attribute (this is an error which is caught
9908 -- elsewhere, and the expansion would interfere with generating the
9909 -- error message).
70482933 9910
81a5b587 9911 if not Is_Packed (Typ) then
08aa9a4a 9912
685094bf
RD		 9913 -- Apply transformation for actuals of a function call, where
9914 -- Expand_Actuals is not used.
81a5b587
AC		 9915
9916 if Nkind (Parent (N)) = N_Function_Call
9917 and then Is_Possibly_Unaligned_Slice (N)
9918 then
b01bf852 9919 Make_Temporary_For_Slice;
81a5b587
AC		 9920 end if;
9921
9922 elsif Nkind (Parent (N)) = N_Assignment_Statement
9923 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
533369aa 9924 and then Parent (N) = Name (Parent (Parent (N))))
70482933 9925 then
81a5b587 9926 return;
70482933 9927
81a5b587
AC		 9928 elsif Nkind (Parent (N)) = N_Indexed_Component
9929 or else Is_Renamed_Object (N)
9930 or else Is_Procedure_Actual (N)
9931 then
9932 return;
70482933 9933
91b1417d
AC		 9934 elsif Nkind (Parent (N)) = N_Attribute_Reference
9935 and then Attribute_Name (Parent (N)) = Name_Address
fbf5a39b 9936 then
81a5b587
AC		 9937 return;
9938
9939 else
b01bf852 9940 Make_Temporary_For_Slice;
70482933
RK		 9941 end if;
9942 end Expand_N_Slice;
9943
9944 ------------------------------
9945 -- Expand_N_Type_Conversion --
9946 ------------------------------
9947
9948 procedure Expand_N_Type_Conversion (N : Node_Id) is
9949 Loc : constant Source_Ptr := Sloc (N);
9950 Operand : constant Node_Id := Expression (N);
9951 Target_Type : constant Entity_Id := Etype (N);
9952 Operand_Type : Entity_Id := Etype (Operand);
9953
9954 procedure Handle_Changed_Representation;
685094bf
RD		 9955 -- This is called in the case of record and array type conversions to
9956 -- see if there is a change of representation to be handled. Change of
9957 -- representation is actually handled at the assignment statement level,
9958 -- and what this procedure does is rewrite node N conversion as an
9959 -- assignment to temporary. If there is no change of representation,
9960 -- then the conversion node is unchanged.
70482933 9961
426908f8
RD		 9962 procedure Raise_Accessibility_Error;
9963 -- Called when we know that an accessibility check will fail. Rewrites
9964 -- node N to an appropriate raise statement and outputs warning msgs.
9965 -- The Etype of the raise node is set to Target_Type.
9966
70482933
RK		 9967 procedure Real_Range_Check;
9968 -- Handles generation of range check for real target value
9969
d15f9422
AC		 9970 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
9971 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9972 -- evaluates to True.
9973
70482933
RK		 9974 -----------------------------------
9975 -- Handle_Changed_Representation --
9976 -----------------------------------
9977
9978 procedure Handle_Changed_Representation is
9979 Temp : Entity_Id;
9980 Decl : Node_Id;
9981 Odef : Node_Id;
9982 Disc : Node_Id;
9983 N_Ix : Node_Id;
9984 Cons : List_Id;
9985
9986 begin
f82944b7 9987 -- Nothing else to do if no change of representation
70482933
RK		 9988
9989 if Same_Representation (Operand_Type, Target_Type) then
9990 return;
9991
9992 -- The real change of representation work is done by the assignment
9993 -- statement processing. So if this type conversion is appearing as
9994 -- the expression of an assignment statement, nothing needs to be
9995 -- done to the conversion.
9996
9997 elsif Nkind (Parent (N)) = N_Assignment_Statement then
9998 return;
9999
10000 -- Otherwise we need to generate a temporary variable, and do the
10001 -- change of representation assignment into that temporary variable.
10002 -- The conversion is then replaced by a reference to this variable.
10003
10004 else
10005 Cons := No_List;
10006
685094bf
RD		 10007 -- If type is unconstrained we have to add a constraint, copied
10008 -- from the actual value of the left hand side.
70482933
RK		 10009
10010 if not Is_Constrained (Target_Type) then
10011 if Has_Discriminants (Operand_Type) then
10012 Disc := First_Discriminant (Operand_Type);
fbf5a39b
AC		 10013
10014 if Disc /= First_Stored_Discriminant (Operand_Type) then
10015 Disc := First_Stored_Discriminant (Operand_Type);
10016 end if;
10017
70482933
RK		 10018 Cons := New_List;
10019 while Present (Disc) loop
10020 Append_To (Cons,
10021 Make_Selected_Component (Loc,
7675ad4f
AC		 10022 Prefix =>
10023 Duplicate_Subexpr_Move_Checks (Operand),
70482933
RK		 10024 Selector_Name =>
10025 Make_Identifier (Loc, Chars (Disc))));
10026 Next_Discriminant (Disc);
10027 end loop;
10028
10029 elsif Is_Array_Type (Operand_Type) then
10030 N_Ix := First_Index (Target_Type);
10031 Cons := New_List;
10032
10033 for J in 1 .. Number_Dimensions (Operand_Type) loop
10034
10035 -- We convert the bounds explicitly. We use an unchecked
10036 -- conversion because bounds checks are done elsewhere.
10037
10038 Append_To (Cons,
10039 Make_Range (Loc,
10040 Low_Bound =>
10041 Unchecked_Convert_To (Etype (N_Ix),
10042 Make_Attribute_Reference (Loc,
10043 Prefix =>
fbf5a39b 10044 Duplicate_Subexpr_No_Checks
70482933
RK		 10045 (Operand, Name_Req => True),
10046 Attribute_Name => Name_First,
10047 Expressions => New_List (
10048 Make_Integer_Literal (Loc, J)))),
10049
10050 High_Bound =>
10051 Unchecked_Convert_To (Etype (N_Ix),
10052 Make_Attribute_Reference (Loc,
10053 Prefix =>
fbf5a39b 10054 Duplicate_Subexpr_No_Checks
70482933
RK		 10055 (Operand, Name_Req => True),
10056 Attribute_Name => Name_Last,
10057 Expressions => New_List (
10058 Make_Integer_Literal (Loc, J))))));
10059
10060 Next_Index (N_Ix);
10061 end loop;
10062 end if;
10063 end if;
10064
10065 Odef := New_Occurrence_Of (Target_Type, Loc);
10066
10067 if Present (Cons) then
10068 Odef :=
10069 Make_Subtype_Indication (Loc,
10070 Subtype_Mark => Odef,
10071 Constraint =>
10072 Make_Index_Or_Discriminant_Constraint (Loc,
10073 Constraints => Cons));
10074 end if;
10075
191fcb3a 10076 Temp := Make_Temporary (Loc, 'C');
70482933
RK		 10077 Decl :=
10078 Make_Object_Declaration (Loc,
10079 Defining_Identifier => Temp,
10080 Object_Definition => Odef);
10081
10082 Set_No_Initialization (Decl, True);
10083
10084 -- Insert required actions. It is essential to suppress checks
10085 -- since we have suppressed default initialization, which means
10086 -- that the variable we create may have no discriminants.
10087
10088 Insert_Actions (N,
10089 New_List (
10090 Decl,
10091 Make_Assignment_Statement (Loc,
10092 Name => New_Occurrence_Of (Temp, Loc),
10093 Expression => Relocate_Node (N))),
10094 Suppress => All_Checks);
10095
10096 Rewrite (N, New_Occurrence_Of (Temp, Loc));
10097 return;
10098 end if;
10099 end Handle_Changed_Representation;
10100
426908f8
RD		 10101 -------------------------------
10102 -- Raise_Accessibility_Error --
10103 -------------------------------
10104
10105 procedure Raise_Accessibility_Error is
10106 begin
43417b90 10107 Error_Msg_Warn := SPARK_Mode /= On;
426908f8
RD		 10108 Rewrite (N,
10109 Make_Raise_Program_Error (Sloc (N),
10110 Reason => PE_Accessibility_Check_Failed));
10111 Set_Etype (N, Target_Type);
10112
4a28b181
AC		 10113 Error_Msg_N ("<<accessibility check failure", N);
10114 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
426908f8
RD		 10115 end Raise_Accessibility_Error;
10116
70482933
RK		 10117 ----------------------
10118 -- Real_Range_Check --
10119 ----------------------
10120
685094bf
RD		 10121 -- Case of conversions to floating-point or fixed-point. If range checks
10122 -- are enabled and the target type has a range constraint, we convert:
70482933
RK		 10123
10124 -- typ (x)
10125
10126 -- to
10127
10128 -- Tnn : typ'Base := typ'Base (x);
10129 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10130 -- Tnn
10131
685094bf
RD		 10132 -- This is necessary when there is a conversion of integer to float or
10133 -- to fixed-point to ensure that the correct checks are made. It is not
10134 -- necessary for float to float where it is enough to simply set the
10135 -- Do_Range_Check flag.
fbf5a39b 10136
70482933
RK		 10137 procedure Real_Range_Check is
10138 Btyp : constant Entity_Id := Base_Type (Target_Type);
10139 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
10140 Hi : constant Node_Id := Type_High_Bound (Target_Type);
fbf5a39b 10141 Xtyp : constant Entity_Id := Etype (Operand);
70482933
RK		 10142 Conv : Node_Id;
10143 Tnn : Entity_Id;
10144
10145 begin
10146 -- Nothing to do if conversion was rewritten
10147
10148 if Nkind (N) /= N_Type_Conversion then
10149 return;
10150 end if;
10151
685094bf
RD		 10152 -- Nothing to do if range checks suppressed, or target has the same
10153 -- range as the base type (or is the base type).
70482933
RK		 10154
10155 if Range_Checks_Suppressed (Target_Type)
533369aa 10156 or else (Lo = Type_Low_Bound (Btyp)
70482933
RK		 10157 and then
10158 Hi = Type_High_Bound (Btyp))
10159 then
10160 return;
10161 end if;
10162
685094bf
RD		 10163 -- Nothing to do if expression is an entity on which checks have been
10164 -- suppressed.
70482933 10165
fbf5a39b
AC		 10166 if Is_Entity_Name (Operand)
10167 and then Range_Checks_Suppressed (Entity (Operand))
10168 then
10169 return;
10170 end if;
10171
685094bf
RD		 10172 -- Nothing to do if bounds are all static and we can tell that the
10173 -- expression is within the bounds of the target. Note that if the
10174 -- operand is of an unconstrained floating-point type, then we do
10175 -- not trust it to be in range (might be infinite)
fbf5a39b
AC		 10176
10177 declare
f02b8bb8
RD		 10178 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
10179 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
fbf5a39b
AC		 10180
10181 begin
10182 if (not Is_Floating_Point_Type (Xtyp)
10183 or else Is_Constrained (Xtyp))
10184 and then Compile_Time_Known_Value (S_Lo)
10185 and then Compile_Time_Known_Value (S_Hi)
10186 and then Compile_Time_Known_Value (Hi)
10187 and then Compile_Time_Known_Value (Lo)
10188 then
10189 declare
10190 D_Lov : constant Ureal := Expr_Value_R (Lo);
10191 D_Hiv : constant Ureal := Expr_Value_R (Hi);
10192 S_Lov : Ureal;
10193 S_Hiv : Ureal;
10194
10195 begin
10196 if Is_Real_Type (Xtyp) then
10197 S_Lov := Expr_Value_R (S_Lo);
10198 S_Hiv := Expr_Value_R (S_Hi);
10199 else
10200 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
10201 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
10202 end if;
10203
10204 if D_Hiv > D_Lov
10205 and then S_Lov >= D_Lov
10206 and then S_Hiv <= D_Hiv
10207 then
8b034336
AC		 10208 -- Unset the range check flag on the current value of
10209 -- Expression (N), since the captured Operand may have
10210 -- been rewritten (such as for the case of a conversion
10211 -- to a fixed-point type).
10212
10213 Set_Do_Range_Check (Expression (N), False);
10214
fbf5a39b
AC		 10215 return;
10216 end if;
10217 end;
10218 end if;
10219 end;
10220
10221 -- For float to float conversions, we are done
10222
10223 if Is_Floating_Point_Type (Xtyp)
10224 and then
10225 Is_Floating_Point_Type (Btyp)
70482933
RK		 10226 then
10227 return;
10228 end if;
10229
fbf5a39b 10230 -- Otherwise rewrite the conversion as described above
70482933
RK		 10231
10232 Conv := Relocate_Node (N);
eaa826f8 10233 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
70482933
RK		 10234 Set_Etype (Conv, Btyp);
10235
f02b8bb8
RD		 10236 -- Enable overflow except for case of integer to float conversions,
10237 -- where it is never required, since we can never have overflow in
10238 -- this case.
70482933 10239
fbf5a39b
AC		 10240 if not Is_Integer_Type (Etype (Operand)) then
10241 Enable_Overflow_Check (Conv);
70482933
RK		 10242 end if;
10243
191fcb3a 10244 Tnn := Make_Temporary (Loc, 'T', Conv);
70482933
RK		 10245
10246 Insert_Actions (N, New_List (
10247 Make_Object_Declaration (Loc,
10248 Defining_Identifier => Tnn,
10249 Object_Definition => New_Occurrence_Of (Btyp, Loc),
0ac2a660
AC		 10250 Constant_Present => True,
10251 Expression => Conv),
70482933
RK		 10252
10253 Make_Raise_Constraint_Error (Loc,
07fc65c4
GB		 10254 Condition =>
10255 Make_Or_Else (Loc,
10256 Left_Opnd =>
10257 Make_Op_Lt (Loc,
10258 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10259 Right_Opnd =>
10260 Make_Attribute_Reference (Loc,
10261 Attribute_Name => Name_First,
10262 Prefix =>
10263 New_Occurrence_Of (Target_Type, Loc))),
70482933 10264
07fc65c4
GB		 10265 Right_Opnd =>
10266 Make_Op_Gt (Loc,
10267 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10268 Right_Opnd =>
10269 Make_Attribute_Reference (Loc,
10270 Attribute_Name => Name_Last,
10271 Prefix =>
10272 New_Occurrence_Of (Target_Type, Loc)))),
10273 Reason => CE_Range_Check_Failed)));
70482933
RK		 10274
10275 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
10276 Analyze_And_Resolve (N, Btyp);
10277 end Real_Range_Check;
10278
d15f9422
AC		 10279 -----------------------------
10280 -- Has_Extra_Accessibility --
10281 -----------------------------
10282
10283 -- Returns true for a formal of an anonymous access type or for
10284 -- an Ada 2012-style stand-alone object of an anonymous access type.
10285
10286 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
10287 begin
10288 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
10289 return Present (Effective_Extra_Accessibility (Id));
10290 else
10291 return False;
10292 end if;
10293 end Has_Extra_Accessibility;
10294
70482933
RK		 10295 -- Start of processing for Expand_N_Type_Conversion
10296
10297 begin
83851b23 10298 -- First remove check marks put by the semantic analysis on the type
b2502161
AC		 10299 -- conversion between array types. We need these checks, and they will
10300 -- be generated by this expansion routine, but we do not depend on these
10301 -- flags being set, and since we do intend to expand the checks in the
10302 -- front end, we don't want them on the tree passed to the back end.
83851b23
AC		 10303
10304 if Is_Array_Type (Target_Type) then
10305 if Is_Constrained (Target_Type) then
10306 Set_Do_Length_Check (N, False);
10307 else
10308 Set_Do_Range_Check (Operand, False);
10309 end if;
10310 end if;
10311
685094bf 10312 -- Nothing at all to do if conversion is to the identical type so remove
76efd572
AC		 10313 -- the conversion completely, it is useless, except that it may carry
10314 -- an Assignment_OK attribute, which must be propagated to the operand.
70482933
RK		 10315
10316 if Operand_Type = Target_Type then
7b00e31d
AC		 10317 if Assignment_OK (N) then
10318 Set_Assignment_OK (Operand);
10319 end if;
10320
fbf5a39b 10321 Rewrite (N, Relocate_Node (Operand));
e606088a 10322 goto Done;
70482933
RK		 10323 end if;
10324
685094bf
RD		 10325 -- Nothing to do if this is the second argument of read. This is a
10326 -- "backwards" conversion that will be handled by the specialized code
10327 -- in attribute processing.
70482933
RK		 10328
10329 if Nkind (Parent (N)) = N_Attribute_Reference
10330 and then Attribute_Name (Parent (N)) = Name_Read
10331 and then Next (First (Expressions (Parent (N)))) = N
10332 then
e606088a
AC		 10333 goto Done;
10334 end if;
10335
10336 -- Check for case of converting to a type that has an invariant
10337 -- associated with it. This required an invariant check. We convert
10338
10339 -- typ (expr)
10340
10341 -- into
10342
10343 -- do invariant_check (typ (expr)) in typ (expr);
10344
10345 -- using Duplicate_Subexpr to avoid multiple side effects
10346
10347 -- Note: the Comes_From_Source check, and then the resetting of this
10348 -- flag prevents what would otherwise be an infinite recursion.
10349
fd0ff1cf
RD		 10350 if Has_Invariants (Target_Type)
10351 and then Present (Invariant_Procedure (Target_Type))
e606088a
AC		 10352 and then Comes_From_Source (N)
10353 then
10354 Set_Comes_From_Source (N, False);
10355 Rewrite (N,
10356 Make_Expression_With_Actions (Loc,
10357 Actions => New_List (
10358 Make_Invariant_Call (Duplicate_Subexpr (N))),
10359 Expression => Duplicate_Subexpr_No_Checks (N)));
10360 Analyze_And_Resolve (N, Target_Type);
10361 goto Done;
70482933
RK		 10362 end if;
10363
10364 -- Here if we may need to expand conversion
10365
eaa826f8
RD		 10366 -- If the operand of the type conversion is an arithmetic operation on
10367 -- signed integers, and the based type of the signed integer type in
10368 -- question is smaller than Standard.Integer, we promote both of the
10369 -- operands to type Integer.
10370
10371 -- For example, if we have
10372
10373 -- target-type (opnd1 + opnd2)
10374
10375 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10376 -- this as:
10377
10378 -- target-type (integer(opnd1) + integer(opnd2))
10379
10380 -- We do this because we are always allowed to compute in a larger type
10381 -- if we do the right thing with the result, and in this case we are
10382 -- going to do a conversion which will do an appropriate check to make
10383 -- sure that things are in range of the target type in any case. This
10384 -- avoids some unnecessary intermediate overflows.
10385
dfcfdc0a
AC		 10386 -- We might consider a similar transformation in the case where the
10387 -- target is a real type or a 64-bit integer type, and the operand
10388 -- is an arithmetic operation using a 32-bit integer type. However,
10389 -- we do not bother with this case, because it could cause significant
308e6f3a 10390 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
dfcfdc0a
AC		 10391 -- much cheaper, but we don't want different behavior on 32-bit and
10392 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10393 -- handles the configurable run-time cases where 64-bit arithmetic
10394 -- may simply be unavailable.
eaa826f8
RD		 10395
10396 -- Note: this circuit is partially redundant with respect to the circuit
10397 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10398 -- the processing here. Also we still need the Checks circuit, since we
10399 -- have to be sure not to generate junk overflow checks in the first
a90bd866 10400 -- place, since it would be trick to remove them here.
eaa826f8 10401
fdfcc663 10402 if Integer_Promotion_Possible (N) then
eaa826f8 10403
fdfcc663 10404 -- All conditions met, go ahead with transformation
eaa826f8 10405
fdfcc663
AC		 10406 declare
10407 Opnd : Node_Id;
10408 L, R : Node_Id;
dfcfdc0a 10409
fdfcc663
AC		 10410 begin
10411 R :=
10412 Make_Type_Conversion (Loc,
e4494292 10413 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
fdfcc663 10414 Expression => Relocate_Node (Right_Opnd (Operand)));
eaa826f8 10415
5f3f175d
AC		 10416 Opnd := New_Op_Node (Nkind (Operand), Loc);
10417 Set_Right_Opnd (Opnd, R);
eaa826f8 10418
5f3f175d 10419 if Nkind (Operand) in N_Binary_Op then
fdfcc663 10420 L :=
eaa826f8 10421 Make_Type_Conversion (Loc,
e4494292 10422 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
fdfcc663
AC		 10423 Expression => Relocate_Node (Left_Opnd (Operand)));
10424
5f3f175d
AC		 10425 Set_Left_Opnd (Opnd, L);
10426 end if;
eaa826f8 10427
5f3f175d
AC		 10428 Rewrite (N,
10429 Make_Type_Conversion (Loc,
10430 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
10431 Expression => Opnd));
dfcfdc0a 10432
5f3f175d 10433 Analyze_And_Resolve (N, Target_Type);
e606088a 10434 goto Done;
fdfcc663
AC		 10435 end;
10436 end if;
eaa826f8 10437
f82944b7
JM		 10438 -- Do validity check if validity checking operands
10439
533369aa 10440 if Validity_Checks_On and Validity_Check_Operands then
f82944b7
JM		 10441 Ensure_Valid (Operand);
10442 end if;
10443
70482933
RK		 10444 -- Special case of converting from non-standard boolean type
10445
10446 if Is_Boolean_Type (Operand_Type)
10447 and then (Nonzero_Is_True (Operand_Type))
10448 then
10449 Adjust_Condition (Operand);
10450 Set_Etype (Operand, Standard_Boolean);
10451 Operand_Type := Standard_Boolean;
10452 end if;
10453
10454 -- Case of converting to an access type
10455
10456 if Is_Access_Type (Target_Type) then
10457
d766cee3
RD		 10458 -- Apply an accessibility check when the conversion operand is an
10459 -- access parameter (or a renaming thereof), unless conversion was
e84e11ba
GD		 10460 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10461 -- Note that other checks may still need to be applied below (such
10462 -- as tagged type checks).
70482933
RK		 10463
10464 if Is_Entity_Name (Operand)
d15f9422 10465 and then Has_Extra_Accessibility (Entity (Operand))
70482933 10466 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
d766cee3
RD		 10467 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
10468 or else Attribute_Name (Original_Node (N)) = Name_Access)
70482933 10469 then
e84e11ba
GD		 10470 Apply_Accessibility_Check
10471 (Operand, Target_Type, Insert_Node => Operand);
70482933 10472
e84e11ba 10473 -- If the level of the operand type is statically deeper than the
685094bf
RD		 10474 -- level of the target type, then force Program_Error. Note that this
10475 -- can only occur for cases where the attribute is within the body of
6c56d9b8
AC		 10476 -- an instantiation, otherwise the conversion will already have been
10477 -- rejected as illegal.
10478
10479 -- Note: warnings are issued by the analyzer for the instance cases
70482933
RK		 10480
10481 elsif In_Instance_Body
6c56d9b8
AC		 10482
10483 -- The case where the target type is an anonymous access type of
10484 -- a discriminant is excluded, because the level of such a type
10485 -- depends on the context and currently the level returned for such
10486 -- types is zero, resulting in warnings about about check failures
10487 -- in certain legal cases involving class-wide interfaces as the
10488 -- designated type (some cases, such as return statements, are
10489 -- checked at run time, but not clear if these are handled right
10490 -- in general, see 3.10.2(12/2-12.5/3) ???).
10491
ad5edba5
AC		 10492 and then
10493 not (Ekind (Target_Type) = E_Anonymous_Access_Type
10494 and then Present (Associated_Node_For_Itype (Target_Type))
10495 and then Nkind (Associated_Node_For_Itype (Target_Type)) =
10496 N_Discriminant_Specification)
10497 and then
10498 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
70482933 10499 then
426908f8 10500 Raise_Accessibility_Error;
70482933 10501
685094bf
RD		 10502 -- When the operand is a selected access discriminant the check needs
10503 -- to be made against the level of the object denoted by the prefix
10504 -- of the selected name. Force Program_Error for this case as well
10505 -- (this accessibility violation can only happen if within the body
10506 -- of an instantiation).
70482933
RK		 10507
10508 elsif In_Instance_Body
10509 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
10510 and then Nkind (Operand) = N_Selected_Component
10511 and then Object_Access_Level (Operand) >
10512 Type_Access_Level (Target_Type)
10513 then
426908f8 10514 Raise_Accessibility_Error;
e606088a 10515 goto Done;
70482933
RK		 10516 end if;
10517 end if;
10518
10519 -- Case of conversions of tagged types and access to tagged types
10520
685094bf
RD		 10521 -- When needed, that is to say when the expression is class-wide, Add
10522 -- runtime a tag check for (strict) downward conversion by using the
10523 -- membership test, generating:
70482933
RK		 10524
10525 -- [constraint_error when Operand not in Target_Type'Class]
10526
10527 -- or in the access type case
10528
10529 -- [constraint_error
10530 -- when Operand /= null
10531 -- and then Operand.all not in
10532 -- Designated_Type (Target_Type)'Class]
10533
10534 if (Is_Access_Type (Target_Type)
10535 and then Is_Tagged_Type (Designated_Type (Target_Type)))
10536 or else Is_Tagged_Type (Target_Type)
10537 then
685094bf
RD		 10538 -- Do not do any expansion in the access type case if the parent is a
10539 -- renaming, since this is an error situation which will be caught by
10540 -- Sem_Ch8, and the expansion can interfere with this error check.
70482933 10541
e7e4d230 10542 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
e606088a 10543 goto Done;
70482933
RK		 10544 end if;
10545
0669bebe 10546 -- Otherwise, proceed with processing tagged conversion
70482933 10547
e7e4d230 10548 Tagged_Conversion : declare
8cea7b64
HK		 10549 Actual_Op_Typ : Entity_Id;
10550 Actual_Targ_Typ : Entity_Id;
10551 Make_Conversion : Boolean := False;
10552 Root_Op_Typ : Entity_Id;
70482933 10553
8cea7b64
HK		 10554 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
10555 -- Create a membership check to test whether Operand is a member
10556 -- of Targ_Typ. If the original Target_Type is an access, include
10557 -- a test for null value. The check is inserted at N.
10558
10559 --------------------
10560 -- Make_Tag_Check --
10561 --------------------
10562
10563 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
10564 Cond : Node_Id;
10565
10566 begin
10567 -- Generate:
10568 -- [Constraint_Error
10569 -- when Operand /= null
10570 -- and then Operand.all not in Targ_Typ]
10571
10572 if Is_Access_Type (Target_Type) then
10573 Cond :=
10574 Make_And_Then (Loc,
10575 Left_Opnd =>
10576 Make_Op_Ne (Loc,
10577 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10578 Right_Opnd => Make_Null (Loc)),
10579
10580 Right_Opnd =>
10581 Make_Not_In (Loc,
10582 Left_Opnd =>
10583 Make_Explicit_Dereference (Loc,
10584 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
e4494292 10585 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
8cea7b64
HK		 10586
10587 -- Generate:
10588 -- [Constraint_Error when Operand not in Targ_Typ]
10589
10590 else
10591 Cond :=
10592 Make_Not_In (Loc,
10593 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
e4494292 10594 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
8cea7b64
HK		 10595 end if;
10596
10597 Insert_Action (N,
10598 Make_Raise_Constraint_Error (Loc,
10599 Condition => Cond,
10600 Reason => CE_Tag_Check_Failed));
10601 end Make_Tag_Check;
10602
e7e4d230 10603 -- Start of processing for Tagged_Conversion
70482933
RK		 10604
10605 begin
9732e886 10606 -- Handle entities from the limited view
852dba80 10607
9732e886 10608 if Is_Access_Type (Operand_Type) then
852dba80
AC		 10609 Actual_Op_Typ :=
10610 Available_View (Designated_Type (Operand_Type));
9732e886
JM		 10611 else
10612 Actual_Op_Typ := Operand_Type;
10613 end if;
10614
10615 if Is_Access_Type (Target_Type) then
852dba80
AC		 10616 Actual_Targ_Typ :=
10617 Available_View (Designated_Type (Target_Type));
70482933 10618 else
8cea7b64 10619 Actual_Targ_Typ := Target_Type;
70482933
RK		 10620 end if;
10621
8cea7b64
HK		 10622 Root_Op_Typ := Root_Type (Actual_Op_Typ);
10623
20b5d666
JM		 10624 -- Ada 2005 (AI-251): Handle interface type conversion
10625
3cb9a885 10626 if Is_Interface (Actual_Op_Typ)
58b81ab0
AC		 10627 or else
10628 Is_Interface (Actual_Targ_Typ)
3cb9a885 10629 then
f6f4d8d4 10630 Expand_Interface_Conversion (N);
e606088a 10631 goto Done;
20b5d666
JM		 10632 end if;
10633
8cea7b64 10634 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
70482933 10635
8cea7b64
HK		 10636 -- Create a runtime tag check for a downward class-wide type
10637 -- conversion.
70482933 10638
8cea7b64 10639 if Is_Class_Wide_Type (Actual_Op_Typ)
852dba80 10640 and then Actual_Op_Typ /= Actual_Targ_Typ
8cea7b64 10641 and then Root_Op_Typ /= Actual_Targ_Typ
4ac2477e
JM		 10642 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
10643 Use_Full_View => True)
8cea7b64
HK		 10644 then
10645 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
10646 Make_Conversion := True;
10647 end if;
70482933 10648
8cea7b64
HK		 10649 -- AI05-0073: If the result subtype of the function is defined
10650 -- by an access_definition designating a specific tagged type
10651 -- T, a check is made that the result value is null or the tag
10652 -- of the object designated by the result value identifies T.
10653 -- Constraint_Error is raised if this check fails.
70482933 10654
92a7cd46 10655 if Nkind (Parent (N)) = N_Simple_Return_Statement then
8cea7b64 10656 declare
e886436a 10657 Func : Entity_Id;
8cea7b64
HK		 10658 Func_Typ : Entity_Id;
10659
10660 begin
e886436a 10661 -- Climb scope stack looking for the enclosing function
8cea7b64 10662
e886436a 10663 Func := Current_Scope;
8cea7b64
HK		 10664 while Present (Func)
10665 and then Ekind (Func) /= E_Function
10666 loop
10667 Func := Scope (Func);
10668 end loop;
10669
10670 -- The function's return subtype must be defined using
10671 -- an access definition.
10672
10673 if Nkind (Result_Definition (Parent (Func))) =
10674 N_Access_Definition
10675 then
10676 Func_Typ := Directly_Designated_Type (Etype (Func));
10677
10678 -- The return subtype denotes a specific tagged type,
10679 -- in other words, a non class-wide type.
10680
10681 if Is_Tagged_Type (Func_Typ)
10682 and then not Is_Class_Wide_Type (Func_Typ)
10683 then
10684 Make_Tag_Check (Actual_Targ_Typ);
10685 Make_Conversion := True;
10686 end if;
10687 end if;
10688 end;
70482933
RK		 10689 end if;
10690
8cea7b64
HK		 10691 -- We have generated a tag check for either a class-wide type
10692 -- conversion or for AI05-0073.
70482933 10693
8cea7b64
HK		 10694 if Make_Conversion then
10695 declare
10696 Conv : Node_Id;
10697 begin
10698 Conv :=
10699 Make_Unchecked_Type_Conversion (Loc,
10700 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
10701 Expression => Relocate_Node (Expression (N)));
10702 Rewrite (N, Conv);
10703 Analyze_And_Resolve (N, Target_Type);
10704 end;
10705 end if;
70482933 10706 end if;
e7e4d230 10707 end Tagged_Conversion;
70482933
RK		 10708
10709 -- Case of other access type conversions
10710
10711 elsif Is_Access_Type (Target_Type) then
10712 Apply_Constraint_Check (Operand, Target_Type);
10713
10714 -- Case of conversions from a fixed-point type
10715
685094bf
RD		 10716 -- These conversions require special expansion and processing, found in
10717 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10718 -- since from a semantic point of view, these are simple integer
70482933
RK		 10719 -- conversions, which do not need further processing.
10720
10721 elsif Is_Fixed_Point_Type (Operand_Type)
10722 and then not Conversion_OK (N)
10723 then
10724 -- We should never see universal fixed at this case, since the
10725 -- expansion of the constituent divide or multiply should have
10726 -- eliminated the explicit mention of universal fixed.
10727
10728 pragma Assert (Operand_Type /= Universal_Fixed);
10729
685094bf
RD		 10730 -- Check for special case of the conversion to universal real that
10731 -- occurs as a result of the use of a round attribute. In this case,
10732 -- the real type for the conversion is taken from the target type of
10733 -- the Round attribute and the result must be marked as rounded.
70482933
RK		 10734
10735 if Target_Type = Universal_Real
10736 and then Nkind (Parent (N)) = N_Attribute_Reference
10737 and then Attribute_Name (Parent (N)) = Name_Round
10738 then
10739 Set_Rounded_Result (N);
10740 Set_Etype (N, Etype (Parent (N)));
10741 end if;
10742
10743 -- Otherwise do correct fixed-conversion, but skip these if the
e7e4d230
AC		 10744 -- Conversion_OK flag is set, because from a semantic point of view
10745 -- these are simple integer conversions needing no further processing
10746 -- (the backend will simply treat them as integers).
70482933
RK		 10747
10748 if not Conversion_OK (N) then
10749 if Is_Fixed_Point_Type (Etype (N)) then
10750 Expand_Convert_Fixed_To_Fixed (N);
10751 Real_Range_Check;
10752
10753 elsif Is_Integer_Type (Etype (N)) then
10754 Expand_Convert_Fixed_To_Integer (N);
10755
10756 else
10757 pragma Assert (Is_Floating_Point_Type (Etype (N)));
10758 Expand_Convert_Fixed_To_Float (N);
10759 Real_Range_Check;
10760 end if;
10761 end if;
10762
10763 -- Case of conversions to a fixed-point type
10764
685094bf
RD		 10765 -- These conversions require special expansion and processing, found in
10766 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10767 -- since from a semantic point of view, these are simple integer
10768 -- conversions, which do not need further processing.
70482933
RK		 10769
10770 elsif Is_Fixed_Point_Type (Target_Type)
10771 and then not Conversion_OK (N)
10772 then
10773 if Is_Integer_Type (Operand_Type) then
10774 Expand_Convert_Integer_To_Fixed (N);
10775 Real_Range_Check;
10776 else
10777 pragma Assert (Is_Floating_Point_Type (Operand_Type));
10778 Expand_Convert_Float_To_Fixed (N);
10779 Real_Range_Check;
10780 end if;
10781
10782 -- Case of float-to-integer conversions
10783
10784 -- We also handle float-to-fixed conversions with Conversion_OK set
10785 -- since semantically the fixed-point target is treated as though it
10786 -- were an integer in such cases.
10787
10788 elsif Is_Floating_Point_Type (Operand_Type)
10789 and then
10790 (Is_Integer_Type (Target_Type)
10791 or else
10792 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
10793 then
70482933
RK		 10794 -- One more check here, gcc is still not able to do conversions of
10795 -- this type with proper overflow checking, and so gigi is doing an
10796 -- approximation of what is required by doing floating-point compares
10797 -- with the end-point. But that can lose precision in some cases, and
f02b8bb8 10798 -- give a wrong result. Converting the operand to Universal_Real is
70482933 10799 -- helpful, but still does not catch all cases with 64-bit integers
e7e4d230 10800 -- on targets with only 64-bit floats.
0669bebe
GB		 10801
10802 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10803 -- Can this code be removed ???
70482933 10804
fbf5a39b
AC		 10805 if Do_Range_Check (Operand) then
10806 Rewrite (Operand,
70482933
RK		 10807 Make_Type_Conversion (Loc,
10808 Subtype_Mark =>
f02b8bb8 10809 New_Occurrence_Of (Universal_Real, Loc),
70482933 10810 Expression =>
fbf5a39b 10811 Relocate_Node (Operand)));
70482933 10812
f02b8bb8 10813 Set_Etype (Operand, Universal_Real);
fbf5a39b
AC		 10814 Enable_Range_Check (Operand);
10815 Set_Do_Range_Check (Expression (Operand), False);
70482933
RK		 10816 end if;
10817
10818 -- Case of array conversions
10819
685094bf
RD		 10820 -- Expansion of array conversions, add required length/range checks but
10821 -- only do this if there is no change of representation. For handling of
10822 -- this case, see Handle_Changed_Representation.
70482933
RK		 10823
10824 elsif Is_Array_Type (Target_Type) then
70482933
RK		 10825 if Is_Constrained (Target_Type) then
10826 Apply_Length_Check (Operand, Target_Type);
10827 else
10828 Apply_Range_Check (Operand, Target_Type);
10829 end if;
10830
10831 Handle_Changed_Representation;
10832
10833 -- Case of conversions of discriminated types
10834
685094bf
RD		 10835 -- Add required discriminant checks if target is constrained. Again this
10836 -- change is skipped if we have a change of representation.
70482933
RK		 10837
10838 elsif Has_Discriminants (Target_Type)
10839 and then Is_Constrained (Target_Type)
10840 then
10841 Apply_Discriminant_Check (Operand, Target_Type);
10842 Handle_Changed_Representation;
10843
10844 -- Case of all other record conversions. The only processing required
10845 -- is to check for a change of representation requiring the special
10846 -- assignment processing.
10847
10848 elsif Is_Record_Type (Target_Type) then
5d09245e
AC		 10849
10850 -- Ada 2005 (AI-216): Program_Error is raised when converting from
685094bf
RD		 10851 -- a derived Unchecked_Union type to an unconstrained type that is
10852 -- not Unchecked_Union if the operand lacks inferable discriminants.
5d09245e
AC		 10853
10854 if Is_Derived_Type (Operand_Type)
10855 and then Is_Unchecked_Union (Base_Type (Operand_Type))
10856 and then not Is_Constrained (Target_Type)
10857 and then not Is_Unchecked_Union (Base_Type (Target_Type))
10858 and then not Has_Inferable_Discriminants (Operand)
10859 then
685094bf 10860 -- To prevent Gigi from generating illegal code, we generate a
5d09245e 10861 -- Program_Error node, but we give it the target type of the
6cb3037c 10862 -- conversion (is this requirement documented somewhere ???)
5d09245e
AC		 10863
10864 declare
10865 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
10866 Reason => PE_Unchecked_Union_Restriction);
10867
10868 begin
10869 Set_Etype (PE, Target_Type);
10870 Rewrite (N, PE);
10871
10872 end;
10873 else
10874 Handle_Changed_Representation;
10875 end if;
70482933
RK		 10876
10877 -- Case of conversions of enumeration types
10878
10879 elsif Is_Enumeration_Type (Target_Type) then
10880
10881 -- Special processing is required if there is a change of
e7e4d230 10882 -- representation (from enumeration representation clauses).
70482933
RK		 10883
10884 if not Same_Representation (Target_Type, Operand_Type) then
10885
10886 -- Convert: x(y) to x'val (ytyp'val (y))
10887
10888 Rewrite (N,
1c66c4f5
AC		 10889 Make_Attribute_Reference (Loc,
10890 Prefix => New_Occurrence_Of (Target_Type, Loc),
10891 Attribute_Name => Name_Val,
10892 Expressions => New_List (
10893 Make_Attribute_Reference (Loc,
10894 Prefix => New_Occurrence_Of (Operand_Type, Loc),
10895 Attribute_Name => Name_Pos,
10896 Expressions => New_List (Operand)))));
70482933
RK		 10897
10898 Analyze_And_Resolve (N, Target_Type);
10899 end if;
10900
10901 -- Case of conversions to floating-point
10902
10903 elsif Is_Floating_Point_Type (Target_Type) then
10904 Real_Range_Check;
70482933
RK		 10905 end if;
10906
685094bf 10907 -- At this stage, either the conversion node has been transformed into
e7e4d230
AC		 10908 -- some other equivalent expression, or left as a conversion that can be
10909 -- handled by Gigi, in the following cases:
70482933
RK		 10910
10911 -- Conversions with no change of representation or type
10912
685094bf
RD		 10913 -- Numeric conversions involving integer, floating- and fixed-point
10914 -- values. Fixed-point values are allowed only if Conversion_OK is
10915 -- set, i.e. if the fixed-point values are to be treated as integers.
70482933 10916
5e1c00fa
RD		 10917 -- No other conversions should be passed to Gigi
10918
10919 -- Check: are these rules stated in sinfo??? if so, why restate here???
70482933 10920
685094bf
RD		 10921 -- The only remaining step is to generate a range check if we still have
10922 -- a type conversion at this stage and Do_Range_Check is set. For now we
f5655e4a
AC		 10923 -- do this only for conversions of discrete types and for float-to-float
10924 -- conversions.
fbf5a39b 10925
7b536495 10926 if Nkind (N) = N_Type_Conversion then
fbf5a39b 10927
f5655e4a
AC		 10928 -- For now we only support floating-point cases where both source
10929 -- and target are floating-point types. Conversions where the source
10930 -- and target involve integer or fixed-point types are still TBD,
10931 -- though not clear whether those can even happen at this point, due
10932 -- to transformations above. ???
fbf5a39b 10933
7b536495 10934 if Is_Floating_Point_Type (Etype (N))
f5655e4a 10935 and then Is_Floating_Point_Type (Etype (Expression (N)))
7b536495
AC		 10936 then
10937 if Do_Range_Check (Expression (N))
10938 and then Is_Floating_Point_Type (Target_Type)
10939 then
10940 Generate_Range_Check
10941 (Expression (N), Target_Type, CE_Range_Check_Failed);
10942 end if;
fbf5a39b 10943
f5655e4a
AC		 10944 -- Discrete-to-discrete conversions
10945
7b536495
AC		 10946 elsif Is_Discrete_Type (Etype (N)) then
10947 declare
10948 Expr : constant Node_Id := Expression (N);
10949 Ftyp : Entity_Id;
10950 Ityp : Entity_Id;
fbf5a39b 10951
7b536495
AC		 10952 begin
10953 if Do_Range_Check (Expr)
10954 and then Is_Discrete_Type (Etype (Expr))
fbf5a39b 10955 then
7b536495 10956 Set_Do_Range_Check (Expr, False);
fbf5a39b 10957
7b536495
AC		 10958 -- Before we do a range check, we have to deal with treating
10959 -- a fixed-point operand as an integer. The way we do this
10960 -- is simply to do an unchecked conversion to an appropriate
10961 -- integer type large enough to hold the result.
fbf5a39b 10962
7b536495
AC		 10963 -- This code is not active yet, because we are only dealing
10964 -- with discrete types so far ???
fbf5a39b 10965
7b536495
AC		 10966 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
10967 and then Treat_Fixed_As_Integer (Expr)
10968 then
10969 Ftyp := Base_Type (Etype (Expr));
fbf5a39b 10970
7b536495
AC		 10971 if Esize (Ftyp) >= Esize (Standard_Integer) then
10972 Ityp := Standard_Long_Long_Integer;
10973 else
10974 Ityp := Standard_Integer;
10975 end if;
edab6088 10976
7b536495
AC		 10977 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
10978 end if;
10979
10980 -- Reset overflow flag, since the range check will include
10981 -- dealing with possible overflow, and generate the check.
10982 -- If Address is either a source type or target type,
10983 -- suppress range check to avoid typing anomalies when
10984 -- it is a visible integer type.
10985
10986 Set_Do_Overflow_Check (N, False);
10987
10988 if not Is_Descendent_Of_Address (Etype (Expr))
10989 and then not Is_Descendent_Of_Address (Target_Type)
10990 then
10991 Generate_Range_Check
10992 (Expr, Target_Type, CE_Range_Check_Failed);
10993 end if;
8a36a0cc 10994 end if;
7b536495
AC		 10995 end;
10996 end if;
fbf5a39b 10997 end if;
f02b8bb8 10998
e606088a
AC		 10999 -- Here at end of processing
11000
48f91b44
RD		 11001 <<Done>>
11002 -- Apply predicate check if required. Note that we can't just call
11003 -- Apply_Predicate_Check here, because the type looks right after
11004 -- the conversion and it would omit the check. The Comes_From_Source
11005 -- guard is necessary to prevent infinite recursions when we generate
11006 -- internal conversions for the purpose of checking predicates.
11007
11008 if Present (Predicate_Function (Target_Type))
11009 and then Target_Type /= Operand_Type
11010 and then Comes_From_Source (N)
11011 then
00332244
AC		 11012 declare
11013 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
11014
11015 begin
11016 -- Avoid infinite recursion on the subsequent expansion of
11017 -- of the copy of the original type conversion.
11018
11019 Set_Comes_From_Source (New_Expr, False);
11020 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr));
11021 end;
48f91b44 11022 end if;
70482933
RK		 11023 end Expand_N_Type_Conversion;
11024
11025 -----------------------------------
11026 -- Expand_N_Unchecked_Expression --
11027 -----------------------------------
11028
e7e4d230 11029 -- Remove the unchecked expression node from the tree. Its job was simply
70482933
RK		 11030 -- to make sure that its constituent expression was handled with checks
11031 -- off, and now that that is done, we can remove it from the tree, and
e7e4d230 11032 -- indeed must, since Gigi does not expect to see these nodes.
70482933
RK		 11033
11034 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
11035 Exp : constant Node_Id := Expression (N);
70482933 11036 begin
e7e4d230 11037 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
70482933
RK		 11038 Rewrite (N, Exp);
11039 end Expand_N_Unchecked_Expression;
11040
11041 ----------------------------------------
11042 -- Expand_N_Unchecked_Type_Conversion --
11043 ----------------------------------------
11044
685094bf
RD		 11045 -- If this cannot be handled by Gigi and we haven't already made a
11046 -- temporary for it, do it now.
70482933
RK		 11047
11048 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
11049 Target_Type : constant Entity_Id := Etype (N);
11050 Operand : constant Node_Id := Expression (N);
11051 Operand_Type : constant Entity_Id := Etype (Operand);
11052
11053 begin
7b00e31d 11054 -- Nothing at all to do if conversion is to the identical type so remove
76efd572 11055 -- the conversion completely, it is useless, except that it may carry
e7e4d230 11056 -- an Assignment_OK indication which must be propagated to the operand.
7b00e31d
AC		 11057
11058 if Operand_Type = Target_Type then
13d923cc 11059
e7e4d230
AC		 11060 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11061
7b00e31d
AC		 11062 if Assignment_OK (N) then
11063 Set_Assignment_OK (Operand);
11064 end if;
11065
11066 Rewrite (N, Relocate_Node (Operand));
11067 return;
11068 end if;
11069
70482933
RK		 11070 -- If we have a conversion of a compile time known value to a target
11071 -- type and the value is in range of the target type, then we can simply
11072 -- replace the construct by an integer literal of the correct type. We
11073 -- only apply this to integer types being converted. Possibly it may
11074 -- apply in other cases, but it is too much trouble to worry about.
11075
11076 -- Note that we do not do this transformation if the Kill_Range_Check
11077 -- flag is set, since then the value may be outside the expected range.
11078 -- This happens in the Normalize_Scalars case.
11079
20b5d666
JM		 11080 -- We also skip this if either the target or operand type is biased
11081 -- because in this case, the unchecked conversion is supposed to
11082 -- preserve the bit pattern, not the integer value.
11083
70482933 11084 if Is_Integer_Type (Target_Type)
20b5d666 11085 and then not Has_Biased_Representation (Target_Type)
70482933 11086 and then Is_Integer_Type (Operand_Type)
20b5d666 11087 and then not Has_Biased_Representation (Operand_Type)
70482933
RK		 11088 and then Compile_Time_Known_Value (Operand)
11089 and then not Kill_Range_Check (N)
11090 then
11091 declare
11092 Val : constant Uint := Expr_Value (Operand);
11093
11094 begin
11095 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
11096 and then
11097 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
11098 and then
11099 Val >= Expr_Value (Type_Low_Bound (Target_Type))
11100 and then
11101 Val <= Expr_Value (Type_High_Bound (Target_Type))
11102 then
11103 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
8a36a0cc 11104
685094bf
RD		 11105 -- If Address is the target type, just set the type to avoid a
11106 -- spurious type error on the literal when Address is a visible
11107 -- integer type.
8a36a0cc
AC		 11108
11109 if Is_Descendent_Of_Address (Target_Type) then
11110 Set_Etype (N, Target_Type);
11111 else
11112 Analyze_And_Resolve (N, Target_Type);
11113 end if;
11114
70482933
RK		 11115 return;
11116 end if;
11117 end;
11118 end if;
11119
11120 -- Nothing to do if conversion is safe
11121
11122 if Safe_Unchecked_Type_Conversion (N) then
11123 return;
11124 end if;
11125
11126 -- Otherwise force evaluation unless Assignment_OK flag is set (this
324ac540 11127 -- flag indicates ??? More comments needed here)
70482933
RK		 11128
11129 if Assignment_OK (N) then
11130 null;
11131 else
11132 Force_Evaluation (N);
11133 end if;
11134 end Expand_N_Unchecked_Type_Conversion;
11135
11136 ----------------------------
11137 -- Expand_Record_Equality --
11138 ----------------------------
11139
11140 -- For non-variant records, Equality is expanded when needed into:
11141
11142 -- and then Lhs.Discr1 = Rhs.Discr1
11143 -- and then ...
11144 -- and then Lhs.Discrn = Rhs.Discrn
11145 -- and then Lhs.Cmp1 = Rhs.Cmp1
11146 -- and then ...
11147 -- and then Lhs.Cmpn = Rhs.Cmpn
11148
11149 -- The expression is folded by the back-end for adjacent fields. This
11150 -- function is called for tagged record in only one occasion: for imple-
11151 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11152 -- otherwise the primitive "=" is used directly.
11153
11154 function Expand_Record_Equality
11155 (Nod : Node_Id;
11156 Typ : Entity_Id;
11157 Lhs : Node_Id;
11158 Rhs : Node_Id;
2e071734 11159 Bodies : List_Id) return Node_Id
70482933
RK		 11160 is
11161 Loc : constant Source_Ptr := Sloc (Nod);
11162
0ab80019
AC		 11163 Result : Node_Id;
11164 C : Entity_Id;
11165
11166 First_Time : Boolean := True;
11167
6b670dcf
AC		 11168 function Element_To_Compare (C : Entity_Id) return Entity_Id;
11169 -- Return the next discriminant or component to compare, starting with
11170 -- C, skipping inherited components.
0ab80019 11171
6b670dcf
AC		 11172 ------------------------
11173 -- Element_To_Compare --
11174 ------------------------
70482933 11175
6b670dcf
AC		 11176 function Element_To_Compare (C : Entity_Id) return Entity_Id is
11177 Comp : Entity_Id;
28270211 11178
70482933 11179 begin
6b670dcf 11180 Comp := C;
6b670dcf
AC		 11181 loop
11182 -- Exit loop when the next element to be compared is found, or
11183 -- there is no more such element.
70482933 11184
6b670dcf 11185 exit when No (Comp);
8190087e 11186
6b670dcf
AC		 11187 exit when Ekind_In (Comp, E_Discriminant, E_Component)
11188 and then not (
70482933 11189
6b670dcf 11190 -- Skip inherited components
70482933 11191
6b670dcf
AC		 11192 -- Note: for a tagged type, we always generate the "=" primitive
11193 -- for the base type (not on the first subtype), so the test for
11194 -- Comp /= Original_Record_Component (Comp) is True for
11195 -- inherited components only.
24558db8 11196
6b670dcf 11197 (Is_Tagged_Type (Typ)
28270211 11198 and then Comp /= Original_Record_Component (Comp))
24558db8 11199
6b670dcf 11200 -- Skip _Tag
26bff3d9 11201
6b670dcf
AC		 11202 or else Chars (Comp) = Name_uTag
11203
11204 -- The .NET/JVM version of type Root_Controlled contains two
11205 -- fields which should not be considered part of the object. To
11206 -- achieve proper equiality between two controlled objects on
11207 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
11208
11209 or else (Chars (Comp) = Name_uParent
28270211
AC		 11210 and then VM_Target /= No_VM
11211 and then Etype (Comp) = RTE (RE_Root_Controlled))
6b670dcf
AC		 11212
11213 -- Skip interface elements (secondary tags???)
11214
11215 or else Is_Interface (Etype (Comp)));
11216
11217 Next_Entity (Comp);
11218 end loop;
11219
11220 return Comp;
11221 end Element_To_Compare;
70482933 11222
70482933
RK		 11223 -- Start of processing for Expand_Record_Equality
11224
11225 begin
70482933
RK		 11226 -- Generates the following code: (assuming that Typ has one Discr and
11227 -- component C2 is also a record)
11228
11229 -- True
11230 -- and then Lhs.Discr1 = Rhs.Discr1
11231 -- and then Lhs.C1 = Rhs.C1
11232 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11233 -- and then ...
11234 -- and then Lhs.Cmpn = Rhs.Cmpn
11235
e4494292 11236 Result := New_Occurrence_Of (Standard_True, Loc);
6b670dcf 11237 C := Element_To_Compare (First_Entity (Typ));
70482933 11238 while Present (C) loop
70482933
RK		 11239 declare
11240 New_Lhs : Node_Id;
11241 New_Rhs : Node_Id;
8aceda64 11242 Check : Node_Id;
70482933
RK		 11243
11244 begin
11245 if First_Time then
11246 First_Time := False;
11247 New_Lhs := Lhs;
11248 New_Rhs := Rhs;
70482933
RK		 11249 else
11250 New_Lhs := New_Copy_Tree (Lhs);
11251 New_Rhs := New_Copy_Tree (Rhs);
11252 end if;
11253
8aceda64
AC		 11254 Check :=
11255 Expand_Composite_Equality (Nod, Etype (C),
11256 Lhs =>
11257 Make_Selected_Component (Loc,
8d80ff64 11258 Prefix => New_Lhs,
e4494292 11259 Selector_Name => New_Occurrence_Of (C, Loc)),
8aceda64
AC		 11260 Rhs =>
11261 Make_Selected_Component (Loc,
8d80ff64 11262 Prefix => New_Rhs,
e4494292 11263 Selector_Name => New_Occurrence_Of (C, Loc)),
8aceda64
AC		 11264 Bodies => Bodies);
11265
11266 -- If some (sub)component is an unchecked_union, the whole
11267 -- operation will raise program error.
11268
11269 if Nkind (Check) = N_Raise_Program_Error then
11270 Result := Check;
11271 Set_Etype (Result, Standard_Boolean);
11272 exit;
11273 else
11274 Result :=
11275 Make_And_Then (Loc,
11276 Left_Opnd => Result,
11277 Right_Opnd => Check);
11278 end if;
70482933
RK		 11279 end;
11280
6b670dcf 11281 C := Element_To_Compare (Next_Entity (C));
70482933
RK		 11282 end loop;
11283
11284 return Result;
11285 end Expand_Record_Equality;
11286
a3068ca6
AC		 11287 ---------------------------
11288 -- Expand_Set_Membership --
11289 ---------------------------
11290
11291 procedure Expand_Set_Membership (N : Node_Id) is
11292 Lop : constant Node_Id := Left_Opnd (N);
11293 Alt : Node_Id;
11294 Res : Node_Id;
11295
11296 function Make_Cond (Alt : Node_Id) return Node_Id;
11297 -- If the alternative is a subtype mark, create a simple membership
11298 -- test. Otherwise create an equality test for it.
11299
11300 ---------------
11301 -- Make_Cond --
11302 ---------------
11303
11304 function Make_Cond (Alt : Node_Id) return Node_Id is
11305 Cond : Node_Id;
11306 L : constant Node_Id := New_Copy (Lop);
11307 R : constant Node_Id := Relocate_Node (Alt);
11308
11309 begin
11310 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
11311 or else Nkind (Alt) = N_Range
11312 then
11313 Cond :=
11314 Make_In (Sloc (Alt),
11315 Left_Opnd => L,
11316 Right_Opnd => R);
11317 else
11318 Cond :=
11319 Make_Op_Eq (Sloc (Alt),
11320 Left_Opnd => L,
11321 Right_Opnd => R);
11322 end if;
11323
11324 return Cond;
11325 end Make_Cond;
11326
11327 -- Start of processing for Expand_Set_Membership
11328
11329 begin
11330 Remove_Side_Effects (Lop);
11331
11332 Alt := Last (Alternatives (N));
11333 Res := Make_Cond (Alt);
11334
11335 Prev (Alt);
11336 while Present (Alt) loop
11337 Res :=
11338 Make_Or_Else (Sloc (Alt),
11339 Left_Opnd => Make_Cond (Alt),
11340 Right_Opnd => Res);
11341 Prev (Alt);
11342 end loop;
11343
11344 Rewrite (N, Res);
11345 Analyze_And_Resolve (N, Standard_Boolean);
11346 end Expand_Set_Membership;
11347
5875f8d6
AC		 11348 -----------------------------------
11349 -- Expand_Short_Circuit_Operator --
11350 -----------------------------------
11351
955871d3
AC		 11352 -- Deal with special expansion if actions are present for the right operand
11353 -- and deal with optimizing case of arguments being True or False. We also
11354 -- deal with the special case of non-standard boolean values.
5875f8d6
AC		 11355
11356 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
11357 Loc : constant Source_Ptr := Sloc (N);
11358 Typ : constant Entity_Id := Etype (N);
5875f8d6
AC		 11359 Left : constant Node_Id := Left_Opnd (N);
11360 Right : constant Node_Id := Right_Opnd (N);
955871d3 11361 LocR : constant Source_Ptr := Sloc (Right);
5875f8d6
AC		 11362 Actlist : List_Id;
11363
11364 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
11365 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
11366 -- If Left = Shortcut_Value then Right need not be evaluated
11367
5875f8d6
AC		 11368 begin
11369 -- Deal with non-standard booleans
11370
11371 if Is_Boolean_Type (Typ) then
11372 Adjust_Condition (Left);
11373 Adjust_Condition (Right);
11374 Set_Etype (N, Standard_Boolean);
11375 end if;
11376
11377 -- Check for cases where left argument is known to be True or False
11378
11379 if Compile_Time_Known_Value (Left) then
25adc5fb
AC		 11380
11381 -- Mark SCO for left condition as compile time known
11382
11383 if Generate_SCO and then Comes_From_Source (Left) then
11384 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
11385 end if;
11386
5875f8d6
AC		 11387 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11388 -- Any actions associated with Right will be executed unconditionally
11389 -- and can thus be inserted into the tree unconditionally.
11390
11391 if Expr_Value_E (Left) /= Shortcut_Ent then
11392 if Present (Actions (N)) then
11393 Insert_Actions (N, Actions (N));
11394 end if;
11395
11396 Rewrite (N, Right);
11397
11398 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11399 -- In this case we can forget the actions associated with Right,
11400 -- since they will never be executed.
11401
11402 else
11403 Kill_Dead_Code (Right);
11404 Kill_Dead_Code (Actions (N));
11405 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11406 end if;
11407
11408 Adjust_Result_Type (N, Typ);
11409 return;
11410 end if;
11411
955871d3
AC		 11412 -- If Actions are present for the right operand, we have to do some
11413 -- special processing. We can't just let these actions filter back into
11414 -- code preceding the short circuit (which is what would have happened
11415 -- if we had not trapped them in the short-circuit form), since they
11416 -- must only be executed if the right operand of the short circuit is
11417 -- executed and not otherwise.
5875f8d6 11418
955871d3
AC		 11419 if Present (Actions (N)) then
11420 Actlist := Actions (N);
5875f8d6 11421
0812b84e
AC		 11422 -- We now use an Expression_With_Actions node for the right operand
11423 -- of the short-circuit form. Note that this solves the traceability
11424 -- problems for coverage analysis.
5875f8d6 11425
0812b84e
AC		 11426 Rewrite (Right,
11427 Make_Expression_With_Actions (LocR,
11428 Expression => Relocate_Node (Right),
11429 Actions => Actlist));
11430 Set_Actions (N, No_List);
11431 Analyze_And_Resolve (Right, Standard_Boolean);
955871d3 11432
5875f8d6
AC		 11433 Adjust_Result_Type (N, Typ);
11434 return;
11435 end if;
11436
11437 -- No actions present, check for cases of right argument True/False
11438
11439 if Compile_Time_Known_Value (Right) then
25adc5fb
AC		 11440
11441 -- Mark SCO for left condition as compile time known
11442
11443 if Generate_SCO and then Comes_From_Source (Right) then
11444 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
11445 end if;
11446
5875f8d6
AC		 11447 -- Change (Left and then True), (Left or else False) to Left.
11448 -- Note that we know there are no actions associated with the right
11449 -- operand, since we just checked for this case above.
11450
11451 if Expr_Value_E (Right) /= Shortcut_Ent then
11452 Rewrite (N, Left);
11453
11454 -- Change (Left and then False), (Left or else True) to Right,
11455 -- making sure to preserve any side effects associated with the Left
11456 -- operand.
11457
11458 else
11459 Remove_Side_Effects (Left);
11460 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11461 end if;
11462 end if;
11463
11464 Adjust_Result_Type (N, Typ);
11465 end Expand_Short_Circuit_Operator;
11466
70482933
RK		 11467 -------------------------------------
11468 -- Fixup_Universal_Fixed_Operation --
11469 -------------------------------------
11470
11471 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
11472 Conv : constant Node_Id := Parent (N);
11473
11474 begin
11475 -- We must have a type conversion immediately above us
11476
11477 pragma Assert (Nkind (Conv) = N_Type_Conversion);
11478
11479 -- Normally the type conversion gives our target type. The exception
11480 -- occurs in the case of the Round attribute, where the conversion
11481 -- will be to universal real, and our real type comes from the Round
11482 -- attribute (as well as an indication that we must round the result)
11483
11484 if Nkind (Parent (Conv)) = N_Attribute_Reference
11485 and then Attribute_Name (Parent (Conv)) = Name_Round
11486 then
11487 Set_Etype (N, Etype (Parent (Conv)));
11488 Set_Rounded_Result (N);
11489
11490 -- Normal case where type comes from conversion above us
11491
11492 else
11493 Set_Etype (N, Etype (Conv));
11494 end if;
11495 end Fixup_Universal_Fixed_Operation;
11496
5d09245e
AC		 11497 ---------------------------------
11498 -- Has_Inferable_Discriminants --
11499 ---------------------------------
11500
11501 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
11502
11503 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
11504 -- Determines whether the left-most prefix of a selected component is a
11505 -- formal parameter in a subprogram. Assumes N is a selected component.
11506
11507 --------------------------------
11508 -- Prefix_Is_Formal_Parameter --
11509 --------------------------------
11510
11511 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
83bb90af 11512 Sel_Comp : Node_Id;
5d09245e
AC		 11513
11514 begin
11515 -- Move to the left-most prefix by climbing up the tree
11516
83bb90af 11517 Sel_Comp := N;
5d09245e
AC		 11518 while Present (Parent (Sel_Comp))
11519 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
11520 loop
11521 Sel_Comp := Parent (Sel_Comp);
11522 end loop;
11523
11524 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
11525 end Prefix_Is_Formal_Parameter;
11526
11527 -- Start of processing for Has_Inferable_Discriminants
11528
11529 begin
5d09245e
AC		 11530 -- For selected components, the subtype of the selector must be a
11531 -- constrained Unchecked_Union. If the component is subject to a
11532 -- per-object constraint, then the enclosing object must have inferable
11533 -- discriminants.
11534
83bb90af 11535 if Nkind (N) = N_Selected_Component then
5d09245e
AC		 11536 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
11537
11538 -- A small hack. If we have a per-object constrained selected
11539 -- component of a formal parameter, return True since we do not
11540 -- know the actual parameter association yet.
11541
11542 if Prefix_Is_Formal_Parameter (N) then
11543 return True;
5d09245e
AC		 11544
11545 -- Otherwise, check the enclosing object and the selector
11546
83bb90af
TQ		 11547 else
11548 return Has_Inferable_Discriminants (Prefix (N))
11549 and then Has_Inferable_Discriminants (Selector_Name (N));
11550 end if;
5d09245e
AC		 11551
11552 -- The call to Has_Inferable_Discriminants will determine whether
11553 -- the selector has a constrained Unchecked_Union nominal type.
11554
83bb90af
TQ		 11555 else
11556 return Has_Inferable_Discriminants (Selector_Name (N));
11557 end if;
5d09245e
AC		 11558
11559 -- A qualified expression has inferable discriminants if its subtype
11560 -- mark is a constrained Unchecked_Union subtype.
11561
11562 elsif Nkind (N) = N_Qualified_Expression then
053cf994 11563 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
5b5b27ad 11564 and then Is_Constrained (Etype (Subtype_Mark (N)));
5d09245e 11565
83bb90af
TQ		 11566 -- For all other names, it is sufficient to have a constrained
11567 -- Unchecked_Union nominal subtype.
11568
11569 else
11570 return Is_Unchecked_Union (Base_Type (Etype (N)))
11571 and then Is_Constrained (Etype (N));
11572 end if;
5d09245e
AC		 11573 end Has_Inferable_Discriminants;
11574
70482933
RK		 11575 -------------------------------
11576 -- Insert_Dereference_Action --
11577 -------------------------------
11578
11579 procedure Insert_Dereference_Action (N : Node_Id) is
8777c5a6 11580
70482933 11581 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
2e071734
AC		 11582 -- Return true if type of P is derived from Checked_Pool;
11583
11584 -----------------------------
11585 -- Is_Checked_Storage_Pool --
11586 -----------------------------
70482933
RK		 11587
11588 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
11589 T : Entity_Id;
761f7dcb 11590
70482933
RK		 11591 begin
11592 if No (P) then
11593 return False;
11594 end if;
11595
11596 T := Etype (P);
11597 while T /= Etype (T) loop
11598 if Is_RTE (T, RE_Checked_Pool) then
11599 return True;
11600 else
11601 T := Etype (T);
11602 end if;
11603 end loop;
11604
11605 return False;
11606 end Is_Checked_Storage_Pool;
11607
b0d71355
HK		 11608 -- Local variables
11609
11610 Typ : constant Entity_Id := Etype (N);
11611 Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
11612 Loc : constant Source_Ptr := Sloc (N);
11613 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
11614 Pnod : constant Node_Id := Parent (N);
11615
51dcceec
AC		 11616 Addr : Entity_Id;
11617 Alig : Entity_Id;
11618 Deref : Node_Id;
11619 Size : Entity_Id;
11620 Size_Bits : Node_Id;
11621 Stmt : Node_Id;
b0d71355 11622
70482933
RK		 11623 -- Start of processing for Insert_Dereference_Action
11624
11625 begin
e6f69614
AC		 11626 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
11627
b0d71355
HK		 11628 -- Do not re-expand a dereference which has already been processed by
11629 -- this routine.
11630
11631 if Has_Dereference_Action (Pnod) then
70482933 11632 return;
70482933 11633
b0d71355
HK		 11634 -- Do not perform this type of expansion for internally-generated
11635 -- dereferences.
70482933 11636
b0d71355
HK		 11637 elsif not Comes_From_Source (Original_Node (Pnod)) then
11638 return;
70482933 11639
b0d71355
HK		 11640 -- A dereference action is only applicable to objects which have been
11641 -- allocated on a checked pool.
70482933 11642
b0d71355
HK		 11643 elsif not Is_Checked_Storage_Pool (Pool) then
11644 return;
11645 end if;
70482933 11646
b0d71355 11647 -- Extract the address of the dereferenced object. Generate:
8777c5a6 11648
b0d71355 11649 -- Addr : System.Address := <N>'Pool_Address;
70482933 11650
b0d71355 11651 Addr := Make_Temporary (Loc, 'P');
70482933 11652
b0d71355
HK		 11653 Insert_Action (N,
11654 Make_Object_Declaration (Loc,
11655 Defining_Identifier => Addr,
11656 Object_Definition =>
e4494292 11657 New_Occurrence_Of (RTE (RE_Address), Loc),
b0d71355
HK		 11658 Expression =>
11659 Make_Attribute_Reference (Loc,
11660 Prefix => Duplicate_Subexpr_Move_Checks (N),
11661 Attribute_Name => Name_Pool_Address)));
11662
11663 -- Calculate the size of the dereferenced object. Generate:
8777c5a6 11664
b0d71355
HK		 11665 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11666
11667 Deref :=
11668 Make_Explicit_Dereference (Loc,
11669 Prefix => Duplicate_Subexpr_Move_Checks (N));
11670 Set_Has_Dereference_Action (Deref);
70482933 11671
51dcceec
AC		 11672 Size_Bits :=
11673 Make_Attribute_Reference (Loc,
11674 Prefix => Deref,
11675 Attribute_Name => Name_Size);
11676
11677 -- Special case of an unconstrained array: need to add descriptor size
11678
11679 if Is_Array_Type (Desig)
11680 and then not Is_Constrained (First_Subtype (Desig))
11681 then
11682 Size_Bits :=
11683 Make_Op_Add (Loc,
11684 Left_Opnd =>
11685 Make_Attribute_Reference (Loc,
11686 Prefix =>
11687 New_Occurrence_Of (First_Subtype (Desig), Loc),
11688 Attribute_Name => Name_Descriptor_Size),
11689 Right_Opnd => Size_Bits);
11690 end if;
b0d71355 11691
51dcceec 11692 Size := Make_Temporary (Loc, 'S');
b0d71355
HK		 11693 Insert_Action (N,
11694 Make_Object_Declaration (Loc,
11695 Defining_Identifier => Size,
11696 Object_Definition =>
e4494292 11697 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
b0d71355
HK		 11698 Expression =>
11699 Make_Op_Divide (Loc,
51dcceec
AC		 11700 Left_Opnd => Size_Bits,
11701 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
70482933 11702
b0d71355
HK		 11703 -- Calculate the alignment of the dereferenced object. Generate:
11704 -- Alig : constant Storage_Count := <N>.all'Alignment;
70482933 11705
b0d71355
HK		 11706 Deref :=
11707 Make_Explicit_Dereference (Loc,
11708 Prefix => Duplicate_Subexpr_Move_Checks (N));
11709 Set_Has_Dereference_Action (Deref);
11710
11711 Alig := Make_Temporary (Loc, 'A');
b0d71355
HK		 11712 Insert_Action (N,
11713 Make_Object_Declaration (Loc,
11714 Defining_Identifier => Alig,
11715 Object_Definition =>
e4494292 11716 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
b0d71355
HK		 11717 Expression =>
11718 Make_Attribute_Reference (Loc,
11719 Prefix => Deref,
11720 Attribute_Name => Name_Alignment)));
11721
11722 -- A dereference of a controlled object requires special processing. The
11723 -- finalization machinery requests additional space from the underlying
11724 -- pool to allocate and hide two pointers. As a result, a checked pool
11725 -- may mark the wrong memory as valid. Since checked pools do not have
11726 -- knowledge of hidden pointers, we have to bring the two pointers back
11727 -- in view in order to restore the original state of the object.
11728
11729 if Needs_Finalization (Desig) then
11730
11731 -- Adjust the address and size of the dereferenced object. Generate:
11732 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11733
11734 Stmt :=
11735 Make_Procedure_Call_Statement (Loc,
11736 Name =>
e4494292 11737 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
b0d71355 11738 Parameter_Associations => New_List (
e4494292
RD		 11739 New_Occurrence_Of (Addr, Loc),
11740 New_Occurrence_Of (Size, Loc),
11741 New_Occurrence_Of (Alig, Loc)));
b0d71355
HK		 11742
11743 -- Class-wide types complicate things because we cannot determine
11744 -- statically whether the actual object is truly controlled. We must
11745 -- generate a runtime check to detect this property. Generate:
11746 --
11747 -- if Needs_Finalization (<N>.all'Tag) then
11748 -- <Stmt>;
11749 -- end if;
11750
11751 if Is_Class_Wide_Type (Desig) then
11752 Deref :=
11753 Make_Explicit_Dereference (Loc,
11754 Prefix => Duplicate_Subexpr_Move_Checks (N));
11755 Set_Has_Dereference_Action (Deref);
11756
11757 Stmt :=
8b1011c0 11758 Make_Implicit_If_Statement (N,
b0d71355
HK		 11759 Condition =>
11760 Make_Function_Call (Loc,
11761 Name =>
e4494292 11762 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
b0d71355
HK		 11763 Parameter_Associations => New_List (
11764 Make_Attribute_Reference (Loc,
11765 Prefix => Deref,
11766 Attribute_Name => Name_Tag))),
11767 Then_Statements => New_List (Stmt));
11768 end if;
11769
11770 Insert_Action (N, Stmt);
11771 end if;
11772
11773 -- Generate:
11774 -- Dereference (Pool, Addr, Size, Alig);
11775
11776 Insert_Action (N,
11777 Make_Procedure_Call_Statement (Loc,
11778 Name =>
e4494292 11779 New_Occurrence_Of
b0d71355
HK		 11780 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
11781 Parameter_Associations => New_List (
e4494292
RD		 11782 New_Occurrence_Of (Pool, Loc),
11783 New_Occurrence_Of (Addr, Loc),
11784 New_Occurrence_Of (Size, Loc),
11785 New_Occurrence_Of (Alig, Loc))));
b0d71355
HK		 11786
11787 -- Mark the explicit dereference as processed to avoid potential
11788 -- infinite expansion.
11789
11790 Set_Has_Dereference_Action (Pnod);
70482933 11791
fbf5a39b
AC		 11792 exception
11793 when RE_Not_Available =>
11794 return;
70482933
RK		 11795 end Insert_Dereference_Action;
11796
fdfcc663
AC		 11797 --------------------------------
11798 -- Integer_Promotion_Possible --
11799 --------------------------------
11800
11801 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
11802 Operand : constant Node_Id := Expression (N);
11803 Operand_Type : constant Entity_Id := Etype (Operand);
11804 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
11805
11806 begin
11807 pragma Assert (Nkind (N) = N_Type_Conversion);
11808
11809 return
11810
11811 -- We only do the transformation for source constructs. We assume
11812 -- that the expander knows what it is doing when it generates code.
11813
11814 Comes_From_Source (N)
11815
11816 -- If the operand type is Short_Integer or Short_Short_Integer,
11817 -- then we will promote to Integer, which is available on all
11818 -- targets, and is sufficient to ensure no intermediate overflow.
11819 -- Furthermore it is likely to be as efficient or more efficient
11820 -- than using the smaller type for the computation so we do this
11821 -- unconditionally.
11822
11823 and then
11824 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
761f7dcb 11825 or else
fdfcc663
AC		 11826 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
11827
11828 -- Test for interesting operation, which includes addition,
5f3f175d
AC		 11829 -- division, exponentiation, multiplication, subtraction, absolute
11830 -- value and unary negation. Unary "+" is omitted since it is a
11831 -- no-op and thus can't overflow.
fdfcc663 11832
5f3f175d
AC		 11833 and then Nkind_In (Operand, N_Op_Abs,
11834 N_Op_Add,
fdfcc663
AC		 11835 N_Op_Divide,
11836 N_Op_Expon,
11837 N_Op_Minus,
11838 N_Op_Multiply,
11839 N_Op_Subtract);
11840 end Integer_Promotion_Possible;
11841
70482933
RK		 11842 ------------------------------
11843 -- Make_Array_Comparison_Op --
11844 ------------------------------
11845
11846 -- This is a hand-coded expansion of the following generic function:
11847
11848 -- generic
11849 -- type elem is (<>);
11850 -- type index is (<>);
11851 -- type a is array (index range <>) of elem;
20b5d666 11852
70482933
RK		 11853 -- function Gnnn (X : a; Y: a) return boolean is
11854 -- J : index := Y'first;
20b5d666 11855
70482933
RK		 11856 -- begin
11857 -- if X'length = 0 then
11858 -- return false;
20b5d666 11859
70482933
RK		 11860 -- elsif Y'length = 0 then
11861 -- return true;
20b5d666 11862
70482933
RK		 11863 -- else
11864 -- for I in X'range loop
11865 -- if X (I) = Y (J) then
11866 -- if J = Y'last then
11867 -- exit;
11868 -- else
11869 -- J := index'succ (J);
11870 -- end if;
20b5d666 11871
70482933
RK		 11872 -- else
11873 -- return X (I) > Y (J);
11874 -- end if;
11875 -- end loop;
20b5d666 11876
70482933
RK		 11877 -- return X'length > Y'length;
11878 -- end if;
11879 -- end Gnnn;
11880
11881 -- Note that since we are essentially doing this expansion by hand, we
11882 -- do not need to generate an actual or formal generic part, just the
11883 -- instantiated function itself.
11884
bb012790
AC		 11885 -- Perhaps we could have the actual generic available in the run-time,
11886 -- obtained by rtsfind, and actually expand a real instantiation ???
11887
70482933 11888 function Make_Array_Comparison_Op
2e071734
AC		 11889 (Typ : Entity_Id;
11890 Nod : Node_Id) return Node_Id
70482933
RK		 11891 is
11892 Loc : constant Source_Ptr := Sloc (Nod);
11893
11894 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
11895 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
11896 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
11897 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
11898
11899 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
11900
11901 Loop_Statement : Node_Id;
11902 Loop_Body : Node_Id;
11903 If_Stat : Node_Id;
11904 Inner_If : Node_Id;
11905 Final_Expr : Node_Id;
11906 Func_Body : Node_Id;
11907 Func_Name : Entity_Id;
11908 Formals : List_Id;
11909 Length1 : Node_Id;
11910 Length2 : Node_Id;
11911
11912 begin
11913 -- if J = Y'last then
11914 -- exit;
11915 -- else
11916 -- J := index'succ (J);
11917 -- end if;
11918
11919 Inner_If :=
11920 Make_Implicit_If_Statement (Nod,
11921 Condition =>
11922 Make_Op_Eq (Loc,
e4494292 11923 Left_Opnd => New_Occurrence_Of (J, Loc),
70482933
RK		 11924 Right_Opnd =>
11925 Make_Attribute_Reference (Loc,
e4494292 11926 Prefix => New_Occurrence_Of (Y, Loc),
70482933
RK		 11927 Attribute_Name => Name_Last)),
11928
11929 Then_Statements => New_List (
11930 Make_Exit_Statement (Loc)),
11931
11932 Else_Statements =>
11933 New_List (
11934 Make_Assignment_Statement (Loc,
e4494292 11935 Name => New_Occurrence_Of (J, Loc),
70482933
RK		 11936 Expression =>
11937 Make_Attribute_Reference (Loc,
e4494292 11938 Prefix => New_Occurrence_Of (Index, Loc),
70482933 11939 Attribute_Name => Name_Succ,
e4494292 11940 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
70482933
RK		 11941
11942 -- if X (I) = Y (J) then
11943 -- if ... end if;
11944 -- else
11945 -- return X (I) > Y (J);
11946 -- end if;
11947
11948 Loop_Body :=
11949 Make_Implicit_If_Statement (Nod,
11950 Condition =>
11951 Make_Op_Eq (Loc,
11952 Left_Opnd =>
11953 Make_Indexed_Component (Loc,
e4494292
RD		 11954 Prefix => New_Occurrence_Of (X, Loc),
11955 Expressions => New_List (New_Occurrence_Of (I, Loc))),
70482933
RK		 11956
11957 Right_Opnd =>
11958 Make_Indexed_Component (Loc,
e4494292
RD		 11959 Prefix => New_Occurrence_Of (Y, Loc),
11960 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
70482933
RK		 11961
11962 Then_Statements => New_List (Inner_If),
11963
11964 Else_Statements => New_List (
d766cee3 11965 Make_Simple_Return_Statement (Loc,
70482933
RK		 11966 Expression =>
11967 Make_Op_Gt (Loc,
11968 Left_Opnd =>
11969 Make_Indexed_Component (Loc,
e4494292
RD		 11970 Prefix => New_Occurrence_Of (X, Loc),
11971 Expressions => New_List (New_Occurrence_Of (I, Loc))),
70482933
RK		 11972
11973 Right_Opnd =>
11974 Make_Indexed_Component (Loc,
e4494292 11975 Prefix => New_Occurrence_Of (Y, Loc),
70482933 11976 Expressions => New_List (
e4494292 11977 New_Occurrence_Of (J, Loc)))))));
70482933
RK		 11978
11979 -- for I in X'range loop
11980 -- if ... end if;
11981 -- end loop;
11982
11983 Loop_Statement :=
11984 Make_Implicit_Loop_Statement (Nod,
11985 Identifier => Empty,
11986
11987 Iteration_Scheme =>
11988 Make_Iteration_Scheme (Loc,
11989 Loop_Parameter_Specification =>
11990 Make_Loop_Parameter_Specification (Loc,
11991 Defining_Identifier => I,
11992 Discrete_Subtype_Definition =>
11993 Make_Attribute_Reference (Loc,
e4494292 11994 Prefix => New_Occurrence_Of (X, Loc),
70482933
RK		 11995 Attribute_Name => Name_Range))),
11996
11997 Statements => New_List (Loop_Body));
11998
11999 -- if X'length = 0 then
12000 -- return false;
12001 -- elsif Y'length = 0 then
12002 -- return true;
12003 -- else
12004 -- for ... loop ... end loop;
12005 -- return X'length > Y'length;
12006 -- end if;
12007
12008 Length1 :=
12009 Make_Attribute_Reference (Loc,
e4494292 12010 Prefix => New_Occurrence_Of (X, Loc),
70482933
RK		 12011 Attribute_Name => Name_Length);
12012
12013 Length2 :=
12014 Make_Attribute_Reference (Loc,
e4494292 12015 Prefix => New_Occurrence_Of (Y, Loc),
70482933
RK		 12016 Attribute_Name => Name_Length);
12017
12018 Final_Expr :=
12019 Make_Op_Gt (Loc,
12020 Left_Opnd => Length1,
12021 Right_Opnd => Length2);
12022
12023 If_Stat :=
12024 Make_Implicit_If_Statement (Nod,
12025 Condition =>
12026 Make_Op_Eq (Loc,
12027 Left_Opnd =>
12028 Make_Attribute_Reference (Loc,
e4494292 12029 Prefix => New_Occurrence_Of (X, Loc),
70482933
RK		 12030 Attribute_Name => Name_Length),
12031 Right_Opnd =>
12032 Make_Integer_Literal (Loc, 0)),
12033
12034 Then_Statements =>
12035 New_List (
d766cee3 12036 Make_Simple_Return_Statement (Loc,
e4494292 12037 Expression => New_Occurrence_Of (Standard_False, Loc))),
70482933
RK		 12038
12039 Elsif_Parts => New_List (
12040 Make_Elsif_Part (Loc,
12041 Condition =>
12042 Make_Op_Eq (Loc,
12043 Left_Opnd =>
12044 Make_Attribute_Reference (Loc,
e4494292 12045 Prefix => New_Occurrence_Of (Y, Loc),
70482933
RK		 12046 Attribute_Name => Name_Length),
12047 Right_Opnd =>
12048 Make_Integer_Literal (Loc, 0)),
12049
12050 Then_Statements =>
12051 New_List (
d766cee3 12052 Make_Simple_Return_Statement (Loc,
e4494292 12053 Expression => New_Occurrence_Of (Standard_True, Loc))))),
70482933
RK		 12054
12055 Else_Statements => New_List (
12056 Loop_Statement,
d766cee3 12057 Make_Simple_Return_Statement (Loc,
70482933
RK		 12058 Expression => Final_Expr)));
12059
12060 -- (X : a; Y: a)
12061
12062 Formals := New_List (
12063 Make_Parameter_Specification (Loc,
12064 Defining_Identifier => X,
e4494292 12065 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
70482933
RK		 12066
12067 Make_Parameter_Specification (Loc,
12068 Defining_Identifier => Y,
e4494292 12069 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
70482933
RK		 12070
12071 -- function Gnnn (...) return boolean is
12072 -- J : index := Y'first;
12073 -- begin
12074 -- if ... end if;
12075 -- end Gnnn;
12076
191fcb3a 12077 Func_Name := Make_Temporary (Loc, 'G');
70482933
RK		 12078
12079 Func_Body :=
12080 Make_Subprogram_Body (Loc,
12081 Specification =>
12082 Make_Function_Specification (Loc,
12083 Defining_Unit_Name => Func_Name,
12084 Parameter_Specifications => Formals,
e4494292 12085 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
70482933
RK		 12086
12087 Declarations => New_List (
12088 Make_Object_Declaration (Loc,
12089 Defining_Identifier => J,
e4494292 12090 Object_Definition => New_Occurrence_Of (Index, Loc),
70482933
RK		 12091 Expression =>
12092 Make_Attribute_Reference (Loc,
e4494292 12093 Prefix => New_Occurrence_Of (Y, Loc),
70482933
RK		 12094 Attribute_Name => Name_First))),
12095
12096 Handled_Statement_Sequence =>
12097 Make_Handled_Sequence_Of_Statements (Loc,
12098 Statements => New_List (If_Stat)));
12099
12100 return Func_Body;
70482933
RK		 12101 end Make_Array_Comparison_Op;
12102
12103 ---------------------------
12104 -- Make_Boolean_Array_Op --
12105 ---------------------------
12106
685094bf
RD		 12107 -- For logical operations on boolean arrays, expand in line the following,
12108 -- replacing 'and' with 'or' or 'xor' where needed:
70482933
RK		 12109
12110 -- function Annn (A : typ; B: typ) return typ is
12111 -- C : typ;
12112 -- begin
12113 -- for J in A'range loop
12114 -- C (J) := A (J) op B (J);
12115 -- end loop;
12116 -- return C;
12117 -- end Annn;
12118
12119 -- Here typ is the boolean array type
12120
12121 function Make_Boolean_Array_Op
2e071734
AC		 12122 (Typ : Entity_Id;
12123 N : Node_Id) return Node_Id
70482933
RK		 12124 is
12125 Loc : constant Source_Ptr := Sloc (N);
12126
12127 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
12128 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
12129 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
12130 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
12131
12132 A_J : Node_Id;
12133 B_J : Node_Id;
12134 C_J : Node_Id;
12135 Op : Node_Id;
12136
12137 Formals : List_Id;
12138 Func_Name : Entity_Id;
12139 Func_Body : Node_Id;
12140 Loop_Statement : Node_Id;
12141
12142 begin
12143 A_J :=
12144 Make_Indexed_Component (Loc,
e4494292
RD		 12145 Prefix => New_Occurrence_Of (A, Loc),
12146 Expressions => New_List (New_Occurrence_Of (J, Loc)));
70482933
RK		 12147
12148 B_J :=
12149 Make_Indexed_Component (Loc,
e4494292
RD		 12150 Prefix => New_Occurrence_Of (B, Loc),
12151 Expressions => New_List (New_Occurrence_Of (J, Loc)));
70482933
RK		 12152
12153 C_J :=
12154 Make_Indexed_Component (Loc,
e4494292
RD		 12155 Prefix => New_Occurrence_Of (C, Loc),
12156 Expressions => New_List (New_Occurrence_Of (J, Loc)));
70482933
RK		 12157
12158 if Nkind (N) = N_Op_And then
12159 Op :=
12160 Make_Op_And (Loc,
12161 Left_Opnd => A_J,
12162 Right_Opnd => B_J);
12163
12164 elsif Nkind (N) = N_Op_Or then
12165 Op :=
12166 Make_Op_Or (Loc,
12167 Left_Opnd => A_J,
12168 Right_Opnd => B_J);
12169
12170 else
12171 Op :=
12172 Make_Op_Xor (Loc,
12173 Left_Opnd => A_J,
12174 Right_Opnd => B_J);
12175 end if;
12176
12177 Loop_Statement :=
12178 Make_Implicit_Loop_Statement (N,
12179 Identifier => Empty,
12180
12181 Iteration_Scheme =>
12182 Make_Iteration_Scheme (Loc,
12183 Loop_Parameter_Specification =>
12184 Make_Loop_Parameter_Specification (Loc,
12185 Defining_Identifier => J,
12186 Discrete_Subtype_Definition =>
12187 Make_Attribute_Reference (Loc,
e4494292 12188 Prefix => New_Occurrence_Of (A, Loc),
70482933
RK		 12189 Attribute_Name => Name_Range))),
12190
12191 Statements => New_List (
12192 Make_Assignment_Statement (Loc,
12193 Name => C_J,
12194 Expression => Op)));
12195
12196 Formals := New_List (
12197 Make_Parameter_Specification (Loc,
12198 Defining_Identifier => A,
e4494292 12199 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
70482933
RK		 12200
12201 Make_Parameter_Specification (Loc,
12202 Defining_Identifier => B,
e4494292 12203 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
70482933 12204
191fcb3a 12205 Func_Name := Make_Temporary (Loc, 'A');
70482933
RK		 12206 Set_Is_Inlined (Func_Name);
12207
12208 Func_Body :=
12209 Make_Subprogram_Body (Loc,
12210 Specification =>
12211 Make_Function_Specification (Loc,
12212 Defining_Unit_Name => Func_Name,
12213 Parameter_Specifications => Formals,
e4494292 12214 Result_Definition => New_Occurrence_Of (Typ, Loc)),
70482933
RK		 12215
12216 Declarations => New_List (
12217 Make_Object_Declaration (Loc,
12218 Defining_Identifier => C,
e4494292 12219 Object_Definition => New_Occurrence_Of (Typ, Loc))),
70482933
RK		 12220
12221 Handled_Statement_Sequence =>
12222 Make_Handled_Sequence_Of_Statements (Loc,
12223 Statements => New_List (
12224 Loop_Statement,
d766cee3 12225 Make_Simple_Return_Statement (Loc,
e4494292 12226 Expression => New_Occurrence_Of (C, Loc)))));
70482933
RK		 12227
12228 return Func_Body;
12229 end Make_Boolean_Array_Op;
12230
b6b5cca8
AC		 12231 -----------------------------------------
12232 -- Minimized_Eliminated_Overflow_Check --
12233 -----------------------------------------
12234
12235 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
12236 begin
12237 return
12238 Is_Signed_Integer_Type (Etype (N))
a7f1b24f 12239 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
b6b5cca8
AC		 12240 end Minimized_Eliminated_Overflow_Check;
12241
0580d807
AC		 12242 --------------------------------
12243 -- Optimize_Length_Comparison --
12244 --------------------------------
12245
12246 procedure Optimize_Length_Comparison (N : Node_Id) is
12247 Loc : constant Source_Ptr := Sloc (N);
12248 Typ : constant Entity_Id := Etype (N);
12249 Result : Node_Id;
12250
12251 Left : Node_Id;
12252 Right : Node_Id;
12253 -- First and Last attribute reference nodes, which end up as left and
12254 -- right operands of the optimized result.
12255
12256 Is_Zero : Boolean;
12257 -- True for comparison operand of zero
12258
12259 Comp : Node_Id;
12260 -- Comparison operand, set only if Is_Zero is false
12261
12262 Ent : Entity_Id;
12263 -- Entity whose length is being compared
12264
12265 Index : Node_Id;
12266 -- Integer_Literal node for length attribute expression, or Empty
12267 -- if there is no such expression present.
12268
12269 Ityp : Entity_Id;
12270 -- Type of array index to which 'Length is applied
12271
12272 Op : Node_Kind := Nkind (N);
12273 -- Kind of comparison operator, gets flipped if operands backwards
12274
12275 function Is_Optimizable (N : Node_Id) return Boolean;
abcd9db2
AC		 12276 -- Tests N to see if it is an optimizable comparison value (defined as
12277 -- constant zero or one, or something else where the value is known to
12278 -- be positive and in the range of 32-bits, and where the corresponding
12279 -- Length value is also known to be 32-bits. If result is true, sets
12280 -- Is_Zero, Ityp, and Comp accordingly.
0580d807
AC		 12281
12282 function Is_Entity_Length (N : Node_Id) return Boolean;
12283 -- Tests if N is a length attribute applied to a simple entity. If so,
12284 -- returns True, and sets Ent to the entity, and Index to the integer
12285 -- literal provided as an attribute expression, or to Empty if none.
12286 -- Also returns True if the expression is a generated type conversion
12287 -- whose expression is of the desired form. This latter case arises
12288 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12289 -- to check for being in range, which is not needed in this context.
12290 -- Returns False if neither condition holds.
12291
12292 function Prepare_64 (N : Node_Id) return Node_Id;
12293 -- Given a discrete expression, returns a Long_Long_Integer typed
12294 -- expression representing the underlying value of the expression.
12295 -- This is done with an unchecked conversion to the result type. We
12296 -- use unchecked conversion to handle the enumeration type case.
12297
12298 ----------------------
12299 -- Is_Entity_Length --
12300 ----------------------
12301
12302 function Is_Entity_Length (N : Node_Id) return Boolean is
12303 begin
12304 if Nkind (N) = N_Attribute_Reference
12305 and then Attribute_Name (N) = Name_Length
12306 and then Is_Entity_Name (Prefix (N))
12307 then
12308 Ent := Entity (Prefix (N));
12309
12310 if Present (Expressions (N)) then
12311 Index := First (Expressions (N));
12312 else
12313 Index := Empty;
12314 end if;
12315
12316 return True;
12317
12318 elsif Nkind (N) = N_Type_Conversion
12319 and then not Comes_From_Source (N)
12320 then
12321 return Is_Entity_Length (Expression (N));
12322
12323 else
12324 return False;
12325 end if;
12326 end Is_Entity_Length;
12327
12328 --------------------
12329 -- Is_Optimizable --
12330 --------------------
12331
12332 function Is_Optimizable (N : Node_Id) return Boolean is
12333 Val : Uint;
12334 OK : Boolean;
12335 Lo : Uint;
12336 Hi : Uint;
12337 Indx : Node_Id;
12338
12339 begin
12340 if Compile_Time_Known_Value (N) then
12341 Val := Expr_Value (N);
12342
12343 if Val = Uint_0 then
12344 Is_Zero := True;
12345 Comp := Empty;
12346 return True;
12347
12348 elsif Val = Uint_1 then
12349 Is_Zero := False;
12350 Comp := Empty;
12351 return True;
12352 end if;
12353 end if;
12354
12355 -- Here we have to make sure of being within 32-bits
12356
12357 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
12358
12359 if not OK
abcd9db2 12360 or else Lo < Uint_1
0580d807
AC		 12361 or else Hi > UI_From_Int (Int'Last)
12362 then
12363 return False;
12364 end if;
12365
abcd9db2
AC		 12366 -- Comparison value was within range, so now we must check the index
12367 -- value to make sure it is also within 32-bits.
0580d807
AC		 12368
12369 Indx := First_Index (Etype (Ent));
12370
12371 if Present (Index) then
12372 for J in 2 .. UI_To_Int (Intval (Index)) loop
12373 Next_Index (Indx);
12374 end loop;
12375 end if;
12376
12377 Ityp := Etype (Indx);
12378
12379 if Esize (Ityp) > 32 then
12380 return False;
12381 end if;
12382
12383 Is_Zero := False;
12384 Comp := N;
12385 return True;
12386 end Is_Optimizable;
12387
12388 ----------------
12389 -- Prepare_64 --
12390 ----------------
12391
12392 function Prepare_64 (N : Node_Id) return Node_Id is
12393 begin
12394 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
12395 end Prepare_64;
12396
12397 -- Start of processing for Optimize_Length_Comparison
12398
12399 begin
12400 -- Nothing to do if not a comparison
12401
12402 if Op not in N_Op_Compare then
12403 return;
12404 end if;
12405
12406 -- Nothing to do if special -gnatd.P debug flag set
12407
12408 if Debug_Flag_Dot_PP then
12409 return;
12410 end if;
12411
12412 -- Ent'Length op 0/1
12413
12414 if Is_Entity_Length (Left_Opnd (N))
12415 and then Is_Optimizable (Right_Opnd (N))
12416 then
12417 null;
12418
12419 -- 0/1 op Ent'Length
12420
12421 elsif Is_Entity_Length (Right_Opnd (N))
12422 and then Is_Optimizable (Left_Opnd (N))
12423 then
12424 -- Flip comparison to opposite sense
12425
12426 case Op is
12427 when N_Op_Lt => Op := N_Op_Gt;
12428 when N_Op_Le => Op := N_Op_Ge;
12429 when N_Op_Gt => Op := N_Op_Lt;
12430 when N_Op_Ge => Op := N_Op_Le;
12431 when others => null;
12432 end case;
12433
12434 -- Else optimization not possible
12435
12436 else
12437 return;
12438 end if;
12439
12440 -- Fall through if we will do the optimization
12441
12442 -- Cases to handle:
12443
12444 -- X'Length = 0 => X'First > X'Last
12445 -- X'Length = 1 => X'First = X'Last
12446 -- X'Length = n => X'First + (n - 1) = X'Last
12447
12448 -- X'Length /= 0 => X'First <= X'Last
12449 -- X'Length /= 1 => X'First /= X'Last
12450 -- X'Length /= n => X'First + (n - 1) /= X'Last
12451
12452 -- X'Length >= 0 => always true, warn
12453 -- X'Length >= 1 => X'First <= X'Last
12454 -- X'Length >= n => X'First + (n - 1) <= X'Last
12455
12456 -- X'Length > 0 => X'First <= X'Last
12457 -- X'Length > 1 => X'First < X'Last
12458 -- X'Length > n => X'First + (n - 1) < X'Last
12459
12460 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12461 -- X'Length <= 1 => X'First >= X'Last
12462 -- X'Length <= n => X'First + (n - 1) >= X'Last
12463
12464 -- X'Length < 0 => always false (warn)
12465 -- X'Length < 1 => X'First > X'Last
12466 -- X'Length < n => X'First + (n - 1) > X'Last
12467
12468 -- Note: for the cases of n (not constant 0,1), we require that the
12469 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12470 -- and the same for the comparison value. Then we do the comparison
12471 -- using 64-bit arithmetic (actually long long integer), so that we
12472 -- cannot have overflow intefering with the result.
12473
12474 -- First deal with warning cases
12475
12476 if Is_Zero then
12477 case Op is
12478
12479 -- X'Length >= 0
12480
12481 when N_Op_Ge =>
12482 Rewrite (N,
12483 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
12484 Analyze_And_Resolve (N, Typ);
12485 Warn_On_Known_Condition (N);
12486 return;
12487
12488 -- X'Length < 0
12489
12490 when N_Op_Lt =>
12491 Rewrite (N,
12492 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
12493 Analyze_And_Resolve (N, Typ);
12494 Warn_On_Known_Condition (N);
12495 return;
12496
12497 when N_Op_Le =>
12498 if Constant_Condition_Warnings
12499 and then Comes_From_Source (Original_Node (N))
12500 then
324ac540 12501 Error_Msg_N ("could replace by ""'=""?c?", N);
0580d807
AC		 12502 end if;
12503
12504 Op := N_Op_Eq;
12505
12506 when others =>
12507 null;
12508 end case;
12509 end if;
12510
12511 -- Build the First reference we will use
12512
12513 Left :=
12514 Make_Attribute_Reference (Loc,
12515 Prefix => New_Occurrence_Of (Ent, Loc),
12516 Attribute_Name => Name_First);
12517
12518 if Present (Index) then
12519 Set_Expressions (Left, New_List (New_Copy (Index)));
12520 end if;
12521
12522 -- If general value case, then do the addition of (n - 1), and
12523 -- also add the needed conversions to type Long_Long_Integer.
12524
12525 if Present (Comp) then
12526 Left :=
12527 Make_Op_Add (Loc,
12528 Left_Opnd => Prepare_64 (Left),
12529 Right_Opnd =>
12530 Make_Op_Subtract (Loc,
12531 Left_Opnd => Prepare_64 (Comp),
12532 Right_Opnd => Make_Integer_Literal (Loc, 1)));
12533 end if;
12534
12535 -- Build the Last reference we will use
12536
12537 Right :=
12538 Make_Attribute_Reference (Loc,
12539 Prefix => New_Occurrence_Of (Ent, Loc),
12540 Attribute_Name => Name_Last);
12541
12542 if Present (Index) then
12543 Set_Expressions (Right, New_List (New_Copy (Index)));
12544 end if;
12545
12546 -- If general operand, convert Last reference to Long_Long_Integer
12547
12548 if Present (Comp) then
12549 Right := Prepare_64 (Right);
12550 end if;
12551
12552 -- Check for cases to optimize
12553
12554 -- X'Length = 0 => X'First > X'Last
12555 -- X'Length < 1 => X'First > X'Last
12556 -- X'Length < n => X'First + (n - 1) > X'Last
12557
12558 if (Is_Zero and then Op = N_Op_Eq)
12559 or else (not Is_Zero and then Op = N_Op_Lt)
12560 then
12561 Result :=
12562 Make_Op_Gt (Loc,
12563 Left_Opnd => Left,
12564 Right_Opnd => Right);
12565
12566 -- X'Length = 1 => X'First = X'Last
12567 -- X'Length = n => X'First + (n - 1) = X'Last
12568
12569 elsif not Is_Zero and then Op = N_Op_Eq then
12570 Result :=
12571 Make_Op_Eq (Loc,
12572 Left_Opnd => Left,
12573 Right_Opnd => Right);
12574
12575 -- X'Length /= 0 => X'First <= X'Last
12576 -- X'Length > 0 => X'First <= X'Last
12577
12578 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
12579 Result :=
12580 Make_Op_Le (Loc,
12581 Left_Opnd => Left,
12582 Right_Opnd => Right);
12583
12584 -- X'Length /= 1 => X'First /= X'Last
12585 -- X'Length /= n => X'First + (n - 1) /= X'Last
12586
12587 elsif not Is_Zero and then Op = N_Op_Ne then
12588 Result :=
12589 Make_Op_Ne (Loc,
12590 Left_Opnd => Left,
12591 Right_Opnd => Right);
12592
12593 -- X'Length >= 1 => X'First <= X'Last
12594 -- X'Length >= n => X'First + (n - 1) <= X'Last
12595
12596 elsif not Is_Zero and then Op = N_Op_Ge then
12597 Result :=
12598 Make_Op_Le (Loc,
12599 Left_Opnd => Left,
12600 Right_Opnd => Right);
12601
12602 -- X'Length > 1 => X'First < X'Last
12603 -- X'Length > n => X'First + (n = 1) < X'Last
12604
12605 elsif not Is_Zero and then Op = N_Op_Gt then
12606 Result :=
12607 Make_Op_Lt (Loc,
12608 Left_Opnd => Left,
12609 Right_Opnd => Right);
12610
12611 -- X'Length <= 1 => X'First >= X'Last
12612 -- X'Length <= n => X'First + (n - 1) >= X'Last
12613
12614 elsif not Is_Zero and then Op = N_Op_Le then
12615 Result :=
12616 Make_Op_Ge (Loc,
12617 Left_Opnd => Left,
12618 Right_Opnd => Right);
12619
12620 -- Should not happen at this stage
12621
12622 else
12623 raise Program_Error;
12624 end if;
12625
12626 -- Rewrite and finish up
12627
12628 Rewrite (N, Result);
12629 Analyze_And_Resolve (N, Typ);
12630 return;
12631 end Optimize_Length_Comparison;
12632
b2c28399
AC		 12633 ------------------------------
12634 -- Process_Transient_Object --
12635 ------------------------------
12636
12637 procedure Process_Transient_Object
12638 (Decl : Node_Id;
12639 Rel_Node : Node_Id)
12640 is
8942b30c
AC		 12641 Loc : constant Source_Ptr := Sloc (Decl);
12642 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
12643 Obj_Typ : constant Node_Id := Etype (Obj_Id);
12644 Desig_Typ : Entity_Id;
12645 Expr : Node_Id;
12646 Fin_Stmts : List_Id;
12647 Ptr_Id : Entity_Id;
12648 Temp_Id : Entity_Id;
12649 Temp_Ins : Node_Id;
12650
9ab5d86b 12651 Hook_Context : constant Node_Id := Find_Hook_Context (Rel_Node);
8942b30c
AC		 12652 -- Node on which to insert the hook pointer (as an action): the
12653 -- innermost enclosing non-transient scope.
b2c28399 12654
064f4527
TQ		 12655 Finalization_Context : Node_Id;
12656 -- Node after which to insert finalization actions
12657
12658 Finalize_Always : Boolean;
9ab5d86b
RD		 12659 -- If False, call to finalizer includes a test of whether the hook
12660 -- pointer is null.
b2c28399 12661
8942b30c
AC		 12662 begin
12663 -- Step 0: determine where to attach finalization actions in the tree
064f4527 12664
8942b30c
AC		 12665 -- Special case for Boolean EWAs: capture expression in a temporary,
12666 -- whose declaration will serve as the context around which to insert
12667 -- finalization code. The finalization thus remains local to the
12668 -- specific condition being evaluated.
064f4527 12669
8942b30c 12670 if Is_Boolean_Type (Etype (Rel_Node)) then
064f4527 12671
9ab5d86b
RD		 12672 -- In this case, the finalization context is chosen so that we know
12673 -- at finalization point that the hook pointer is never null, so no
12674 -- need for a test, we can call the finalizer unconditionally, except
12675 -- in the case where the object is created in a specific branch of a
12676 -- conditional expression.
064f4527 12677
8942b30c 12678 Finalize_Always :=
c5c780e6
HK		 12679 not Within_Case_Or_If_Expression (Rel_Node)
12680 and then not Nkind_In
12681 (Original_Node (Rel_Node), N_Case_Expression,
12682 N_If_Expression);
064f4527 12683
8942b30c
AC		 12684 declare
12685 Loc : constant Source_Ptr := Sloc (Rel_Node);
12686 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', Rel_Node);
b2c28399 12687
8942b30c
AC		 12688 begin
12689 Append_To (Actions (Rel_Node),
12690 Make_Object_Declaration (Loc,
12691 Defining_Identifier => Temp,
12692 Constant_Present => True,
12693 Object_Definition =>
12694 New_Occurrence_Of (Etype (Rel_Node), Loc),
12695 Expression => Expression (Rel_Node)));
12696 Finalization_Context := Last (Actions (Rel_Node));
b2c28399 12697
8942b30c 12698 Analyze (Last (Actions (Rel_Node)));
b2c28399 12699
8942b30c
AC		 12700 Set_Expression (Rel_Node, New_Occurrence_Of (Temp, Loc));
12701 Analyze (Expression (Rel_Node));
12702 end;
b2c28399 12703
8942b30c
AC		 12704 else
12705 Finalize_Always := False;
12706 Finalization_Context := Hook_Context;
12707 end if;
064f4527 12708
b2c28399
AC		 12709 -- Step 1: Create the access type which provides a reference to the
12710 -- transient controlled object.
12711
12712 if Is_Access_Type (Obj_Typ) then
12713 Desig_Typ := Directly_Designated_Type (Obj_Typ);
12714 else
12715 Desig_Typ := Obj_Typ;
12716 end if;
12717
12718 Desig_Typ := Base_Type (Desig_Typ);
12719
12720 -- Generate:
12721 -- Ann : access [all] <Desig_Typ>;
12722
12723 Ptr_Id := Make_Temporary (Loc, 'A');
12724
064f4527 12725 Insert_Action (Hook_Context,
b2c28399
AC		 12726 Make_Full_Type_Declaration (Loc,
12727 Defining_Identifier => Ptr_Id,
12728 Type_Definition =>
12729 Make_Access_To_Object_Definition (Loc,
12730 All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
e4494292 12731 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
b2c28399
AC		 12732
12733 -- Step 2: Create a temporary which acts as a hook to the transient
12734 -- controlled object. Generate:
12735
12736 -- Temp : Ptr_Id := null;
12737
12738 Temp_Id := Make_Temporary (Loc, 'T');
12739
064f4527 12740 Insert_Action (Hook_Context,
b2c28399
AC		 12741 Make_Object_Declaration (Loc,
12742 Defining_Identifier => Temp_Id,
e4494292 12743 Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
b2c28399
AC		 12744
12745 -- Mark the temporary as created for the purposes of exporting the
12746 -- transient controlled object out of the expression_with_action or if
12747 -- expression. This signals the machinery in Build_Finalizer to treat
12748 -- this case specially.
12749
12750 Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
12751
12752 -- Step 3: Hook the transient object to the temporary
12753
a7d08a38
AC		 12754 -- This must be inserted right after the object declaration, so that
12755 -- the assignment is executed if, and only if, the object is actually
12756 -- created (whereas the declaration of the hook pointer, and the
12757 -- finalization call, may be inserted at an outer level, and may
12758 -- remain unused for some executions, if the actual creation of
12759 -- the object is conditional).
12760
b2c28399
AC		 12761 -- The use of unchecked conversion / unrestricted access is needed to
12762 -- avoid an accessibility violation. Note that the finalization code is
12763 -- structured in such a way that the "hook" is processed only when it
12764 -- points to an existing object.
12765
12766 if Is_Access_Type (Obj_Typ) then
e4494292
RD		 12767 Expr :=
12768 Unchecked_Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc));
b2c28399
AC		 12769 else
12770 Expr :=
12771 Make_Attribute_Reference (Loc,
e4494292 12772 Prefix => New_Occurrence_Of (Obj_Id, Loc),
b2c28399
AC		 12773 Attribute_Name => Name_Unrestricted_Access);
12774 end if;
12775
12776 -- Generate:
12777 -- Temp := Ptr_Id (Obj_Id);
12778 -- <or>
12779 -- Temp := Obj_Id'Unrestricted_Access;
12780
97779c34
AC		 12781 -- When the transient object is initialized by an aggregate, the hook
12782 -- must capture the object after the last component assignment takes
12783 -- place. Only then is the object fully initialized.
12784
12785 if Ekind (Obj_Id) = E_Variable
12786 and then Present (Last_Aggregate_Assignment (Obj_Id))
12787 then
12788 Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
12789
12790 -- Otherwise the hook seizes the related object immediately
12791
12792 else
12793 Temp_Ins := Decl;
12794 end if;
12795
12796 Insert_After_And_Analyze (Temp_Ins,
a7d08a38 12797 Make_Assignment_Statement (Loc,
e4494292 12798 Name => New_Occurrence_Of (Temp_Id, Loc),
a7d08a38 12799 Expression => Expr));
b2c28399
AC		 12800
12801 -- Step 4: Finalize the transient controlled object after the context
12802 -- has been evaluated/elaborated. Generate:
12803
12804 -- if Temp /= null then
12805 -- [Deep_]Finalize (Temp.all);
12806 -- Temp := null;
12807 -- end if;
12808
12809 -- When the node is part of a return statement, there is no need to
12810 -- insert a finalization call, as the general finalization mechanism
12811 -- (see Build_Finalizer) would take care of the transient controlled
12812 -- object on subprogram exit. Note that it would also be impossible to
12813 -- insert the finalization code after the return statement as this will
12814 -- render it unreachable.
12815
064f4527
TQ		 12816 if Nkind (Finalization_Context) /= N_Simple_Return_Statement then
12817 Fin_Stmts := New_List (
12818 Make_Final_Call
12819 (Obj_Ref =>
12820 Make_Explicit_Dereference (Loc,
e4494292 12821 Prefix => New_Occurrence_Of (Temp_Id, Loc)),
064f4527 12822 Typ => Desig_Typ),
b2c28399 12823
064f4527 12824 Make_Assignment_Statement (Loc,
e4494292 12825 Name => New_Occurrence_Of (Temp_Id, Loc),
064f4527 12826 Expression => Make_Null (Loc)));
b2c28399 12827
064f4527
TQ		 12828 if not Finalize_Always then
12829 Fin_Stmts := New_List (
12830 Make_Implicit_If_Statement (Decl,
12831 Condition =>
12832 Make_Op_Ne (Loc,
e4494292 12833 Left_Opnd => New_Occurrence_Of (Temp_Id, Loc),
064f4527
TQ		 12834 Right_Opnd => Make_Null (Loc)),
12835 Then_Statements => Fin_Stmts));
12836 end if;
b2c28399 12837
064f4527 12838 Insert_Actions_After (Finalization_Context, Fin_Stmts);
b2c28399
AC		 12839 end if;
12840 end Process_Transient_Object;
12841
70482933
RK		 12842 ------------------------
12843 -- Rewrite_Comparison --
12844 ------------------------
12845
12846 procedure Rewrite_Comparison (N : Node_Id) is
c800f862
RD		 12847 Warning_Generated : Boolean := False;
12848 -- Set to True if first pass with Assume_Valid generates a warning in
12849 -- which case we skip the second pass to avoid warning overloaded.
12850
12851 Result : Node_Id;
12852 -- Set to Standard_True or Standard_False
12853
d26dc4b5
AC		 12854 begin
12855 if Nkind (N) = N_Type_Conversion then
12856 Rewrite_Comparison (Expression (N));
20b5d666 12857 return;
70482933 12858
d26dc4b5 12859 elsif Nkind (N) not in N_Op_Compare then
20b5d666
JM		 12860 return;
12861 end if;
70482933 12862
c800f862
RD		 12863 -- Now start looking at the comparison in detail. We potentially go
12864 -- through this loop twice. The first time, Assume_Valid is set False
12865 -- in the call to Compile_Time_Compare. If this call results in a
12866 -- clear result of always True or Always False, that's decisive and
12867 -- we are done. Otherwise we repeat the processing with Assume_Valid
e7e4d230 12868 -- set to True to generate additional warnings. We can skip that step
c800f862
RD		 12869 -- if Constant_Condition_Warnings is False.
12870
12871 for AV in False .. True loop
12872 declare
12873 Typ : constant Entity_Id := Etype (N);
12874 Op1 : constant Node_Id := Left_Opnd (N);
12875 Op2 : constant Node_Id := Right_Opnd (N);
70482933 12876
c800f862
RD		 12877 Res : constant Compare_Result :=
12878 Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
12879 -- Res indicates if compare outcome can be compile time determined
f02b8bb8 12880
c800f862
RD		 12881 True_Result : Boolean;
12882 False_Result : Boolean;
f02b8bb8 12883
c800f862
RD		 12884 begin
12885 case N_Op_Compare (Nkind (N)) is
d26dc4b5
AC		 12886 when N_Op_Eq =>
12887 True_Result := Res = EQ;
12888 False_Result := Res = LT or else Res = GT or else Res = NE;
12889
12890 when N_Op_Ge =>
12891 True_Result := Res in Compare_GE;
12892 False_Result := Res = LT;
12893
12894 if Res = LE
12895 and then Constant_Condition_Warnings
12896 and then Comes_From_Source (Original_Node (N))
12897 and then Nkind (Original_Node (N)) = N_Op_Ge
12898 and then not In_Instance
d26dc4b5 12899 and then Is_Integer_Type (Etype (Left_Opnd (N)))
59ae6391 12900 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
d26dc4b5 12901 then
ed2233dc 12902 Error_Msg_N
324ac540
AC		 12903 ("can never be greater than, could replace by ""'=""?c?",
12904 N);
c800f862 12905 Warning_Generated := True;
d26dc4b5 12906 end if;
70482933 12907
d26dc4b5
AC		 12908 when N_Op_Gt =>
12909 True_Result := Res = GT;
12910 False_Result := Res in Compare_LE;
12911
12912 when N_Op_Lt =>
12913 True_Result := Res = LT;
12914 False_Result := Res in Compare_GE;
12915
12916 when N_Op_Le =>
12917 True_Result := Res in Compare_LE;
12918 False_Result := Res = GT;
12919
12920 if Res = GE
12921 and then Constant_Condition_Warnings
12922 and then Comes_From_Source (Original_Node (N))
12923 and then Nkind (Original_Node (N)) = N_Op_Le
12924 and then not In_Instance
d26dc4b5 12925 and then Is_Integer_Type (Etype (Left_Opnd (N)))
59ae6391 12926 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
d26dc4b5 12927 then
ed2233dc 12928 Error_Msg_N
324ac540 12929 ("can never be less than, could replace by ""'=""?c?", N);
c800f862 12930 Warning_Generated := True;
d26dc4b5 12931 end if;
70482933 12932
d26dc4b5
AC		 12933 when N_Op_Ne =>
12934 True_Result := Res = NE or else Res = GT or else Res = LT;
12935 False_Result := Res = EQ;
c800f862 12936 end case;
d26dc4b5 12937
c800f862
RD		 12938 -- If this is the first iteration, then we actually convert the
12939 -- comparison into True or False, if the result is certain.
d26dc4b5 12940
c800f862
RD		 12941 if AV = False then
12942 if True_Result or False_Result then
21791d97 12943 Result := Boolean_Literals (True_Result);
c800f862
RD		 12944 Rewrite (N,
12945 Convert_To (Typ,
12946 New_Occurrence_Of (Result, Sloc (N))));
12947 Analyze_And_Resolve (N, Typ);
12948 Warn_On_Known_Condition (N);
12949 return;
12950 end if;
12951
12952 -- If this is the second iteration (AV = True), and the original
e7e4d230
AC		 12953 -- node comes from source and we are not in an instance, then give
12954 -- a warning if we know result would be True or False. Note: we
12955 -- know Constant_Condition_Warnings is set if we get here.
c800f862
RD		 12956
12957 elsif Comes_From_Source (Original_Node (N))
12958 and then not In_Instance
12959 then
12960 if True_Result then
ed2233dc 12961 Error_Msg_N
324ac540 12962 ("condition can only be False if invalid values present??",
c800f862
RD		 12963 N);
12964 elsif False_Result then
ed2233dc 12965 Error_Msg_N
324ac540 12966 ("condition can only be True if invalid values present??",
c800f862
RD		 12967 N);
12968 end if;
12969 end if;
12970 end;
12971
12972 -- Skip second iteration if not warning on constant conditions or
e7e4d230
AC		 12973 -- if the first iteration already generated a warning of some kind or
12974 -- if we are in any case assuming all values are valid (so that the
12975 -- first iteration took care of the valid case).
c800f862
RD		 12976
12977 exit when not Constant_Condition_Warnings;
12978 exit when Warning_Generated;
12979 exit when Assume_No_Invalid_Values;
12980 end loop;
70482933
RK		 12981 end Rewrite_Comparison;
12982
fbf5a39b
AC		 12983 ----------------------------
12984 -- Safe_In_Place_Array_Op --
12985 ----------------------------
12986
12987 function Safe_In_Place_Array_Op
2e071734
AC		 12988 (Lhs : Node_Id;
12989 Op1 : Node_Id;
12990 Op2 : Node_Id) return Boolean
fbf5a39b
AC		 12991 is
12992 Target : Entity_Id;
12993
12994 function Is_Safe_Operand (Op : Node_Id) return Boolean;
12995 -- Operand is safe if it cannot overlap part of the target of the
12996 -- operation. If the operand and the target are identical, the operand
12997 -- is safe. The operand can be empty in the case of negation.
12998
12999 function Is_Unaliased (N : Node_Id) return Boolean;
5e1c00fa 13000 -- Check that N is a stand-alone entity
fbf5a39b
AC		 13001
13002 ------------------
13003 -- Is_Unaliased --
13004 ------------------
13005
13006 function Is_Unaliased (N : Node_Id) return Boolean is
13007 begin
13008 return
13009 Is_Entity_Name (N)
13010 and then No (Address_Clause (Entity (N)))
13011 and then No (Renamed_Object (Entity (N)));
13012 end Is_Unaliased;
13013
13014 ---------------------
13015 -- Is_Safe_Operand --
13016 ---------------------
13017
13018 function Is_Safe_Operand (Op : Node_Id) return Boolean is
13019 begin
13020 if No (Op) then
13021 return True;
13022
13023 elsif Is_Entity_Name (Op) then
13024 return Is_Unaliased (Op);
13025
303b4d58 13026 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
fbf5a39b
AC		 13027 return Is_Unaliased (Prefix (Op));
13028
13029 elsif Nkind (Op) = N_Slice then
13030 return
13031 Is_Unaliased (Prefix (Op))
13032 and then Entity (Prefix (Op)) /= Target;
13033
13034 elsif Nkind (Op) = N_Op_Not then
13035 return Is_Safe_Operand (Right_Opnd (Op));
13036
13037 else
13038 return False;
13039 end if;
13040 end Is_Safe_Operand;
13041
b6b5cca8 13042 -- Start of processing for Safe_In_Place_Array_Op
fbf5a39b
AC		 13043
13044 begin
685094bf
RD		 13045 -- Skip this processing if the component size is different from system
13046 -- storage unit (since at least for NOT this would cause problems).
fbf5a39b 13047
eaa826f8 13048 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
fbf5a39b
AC		 13049 return False;
13050
26bff3d9 13051 -- Cannot do in place stuff on VM_Target since cannot pass addresses
fbf5a39b 13052
26bff3d9 13053 elsif VM_Target /= No_VM then
fbf5a39b
AC		 13054 return False;
13055
13056 -- Cannot do in place stuff if non-standard Boolean representation
13057
eaa826f8 13058 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
fbf5a39b
AC		 13059 return False;
13060
13061 elsif not Is_Unaliased (Lhs) then
13062 return False;
e7e4d230 13063
fbf5a39b
AC		 13064 else
13065 Target := Entity (Lhs);
e7e4d230 13066 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
fbf5a39b
AC		 13067 end if;
13068 end Safe_In_Place_Array_Op;
13069
70482933
RK		 13070 -----------------------
13071 -- Tagged_Membership --
13072 -----------------------
13073
685094bf
RD		 13074 -- There are two different cases to consider depending on whether the right
13075 -- operand is a class-wide type or not. If not we just compare the actual
13076 -- tag of the left expr to the target type tag:
70482933
RK		 13077 --
13078 -- Left_Expr.Tag = Right_Type'Tag;
13079 --
685094bf
RD		 13080 -- If it is a class-wide type we use the RT function CW_Membership which is
13081 -- usually implemented by looking in the ancestor tables contained in the
13082 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
70482933 13083
0669bebe
GB		 13084 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13085 -- function IW_Membership which is usually implemented by looking in the
13086 -- table of abstract interface types plus the ancestor table contained in
13087 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13088
82878151
AC		 13089 procedure Tagged_Membership
13090 (N : Node_Id;
13091 SCIL_Node : out Node_Id;
13092 Result : out Node_Id)
13093 is
70482933
RK		 13094 Left : constant Node_Id := Left_Opnd (N);
13095 Right : constant Node_Id := Right_Opnd (N);
13096 Loc : constant Source_Ptr := Sloc (N);
13097
38171f43 13098 Full_R_Typ : Entity_Id;
70482933 13099 Left_Type : Entity_Id;
82878151 13100 New_Node : Node_Id;
70482933
RK		 13101 Right_Type : Entity_Id;
13102 Obj_Tag : Node_Id;
13103
13104 begin
82878151
AC		 13105 SCIL_Node := Empty;
13106
852dba80
AC		 13107 -- Handle entities from the limited view
13108
13109 Left_Type := Available_View (Etype (Left));
13110 Right_Type := Available_View (Etype (Right));
70482933 13111
6cce2156
GD		 13112 -- In the case where the type is an access type, the test is applied
13113 -- using the designated types (needed in Ada 2012 for implicit anonymous
13114 -- access conversions, for AI05-0149).
13115
13116 if Is_Access_Type (Right_Type) then
13117 Left_Type := Designated_Type (Left_Type);
13118 Right_Type := Designated_Type (Right_Type);
13119 end if;
13120
70482933
RK		 13121 if Is_Class_Wide_Type (Left_Type) then
13122 Left_Type := Root_Type (Left_Type);
13123 end if;
13124
38171f43
AC		 13125 if Is_Class_Wide_Type (Right_Type) then
13126 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
13127 else
13128 Full_R_Typ := Underlying_Type (Right_Type);
13129 end if;
13130
70482933
RK		 13131 Obj_Tag :=
13132 Make_Selected_Component (Loc,
13133 Prefix => Relocate_Node (Left),
a9d8907c 13134 Selector_Name =>
e4494292 13135 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
70482933
RK		 13136
13137 if Is_Class_Wide_Type (Right_Type) then
758c442c 13138
0669bebe
GB		 13139 -- No need to issue a run-time check if we statically know that the
13140 -- result of this membership test is always true. For example,
13141 -- considering the following declarations:
13142
13143 -- type Iface is interface;
13144 -- type T is tagged null record;
13145 -- type DT is new T and Iface with null record;
13146
13147 -- Obj1 : T;
13148 -- Obj2 : DT;
13149
13150 -- These membership tests are always true:
13151
13152 -- Obj1 in T'Class
13153 -- Obj2 in T'Class;
13154 -- Obj2 in Iface'Class;
13155
13156 -- We do not need to handle cases where the membership is illegal.
13157 -- For example:
13158
13159 -- Obj1 in DT'Class; -- Compile time error
13160 -- Obj1 in Iface'Class; -- Compile time error
13161
13162 if not Is_Class_Wide_Type (Left_Type)
4ac2477e
JM		 13163 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
13164 Use_Full_View => True)
533369aa
AC		 13165 or else (Is_Interface (Etype (Right_Type))
13166 and then Interface_Present_In_Ancestor
761f7dcb
AC		 13167 (Typ => Left_Type,
13168 Iface => Etype (Right_Type))))
0669bebe 13169 then
e4494292 13170 Result := New_Occurrence_Of (Standard_True, Loc);
82878151 13171 return;
0669bebe
GB		 13172 end if;
13173
758c442c
GD		 13174 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13175
630d30e9
RD		 13176 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
13177
0669bebe 13178 -- Support to: "Iface_CW_Typ in Typ'Class"
630d30e9
RD		 13179
13180 or else Is_Interface (Left_Type)
13181 then
dfd99a80
TQ		 13182 -- Issue error if IW_Membership operation not available in a
13183 -- configurable run time setting.
13184
13185 if not RTE_Available (RE_IW_Membership) then
b4592168
GD		 13186 Error_Msg_CRT
13187 ("dynamic membership test on interface types", N);
82878151
AC		 13188 Result := Empty;
13189 return;
dfd99a80
TQ		 13190 end if;
13191
82878151 13192 Result :=
758c442c
GD		 13193 Make_Function_Call (Loc,
13194 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
13195 Parameter_Associations => New_List (
13196 Make_Attribute_Reference (Loc,
13197 Prefix => Obj_Tag,
13198 Attribute_Name => Name_Address),
e4494292 13199 New_Occurrence_Of (
38171f43 13200 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
758c442c
GD		 13201 Loc)));
13202
13203 -- Ada 95: Normal case
13204
13205 else
82878151
AC		 13206 Build_CW_Membership (Loc,
13207 Obj_Tag_Node => Obj_Tag,
13208 Typ_Tag_Node =>
e4494292 13209 New_Occurrence_Of (
38171f43 13210 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
82878151
AC		 13211 Related_Nod => N,
13212 New_Node => New_Node);
13213
13214 -- Generate the SCIL node for this class-wide membership test.
13215 -- Done here because the previous call to Build_CW_Membership
13216 -- relocates Obj_Tag.
13217
13218 if Generate_SCIL then
13219 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
13220 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
13221 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
13222 end if;
13223
13224 Result := New_Node;
758c442c
GD		 13225 end if;
13226
0669bebe
GB		 13227 -- Right_Type is not a class-wide type
13228
70482933 13229 else
0669bebe
GB		 13230 -- No need to check the tag of the object if Right_Typ is abstract
13231
13232 if Is_Abstract_Type (Right_Type) then
e4494292 13233 Result := New_Occurrence_Of (Standard_False, Loc);
0669bebe
GB		 13234
13235 else
82878151 13236 Result :=
0669bebe
GB		 13237 Make_Op_Eq (Loc,
13238 Left_Opnd => Obj_Tag,
13239 Right_Opnd =>
e4494292 13240 New_Occurrence_Of
38171f43 13241 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
0669bebe 13242 end if;
70482933 13243 end if;
70482933
RK		 13244 end Tagged_Membership;
13245
13246 ------------------------------
13247 -- Unary_Op_Validity_Checks --
13248 ------------------------------
13249
13250 procedure Unary_Op_Validity_Checks (N : Node_Id) is
13251 begin
13252 if Validity_Checks_On and Validity_Check_Operands then
13253 Ensure_Valid (Right_Opnd (N));
13254 end if;
13255 end Unary_Op_Validity_Checks;
13256
13257end Exp_Ch4;
Mirror of https://gcc.gnu.org/git/gcc.git