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