]> 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
2003-10-21 Arnaud Charlet <charlet@act-europe.fr>
[thirdparty/gcc.git] / gcc / ada / exp_ch4.adb
CommitLineData
ee6ba406 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ C H 4 --
6-- --
7-- B o d y --
8-- --
9dfe12ae 9-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
ee6ba406 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- --
13-- ware Foundation; either version 2, or (at your option) any later ver- --
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 --
18-- Public License distributed with GNAT; see file COPYING. If not, write --
19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20-- MA 02111-1307, USA. --
21-- --
22-- GNAT was originally developed by the GNAT team at New York University. --
e78e8c8e 23-- Extensive contributions were provided by Ada Core Technologies Inc. --
ee6ba406 24-- --
25------------------------------------------------------------------------------
26
27with Atree; use Atree;
28with Checks; use Checks;
29with Einfo; use Einfo;
30with Elists; use Elists;
31with Errout; use Errout;
32with Exp_Aggr; use Exp_Aggr;
33with Exp_Ch3; use Exp_Ch3;
34with Exp_Ch7; use Exp_Ch7;
35with Exp_Ch9; use Exp_Ch9;
36with Exp_Disp; use Exp_Disp;
37with Exp_Fixd; use Exp_Fixd;
38with Exp_Pakd; use Exp_Pakd;
39with Exp_Tss; use Exp_Tss;
40with Exp_Util; use Exp_Util;
41with Exp_VFpt; use Exp_VFpt;
42with Hostparm; use Hostparm;
43with Inline; use Inline;
44with Nlists; use Nlists;
45with Nmake; use Nmake;
46with Opt; use Opt;
47with Rtsfind; use Rtsfind;
48with Sem; use Sem;
49with Sem_Cat; use Sem_Cat;
50with Sem_Ch13; use Sem_Ch13;
51with Sem_Eval; use Sem_Eval;
52with Sem_Res; use Sem_Res;
53with Sem_Type; use Sem_Type;
54with Sem_Util; use Sem_Util;
f15731c4 55with Sem_Warn; use Sem_Warn;
ee6ba406 56with Sinfo; use Sinfo;
57with Sinfo.CN; use Sinfo.CN;
58with Snames; use Snames;
59with Stand; use Stand;
f15731c4 60with Targparm; use Targparm;
ee6ba406 61with Tbuild; use Tbuild;
62with Ttypes; use Ttypes;
63with Uintp; use Uintp;
64with Urealp; use Urealp;
65with Validsw; use Validsw;
66
67package body Exp_Ch4 is
68
69 ------------------------
70 -- Local Subprograms --
71 ------------------------
72
73 procedure Binary_Op_Validity_Checks (N : Node_Id);
74 pragma Inline (Binary_Op_Validity_Checks);
75 -- Performs validity checks for a binary operator
76
9dfe12ae 77 procedure Build_Boolean_Array_Proc_Call
78 (N : Node_Id;
79 Op1 : Node_Id;
80 Op2 : Node_Id);
81 -- If an boolean array assignment can be done in place, build call to
82 -- corresponding library procedure.
83
84 procedure Expand_Allocator_Expression (N : Node_Id);
85 -- Subsidiary to Expand_N_Allocator, for the case when the expression
86 -- is a qualified expression or an aggregate.
87
ee6ba406 88 procedure Expand_Array_Comparison (N : Node_Id);
89 -- This routine handles expansion of the comparison operators (N_Op_Lt,
90 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
91 -- code for these operators is similar, differing only in the details of
9dfe12ae 92 -- the actual comparison call that is made. Special processing (call a
93 -- run-time routine)
ee6ba406 94
95 function Expand_Array_Equality
96 (Nod : Node_Id;
97 Typ : Entity_Id;
98 A_Typ : Entity_Id;
99 Lhs : Node_Id;
100 Rhs : Node_Id;
101 Bodies : List_Id)
102 return Node_Id;
103 -- Expand an array equality into a call to a function implementing this
104 -- equality, and a call to it. Loc is the location for the generated
105 -- nodes. Typ is the type of the array, and Lhs, Rhs are the array
106 -- expressions to be compared. A_Typ is the type of the arguments,
107 -- which may be a private type, in which case Typ is its full view.
108 -- Bodies is a list on which to attach bodies of local functions that
9dfe12ae 109 -- are created in the process. This is the responsibility of the
ee6ba406 110 -- caller to insert those bodies at the right place. Nod provides
111 -- the Sloc value for the generated code.
112
113 procedure Expand_Boolean_Operator (N : Node_Id);
114 -- Common expansion processing for Boolean operators (And, Or, Xor)
115 -- for the case of array type arguments.
116
117 function Expand_Composite_Equality
118 (Nod : Node_Id;
119 Typ : Entity_Id;
120 Lhs : Node_Id;
121 Rhs : Node_Id;
122 Bodies : List_Id)
123 return Node_Id;
124 -- Local recursive function used to expand equality for nested
125 -- composite types. Used by Expand_Record/Array_Equality, Bodies
126 -- is a list on which to attach bodies of local functions that are
127 -- created in the process. This is the responsability of the caller
128 -- to insert those bodies at the right place. Nod provides the Sloc
129 -- value for generated code.
130
131 procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
132 -- This routine handles expansion of concatenation operations, where
133 -- N is the N_Op_Concat node being expanded and Operands is the list
134 -- of operands (at least two are present). The caller has dealt with
135 -- converting any singleton operands into singleton aggregates.
136
137 procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
138 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
139 -- and replace node Cnode with the result of the contatenation. If there
140 -- are two operands, they can be string or character. If there are more
141 -- than two operands, then are always of type string (i.e. the caller has
142 -- already converted character operands to strings in this case).
143
144 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
145 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
146 -- universal fixed. We do not have such a type at runtime, so the
147 -- purpose of this routine is to find the real type by looking up
148 -- the tree. We also determine if the operation must be rounded.
149
9dfe12ae 150 function Get_Allocator_Final_List
151 (N : Node_Id;
152 T : Entity_Id;
153 PtrT : Entity_Id)
154 return Entity_Id;
155 -- If the designated type is controlled, build final_list expression
156 -- for created object. If context is an access parameter, create a
157 -- local access type to have a usable finalization list.
158
ee6ba406 159 procedure Insert_Dereference_Action (N : Node_Id);
160 -- N is an expression whose type is an access. When the type is derived
161 -- from Checked_Pool, expands a call to the primitive 'dereference'.
162
163 function Make_Array_Comparison_Op
164 (Typ : Entity_Id;
165 Nod : Node_Id)
166 return Node_Id;
167 -- Comparisons between arrays are expanded in line. This function
168 -- produces the body of the implementation of (a > b), where a and b
169 -- are one-dimensional arrays of some discrete type. The original
170 -- node is then expanded into the appropriate call to this function.
171 -- Nod provides the Sloc value for the generated code.
172
173 function Make_Boolean_Array_Op
174 (Typ : Entity_Id;
175 N : Node_Id)
176 return Node_Id;
177 -- Boolean operations on boolean arrays are expanded in line. This
178 -- function produce the body for the node N, which is (a and b),
179 -- (a or b), or (a xor b). It is used only the normal case and not
180 -- the packed case. The type involved, Typ, is the Boolean array type,
181 -- and the logical operations in the body are simple boolean operations.
182 -- Note that Typ is always a constrained type (the caller has ensured
183 -- this by using Convert_To_Actual_Subtype if necessary).
184
185 procedure Rewrite_Comparison (N : Node_Id);
186 -- N is the node for a compile time comparison. If this outcome of this
187 -- comparison can be determined at compile time, then the node N can be
188 -- rewritten with True or False. If the outcome cannot be determined at
189 -- compile time, the call has no effect.
190
191 function Tagged_Membership (N : Node_Id) return Node_Id;
192 -- Construct the expression corresponding to the tagged membership test.
193 -- Deals with a second operand being (or not) a class-wide type.
194
9dfe12ae 195 function Safe_In_Place_Array_Op
196 (Lhs : Node_Id;
197 Op1 : Node_Id;
198 Op2 : Node_Id)
199 return Boolean;
200 -- In the context of an assignment, where the right-hand side is a
201 -- boolean operation on arrays, check whether operation can be performed
202 -- in place.
203
ee6ba406 204 procedure Unary_Op_Validity_Checks (N : Node_Id);
205 pragma Inline (Unary_Op_Validity_Checks);
206 -- Performs validity checks for a unary operator
207
208 -------------------------------
209 -- Binary_Op_Validity_Checks --
210 -------------------------------
211
212 procedure Binary_Op_Validity_Checks (N : Node_Id) is
213 begin
214 if Validity_Checks_On and Validity_Check_Operands then
215 Ensure_Valid (Left_Opnd (N));
216 Ensure_Valid (Right_Opnd (N));
217 end if;
218 end Binary_Op_Validity_Checks;
219
9dfe12ae 220 ------------------------------------
221 -- Build_Boolean_Array_Proc_Call --
222 ------------------------------------
223
224 procedure Build_Boolean_Array_Proc_Call
225 (N : Node_Id;
226 Op1 : Node_Id;
227 Op2 : Node_Id)
228 is
229 Loc : constant Source_Ptr := Sloc (N);
230 Kind : constant Node_Kind := Nkind (Expression (N));
231 Target : constant Node_Id :=
232 Make_Attribute_Reference (Loc,
233 Prefix => Name (N),
234 Attribute_Name => Name_Address);
235
236 Arg1 : constant Node_Id := Op1;
237 Arg2 : Node_Id := Op2;
238 Call_Node : Node_Id;
239 Proc_Name : Entity_Id;
240
241 begin
242 if Kind = N_Op_Not then
243 if Nkind (Op1) in N_Binary_Op then
244
245 -- Use negated version of the binary operators.
246
247 if Nkind (Op1) = N_Op_And then
248 Proc_Name := RTE (RE_Vector_Nand);
249
250 elsif Nkind (Op1) = N_Op_Or then
251 Proc_Name := RTE (RE_Vector_Nor);
252
253 else pragma Assert (Nkind (Op1) = N_Op_Xor);
254 Proc_Name := RTE (RE_Vector_Xor);
255 end if;
256
257 Call_Node :=
258 Make_Procedure_Call_Statement (Loc,
259 Name => New_Occurrence_Of (Proc_Name, Loc),
260
261 Parameter_Associations => New_List (
262 Target,
263 Make_Attribute_Reference (Loc,
264 Prefix => Left_Opnd (Op1),
265 Attribute_Name => Name_Address),
266
267 Make_Attribute_Reference (Loc,
268 Prefix => Right_Opnd (Op1),
269 Attribute_Name => Name_Address),
270
271 Make_Attribute_Reference (Loc,
272 Prefix => Left_Opnd (Op1),
273 Attribute_Name => Name_Length)));
274
275 else
276 Proc_Name := RTE (RE_Vector_Not);
277
278 Call_Node :=
279 Make_Procedure_Call_Statement (Loc,
280 Name => New_Occurrence_Of (Proc_Name, Loc),
281 Parameter_Associations => New_List (
282 Target,
283
284 Make_Attribute_Reference (Loc,
285 Prefix => Op1,
286 Attribute_Name => Name_Address),
287
288 Make_Attribute_Reference (Loc,
289 Prefix => Op1,
290 Attribute_Name => Name_Length)));
291 end if;
292
293 else
294 -- We use the following equivalences:
295
296 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
297 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
298 -- (not X) xor (not Y) = X xor Y
299 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
300
301 if Nkind (Op1) = N_Op_Not then
302 if Kind = N_Op_And then
303 Proc_Name := RTE (RE_Vector_Nor);
304
305 elsif Kind = N_Op_Or then
306 Proc_Name := RTE (RE_Vector_Nand);
307
308 else
309 Proc_Name := RTE (RE_Vector_Xor);
310 end if;
311
312 else
313 if Kind = N_Op_And then
314 Proc_Name := RTE (RE_Vector_And);
315
316 elsif Kind = N_Op_Or then
317 Proc_Name := RTE (RE_Vector_Or);
318
319 elsif Nkind (Op2) = N_Op_Not then
320 Proc_Name := RTE (RE_Vector_Nxor);
321 Arg2 := Right_Opnd (Op2);
322
323 else
324 Proc_Name := RTE (RE_Vector_Xor);
325 end if;
326 end if;
327
328 Call_Node :=
329 Make_Procedure_Call_Statement (Loc,
330 Name => New_Occurrence_Of (Proc_Name, Loc),
331 Parameter_Associations => New_List (
332 Target,
333 Make_Attribute_Reference (Loc,
334 Prefix => Arg1,
335 Attribute_Name => Name_Address),
336 Make_Attribute_Reference (Loc,
337 Prefix => Arg2,
338 Attribute_Name => Name_Address),
339 Make_Attribute_Reference (Loc,
340 Prefix => Op1,
341 Attribute_Name => Name_Length)));
342 end if;
343
344 Rewrite (N, Call_Node);
345 Analyze (N);
346
347 exception
348 when RE_Not_Available =>
349 return;
350 end Build_Boolean_Array_Proc_Call;
351
352 ---------------------------------
353 -- Expand_Allocator_Expression --
354 ---------------------------------
355
356 procedure Expand_Allocator_Expression (N : Node_Id) is
357 Loc : constant Source_Ptr := Sloc (N);
358 Exp : constant Node_Id := Expression (Expression (N));
359 Indic : constant Node_Id := Subtype_Mark (Expression (N));
360 PtrT : constant Entity_Id := Etype (N);
361 T : constant Entity_Id := Entity (Indic);
362 Flist : Node_Id;
363 Node : Node_Id;
364 Temp : Entity_Id;
365
366 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
367
368 Tag_Assign : Node_Id;
369 Tmp_Node : Node_Id;
370
371 begin
372 if Is_Tagged_Type (T) or else Controlled_Type (T) then
373
374 -- Actions inserted before:
375 -- Temp : constant ptr_T := new T'(Expression);
376 -- <no CW> Temp._tag := T'tag;
377 -- <CTRL> Adjust (Finalizable (Temp.all));
378 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
379
380 -- We analyze by hand the new internal allocator to avoid
381 -- any recursion and inappropriate call to Initialize
382 if not Aggr_In_Place then
383 Remove_Side_Effects (Exp);
384 end if;
385
386 Temp :=
387 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
388
389 -- For a class wide allocation generate the following code:
390
391 -- type Equiv_Record is record ... end record;
392 -- implicit subtype CW is <Class_Wide_Subytpe>;
393 -- temp : PtrT := new CW'(CW!(expr));
394
395 if Is_Class_Wide_Type (T) then
396 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
397
398 Set_Expression (Expression (N),
399 Unchecked_Convert_To (Entity (Indic), Exp));
400
401 Analyze_And_Resolve (Expression (N), Entity (Indic));
402 end if;
403
404 if Aggr_In_Place then
405 Tmp_Node :=
406 Make_Object_Declaration (Loc,
407 Defining_Identifier => Temp,
408 Object_Definition => New_Reference_To (PtrT, Loc),
409 Expression =>
410 Make_Allocator (Loc,
411 New_Reference_To (Etype (Exp), Loc)));
412
413 Set_Comes_From_Source
414 (Expression (Tmp_Node), Comes_From_Source (N));
415
416 Set_No_Initialization (Expression (Tmp_Node));
417 Insert_Action (N, Tmp_Node);
418
419 if Controlled_Type (T)
420 and then Ekind (PtrT) = E_Anonymous_Access_Type
421 then
422 -- Create local finalization list for access parameter.
423
424 Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
425 end if;
426
427 Convert_Aggr_In_Allocator (Tmp_Node, Exp);
428 else
429 Node := Relocate_Node (N);
430 Set_Analyzed (Node);
431 Insert_Action (N,
432 Make_Object_Declaration (Loc,
433 Defining_Identifier => Temp,
434 Constant_Present => True,
435 Object_Definition => New_Reference_To (PtrT, Loc),
436 Expression => Node));
437 end if;
438
439 -- Suppress the tag assignment when Java_VM because JVM tags
440 -- are represented implicitly in objects.
441
442 if Is_Tagged_Type (T)
443 and then not Is_Class_Wide_Type (T)
444 and then not Java_VM
445 then
446 Tag_Assign :=
447 Make_Assignment_Statement (Loc,
448 Name =>
449 Make_Selected_Component (Loc,
450 Prefix => New_Reference_To (Temp, Loc),
451 Selector_Name =>
452 New_Reference_To (Tag_Component (T), Loc)),
453
454 Expression =>
455 Unchecked_Convert_To (RTE (RE_Tag),
456 New_Reference_To (Access_Disp_Table (T), Loc)));
457
458 -- The previous assignment has to be done in any case
459
460 Set_Assignment_OK (Name (Tag_Assign));
461 Insert_Action (N, Tag_Assign);
462
463 elsif Is_Private_Type (T)
464 and then Is_Tagged_Type (Underlying_Type (T))
465 and then not Java_VM
466 then
467 declare
468 Utyp : constant Entity_Id := Underlying_Type (T);
469 Ref : constant Node_Id :=
470 Unchecked_Convert_To (Utyp,
471 Make_Explicit_Dereference (Loc,
472 New_Reference_To (Temp, Loc)));
473
474 begin
475 Tag_Assign :=
476 Make_Assignment_Statement (Loc,
477 Name =>
478 Make_Selected_Component (Loc,
479 Prefix => Ref,
480 Selector_Name =>
481 New_Reference_To (Tag_Component (Utyp), Loc)),
482
483 Expression =>
484 Unchecked_Convert_To (RTE (RE_Tag),
485 New_Reference_To (
486 Access_Disp_Table (Utyp), Loc)));
487
488 Set_Assignment_OK (Name (Tag_Assign));
489 Insert_Action (N, Tag_Assign);
490 end;
491 end if;
492
493 if Controlled_Type (Designated_Type (PtrT))
494 and then Controlled_Type (T)
495 then
496 declare
497 Attach : Node_Id;
498 Apool : constant Entity_Id :=
499 Associated_Storage_Pool (PtrT);
500
501 begin
502 -- If it is an allocation on the secondary stack
503 -- (i.e. a value returned from a function), the object
504 -- is attached on the caller side as soon as the call
505 -- is completed (see Expand_Ctrl_Function_Call)
506
507 if Is_RTE (Apool, RE_SS_Pool) then
508 declare
509 F : constant Entity_Id :=
510 Make_Defining_Identifier (Loc,
511 New_Internal_Name ('F'));
512 begin
513 Insert_Action (N,
514 Make_Object_Declaration (Loc,
515 Defining_Identifier => F,
516 Object_Definition => New_Reference_To (RTE
517 (RE_Finalizable_Ptr), Loc)));
518
519 Flist := New_Reference_To (F, Loc);
520 Attach := Make_Integer_Literal (Loc, 1);
521 end;
522
523 -- Normal case, not a secondary stack allocation
524
525 else
526 Flist := Find_Final_List (PtrT);
527 Attach := Make_Integer_Literal (Loc, 2);
528 end if;
529
530 if not Aggr_In_Place then
531 Insert_Actions (N,
532 Make_Adjust_Call (
533 Ref =>
534
535 -- An unchecked conversion is needed in the
536 -- classwide case because the designated type
537 -- can be an ancestor of the subtype mark of
538 -- the allocator.
539
540 Unchecked_Convert_To (T,
541 Make_Explicit_Dereference (Loc,
542 New_Reference_To (Temp, Loc))),
543
544 Typ => T,
545 Flist_Ref => Flist,
546 With_Attach => Attach));
547 end if;
548 end;
549 end if;
550
551 Rewrite (N, New_Reference_To (Temp, Loc));
552 Analyze_And_Resolve (N, PtrT);
553
554 elsif Aggr_In_Place then
555 Temp :=
556 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
557 Tmp_Node :=
558 Make_Object_Declaration (Loc,
559 Defining_Identifier => Temp,
560 Object_Definition => New_Reference_To (PtrT, Loc),
561 Expression => Make_Allocator (Loc,
562 New_Reference_To (Etype (Exp), Loc)));
563
564 Set_Comes_From_Source
565 (Expression (Tmp_Node), Comes_From_Source (N));
566
567 Set_No_Initialization (Expression (Tmp_Node));
568 Insert_Action (N, Tmp_Node);
569 Convert_Aggr_In_Allocator (Tmp_Node, Exp);
570 Rewrite (N, New_Reference_To (Temp, Loc));
571 Analyze_And_Resolve (N, PtrT);
572
573 elsif Is_Access_Type (Designated_Type (PtrT))
574 and then Nkind (Exp) = N_Allocator
575 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
576 then
577 -- Apply constraint to designated subtype indication.
578
579 Apply_Constraint_Check (Expression (Exp),
580 Designated_Type (Designated_Type (PtrT)),
581 No_Sliding => True);
582
583 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
584
585 -- Propagate constraint_error to enclosing allocator
586
587 Rewrite (Exp, New_Copy (Expression (Exp)));
588 end if;
589 else
590 -- First check against the type of the qualified expression
591 --
592 -- NOTE: The commented call should be correct, but for
593 -- some reason causes the compiler to bomb (sigsegv) on
594 -- ACVC test c34007g, so for now we just perform the old
595 -- (incorrect) test against the designated subtype with
596 -- no sliding in the else part of the if statement below.
597 -- ???
598 --
599 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
600
601 -- A check is also needed in cases where the designated
602 -- subtype is constrained and differs from the subtype
603 -- given in the qualified expression. Note that the check
604 -- on the qualified expression does not allow sliding,
605 -- but this check does (a relaxation from Ada 83).
606
607 if Is_Constrained (Designated_Type (PtrT))
608 and then not Subtypes_Statically_Match
609 (T, Designated_Type (PtrT))
610 then
611 Apply_Constraint_Check
612 (Exp, Designated_Type (PtrT), No_Sliding => False);
613
614 -- The nonsliding check should really be performed
615 -- (unconditionally) against the subtype of the
616 -- qualified expression, but that causes a problem
617 -- with c34007g (see above), so for now we retain this.
618
619 else
620 Apply_Constraint_Check
621 (Exp, Designated_Type (PtrT), No_Sliding => True);
622 end if;
623 end if;
624
625 exception
626 when RE_Not_Available =>
627 return;
628 end Expand_Allocator_Expression;
629
ee6ba406 630 -----------------------------
631 -- Expand_Array_Comparison --
632 -----------------------------
633
9dfe12ae 634 -- Expansion is only required in the case of array types. For the
635 -- unpacked case, an appropriate runtime routine is called. For
636 -- packed cases, and also in some other cases where a runtime
637 -- routine cannot be called, the form of the expansion is:
ee6ba406 638
639 -- [body for greater_nn; boolean_expression]
640
641 -- The body is built by Make_Array_Comparison_Op, and the form of the
642 -- Boolean expression depends on the operator involved.
643
644 procedure Expand_Array_Comparison (N : Node_Id) is
645 Loc : constant Source_Ptr := Sloc (N);
646 Op1 : Node_Id := Left_Opnd (N);
647 Op2 : Node_Id := Right_Opnd (N);
648 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9dfe12ae 649 Ctyp : constant Entity_Id := Component_Type (Typ1);
ee6ba406 650
651 Expr : Node_Id;
652 Func_Body : Node_Id;
653 Func_Name : Entity_Id;
654
9dfe12ae 655 Comp : RE_Id;
656
657 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
658 -- Returns True if the length of the given operand is known to be
659 -- less than 4. Returns False if this length is known to be four
660 -- or greater or is not known at compile time.
661
662 ------------------------
663 -- Length_Less_Than_4 --
664 ------------------------
665
666 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
667 Otyp : constant Entity_Id := Etype (Opnd);
668
669 begin
670 if Ekind (Otyp) = E_String_Literal_Subtype then
671 return String_Literal_Length (Otyp) < 4;
672
673 else
674 declare
675 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
676 Lo : constant Node_Id := Type_Low_Bound (Ityp);
677 Hi : constant Node_Id := Type_High_Bound (Ityp);
678 Lov : Uint;
679 Hiv : Uint;
680
681 begin
682 if Compile_Time_Known_Value (Lo) then
683 Lov := Expr_Value (Lo);
684 else
685 return False;
686 end if;
687
688 if Compile_Time_Known_Value (Hi) then
689 Hiv := Expr_Value (Hi);
690 else
691 return False;
692 end if;
693
694 return Hiv < Lov + 3;
695 end;
696 end if;
697 end Length_Less_Than_4;
698
699 -- Start of processing for Expand_Array_Comparison
700
ee6ba406 701 begin
9dfe12ae 702 -- Deal first with unpacked case, where we can call a runtime routine
703 -- except that we avoid this for targets for which are not addressable
704 -- by bytes, and for the JVM, since the JVM does not support direct
705 -- addressing of array components.
706
707 if not Is_Bit_Packed_Array (Typ1)
708 and then System_Storage_Unit = Byte'Size
709 and then not Java_VM
710 then
711 -- The call we generate is:
712
713 -- Compare_Array_xn[_Unaligned]
714 -- (left'address, right'address, left'length, right'length) <op> 0
715
716 -- x = U for unsigned, S for signed
717 -- n = 8,16,32,64 for component size
718 -- Add _Unaligned if length < 4 and component size is 8.
719 -- <op> is the standard comparison operator
720
721 if Component_Size (Typ1) = 8 then
722 if Length_Less_Than_4 (Op1)
723 or else
724 Length_Less_Than_4 (Op2)
725 then
726 if Is_Unsigned_Type (Ctyp) then
727 Comp := RE_Compare_Array_U8_Unaligned;
728 else
729 Comp := RE_Compare_Array_S8_Unaligned;
730 end if;
731
732 else
733 if Is_Unsigned_Type (Ctyp) then
734 Comp := RE_Compare_Array_U8;
735 else
736 Comp := RE_Compare_Array_S8;
737 end if;
738 end if;
739
740 elsif Component_Size (Typ1) = 16 then
741 if Is_Unsigned_Type (Ctyp) then
742 Comp := RE_Compare_Array_U16;
743 else
744 Comp := RE_Compare_Array_S16;
745 end if;
746
747 elsif Component_Size (Typ1) = 32 then
748 if Is_Unsigned_Type (Ctyp) then
749 Comp := RE_Compare_Array_U32;
750 else
751 Comp := RE_Compare_Array_S32;
752 end if;
753
754 else pragma Assert (Component_Size (Typ1) = 64);
755 if Is_Unsigned_Type (Ctyp) then
756 Comp := RE_Compare_Array_U64;
757 else
758 Comp := RE_Compare_Array_S64;
759 end if;
760 end if;
761
762 Remove_Side_Effects (Op1, Name_Req => True);
763 Remove_Side_Effects (Op2, Name_Req => True);
764
765 Rewrite (Op1,
766 Make_Function_Call (Sloc (Op1),
767 Name => New_Occurrence_Of (RTE (Comp), Loc),
768
769 Parameter_Associations => New_List (
770 Make_Attribute_Reference (Loc,
771 Prefix => Relocate_Node (Op1),
772 Attribute_Name => Name_Address),
773
774 Make_Attribute_Reference (Loc,
775 Prefix => Relocate_Node (Op2),
776 Attribute_Name => Name_Address),
777
778 Make_Attribute_Reference (Loc,
779 Prefix => Relocate_Node (Op1),
780 Attribute_Name => Name_Length),
781
782 Make_Attribute_Reference (Loc,
783 Prefix => Relocate_Node (Op2),
784 Attribute_Name => Name_Length))));
785
786 Rewrite (Op2,
787 Make_Integer_Literal (Sloc (Op2),
788 Intval => Uint_0));
789
790 Analyze_And_Resolve (Op1, Standard_Integer);
791 Analyze_And_Resolve (Op2, Standard_Integer);
792 return;
793 end if;
794
795 -- Cases where we cannot make runtime call
796
ee6ba406 797 -- For (a <= b) we convert to not (a > b)
798
799 if Chars (N) = Name_Op_Le then
800 Rewrite (N,
801 Make_Op_Not (Loc,
802 Right_Opnd =>
803 Make_Op_Gt (Loc,
804 Left_Opnd => Op1,
805 Right_Opnd => Op2)));
806 Analyze_And_Resolve (N, Standard_Boolean);
807 return;
808
809 -- For < the Boolean expression is
810 -- greater__nn (op2, op1)
811
812 elsif Chars (N) = Name_Op_Lt then
813 Func_Body := Make_Array_Comparison_Op (Typ1, N);
814
815 -- Switch operands
816
817 Op1 := Right_Opnd (N);
818 Op2 := Left_Opnd (N);
819
820 -- For (a >= b) we convert to not (a < b)
821
822 elsif Chars (N) = Name_Op_Ge then
823 Rewrite (N,
824 Make_Op_Not (Loc,
825 Right_Opnd =>
826 Make_Op_Lt (Loc,
827 Left_Opnd => Op1,
828 Right_Opnd => Op2)));
829 Analyze_And_Resolve (N, Standard_Boolean);
830 return;
831
832 -- For > the Boolean expression is
833 -- greater__nn (op1, op2)
834
835 else
836 pragma Assert (Chars (N) = Name_Op_Gt);
837 Func_Body := Make_Array_Comparison_Op (Typ1, N);
838 end if;
839
840 Func_Name := Defining_Unit_Name (Specification (Func_Body));
841 Expr :=
842 Make_Function_Call (Loc,
843 Name => New_Reference_To (Func_Name, Loc),
844 Parameter_Associations => New_List (Op1, Op2));
845
846 Insert_Action (N, Func_Body);
847 Rewrite (N, Expr);
848 Analyze_And_Resolve (N, Standard_Boolean);
849
9dfe12ae 850 exception
851 when RE_Not_Available =>
852 return;
ee6ba406 853 end Expand_Array_Comparison;
854
855 ---------------------------
856 -- Expand_Array_Equality --
857 ---------------------------
858
859 -- Expand an equality function for multi-dimensional arrays. Here is
860 -- an example of such a function for Nb_Dimension = 2
861
862 -- function Enn (A : arr; B : arr) return boolean is
ee6ba406 863 -- begin
9dfe12ae 864 -- if (A'length (1) = 0 or else A'length (2) = 0)
865 -- and then
866 -- (B'length (1) = 0 or else B'length (2) = 0)
867 -- then
868 -- return True; -- RM 4.5.2(22)
869 -- end if;
870 --
871 -- if A'length (1) /= B'length (1)
872 -- or else
873 -- A'length (2) /= B'length (2)
874 -- then
875 -- return False; -- RM 4.5.2(23)
876 -- end if;
877 --
878 -- declare
879 -- A1 : Index_type_1 := A'first (1)
880 -- B1 : Index_Type_1 := B'first (1)
881 -- begin
882 -- loop
883 -- declare
884 -- A2 : Index_type_2 := A'first (2);
885 -- B2 : Index_type_2 := B'first (2)
886 -- begin
887 -- loop
888 -- if A (A1, A2) /= B (B1, B2) then
889 -- return False;
ee6ba406 890 -- end if;
9dfe12ae 891 --
892 -- exit when A2 = A'last (2);
893 -- A2 := Index_type2'succ (A2);
894 -- B2 := Index_type2'succ (B2);
ee6ba406 895 -- end loop;
9dfe12ae 896 -- end;
897 --
898 -- exit when A1 = A'last (1);
899 -- A1 := Index_type1'succ (A1);
900 -- B1 := Index_type1'succ (B1);
ee6ba406 901 -- end loop;
9dfe12ae 902 -- end;
903 --
ee6ba406 904 -- return true;
905 -- end Enn;
906
907 function Expand_Array_Equality
908 (Nod : Node_Id;
909 Typ : Entity_Id;
910 A_Typ : Entity_Id;
911 Lhs : Node_Id;
912 Rhs : Node_Id;
913 Bodies : List_Id)
914 return Node_Id
915 is
916 Loc : constant Source_Ptr := Sloc (Nod);
9dfe12ae 917 Decls : constant List_Id := New_List;
918 Index_List1 : constant List_Id := New_List;
919 Index_List2 : constant List_Id := New_List;
920
921 Actuals : List_Id;
922 Formals : List_Id;
923 Func_Name : Entity_Id;
924 Func_Body : Node_Id;
ee6ba406 925
926 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
927 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
928
9dfe12ae 929 function Arr_Attr
930 (Arr : Entity_Id;
931 Nam : Name_Id;
932 Num : Int)
933 return Node_Id;
934 -- This builds the attribute reference Arr'Nam (Expr).
935
ee6ba406 936 function Component_Equality (Typ : Entity_Id) return Node_Id;
9dfe12ae 937 -- Create one statement to compare corresponding components,
938 -- designated by a full set of indices.
ee6ba406 939
9dfe12ae 940 function Handle_One_Dimension
ee6ba406 941 (N : Int;
942 Index : Node_Id)
9dfe12ae 943 return Node_Id;
944 -- This procedure returns a declare block:
945 --
946 -- declare
947 -- An : Index_Type_n := A'First (n);
948 -- Bn : Index_Type_n := B'First (n);
949 -- begin
950 -- loop
951 -- xxx
952 -- exit when An = A'Last (n);
953 -- An := Index_Type_n'Succ (An)
954 -- Bn := Index_Type_n'Succ (Bn)
955 -- end loop;
956 -- end;
957 --
958 -- where N is the value of "n" in the above code. Index is the
959 -- N'th index node, whose Etype is Index_Type_n in the above code.
960 -- The xxx statement is either the declare block for the next
961 -- dimension or if this is the last dimension the comparison
962 -- of corresponding components of the arrays.
963 --
964 -- The actual way the code works is to return the comparison
965 -- of corresponding components for the N+1 call. That's neater!
966
967 function Test_Empty_Arrays return Node_Id;
968 -- This function constructs the test for both arrays being empty
969 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
970 -- and then
971 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
972
973 function Test_Lengths_Correspond return Node_Id;
974 -- This function constructs the test for arrays having different
975 -- lengths in at least one index position, in which case resull
976
977 -- A'length (1) /= B'length (1)
978 -- or else
979 -- A'length (2) /= B'length (2)
980 -- or else
981 -- ...
982
983 --------------
984 -- Arr_Attr --
985 --------------
986
987 function Arr_Attr
988 (Arr : Entity_Id;
989 Nam : Name_Id;
990 Num : Int)
991 return Node_Id
992 is
993 begin
994 return
995 Make_Attribute_Reference (Loc,
996 Attribute_Name => Nam,
997 Prefix => New_Reference_To (Arr, Loc),
998 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
999 end Arr_Attr;
ee6ba406 1000
1001 ------------------------
1002 -- Component_Equality --
1003 ------------------------
1004
1005 function Component_Equality (Typ : Entity_Id) return Node_Id is
1006 Test : Node_Id;
1007 L, R : Node_Id;
1008
1009 begin
1010 -- if a(i1...) /= b(j1...) then return false; end if;
1011
1012 L :=
1013 Make_Indexed_Component (Loc,
1014 Prefix => Make_Identifier (Loc, Chars (A)),
1015 Expressions => Index_List1);
1016
1017 R :=
1018 Make_Indexed_Component (Loc,
1019 Prefix => Make_Identifier (Loc, Chars (B)),
1020 Expressions => Index_List2);
1021
1022 Test := Expand_Composite_Equality
1023 (Nod, Component_Type (Typ), L, R, Decls);
1024
1025 return
1026 Make_Implicit_If_Statement (Nod,
1027 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1028 Then_Statements => New_List (
1029 Make_Return_Statement (Loc,
1030 Expression => New_Occurrence_Of (Standard_False, Loc))));
ee6ba406 1031 end Component_Equality;
1032
9dfe12ae 1033 --------------------------
1034 -- Handle_One_Dimension --
1035 ---------------------------
ee6ba406 1036
9dfe12ae 1037 function Handle_One_Dimension
ee6ba406 1038 (N : Int;
1039 Index : Node_Id)
9dfe12ae 1040 return Node_Id
ee6ba406 1041 is
9dfe12ae 1042 An : constant Entity_Id := Make_Defining_Identifier (Loc,
1043 Chars => New_Internal_Name ('A'));
1044 Bn : constant Entity_Id := Make_Defining_Identifier (Loc,
1045 Chars => New_Internal_Name ('B'));
1046 Index_Type_n : Entity_Id;
ee6ba406 1047
1048 begin
1049 if N > Number_Dimensions (Typ) then
1050 return Component_Equality (Typ);
9dfe12ae 1051 end if;
ee6ba406 1052
9dfe12ae 1053 -- Case where we generate a declare block
ee6ba406 1054
9dfe12ae 1055 Index_Type_n := Base_Type (Etype (Index));
1056 Append (New_Reference_To (An, Loc), Index_List1);
1057 Append (New_Reference_To (Bn, Loc), Index_List2);
ee6ba406 1058
9dfe12ae 1059 return
1060 Make_Block_Statement (Loc,
1061 Declarations => New_List (
1062 Make_Object_Declaration (Loc,
1063 Defining_Identifier => An,
1064 Object_Definition =>
1065 New_Reference_To (Index_Type_n, Loc),
1066 Expression => Arr_Attr (A, Name_First, N)),
ee6ba406 1067
9dfe12ae 1068 Make_Object_Declaration (Loc,
1069 Defining_Identifier => Bn,
1070 Object_Definition =>
1071 New_Reference_To (Index_Type_n, Loc),
1072 Expression => Arr_Attr (B, Name_First, N))),
1073
1074 Handled_Statement_Sequence =>
1075 Make_Handled_Sequence_Of_Statements (Loc,
1076 Statements => New_List (
1077 Make_Implicit_Loop_Statement (Nod,
1078 Statements => New_List (
1079 Handle_One_Dimension (N + 1, Next_Index (Index)),
1080
1081 Make_Exit_Statement (Loc,
1082 Condition =>
1083 Make_Op_Eq (Loc,
1084 Left_Opnd => New_Reference_To (An, Loc),
1085 Right_Opnd => Arr_Attr (A, Name_Last, N))),
1086
1087 Make_Assignment_Statement (Loc,
1088 Name => New_Reference_To (An, Loc),
1089 Expression =>
1090 Make_Attribute_Reference (Loc,
1091 Prefix =>
1092 New_Reference_To (Index_Type_n, Loc),
1093 Attribute_Name => Name_Succ,
1094 Expressions => New_List (
1095 New_Reference_To (An, Loc)))),
ee6ba406 1096
9dfe12ae 1097 Make_Assignment_Statement (Loc,
1098 Name => New_Reference_To (Bn, Loc),
1099 Expression =>
1100 Make_Attribute_Reference (Loc,
1101 Prefix =>
1102 New_Reference_To (Index_Type_n, Loc),
1103 Attribute_Name => Name_Succ,
1104 Expressions => New_List (
1105 New_Reference_To (Bn, Loc)))))))));
1106 end Handle_One_Dimension;
1107
1108 -----------------------
1109 -- Test_Empty_Arrays --
1110 -----------------------
1111
1112 function Test_Empty_Arrays return Node_Id is
1113 Alist : Node_Id;
1114 Blist : Node_Id;
1115
1116 Atest : Node_Id;
1117 Btest : Node_Id;
ee6ba406 1118
9dfe12ae 1119 begin
1120 Alist := Empty;
1121 Blist := Empty;
1122 for J in 1 .. Number_Dimensions (Typ) loop
1123 Atest :=
1124 Make_Op_Eq (Loc,
1125 Left_Opnd => Arr_Attr (A, Name_Length, J),
1126 Right_Opnd => Make_Integer_Literal (Loc, 0));
1127
1128 Btest :=
1129 Make_Op_Eq (Loc,
1130 Left_Opnd => Arr_Attr (B, Name_Length, J),
1131 Right_Opnd => Make_Integer_Literal (Loc, 0));
1132
1133 if No (Alist) then
1134 Alist := Atest;
1135 Blist := Btest;
ee6ba406 1136
9dfe12ae 1137 else
1138 Alist :=
1139 Make_Or_Else (Loc,
1140 Left_Opnd => Relocate_Node (Alist),
1141 Right_Opnd => Atest);
1142
1143 Blist :=
1144 Make_Or_Else (Loc,
1145 Left_Opnd => Relocate_Node (Blist),
1146 Right_Opnd => Btest);
1147 end if;
1148 end loop;
ee6ba406 1149
9dfe12ae 1150 return
1151 Make_And_Then (Loc,
1152 Left_Opnd => Alist,
1153 Right_Opnd => Blist);
1154 end Test_Empty_Arrays;
ee6ba406 1155
9dfe12ae 1156 -----------------------------
1157 -- Test_Lengths_Correspond --
1158 -----------------------------
ee6ba406 1159
9dfe12ae 1160 function Test_Lengths_Correspond return Node_Id is
1161 Result : Node_Id;
1162 Rtest : Node_Id;
1163
1164 begin
1165 Result := Empty;
1166 for J in 1 .. Number_Dimensions (Typ) loop
1167 Rtest :=
1168 Make_Op_Ne (Loc,
1169 Left_Opnd => Arr_Attr (A, Name_Length, J),
1170 Right_Opnd => Arr_Attr (B, Name_Length, J));
1171
1172 if No (Result) then
1173 Result := Rtest;
1174 else
1175 Result :=
1176 Make_Or_Else (Loc,
1177 Left_Opnd => Relocate_Node (Result),
1178 Right_Opnd => Rtest);
1179 end if;
1180 end loop;
1181
1182 return Result;
1183 end Test_Lengths_Correspond;
ee6ba406 1184
1185 -- Start of processing for Expand_Array_Equality
1186
1187 begin
1188 Formals := New_List (
1189 Make_Parameter_Specification (Loc,
1190 Defining_Identifier => A,
1191 Parameter_Type => New_Reference_To (Typ, Loc)),
1192
1193 Make_Parameter_Specification (Loc,
1194 Defining_Identifier => B,
1195 Parameter_Type => New_Reference_To (Typ, Loc)));
1196
1197 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1198
9dfe12ae 1199 -- Build statement sequence for function
ee6ba406 1200
1201 Func_Body :=
1202 Make_Subprogram_Body (Loc,
1203 Specification =>
1204 Make_Function_Specification (Loc,
1205 Defining_Unit_Name => Func_Name,
1206 Parameter_Specifications => Formals,
1207 Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
9dfe12ae 1208
1209 Declarations => Decls,
1210
ee6ba406 1211 Handled_Statement_Sequence =>
1212 Make_Handled_Sequence_Of_Statements (Loc,
1213 Statements => New_List (
9dfe12ae 1214
1215 Make_Implicit_If_Statement (Nod,
1216 Condition => Test_Empty_Arrays,
1217 Then_Statements => New_List (
1218 Make_Return_Statement (Loc,
1219 Expression =>
1220 New_Occurrence_Of (Standard_True, Loc)))),
1221
1222 Make_Implicit_If_Statement (Nod,
1223 Condition => Test_Lengths_Correspond,
1224 Then_Statements => New_List (
1225 Make_Return_Statement (Loc,
1226 Expression =>
1227 New_Occurrence_Of (Standard_False, Loc)))),
1228
1229 Handle_One_Dimension (1, First_Index (Typ)),
1230
ee6ba406 1231 Make_Return_Statement (Loc,
1232 Expression => New_Occurrence_Of (Standard_True, Loc)))));
1233
1234 Set_Has_Completion (Func_Name, True);
1235
1236 -- If the array type is distinct from the type of the arguments,
1237 -- it is the full view of a private type. Apply an unchecked
1238 -- conversion to insure that analysis of the call succeeds.
1239
1240 if Base_Type (A_Typ) /= Base_Type (Typ) then
1241 Actuals := New_List (
1242 OK_Convert_To (Typ, Lhs),
1243 OK_Convert_To (Typ, Rhs));
1244 else
1245 Actuals := New_List (Lhs, Rhs);
1246 end if;
1247
1248 Append_To (Bodies, Func_Body);
1249
1250 return
1251 Make_Function_Call (Loc,
1252 Name => New_Reference_To (Func_Name, Loc),
1253 Parameter_Associations => Actuals);
1254 end Expand_Array_Equality;
1255
1256 -----------------------------
1257 -- Expand_Boolean_Operator --
1258 -----------------------------
1259
1260 -- Note that we first get the actual subtypes of the operands,
1261 -- since we always want to deal with types that have bounds.
1262
1263 procedure Expand_Boolean_Operator (N : Node_Id) is
9dfe12ae 1264 Typ : constant Entity_Id := Etype (N);
ee6ba406 1265
1266 begin
1267 if Is_Bit_Packed_Array (Typ) then
1268 Expand_Packed_Boolean_Operator (N);
1269
1270 else
9dfe12ae 1271 -- For the normal non-packed case, the general expansion is
1272 -- to build a function for carrying out the comparison (using
1273 -- Make_Boolean_Array_Op) and then inserting it into the tree.
1274 -- The original operator node is then rewritten as a call to
1275 -- this function.
ee6ba406 1276
1277 declare
1278 Loc : constant Source_Ptr := Sloc (N);
1279 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
1280 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
1281 Func_Body : Node_Id;
1282 Func_Name : Entity_Id;
9dfe12ae 1283
ee6ba406 1284 begin
1285 Convert_To_Actual_Subtype (L);
1286 Convert_To_Actual_Subtype (R);
1287 Ensure_Defined (Etype (L), N);
1288 Ensure_Defined (Etype (R), N);
1289 Apply_Length_Check (R, Etype (L));
1290
9dfe12ae 1291 if Nkind (Parent (N)) = N_Assignment_Statement
1292 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
1293 then
1294 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
1295
1296 elsif Nkind (Parent (N)) = N_Op_Not
1297 and then Nkind (N) = N_Op_And
1298 and then
1299 Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
1300 then
1301 return;
1302 else
1303
1304 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
1305 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1306 Insert_Action (N, Func_Body);
ee6ba406 1307
9dfe12ae 1308 -- Now rewrite the expression with a call
ee6ba406 1309
9dfe12ae 1310 Rewrite (N,
1311 Make_Function_Call (Loc,
1312 Name => New_Reference_To (Func_Name, Loc),
1313 Parameter_Associations =>
1314 New_List
1315 (L, Make_Type_Conversion
ee6ba406 1316 (Loc, New_Reference_To (Etype (L), Loc), R))));
1317
9dfe12ae 1318 Analyze_And_Resolve (N, Typ);
1319 end if;
ee6ba406 1320 end;
1321 end if;
1322 end Expand_Boolean_Operator;
1323
1324 -------------------------------
1325 -- Expand_Composite_Equality --
1326 -------------------------------
1327
1328 -- This function is only called for comparing internal fields of composite
1329 -- types when these fields are themselves composites. This is a special
1330 -- case because it is not possible to respect normal Ada visibility rules.
1331
1332 function Expand_Composite_Equality
1333 (Nod : Node_Id;
1334 Typ : Entity_Id;
1335 Lhs : Node_Id;
1336 Rhs : Node_Id;
1337 Bodies : List_Id)
1338 return Node_Id
1339 is
1340 Loc : constant Source_Ptr := Sloc (Nod);
1341 Full_Type : Entity_Id;
1342 Prim : Elmt_Id;
1343 Eq_Op : Entity_Id;
1344
1345 begin
1346 if Is_Private_Type (Typ) then
1347 Full_Type := Underlying_Type (Typ);
1348 else
1349 Full_Type := Typ;
1350 end if;
1351
1352 -- Defense against malformed private types with no completion
1353 -- the error will be diagnosed later by check_completion
1354
1355 if No (Full_Type) then
1356 return New_Reference_To (Standard_False, Loc);
1357 end if;
1358
1359 Full_Type := Base_Type (Full_Type);
1360
1361 if Is_Array_Type (Full_Type) then
1362
1363 -- If the operand is an elementary type other than a floating-point
1364 -- type, then we can simply use the built-in block bitwise equality,
1365 -- since the predefined equality operators always apply and bitwise
1366 -- equality is fine for all these cases.
1367
1368 if Is_Elementary_Type (Component_Type (Full_Type))
1369 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
1370 then
1371 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
1372
1373 -- For composite component types, and floating-point types, use
1374 -- the expansion. This deals with tagged component types (where
1375 -- we use the applicable equality routine) and floating-point,
1376 -- (where we need to worry about negative zeroes), and also the
1377 -- case of any composite type recursively containing such fields.
1378
1379 else
1380 return Expand_Array_Equality
1381 (Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
1382 end if;
1383
1384 elsif Is_Tagged_Type (Full_Type) then
1385
1386 -- Call the primitive operation "=" of this type
1387
1388 if Is_Class_Wide_Type (Full_Type) then
1389 Full_Type := Root_Type (Full_Type);
1390 end if;
1391
1392 -- If this is derived from an untagged private type completed
1393 -- with a tagged type, it does not have a full view, so we
1394 -- use the primitive operations of the private type.
1395 -- This check should no longer be necessary when these
1396 -- types receive their full views ???
1397
1398 if Is_Private_Type (Typ)
1399 and then not Is_Tagged_Type (Typ)
1400 and then not Is_Controlled (Typ)
1401 and then Is_Derived_Type (Typ)
1402 and then No (Full_View (Typ))
1403 then
1404 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
1405 else
1406 Prim := First_Elmt (Primitive_Operations (Full_Type));
1407 end if;
1408
1409 loop
1410 Eq_Op := Node (Prim);
1411 exit when Chars (Eq_Op) = Name_Op_Eq
1412 and then Etype (First_Formal (Eq_Op)) =
1413 Etype (Next_Formal (First_Formal (Eq_Op)));
1414 Next_Elmt (Prim);
1415 pragma Assert (Present (Prim));
1416 end loop;
1417
1418 Eq_Op := Node (Prim);
1419
1420 return
1421 Make_Function_Call (Loc,
1422 Name => New_Reference_To (Eq_Op, Loc),
1423 Parameter_Associations =>
1424 New_List
1425 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
1426 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
1427
1428 elsif Is_Record_Type (Full_Type) then
9dfe12ae 1429 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
ee6ba406 1430
1431 if Present (Eq_Op) then
1432 if Etype (First_Formal (Eq_Op)) /= Full_Type then
1433
1434 -- Inherited equality from parent type. Convert the actuals
1435 -- to match signature of operation.
1436
1437 declare
9dfe12ae 1438 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
ee6ba406 1439
1440 begin
1441 return
1442 Make_Function_Call (Loc,
1443 Name => New_Reference_To (Eq_Op, Loc),
1444 Parameter_Associations =>
1445 New_List (OK_Convert_To (T, Lhs),
1446 OK_Convert_To (T, Rhs)));
1447 end;
1448
1449 else
1450 return
1451 Make_Function_Call (Loc,
1452 Name => New_Reference_To (Eq_Op, Loc),
1453 Parameter_Associations => New_List (Lhs, Rhs));
1454 end if;
1455
1456 else
1457 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
1458 end if;
1459
1460 else
1461 -- It can be a simple record or the full view of a scalar private
1462
1463 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
1464 end if;
1465 end Expand_Composite_Equality;
1466
1467 ------------------------------
1468 -- Expand_Concatenate_Other --
1469 ------------------------------
1470
1471 -- Let n be the number of array operands to be concatenated, Base_Typ
1472 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1473 -- array type to which the concatenantion operator applies, then the
1474 -- following subprogram is constructed:
1475 --
1476 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1477 -- L : Ind_Typ;
1478 -- begin
1479 -- if S1'Length /= 0 then
1480 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1481 -- XXX = Arr_Typ'First otherwise
1482 -- elsif S2'Length /= 0 then
1483 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1484 -- YYY = Arr_Typ'First otherwise
1485 -- ...
1486 -- elsif Sn-1'Length /= 0 then
1487 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1488 -- ZZZ = Arr_Typ'First otherwise
1489 -- else
1490 -- return Sn;
1491 -- end if;
1492 --
1493 -- declare
1494 -- P : Ind_Typ;
1495 -- H : Ind_Typ :=
1496 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1497 -- + Ind_Typ'Pos (L));
1498 -- R : Base_Typ (L .. H);
1499 -- begin
1500 -- if S1'Length /= 0 then
1501 -- P := S1'First;
1502 -- loop
1503 -- R (L) := S1 (P);
1504 -- L := Ind_Typ'Succ (L);
1505 -- exit when P = S1'Last;
1506 -- P := Ind_Typ'Succ (P);
1507 -- end loop;
1508 -- end if;
1509 --
1510 -- if S2'Length /= 0 then
1511 -- L := Ind_Typ'Succ (L);
1512 -- loop
1513 -- R (L) := S2 (P);
1514 -- L := Ind_Typ'Succ (L);
1515 -- exit when P = S2'Last;
1516 -- P := Ind_Typ'Succ (P);
1517 -- end loop;
1518 -- end if;
1519 --
1520 -- ...
1521 --
1522 -- if Sn'Length /= 0 then
1523 -- P := Sn'First;
1524 -- loop
1525 -- R (L) := Sn (P);
1526 -- L := Ind_Typ'Succ (L);
1527 -- exit when P = Sn'Last;
1528 -- P := Ind_Typ'Succ (P);
1529 -- end loop;
1530 -- end if;
1531 --
1532 -- return R;
1533 -- end;
1534 -- end Cnn;]
1535
1536 procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
1537 Loc : constant Source_Ptr := Sloc (Cnode);
1538 Nb_Opnds : constant Nat := List_Length (Opnds);
1539
1540 Arr_Typ : constant Entity_Id := Etype (Entity (Cnode));
1541 Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
1542 Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ));
1543
1544 Func_Id : Node_Id;
1545 Func_Spec : Node_Id;
1546 Param_Specs : List_Id;
1547
1548 Func_Body : Node_Id;
1549 Func_Decls : List_Id;
1550 Func_Stmts : List_Id;
1551
1552 L_Decl : Node_Id;
1553
1554 If_Stmt : Node_Id;
1555 Elsif_List : List_Id;
1556
1557 Declare_Block : Node_Id;
1558 Declare_Decls : List_Id;
1559 Declare_Stmts : List_Id;
1560
1561 H_Decl : Node_Id;
1562 H_Init : Node_Id;
1563 P_Decl : Node_Id;
1564 R_Decl : Node_Id;
1565 R_Constr : Node_Id;
1566 R_Range : Node_Id;
1567
1568 Params : List_Id;
1569 Operand : Node_Id;
1570
9dfe12ae 1571 function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
ee6ba406 1572 -- Builds the sequence of statement:
1573 -- P := Si'First;
1574 -- loop
1575 -- R (L) := Si (P);
1576 -- L := Ind_Typ'Succ (L);
1577 -- exit when P = Si'Last;
1578 -- P := Ind_Typ'Succ (P);
1579 -- end loop;
1580 --
1581 -- where i is the input parameter I given.
9dfe12ae 1582 -- If the flag Last is true, the exit statement is emitted before
1583 -- incrementing the lower bound, to prevent the creation out of
1584 -- bound values.
ee6ba406 1585
1586 function Init_L (I : Nat) return Node_Id;
1587 -- Builds the statement:
1588 -- L := Arr_Typ'First; If Arr_Typ is constrained
1589 -- L := Si'First; otherwise (where I is the input param given)
1590
1591 function H return Node_Id;
1592 -- Builds reference to identifier H.
1593
1594 function Ind_Val (E : Node_Id) return Node_Id;
1595 -- Builds expression Ind_Typ'Val (E);
1596
1597 function L return Node_Id;
1598 -- Builds reference to identifier L.
1599
1600 function L_Pos return Node_Id;
1601 -- Builds expression Ind_Typ'Pos (L).
1602
1603 function L_Succ return Node_Id;
1604 -- Builds expression Ind_Typ'Succ (L).
1605
1606 function One return Node_Id;
1607 -- Builds integer literal one.
1608
1609 function P return Node_Id;
1610 -- Builds reference to identifier P.
1611
1612 function P_Succ return Node_Id;
1613 -- Builds expression Ind_Typ'Succ (P).
1614
1615 function R return Node_Id;
1616 -- Builds reference to identifier R.
1617
1618 function S (I : Nat) return Node_Id;
1619 -- Builds reference to identifier Si, where I is the value given.
1620
1621 function S_First (I : Nat) return Node_Id;
1622 -- Builds expression Si'First, where I is the value given.
1623
1624 function S_Last (I : Nat) return Node_Id;
1625 -- Builds expression Si'Last, where I is the value given.
1626
1627 function S_Length (I : Nat) return Node_Id;
1628 -- Builds expression Si'Length, where I is the value given.
1629
1630 function S_Length_Test (I : Nat) return Node_Id;
1631 -- Builds expression Si'Length /= 0, where I is the value given.
1632
1633 -------------------
1634 -- Copy_Into_R_S --
1635 -------------------
1636
9dfe12ae 1637 function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
1638 Stmts : constant List_Id := New_List;
ee6ba406 1639 P_Start : Node_Id;
1640 Loop_Stmt : Node_Id;
1641 R_Copy : Node_Id;
1642 Exit_Stmt : Node_Id;
1643 L_Inc : Node_Id;
1644 P_Inc : Node_Id;
1645
1646 begin
1647 -- First construct the initializations
1648
1649 P_Start := Make_Assignment_Statement (Loc,
1650 Name => P,
1651 Expression => S_First (I));
1652 Append_To (Stmts, P_Start);
1653
1654 -- Then build the loop
1655
1656 R_Copy := Make_Assignment_Statement (Loc,
1657 Name => Make_Indexed_Component (Loc,
1658 Prefix => R,
1659 Expressions => New_List (L)),
1660 Expression => Make_Indexed_Component (Loc,
1661 Prefix => S (I),
1662 Expressions => New_List (P)));
1663
1664 L_Inc := Make_Assignment_Statement (Loc,
1665 Name => L,
1666 Expression => L_Succ);
1667
1668 Exit_Stmt := Make_Exit_Statement (Loc,
1669 Condition => Make_Op_Eq (Loc, P, S_Last (I)));
1670
1671 P_Inc := Make_Assignment_Statement (Loc,
1672 Name => P,
1673 Expression => P_Succ);
1674
9dfe12ae 1675 if Last then
1676 Loop_Stmt :=
1677 Make_Implicit_Loop_Statement (Cnode,
1678 Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
1679 else
1680 Loop_Stmt :=
1681 Make_Implicit_Loop_Statement (Cnode,
1682 Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
1683 end if;
ee6ba406 1684
1685 Append_To (Stmts, Loop_Stmt);
1686
1687 return Stmts;
1688 end Copy_Into_R_S;
1689
1690 -------
1691 -- H --
1692 -------
1693
1694 function H return Node_Id is
1695 begin
1696 return Make_Identifier (Loc, Name_uH);
1697 end H;
1698
1699 -------------
1700 -- Ind_Val --
1701 -------------
1702
1703 function Ind_Val (E : Node_Id) return Node_Id is
1704 begin
1705 return
1706 Make_Attribute_Reference (Loc,
1707 Prefix => New_Reference_To (Ind_Typ, Loc),
1708 Attribute_Name => Name_Val,
1709 Expressions => New_List (E));
1710 end Ind_Val;
1711
1712 ------------
1713 -- Init_L --
1714 ------------
1715
1716 function Init_L (I : Nat) return Node_Id is
1717 E : Node_Id;
1718
1719 begin
1720 if Is_Constrained (Arr_Typ) then
1721 E := Make_Attribute_Reference (Loc,
1722 Prefix => New_Reference_To (Arr_Typ, Loc),
1723 Attribute_Name => Name_First);
1724
1725 else
1726 E := S_First (I);
1727 end if;
1728
1729 return Make_Assignment_Statement (Loc, Name => L, Expression => E);
1730 end Init_L;
1731
1732 -------
1733 -- L --
1734 -------
1735
1736 function L return Node_Id is
1737 begin
1738 return Make_Identifier (Loc, Name_uL);
1739 end L;
1740
1741 -----------
1742 -- L_Pos --
1743 -----------
1744
1745 function L_Pos return Node_Id is
1746 begin
1747 return
1748 Make_Attribute_Reference (Loc,
1749 Prefix => New_Reference_To (Ind_Typ, Loc),
1750 Attribute_Name => Name_Pos,
1751 Expressions => New_List (L));
1752 end L_Pos;
1753
1754 ------------
1755 -- L_Succ --
1756 ------------
1757
1758 function L_Succ return Node_Id is
1759 begin
1760 return
1761 Make_Attribute_Reference (Loc,
1762 Prefix => New_Reference_To (Ind_Typ, Loc),
1763 Attribute_Name => Name_Succ,
1764 Expressions => New_List (L));
1765 end L_Succ;
1766
1767 ---------
1768 -- One --
1769 ---------
1770
1771 function One return Node_Id is
1772 begin
1773 return Make_Integer_Literal (Loc, 1);
1774 end One;
1775
1776 -------
1777 -- P --
1778 -------
1779
1780 function P return Node_Id is
1781 begin
1782 return Make_Identifier (Loc, Name_uP);
1783 end P;
1784
1785 ------------
1786 -- P_Succ --
1787 ------------
1788
1789 function P_Succ return Node_Id is
1790 begin
1791 return
1792 Make_Attribute_Reference (Loc,
1793 Prefix => New_Reference_To (Ind_Typ, Loc),
1794 Attribute_Name => Name_Succ,
1795 Expressions => New_List (P));
1796 end P_Succ;
1797
1798 -------
1799 -- R --
1800 -------
1801
1802 function R return Node_Id is
1803 begin
1804 return Make_Identifier (Loc, Name_uR);
1805 end R;
1806
1807 -------
1808 -- S --
1809 -------
1810
1811 function S (I : Nat) return Node_Id is
1812 begin
1813 return Make_Identifier (Loc, New_External_Name ('S', I));
1814 end S;
1815
1816 -------------
1817 -- S_First --
1818 -------------
1819
1820 function S_First (I : Nat) return Node_Id is
1821 begin
1822 return Make_Attribute_Reference (Loc,
1823 Prefix => S (I),
1824 Attribute_Name => Name_First);
1825 end S_First;
1826
1827 ------------
1828 -- S_Last --
1829 ------------
1830
1831 function S_Last (I : Nat) return Node_Id is
1832 begin
1833 return Make_Attribute_Reference (Loc,
1834 Prefix => S (I),
1835 Attribute_Name => Name_Last);
1836 end S_Last;
1837
1838 --------------
1839 -- S_Length --
1840 --------------
1841
1842 function S_Length (I : Nat) return Node_Id is
1843 begin
1844 return Make_Attribute_Reference (Loc,
1845 Prefix => S (I),
1846 Attribute_Name => Name_Length);
1847 end S_Length;
1848
1849 -------------------
1850 -- S_Length_Test --
1851 -------------------
1852
1853 function S_Length_Test (I : Nat) return Node_Id is
1854 begin
1855 return
1856 Make_Op_Ne (Loc,
1857 Left_Opnd => S_Length (I),
1858 Right_Opnd => Make_Integer_Literal (Loc, 0));
1859 end S_Length_Test;
1860
1861 -- Start of processing for Expand_Concatenate_Other
1862
1863 begin
1864 -- Construct the parameter specs and the overall function spec
1865
1866 Param_Specs := New_List;
1867 for I in 1 .. Nb_Opnds loop
1868 Append_To
1869 (Param_Specs,
1870 Make_Parameter_Specification (Loc,
1871 Defining_Identifier =>
1872 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
1873 Parameter_Type => New_Reference_To (Base_Typ, Loc)));
1874 end loop;
1875
1876 Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
1877 Func_Spec :=
1878 Make_Function_Specification (Loc,
1879 Defining_Unit_Name => Func_Id,
1880 Parameter_Specifications => Param_Specs,
1881 Subtype_Mark => New_Reference_To (Base_Typ, Loc));
1882
1883 -- Construct L's object declaration
1884
1885 L_Decl :=
1886 Make_Object_Declaration (Loc,
1887 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
1888 Object_Definition => New_Reference_To (Ind_Typ, Loc));
1889
1890 Func_Decls := New_List (L_Decl);
1891
1892 -- Construct the if-then-elsif statements
1893
1894 Elsif_List := New_List;
1895 for I in 2 .. Nb_Opnds - 1 loop
1896 Append_To (Elsif_List, Make_Elsif_Part (Loc,
1897 Condition => S_Length_Test (I),
1898 Then_Statements => New_List (Init_L (I))));
1899 end loop;
1900
1901 If_Stmt :=
1902 Make_Implicit_If_Statement (Cnode,
1903 Condition => S_Length_Test (1),
1904 Then_Statements => New_List (Init_L (1)),
1905 Elsif_Parts => Elsif_List,
1906 Else_Statements => New_List (Make_Return_Statement (Loc,
1907 Expression => S (Nb_Opnds))));
1908
1909 -- Construct the declaration for H
1910
1911 P_Decl :=
1912 Make_Object_Declaration (Loc,
1913 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
1914 Object_Definition => New_Reference_To (Ind_Typ, Loc));
1915
1916 H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
1917 for I in 2 .. Nb_Opnds loop
1918 H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
1919 end loop;
1920 H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
1921
1922 H_Decl :=
1923 Make_Object_Declaration (Loc,
1924 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
1925 Object_Definition => New_Reference_To (Ind_Typ, Loc),
1926 Expression => H_Init);
1927
1928 -- Construct the declaration for R
1929
1930 R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
1931 R_Constr :=
1932 Make_Index_Or_Discriminant_Constraint (Loc,
1933 Constraints => New_List (R_Range));
1934
1935 R_Decl :=
1936 Make_Object_Declaration (Loc,
1937 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
1938 Object_Definition =>
1939 Make_Subtype_Indication (Loc,
1940 Subtype_Mark => New_Reference_To (Base_Typ, Loc),
1941 Constraint => R_Constr));
1942
1943 -- Construct the declarations for the declare block
1944
1945 Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
1946
1947 -- Construct list of statements for the declare block
1948
1949 Declare_Stmts := New_List;
1950 for I in 1 .. Nb_Opnds loop
1951 Append_To (Declare_Stmts,
1952 Make_Implicit_If_Statement (Cnode,
1953 Condition => S_Length_Test (I),
9dfe12ae 1954 Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
ee6ba406 1955 end loop;
1956
1957 Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
1958
1959 -- Construct the declare block
1960
1961 Declare_Block := Make_Block_Statement (Loc,
1962 Declarations => Declare_Decls,
1963 Handled_Statement_Sequence =>
1964 Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
1965
1966 -- Construct the list of function statements
1967
1968 Func_Stmts := New_List (If_Stmt, Declare_Block);
1969
1970 -- Construct the function body
1971
1972 Func_Body :=
1973 Make_Subprogram_Body (Loc,
1974 Specification => Func_Spec,
1975 Declarations => Func_Decls,
1976 Handled_Statement_Sequence =>
1977 Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
1978
1979 -- Insert the newly generated function in the code. This is analyzed
1980 -- with all checks off, since we have completed all the checks.
1981
1982 -- Note that this does *not* fix the array concatenation bug when the
1983 -- low bound is Integer'first sibce that bug comes from the pointer
3d069ad4 1984 -- dereferencing an unconstrained array. An there we need a constraint
ee6ba406 1985 -- check to make sure the length of the concatenated array is ok. ???
1986
1987 Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
1988
1989 -- Construct list of arguments for the function call
1990
1991 Params := New_List;
1992 Operand := First (Opnds);
1993 for I in 1 .. Nb_Opnds loop
1994 Append_To (Params, Relocate_Node (Operand));
1995 Next (Operand);
1996 end loop;
1997
1998 -- Insert the function call
1999
2000 Rewrite
2001 (Cnode,
2002 Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
2003
2004 Analyze_And_Resolve (Cnode, Base_Typ);
2005 Set_Is_Inlined (Func_Id);
2006 end Expand_Concatenate_Other;
2007
2008 -------------------------------
2009 -- Expand_Concatenate_String --
2010 -------------------------------
2011
2012 procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
2013 Loc : constant Source_Ptr := Sloc (Cnode);
2014 Opnd1 : constant Node_Id := First (Opnds);
2015 Opnd2 : constant Node_Id := Next (Opnd1);
2016 Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1));
2017 Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2));
2018
2019 R : RE_Id;
2020 -- RE_Id value for function to be called
2021
2022 begin
2023 -- In all cases, we build a call to a routine giving the list of
2024 -- arguments as the parameter list to the routine.
2025
2026 case List_Length (Opnds) is
2027 when 2 =>
2028 if Typ1 = Standard_Character then
2029 if Typ2 = Standard_Character then
2030 R := RE_Str_Concat_CC;
2031
2032 else
2033 pragma Assert (Typ2 = Standard_String);
2034 R := RE_Str_Concat_CS;
2035 end if;
2036
2037 elsif Typ1 = Standard_String then
2038 if Typ2 = Standard_Character then
2039 R := RE_Str_Concat_SC;
2040
2041 else
2042 pragma Assert (Typ2 = Standard_String);
2043 R := RE_Str_Concat;
2044 end if;
2045
2046 -- If we have anything other than Standard_Character or
f15731c4 2047 -- Standard_String, then we must have had a serious error
2048 -- earlier, so we just abandon the attempt at expansion.
ee6ba406 2049
2050 else
f15731c4 2051 pragma Assert (Serious_Errors_Detected > 0);
ee6ba406 2052 return;
2053 end if;
2054
2055 when 3 =>
2056 R := RE_Str_Concat_3;
2057
2058 when 4 =>
2059 R := RE_Str_Concat_4;
2060
2061 when 5 =>
2062 R := RE_Str_Concat_5;
2063
2064 when others =>
2065 R := RE_Null;
2066 raise Program_Error;
2067 end case;
2068
2069 -- Now generate the appropriate call
2070
2071 Rewrite (Cnode,
2072 Make_Function_Call (Sloc (Cnode),
2073 Name => New_Occurrence_Of (RTE (R), Loc),
2074 Parameter_Associations => Opnds));
2075
2076 Analyze_And_Resolve (Cnode, Standard_String);
9dfe12ae 2077
2078 exception
2079 when RE_Not_Available =>
2080 return;
ee6ba406 2081 end Expand_Concatenate_String;
2082
2083 ------------------------
2084 -- Expand_N_Allocator --
2085 ------------------------
2086
2087 procedure Expand_N_Allocator (N : Node_Id) is
2088 PtrT : constant Entity_Id := Etype (N);
2089 Desig : Entity_Id;
2090 Loc : constant Source_Ptr := Sloc (N);
2091 Temp : Entity_Id;
2092 Node : Node_Id;
2093
2094 begin
2095 -- RM E.2.3(22). We enforce that the expected type of an allocator
2096 -- shall not be a remote access-to-class-wide-limited-private type
2097
2098 -- Why is this being done at expansion time, seems clearly wrong ???
2099
2100 Validate_Remote_Access_To_Class_Wide_Type (N);
2101
2102 -- Set the Storage Pool
2103
2104 Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
2105
2106 if Present (Storage_Pool (N)) then
2107 if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
2108 if not Java_VM then
2109 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
2110 end if;
9dfe12ae 2111
2112 elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
2113 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
2114
ee6ba406 2115 else
2116 Set_Procedure_To_Call (N,
2117 Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
2118 end if;
2119 end if;
2120
2121 -- Under certain circumstances we can replace an allocator by an
2122 -- access to statically allocated storage. The conditions, as noted
2123 -- in AARM 3.10 (10c) are as follows:
2124
2125 -- Size and initial value is known at compile time
2126 -- Access type is access-to-constant
2127
9dfe12ae 2128 -- The allocator is not part of a constraint on a record component,
2129 -- because in that case the inserted actions are delayed until the
2130 -- record declaration is fully analyzed, which is too late for the
2131 -- analysis of the rewritten allocator.
2132
ee6ba406 2133 if Is_Access_Constant (PtrT)
2134 and then Nkind (Expression (N)) = N_Qualified_Expression
2135 and then Compile_Time_Known_Value (Expression (Expression (N)))
2136 and then Size_Known_At_Compile_Time (Etype (Expression
2137 (Expression (N))))
9dfe12ae 2138 and then not Is_Record_Type (Current_Scope)
ee6ba406 2139 then
2140 -- Here we can do the optimization. For the allocator
2141
2142 -- new x'(y)
2143
2144 -- We insert an object declaration
2145
2146 -- Tnn : aliased x := y;
2147
2148 -- and replace the allocator by Tnn'Unrestricted_Access.
2149 -- Tnn is marked as requiring static allocation.
2150
2151 Temp :=
2152 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2153
2154 Desig := Subtype_Mark (Expression (N));
2155
2156 -- If context is constrained, use constrained subtype directly,
2157 -- so that the constant is not labelled as having a nomimally
2158 -- unconstrained subtype.
2159
2160 if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
2161 Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
2162 end if;
2163
2164 Insert_Action (N,
2165 Make_Object_Declaration (Loc,
2166 Defining_Identifier => Temp,
2167 Aliased_Present => True,
2168 Constant_Present => Is_Access_Constant (PtrT),
2169 Object_Definition => Desig,
2170 Expression => Expression (Expression (N))));
2171
2172 Rewrite (N,
2173 Make_Attribute_Reference (Loc,
2174 Prefix => New_Occurrence_Of (Temp, Loc),
2175 Attribute_Name => Name_Unrestricted_Access));
2176
2177 Analyze_And_Resolve (N, PtrT);
2178
2179 -- We set the variable as statically allocated, since we don't
2180 -- want it going on the stack of the current procedure!
2181
2182 Set_Is_Statically_Allocated (Temp);
2183 return;
2184 end if;
2185
ee6ba406 2186 if Nkind (Expression (N)) = N_Qualified_Expression then
9dfe12ae 2187 Expand_Allocator_Expression (N);
2188
2189 -- If the allocator is for a type which requires initialization, and
2190 -- there is no initial value (i.e. operand is a subtype indication
2191 -- rather than a qualifed expression), then we must generate a call
2192 -- to the initialization routine. This is done using an expression
2193 -- actions node:
2194 --
2195 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2196 --
2197 -- Here ptr_T is the pointer type for the allocator, and T is the
2198 -- subtype of the allocator. A special case arises if the designated
2199 -- type of the access type is a task or contains tasks. In this case
2200 -- the call to Init (Temp.all ...) is replaced by code that ensures
2201 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2202 -- for details). In addition, if the type T is a task T, then the
2203 -- first argument to Init must be converted to the task record type.
ee6ba406 2204
2205 else
2206 declare
2207 T : constant Entity_Id := Entity (Expression (N));
2208 Init : Entity_Id;
2209 Arg1 : Node_Id;
2210 Args : List_Id;
2211 Decls : List_Id;
2212 Decl : Node_Id;
2213 Discr : Elmt_Id;
2214 Flist : Node_Id;
2215 Temp_Decl : Node_Id;
2216 Temp_Type : Entity_Id;
2217
2218 begin
2219
2220 if No_Initialization (N) then
2221 null;
2222
2223 -- Case of no initialization procedure present
2224
2225 elsif not Has_Non_Null_Base_Init_Proc (T) then
2226
2227 -- Case of simple initialization required
2228
2229 if Needs_Simple_Initialization (T) then
2230 Rewrite (Expression (N),
2231 Make_Qualified_Expression (Loc,
2232 Subtype_Mark => New_Occurrence_Of (T, Loc),
2233 Expression => Get_Simple_Init_Val (T, Loc)));
2234
2235 Analyze_And_Resolve (Expression (Expression (N)), T);
2236 Analyze_And_Resolve (Expression (N), T);
2237 Set_Paren_Count (Expression (Expression (N)), 1);
2238 Expand_N_Allocator (N);
2239
2240 -- No initialization required
2241
2242 else
2243 null;
2244 end if;
2245
2246 -- Case of initialization procedure present, must be called
2247
2248 else
2249 Init := Base_Init_Proc (T);
2250 Node := N;
2251 Temp :=
2252 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2253
2254 -- Construct argument list for the initialization routine call
2255 -- The CPP constructor needs the address directly
2256
2257 if Is_CPP_Class (T) then
2258 Arg1 := New_Reference_To (Temp, Loc);
2259 Temp_Type := T;
2260
2261 else
2262 Arg1 :=
2263 Make_Explicit_Dereference (Loc,
2264 Prefix => New_Reference_To (Temp, Loc));
2265 Set_Assignment_OK (Arg1);
2266 Temp_Type := PtrT;
2267
2268 -- The initialization procedure expects a specific type.
2269 -- if the context is access to class wide, indicate that
2270 -- the object being allocated has the right specific type.
2271
2272 if Is_Class_Wide_Type (Designated_Type (PtrT)) then
2273 Arg1 := Unchecked_Convert_To (T, Arg1);
2274 end if;
2275 end if;
2276
2277 -- If designated type is a concurrent type or if it is a
2278 -- private type whose definition is a concurrent type,
2279 -- the first argument in the Init routine has to be
2280 -- unchecked conversion to the corresponding record type.
2281 -- If the designated type is a derived type, we also
2282 -- convert the argument to its root type.
2283
2284 if Is_Concurrent_Type (T) then
2285 Arg1 :=
2286 Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
2287
2288 elsif Is_Private_Type (T)
2289 and then Present (Full_View (T))
2290 and then Is_Concurrent_Type (Full_View (T))
2291 then
2292 Arg1 :=
2293 Unchecked_Convert_To
2294 (Corresponding_Record_Type (Full_View (T)), Arg1);
2295
2296 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
2297
2298 declare
2299 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
2300
2301 begin
2302 Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
2303 Set_Etype (Arg1, Ftyp);
2304 end;
2305 end if;
2306
2307 Args := New_List (Arg1);
2308
2309 -- For the task case, pass the Master_Id of the access type
2310 -- as the value of the _Master parameter, and _Chain as the
2311 -- value of the _Chain parameter (_Chain will be defined as
2312 -- part of the generated code for the allocator).
2313
2314 if Has_Task (T) then
2315
2316 if No (Master_Id (Base_Type (PtrT))) then
2317
2318 -- The designated type was an incomplete type, and
2319 -- the access type did not get expanded. Salvage
2320 -- it now.
2321
2322 Expand_N_Full_Type_Declaration
2323 (Parent (Base_Type (PtrT)));
2324 end if;
2325
2326 -- If the context of the allocator is a declaration or
2327 -- an assignment, we can generate a meaningful image for
2328 -- it, even though subsequent assignments might remove
71b30311 2329 -- the connection between task and entity. We build this
2330 -- image when the left-hand side is a simple variable,
2331 -- a simple indexed assignment or a simple selected
2332 -- component.
ee6ba406 2333
2334 if Nkind (Parent (N)) = N_Assignment_Statement then
2335 declare
2336 Nam : constant Node_Id := Name (Parent (N));
2337
2338 begin
2339 if Is_Entity_Name (Nam) then
2340 Decls :=
2341 Build_Task_Image_Decls (
2342 Loc,
2343 New_Occurrence_Of
2344 (Entity (Nam), Sloc (Nam)), T);
2345
71b30311 2346 elsif (Nkind (Nam) = N_Indexed_Component
2347 or else Nkind (Nam) = N_Selected_Component)
2348 and then Is_Entity_Name (Prefix (Nam))
2349 then
2350 Decls :=
515cb44b 2351 Build_Task_Image_Decls
2352 (Loc, Nam, Etype (Prefix (Nam)));
ee6ba406 2353 else
2354 Decls := Build_Task_Image_Decls (Loc, T, T);
2355 end if;
2356 end;
2357
2358 elsif Nkind (Parent (N)) = N_Object_Declaration then
2359 Decls :=
2360 Build_Task_Image_Decls (
2361 Loc, Defining_Identifier (Parent (N)), T);
2362
2363 else
2364 Decls := Build_Task_Image_Decls (Loc, T, T);
2365 end if;
2366
2367 Append_To (Args,
2368 New_Reference_To
2369 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
2370 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2371
2372 Decl := Last (Decls);
2373 Append_To (Args,
2374 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
2375
2376 -- Has_Task is false, Decls not used
2377
2378 else
2379 Decls := No_List;
2380 end if;
2381
2382 -- Add discriminants if discriminated type
2383
2384 if Has_Discriminants (T) then
2385 Discr := First_Elmt (Discriminant_Constraint (T));
2386
2387 while Present (Discr) loop
9dfe12ae 2388 Append (New_Copy_Tree (Elists.Node (Discr)), Args);
ee6ba406 2389 Next_Elmt (Discr);
2390 end loop;
2391
2392 elsif Is_Private_Type (T)
2393 and then Present (Full_View (T))
2394 and then Has_Discriminants (Full_View (T))
2395 then
2396 Discr :=
2397 First_Elmt (Discriminant_Constraint (Full_View (T)));
2398
2399 while Present (Discr) loop
9dfe12ae 2400 Append (New_Copy_Tree (Elists.Node (Discr)), Args);
ee6ba406 2401 Next_Elmt (Discr);
2402 end loop;
2403 end if;
2404
2405 -- We set the allocator as analyzed so that when we analyze the
2406 -- expression actions node, we do not get an unwanted recursive
2407 -- expansion of the allocator expression.
2408
2409 Set_Analyzed (N, True);
2410 Node := Relocate_Node (N);
2411
2412 -- Here is the transformation:
2413 -- input: new T
2414 -- output: Temp : constant ptr_T := new T;
2415 -- Init (Temp.all, ...);
2416 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2417 -- <CTRL> Initialize (Finalizable (Temp.all));
2418
2419 -- Here ptr_T is the pointer type for the allocator, and T
2420 -- is the subtype of the allocator.
2421
2422 Temp_Decl :=
2423 Make_Object_Declaration (Loc,
2424 Defining_Identifier => Temp,
2425 Constant_Present => True,
2426 Object_Definition => New_Reference_To (Temp_Type, Loc),
2427 Expression => Node);
2428
2429 Set_Assignment_OK (Temp_Decl);
2430
2431 if Is_CPP_Class (T) then
2432 Set_Aliased_Present (Temp_Decl);
2433 end if;
2434
2435 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
2436
9dfe12ae 2437 -- If the designated type is task type or contains tasks,
ee6ba406 2438 -- Create block to activate created tasks, and insert
2439 -- declaration for Task_Image variable ahead of call.
2440
2441 if Has_Task (T) then
2442 declare
9dfe12ae 2443 L : constant List_Id := New_List;
ee6ba406 2444 Blk : Node_Id;
2445
2446 begin
2447 Build_Task_Allocate_Block (L, Node, Args);
2448 Blk := Last (L);
2449
2450 Insert_List_Before (First (Declarations (Blk)), Decls);
2451 Insert_Actions (N, L);
2452 end;
2453
2454 else
2455 Insert_Action (N,
2456 Make_Procedure_Call_Statement (Loc,
2457 Name => New_Reference_To (Init, Loc),
2458 Parameter_Associations => Args));
2459 end if;
2460
2461 if Controlled_Type (T) then
9dfe12ae 2462 Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
ee6ba406 2463
2464 Insert_Actions (N,
2465 Make_Init_Call (
2466 Ref => New_Copy_Tree (Arg1),
2467 Typ => T,
2468 Flist_Ref => Flist,
2469 With_Attach => Make_Integer_Literal (Loc, 2)));
2470 end if;
2471
2472 if Is_CPP_Class (T) then
2473 Rewrite (N,
2474 Make_Attribute_Reference (Loc,
2475 Prefix => New_Reference_To (Temp, Loc),
2476 Attribute_Name => Name_Unchecked_Access));
2477 else
2478 Rewrite (N, New_Reference_To (Temp, Loc));
2479 end if;
2480
2481 Analyze_And_Resolve (N, PtrT);
2482 end if;
2483 end;
2484 end if;
9dfe12ae 2485
2486 exception
2487 when RE_Not_Available =>
2488 return;
ee6ba406 2489 end Expand_N_Allocator;
2490
2491 -----------------------
2492 -- Expand_N_And_Then --
2493 -----------------------
2494
2495 -- Expand into conditional expression if Actions present, and also
2496 -- deal with optimizing case of arguments being True or False.
2497
2498 procedure Expand_N_And_Then (N : Node_Id) is
2499 Loc : constant Source_Ptr := Sloc (N);
2500 Typ : constant Entity_Id := Etype (N);
2501 Left : constant Node_Id := Left_Opnd (N);
2502 Right : constant Node_Id := Right_Opnd (N);
2503 Actlist : List_Id;
2504
2505 begin
2506 -- Deal with non-standard booleans
2507
2508 if Is_Boolean_Type (Typ) then
2509 Adjust_Condition (Left);
2510 Adjust_Condition (Right);
2511 Set_Etype (N, Standard_Boolean);
2512 end if;
2513
2514 -- Check for cases of left argument is True or False
2515
2516 if Nkind (Left) = N_Identifier then
2517
2518 -- If left argument is True, change (True and then Right) to Right.
2519 -- Any actions associated with Right will be executed unconditionally
2520 -- and can thus be inserted into the tree unconditionally.
2521
2522 if Entity (Left) = Standard_True then
2523 if Present (Actions (N)) then
2524 Insert_Actions (N, Actions (N));
2525 end if;
2526
2527 Rewrite (N, Right);
2528 Adjust_Result_Type (N, Typ);
2529 return;
2530
2531 -- If left argument is False, change (False and then Right) to
2532 -- False. In this case we can forget the actions associated with
2533 -- Right, since they will never be executed.
2534
2535 elsif Entity (Left) = Standard_False then
2536 Kill_Dead_Code (Right);
2537 Kill_Dead_Code (Actions (N));
2538 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2539 Adjust_Result_Type (N, Typ);
2540 return;
2541 end if;
2542 end if;
2543
2544 -- If Actions are present, we expand
2545
2546 -- left and then right
2547
2548 -- into
2549
2550 -- if left then right else false end
2551
2552 -- with the actions becoming the Then_Actions of the conditional
2553 -- expression. This conditional expression is then further expanded
2554 -- (and will eventually disappear)
2555
2556 if Present (Actions (N)) then
2557 Actlist := Actions (N);
2558 Rewrite (N,
2559 Make_Conditional_Expression (Loc,
2560 Expressions => New_List (
2561 Left,
2562 Right,
2563 New_Occurrence_Of (Standard_False, Loc))));
2564
2565 Set_Then_Actions (N, Actlist);
2566 Analyze_And_Resolve (N, Standard_Boolean);
2567 Adjust_Result_Type (N, Typ);
2568 return;
2569 end if;
2570
2571 -- No actions present, check for cases of right argument True/False
2572
2573 if Nkind (Right) = N_Identifier then
2574
2575 -- Change (Left and then True) to Left. Note that we know there
2576 -- are no actions associated with the True operand, since we
2577 -- just checked for this case above.
2578
2579 if Entity (Right) = Standard_True then
2580 Rewrite (N, Left);
2581
2582 -- Change (Left and then False) to False, making sure to preserve
2583 -- any side effects associated with the Left operand.
2584
2585 elsif Entity (Right) = Standard_False then
2586 Remove_Side_Effects (Left);
2587 Rewrite
2588 (N, New_Occurrence_Of (Standard_False, Loc));
2589 end if;
2590 end if;
2591
2592 Adjust_Result_Type (N, Typ);
2593 end Expand_N_And_Then;
2594
2595 -------------------------------------
2596 -- Expand_N_Conditional_Expression --
2597 -------------------------------------
2598
2599 -- Expand into expression actions if then/else actions present
2600
2601 procedure Expand_N_Conditional_Expression (N : Node_Id) is
2602 Loc : constant Source_Ptr := Sloc (N);
2603 Cond : constant Node_Id := First (Expressions (N));
2604 Thenx : constant Node_Id := Next (Cond);
2605 Elsex : constant Node_Id := Next (Thenx);
2606 Typ : constant Entity_Id := Etype (N);
2607 Cnn : Entity_Id;
2608 New_If : Node_Id;
2609
2610 begin
2611 -- If either then or else actions are present, then given:
2612
2613 -- if cond then then-expr else else-expr end
2614
2615 -- we insert the following sequence of actions (using Insert_Actions):
2616
2617 -- Cnn : typ;
2618 -- if cond then
2619 -- <<then actions>>
2620 -- Cnn := then-expr;
2621 -- else
2622 -- <<else actions>>
2623 -- Cnn := else-expr
2624 -- end if;
2625
2626 -- and replace the conditional expression by a reference to Cnn.
2627
2628 if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
2629 Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2630
2631 New_If :=
2632 Make_Implicit_If_Statement (N,
2633 Condition => Relocate_Node (Cond),
2634
2635 Then_Statements => New_List (
2636 Make_Assignment_Statement (Sloc (Thenx),
2637 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
2638 Expression => Relocate_Node (Thenx))),
2639
2640 Else_Statements => New_List (
2641 Make_Assignment_Statement (Sloc (Elsex),
2642 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
2643 Expression => Relocate_Node (Elsex))));
2644
9dfe12ae 2645 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
2646 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
2647
ee6ba406 2648 if Present (Then_Actions (N)) then
2649 Insert_List_Before
2650 (First (Then_Statements (New_If)), Then_Actions (N));
2651 end if;
2652
2653 if Present (Else_Actions (N)) then
2654 Insert_List_Before
2655 (First (Else_Statements (New_If)), Else_Actions (N));
2656 end if;
2657
2658 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
2659
2660 Insert_Action (N,
2661 Make_Object_Declaration (Loc,
2662 Defining_Identifier => Cnn,
2663 Object_Definition => New_Occurrence_Of (Typ, Loc)));
2664
2665 Insert_Action (N, New_If);
2666 Analyze_And_Resolve (N, Typ);
2667 end if;
2668 end Expand_N_Conditional_Expression;
2669
2670 -----------------------------------
2671 -- Expand_N_Explicit_Dereference --
2672 -----------------------------------
2673
2674 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
2675 begin
2676 -- The only processing required is an insertion of an explicit
2677 -- dereference call for the checked storage pool case.
2678
2679 Insert_Dereference_Action (Prefix (N));
2680 end Expand_N_Explicit_Dereference;
2681
2682 -----------------
2683 -- Expand_N_In --
2684 -----------------
2685
2686 procedure Expand_N_In (N : Node_Id) is
2687 Loc : constant Source_Ptr := Sloc (N);
2688 Rtyp : constant Entity_Id := Etype (N);
9dfe12ae 2689 Lop : constant Node_Id := Left_Opnd (N);
2690 Rop : constant Node_Id := Right_Opnd (N);
ee6ba406 2691
2692 begin
9dfe12ae 2693 -- If we have an explicit range, do a bit of optimization based
2694 -- on range analysis (we may be able to kill one or both checks).
2695
2696 if Nkind (Rop) = N_Range then
2697 declare
2698 Lcheck : constant Compare_Result :=
2699 Compile_Time_Compare (Lop, Low_Bound (Rop));
2700 Ucheck : constant Compare_Result :=
2701 Compile_Time_Compare (Lop, High_Bound (Rop));
2702
2703 begin
2704 -- If either check is known to fail, replace result
2705 -- by False, since the other check does not matter.
2706
2707 if Lcheck = LT or else Ucheck = GT then
2708 Rewrite (N,
2709 New_Reference_To (Standard_False, Loc));
2710 Analyze_And_Resolve (N, Rtyp);
2711 return;
2712
2713 -- If both checks are known to succeed, replace result
2714 -- by True, since we know we are in range.
2715
2716 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
2717 Rewrite (N,
2718 New_Reference_To (Standard_True, Loc));
2719 Analyze_And_Resolve (N, Rtyp);
2720 return;
2721
2722 -- If lower bound check succeeds and upper bound check is
2723 -- not known to succeed or fail, then replace the range check
2724 -- with a comparison against the upper bound.
2725
2726 elsif Lcheck in Compare_GE then
2727 Rewrite (N,
2728 Make_Op_Le (Loc,
2729 Left_Opnd => Lop,
2730 Right_Opnd => High_Bound (Rop)));
2731 Analyze_And_Resolve (N, Rtyp);
2732 return;
2733
2734 -- If upper bound check succeeds and lower bound check is
2735 -- not known to succeed or fail, then replace the range check
2736 -- with a comparison against the lower bound.
2737
2738 elsif Ucheck in Compare_LE then
2739 Rewrite (N,
2740 Make_Op_Ge (Loc,
2741 Left_Opnd => Lop,
2742 Right_Opnd => Low_Bound (Rop)));
2743 Analyze_And_Resolve (N, Rtyp);
2744 return;
2745 end if;
2746 end;
2747
2748 -- For all other cases of an explicit range, nothing to be done
ee6ba406 2749
ee6ba406 2750 return;
2751
2752 -- Here right operand is a subtype mark
2753
2754 else
2755 declare
9dfe12ae 2756 Typ : Entity_Id := Etype (Rop);
2757 Is_Acc : constant Boolean := Is_Access_Type (Typ);
2758 Obj : Node_Id := Lop;
2759 Cond : Node_Id := Empty;
ee6ba406 2760
2761 begin
2762 Remove_Side_Effects (Obj);
2763
2764 -- For tagged type, do tagged membership operation
2765
2766 if Is_Tagged_Type (Typ) then
9dfe12ae 2767
ee6ba406 2768 -- No expansion will be performed when Java_VM, as the
2769 -- JVM back end will handle the membership tests directly
2770 -- (tags are not explicitly represented in Java objects,
2771 -- so the normal tagged membership expansion is not what
2772 -- we want).
2773
2774 if not Java_VM then
2775 Rewrite (N, Tagged_Membership (N));
2776 Analyze_And_Resolve (N, Rtyp);
2777 end if;
2778
2779 return;
2780
2781 -- If type is scalar type, rewrite as x in t'first .. t'last
2782 -- This reason we do this is that the bounds may have the wrong
2783 -- type if they come from the original type definition.
2784
2785 elsif Is_Scalar_Type (Typ) then
9dfe12ae 2786 Rewrite (Rop,
ee6ba406 2787 Make_Range (Loc,
2788 Low_Bound =>
2789 Make_Attribute_Reference (Loc,
2790 Attribute_Name => Name_First,
2791 Prefix => New_Reference_To (Typ, Loc)),
2792
2793 High_Bound =>
2794 Make_Attribute_Reference (Loc,
2795 Attribute_Name => Name_Last,
2796 Prefix => New_Reference_To (Typ, Loc))));
2797 Analyze_And_Resolve (N, Rtyp);
2798 return;
2799 end if;
2800
9dfe12ae 2801 -- Here we have a non-scalar type
2802
ee6ba406 2803 if Is_Acc then
2804 Typ := Designated_Type (Typ);
2805 end if;
2806
2807 if not Is_Constrained (Typ) then
2808 Rewrite (N,
2809 New_Reference_To (Standard_True, Loc));
2810 Analyze_And_Resolve (N, Rtyp);
2811
2812 -- For the constrained array case, we have to check the
2813 -- subscripts for an exact match if the lengths are
2814 -- non-zero (the lengths must match in any case).
2815
2816 elsif Is_Array_Type (Typ) then
2817
9dfe12ae 2818 Check_Subscripts : declare
ee6ba406 2819 function Construct_Attribute_Reference
2820 (E : Node_Id;
2821 Nam : Name_Id;
2822 Dim : Nat)
2823 return Node_Id;
2824 -- Build attribute reference E'Nam(Dim)
2825
9dfe12ae 2826 -----------------------------------
2827 -- Construct_Attribute_Reference --
2828 -----------------------------------
2829
ee6ba406 2830 function Construct_Attribute_Reference
2831 (E : Node_Id;
2832 Nam : Name_Id;
2833 Dim : Nat)
2834 return Node_Id
2835 is
2836 begin
2837 return
2838 Make_Attribute_Reference (Loc,
2839 Prefix => E,
2840 Attribute_Name => Nam,
2841 Expressions => New_List (
2842 Make_Integer_Literal (Loc, Dim)));
2843 end Construct_Attribute_Reference;
2844
9dfe12ae 2845 -- Start processing for Check_Subscripts
2846
ee6ba406 2847 begin
2848 for J in 1 .. Number_Dimensions (Typ) loop
2849 Evolve_And_Then (Cond,
2850 Make_Op_Eq (Loc,
2851 Left_Opnd =>
2852 Construct_Attribute_Reference
9dfe12ae 2853 (Duplicate_Subexpr_No_Checks (Obj),
2854 Name_First, J),
ee6ba406 2855 Right_Opnd =>
2856 Construct_Attribute_Reference
2857 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
2858
2859 Evolve_And_Then (Cond,
2860 Make_Op_Eq (Loc,
2861 Left_Opnd =>
2862 Construct_Attribute_Reference
9dfe12ae 2863 (Duplicate_Subexpr_No_Checks (Obj),
2864 Name_Last, J),
ee6ba406 2865 Right_Opnd =>
2866 Construct_Attribute_Reference
2867 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
2868 end loop;
2869
2870 if Is_Acc then
9dfe12ae 2871 Cond :=
2872 Make_Or_Else (Loc,
2873 Left_Opnd =>
2874 Make_Op_Eq (Loc,
2875 Left_Opnd => Obj,
2876 Right_Opnd => Make_Null (Loc)),
2877 Right_Opnd => Cond);
ee6ba406 2878 end if;
2879
2880 Rewrite (N, Cond);
2881 Analyze_And_Resolve (N, Rtyp);
9dfe12ae 2882 end Check_Subscripts;
ee6ba406 2883
2884 -- These are the cases where constraint checks may be
2885 -- required, e.g. records with possible discriminants
2886
2887 else
2888 -- Expand the test into a series of discriminant comparisons.
2889 -- The expression that is built is the negation of the one
2890 -- that is used for checking discriminant constraints.
2891
2892 Obj := Relocate_Node (Left_Opnd (N));
2893
2894 if Has_Discriminants (Typ) then
2895 Cond := Make_Op_Not (Loc,
2896 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
2897
2898 if Is_Acc then
2899 Cond := Make_Or_Else (Loc,
2900 Left_Opnd =>
2901 Make_Op_Eq (Loc,
2902 Left_Opnd => Obj,
2903 Right_Opnd => Make_Null (Loc)),
2904 Right_Opnd => Cond);
2905 end if;
2906
2907 else
2908 Cond := New_Occurrence_Of (Standard_True, Loc);
2909 end if;
2910
2911 Rewrite (N, Cond);
2912 Analyze_And_Resolve (N, Rtyp);
2913 end if;
2914 end;
2915 end if;
2916 end Expand_N_In;
2917
2918 --------------------------------
2919 -- Expand_N_Indexed_Component --
2920 --------------------------------
2921
2922 procedure Expand_N_Indexed_Component (N : Node_Id) is
2923 Loc : constant Source_Ptr := Sloc (N);
2924 Typ : constant Entity_Id := Etype (N);
2925 P : constant Node_Id := Prefix (N);
2926 T : constant Entity_Id := Etype (P);
2927
2928 begin
2929 -- A special optimization, if we have an indexed component that
2930 -- is selecting from a slice, then we can eliminate the slice,
2931 -- since, for example, x (i .. j)(k) is identical to x(k). The
2932 -- only difference is the range check required by the slice. The
2933 -- range check for the slice itself has already been generated.
2934 -- The range check for the subscripting operation is ensured
2935 -- by converting the subject to the subtype of the slice.
2936
2937 -- This optimization not only generates better code, avoiding
2938 -- slice messing especially in the packed case, but more importantly
2939 -- bypasses some problems in handling this peculiar case, for
2940 -- example, the issue of dealing specially with object renamings.
2941
2942 if Nkind (P) = N_Slice then
2943 Rewrite (N,
2944 Make_Indexed_Component (Loc,
2945 Prefix => Prefix (P),
2946 Expressions => New_List (
2947 Convert_To
2948 (Etype (First_Index (Etype (P))),
2949 First (Expressions (N))))));
2950 Analyze_And_Resolve (N, Typ);
2951 return;
2952 end if;
2953
2954 -- If the prefix is an access type, then we unconditionally rewrite
2955 -- if as an explicit deference. This simplifies processing for several
2956 -- cases, including packed array cases and certain cases in which
2957 -- checks must be generated. We used to try to do this only when it
2958 -- was necessary, but it cleans up the code to do it all the time.
2959
2960 if Is_Access_Type (T) then
9dfe12ae 2961
2962 -- Check whether the prefix comes from a debug pool, and generate
2963 -- the check before rewriting.
2964
2965 Insert_Dereference_Action (P);
2966
ee6ba406 2967 Rewrite (P,
2968 Make_Explicit_Dereference (Sloc (N),
2969 Prefix => Relocate_Node (P)));
2970 Analyze_And_Resolve (P, Designated_Type (T));
2971 end if;
2972
9dfe12ae 2973 -- Generate index and validity checks
2974
2975 Generate_Index_Checks (N);
2976
ee6ba406 2977 if Validity_Checks_On and then Validity_Check_Subscripts then
2978 Apply_Subscript_Validity_Checks (N);
2979 end if;
2980
2981 -- All done for the non-packed case
2982
2983 if not Is_Packed (Etype (Prefix (N))) then
2984 return;
2985 end if;
2986
2987 -- For packed arrays that are not bit-packed (i.e. the case of an array
2988 -- with one or more index types with a non-coniguous enumeration type),
2989 -- we can always use the normal packed element get circuit.
2990
2991 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
2992 Expand_Packed_Element_Reference (N);
2993 return;
2994 end if;
2995
2996 -- For a reference to a component of a bit packed array, we have to
2997 -- convert it to a reference to the corresponding Packed_Array_Type.
2998 -- We only want to do this for simple references, and not for:
2999
9dfe12ae 3000 -- Left side of assignment, or prefix of left side of assignment,
3001 -- or prefix of the prefix, to handle packed arrays of packed arrays,
ee6ba406 3002 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3003
3004 -- Renaming objects in renaming associations
3005 -- This case is handled when a use of the renamed variable occurs
3006
3007 -- Actual parameters for a procedure call
3008 -- This case is handled in Exp_Ch6.Expand_Actuals
3009
3010 -- The second expression in a 'Read attribute reference
3011
3012 -- The prefix of an address or size attribute reference
3013
3014 -- The following circuit detects these exceptions
3015
3016 declare
3017 Child : Node_Id := N;
3018 Parnt : Node_Id := Parent (N);
3019
3020 begin
3021 loop
3022 if Nkind (Parnt) = N_Unchecked_Expression then
3023 null;
3024
3025 elsif Nkind (Parnt) = N_Object_Renaming_Declaration
3026 or else Nkind (Parnt) = N_Procedure_Call_Statement
3027 or else (Nkind (Parnt) = N_Parameter_Association
3028 and then
3029 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
3030 then
3031 return;
3032
3033 elsif Nkind (Parnt) = N_Attribute_Reference
3034 and then (Attribute_Name (Parnt) = Name_Address
3035 or else
3036 Attribute_Name (Parnt) = Name_Size)
3037 and then Prefix (Parnt) = Child
3038 then
3039 return;
3040
3041 elsif Nkind (Parnt) = N_Assignment_Statement
3042 and then Name (Parnt) = Child
3043 then
3044 return;
3045
9dfe12ae 3046 -- If the expression is an index of an indexed component,
3047 -- it must be expanded regardless of context.
3048
3049 elsif Nkind (Parnt) = N_Indexed_Component
3050 and then Child /= Prefix (Parnt)
3051 then
3052 Expand_Packed_Element_Reference (N);
3053 return;
3054
3055 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
3056 and then Name (Parent (Parnt)) = Parnt
3057 then
3058 return;
3059
ee6ba406 3060 elsif Nkind (Parnt) = N_Attribute_Reference
3061 and then Attribute_Name (Parnt) = Name_Read
3062 and then Next (First (Expressions (Parnt))) = Child
3063 then
3064 return;
3065
3066 elsif (Nkind (Parnt) = N_Indexed_Component
3067 or else Nkind (Parnt) = N_Selected_Component)
3068 and then Prefix (Parnt) = Child
3069 then
3070 null;
3071
3072 else
3073 Expand_Packed_Element_Reference (N);
3074 return;
3075 end if;
3076
3077 -- Keep looking up tree for unchecked expression, or if we are
3078 -- the prefix of a possible assignment left side.
3079
3080 Child := Parnt;
3081 Parnt := Parent (Child);
3082 end loop;
3083 end;
3084
3085 end Expand_N_Indexed_Component;
3086
3087 ---------------------
3088 -- Expand_N_Not_In --
3089 ---------------------
3090
3091 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3092 -- can be done. This avoids needing to duplicate this expansion code.
3093
3094 procedure Expand_N_Not_In (N : Node_Id) is
3095 Loc : constant Source_Ptr := Sloc (N);
3096 Typ : constant Entity_Id := Etype (N);
3097
3098 begin
3099 Rewrite (N,
3100 Make_Op_Not (Loc,
3101 Right_Opnd =>
3102 Make_In (Loc,
3103 Left_Opnd => Left_Opnd (N),
3104 Right_Opnd => Right_Opnd (N))));
3105 Analyze_And_Resolve (N, Typ);
3106 end Expand_N_Not_In;
3107
3108 -------------------
3109 -- Expand_N_Null --
3110 -------------------
3111
3112 -- The only replacement required is for the case of a null of type
3113 -- that is an access to protected subprogram. We represent such
3114 -- access values as a record, and so we must replace the occurrence
3115 -- of null by the equivalent record (with a null address and a null
3116 -- pointer in it), so that the backend creates the proper value.
3117
3118 procedure Expand_N_Null (N : Node_Id) is
3119 Loc : constant Source_Ptr := Sloc (N);
3120 Typ : constant Entity_Id := Etype (N);
3121 Agg : Node_Id;
3122
3123 begin
3124 if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
3125 Agg :=
3126 Make_Aggregate (Loc,
3127 Expressions => New_List (
3128 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
3129 Make_Null (Loc)));
3130
3131 Rewrite (N, Agg);
3132 Analyze_And_Resolve (N, Equivalent_Type (Typ));
3133
3134 -- For subsequent semantic analysis, the node must retain its
3135 -- type. Gigi in any case replaces this type by the corresponding
3136 -- record type before processing the node.
3137
3138 Set_Etype (N, Typ);
3139 end if;
9dfe12ae 3140
3141 exception
3142 when RE_Not_Available =>
3143 return;
ee6ba406 3144 end Expand_N_Null;
3145
3146 ---------------------
3147 -- Expand_N_Op_Abs --
3148 ---------------------
3149
3150 procedure Expand_N_Op_Abs (N : Node_Id) is
3151 Loc : constant Source_Ptr := Sloc (N);
3152 Expr : constant Node_Id := Right_Opnd (N);
3153
3154 begin
3155 Unary_Op_Validity_Checks (N);
3156
3157 -- Deal with software overflow checking
3158
f15731c4 3159 if not Backend_Overflow_Checks_On_Target
ee6ba406 3160 and then Is_Signed_Integer_Type (Etype (N))
3161 and then Do_Overflow_Check (N)
3162 then
9dfe12ae 3163 -- The only case to worry about is when the argument is
3164 -- equal to the largest negative number, so what we do is
3165 -- to insert the check:
ee6ba406 3166
9dfe12ae 3167 -- [constraint_error when Expr = typ'Base'First]
ee6ba406 3168
3169 -- with the usual Duplicate_Subexpr use coding for expr
3170
9dfe12ae 3171 Insert_Action (N,
3172 Make_Raise_Constraint_Error (Loc,
3173 Condition =>
3174 Make_Op_Eq (Loc,
ee6ba406 3175 Left_Opnd => Duplicate_Subexpr (Expr),
9dfe12ae 3176 Right_Opnd =>
3177 Make_Attribute_Reference (Loc,
3178 Prefix =>
3179 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
3180 Attribute_Name => Name_First)),
3181 Reason => CE_Overflow_Check_Failed));
3182 end if;
ee6ba406 3183
3184 -- Vax floating-point types case
3185
9dfe12ae 3186 if Vax_Float (Etype (N)) then
ee6ba406 3187 Expand_Vax_Arith (N);
3188 end if;
3189 end Expand_N_Op_Abs;
3190
3191 ---------------------
3192 -- Expand_N_Op_Add --
3193 ---------------------
3194
3195 procedure Expand_N_Op_Add (N : Node_Id) is
3196 Typ : constant Entity_Id := Etype (N);
3197
3198 begin
3199 Binary_Op_Validity_Checks (N);
3200
3201 -- N + 0 = 0 + N = N for integer types
3202
3203 if Is_Integer_Type (Typ) then
3204 if Compile_Time_Known_Value (Right_Opnd (N))
3205 and then Expr_Value (Right_Opnd (N)) = Uint_0
3206 then
3207 Rewrite (N, Left_Opnd (N));
3208 return;
3209
3210 elsif Compile_Time_Known_Value (Left_Opnd (N))
3211 and then Expr_Value (Left_Opnd (N)) = Uint_0
3212 then
3213 Rewrite (N, Right_Opnd (N));
3214 return;
3215 end if;
3216 end if;
3217
9dfe12ae 3218 -- Arithmetic overflow checks for signed integer/fixed point types
ee6ba406 3219
3220 if Is_Signed_Integer_Type (Typ)
3221 or else Is_Fixed_Point_Type (Typ)
3222 then
3223 Apply_Arithmetic_Overflow_Check (N);
3224 return;
3225
3226 -- Vax floating-point types case
3227
3228 elsif Vax_Float (Typ) then
3229 Expand_Vax_Arith (N);
3230 end if;
3231 end Expand_N_Op_Add;
3232
3233 ---------------------
3234 -- Expand_N_Op_And --
3235 ---------------------
3236
3237 procedure Expand_N_Op_And (N : Node_Id) is
3238 Typ : constant Entity_Id := Etype (N);
3239
3240 begin
3241 Binary_Op_Validity_Checks (N);
3242
3243 if Is_Array_Type (Etype (N)) then
3244 Expand_Boolean_Operator (N);
3245
3246 elsif Is_Boolean_Type (Etype (N)) then
3247 Adjust_Condition (Left_Opnd (N));
3248 Adjust_Condition (Right_Opnd (N));
3249 Set_Etype (N, Standard_Boolean);
3250 Adjust_Result_Type (N, Typ);
3251 end if;
3252 end Expand_N_Op_And;
3253
3254 ------------------------
3255 -- Expand_N_Op_Concat --
3256 ------------------------
3257
9dfe12ae 3258 Max_Available_String_Operands : Int := -1;
3259 -- This is initialized the first time this routine is called. It records
3260 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3261 -- available in the run-time:
3262 --
3263 -- 0 None available
3264 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3265 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3266 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3267 -- 5 All routines including RE_Str_Concat_5 available
3268
3269 Char_Concat_Available : Boolean;
3270 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3271 -- all three are available, False if any one of these is unavailable.
3272
ee6ba406 3273 procedure Expand_N_Op_Concat (N : Node_Id) is
3274
3275 Opnds : List_Id;
3276 -- List of operands to be concatenated
3277
3278 Opnd : Node_Id;
3279 -- Single operand for concatenation
3280
3281 Cnode : Node_Id;
3282 -- Node which is to be replaced by the result of concatenating
3283 -- the nodes in the list Opnds.
3284
3285 Atyp : Entity_Id;
3286 -- Array type of concatenation result type
3287
3288 Ctyp : Entity_Id;
3289 -- Component type of concatenation represented by Cnode
3290
3291 begin
9dfe12ae 3292 -- Initialize global variables showing run-time status
3293
3294 if Max_Available_String_Operands < 1 then
3295 if not RTE_Available (RE_Str_Concat) then
3296 Max_Available_String_Operands := 0;
3297 elsif not RTE_Available (RE_Str_Concat_3) then
3298 Max_Available_String_Operands := 2;
3299 elsif not RTE_Available (RE_Str_Concat_4) then
3300 Max_Available_String_Operands := 3;
3301 elsif not RTE_Available (RE_Str_Concat_5) then
3302 Max_Available_String_Operands := 4;
3303 else
3304 Max_Available_String_Operands := 5;
3305 end if;
3306
3307 Char_Concat_Available :=
3308 RTE_Available (RE_Str_Concat_CC)
3309 and then
3310 RTE_Available (RE_Str_Concat_CS)
3311 and then
3312 RTE_Available (RE_Str_Concat_SC);
3313 end if;
3314
3315 -- Ensure validity of both operands
3316
ee6ba406 3317 Binary_Op_Validity_Checks (N);
3318
3319 -- If we are the left operand of a concatenation higher up the
3320 -- tree, then do nothing for now, since we want to deal with a
3321 -- series of concatenations as a unit.
3322
3323 if Nkind (Parent (N)) = N_Op_Concat
3324 and then N = Left_Opnd (Parent (N))
3325 then
3326 return;
3327 end if;
3328
3329 -- We get here with a concatenation whose left operand may be a
3330 -- concatenation itself with a consistent type. We need to process
3331 -- these concatenation operands from left to right, which means
3332 -- from the deepest node in the tree to the highest node.
3333
3334 Cnode := N;
3335 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
3336 Cnode := Left_Opnd (Cnode);
3337 end loop;
3338
3339 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3340 -- nodes above, so now we process bottom up, doing the operations. We
3341 -- gather a string that is as long as possible up to five operands
3342
3343 -- The outer loop runs more than once if there are more than five
3344 -- concatenations of type Standard.String, the most we handle for
3345 -- this case, or if more than one concatenation type is involved.
3346
3347 Outer : loop
3348 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
3349 Set_Parent (Opnds, N);
3350
9dfe12ae 3351 -- The inner loop gathers concatenation operands. We gather any
3352 -- number of these in the non-string case, or if no concatenation
3353 -- routines are available for string (since in that case we will
3354 -- treat string like any other non-string case). Otherwise we only
3355 -- gather as many operands as can be handled by the available
3356 -- procedures in the run-time library (normally 5, but may be
3357 -- less for the configurable run-time case).
ee6ba406 3358
3359 Inner : while Cnode /= N
3360 and then (Base_Type (Etype (Cnode)) /= Standard_String
3361 or else
9dfe12ae 3362 Max_Available_String_Operands = 0
3363 or else
3364 List_Length (Opnds) <
3365 Max_Available_String_Operands)
ee6ba406 3366 and then Base_Type (Etype (Cnode)) =
3367 Base_Type (Etype (Parent (Cnode)))
3368 loop
3369 Cnode := Parent (Cnode);
3370 Append (Right_Opnd (Cnode), Opnds);
3371 end loop Inner;
3372
3373 -- Here we process the collected operands. First we convert
3374 -- singleton operands to singleton aggregates. This is skipped
3375 -- however for the case of two operands of type String, since
3376 -- we have special routines for these cases.
3377
3378 Atyp := Base_Type (Etype (Cnode));
3379 Ctyp := Base_Type (Component_Type (Etype (Cnode)));
3380
9dfe12ae 3381 if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
3382 or else not Char_Concat_Available
3383 then
ee6ba406 3384 Opnd := First (Opnds);
3385 loop
3386 if Base_Type (Etype (Opnd)) = Ctyp then
3387 Rewrite (Opnd,
3388 Make_Aggregate (Sloc (Cnode),
3389 Expressions => New_List (Relocate_Node (Opnd))));
3390 Analyze_And_Resolve (Opnd, Atyp);
3391 end if;
3392
3393 Next (Opnd);
3394 exit when No (Opnd);
3395 end loop;
3396 end if;
3397
3398 -- Now call appropriate continuation routine
3399
9dfe12ae 3400 if Atyp = Standard_String
3401 and then Max_Available_String_Operands > 0
3402 then
ee6ba406 3403 Expand_Concatenate_String (Cnode, Opnds);
3404 else
3405 Expand_Concatenate_Other (Cnode, Opnds);
3406 end if;
3407
3408 exit Outer when Cnode = N;
3409 Cnode := Parent (Cnode);
3410 end loop Outer;
3411 end Expand_N_Op_Concat;
3412
3413 ------------------------
3414 -- Expand_N_Op_Divide --
3415 ------------------------
3416
3417 procedure Expand_N_Op_Divide (N : Node_Id) is
3418 Loc : constant Source_Ptr := Sloc (N);
3419 Ltyp : constant Entity_Id := Etype (Left_Opnd (N));
3420 Rtyp : constant Entity_Id := Etype (Right_Opnd (N));
3421 Typ : Entity_Id := Etype (N);
3422
3423 begin
3424 Binary_Op_Validity_Checks (N);
3425
3426 -- Vax_Float is a special case
3427
3428 if Vax_Float (Typ) then
3429 Expand_Vax_Arith (N);
3430 return;
3431 end if;
3432
3433 -- N / 1 = N for integer types
3434
3435 if Is_Integer_Type (Typ)
3436 and then Compile_Time_Known_Value (Right_Opnd (N))
3437 and then Expr_Value (Right_Opnd (N)) = Uint_1
3438 then
3439 Rewrite (N, Left_Opnd (N));
3440 return;
3441 end if;
3442
3443 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3444 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3445 -- operand is an unsigned integer, as required for this to work.
3446
3447 if Nkind (Right_Opnd (N)) = N_Op_Expon
3448 and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
9dfe12ae 3449
3450 -- We cannot do this transformation in configurable run time mode if we
3451 -- have 64-bit -- integers and long shifts are not available.
3452
3453 and then
3454 (Esize (Ltyp) <= 32
3455 or else Support_Long_Shifts_On_Target)
ee6ba406 3456 then
3457 Rewrite (N,
3458 Make_Op_Shift_Right (Loc,
3459 Left_Opnd => Left_Opnd (N),
3460 Right_Opnd =>
3461 Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
3462 Analyze_And_Resolve (N, Typ);
3463 return;
3464 end if;
3465
3466 -- Do required fixup of universal fixed operation
3467
3468 if Typ = Universal_Fixed then
3469 Fixup_Universal_Fixed_Operation (N);
3470 Typ := Etype (N);
3471 end if;
3472
3473 -- Divisions with fixed-point results
3474
3475 if Is_Fixed_Point_Type (Typ) then
3476
3477 -- No special processing if Treat_Fixed_As_Integer is set,
3478 -- since from a semantic point of view such operations are
3479 -- simply integer operations and will be treated that way.
3480
3481 if not Treat_Fixed_As_Integer (N) then
3482 if Is_Integer_Type (Rtyp) then
3483 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
3484 else
3485 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
3486 end if;
3487 end if;
3488
3489 -- Other cases of division of fixed-point operands. Again we
3490 -- exclude the case where Treat_Fixed_As_Integer is set.
3491
3492 elsif (Is_Fixed_Point_Type (Ltyp) or else
3493 Is_Fixed_Point_Type (Rtyp))
3494 and then not Treat_Fixed_As_Integer (N)
3495 then
3496 if Is_Integer_Type (Typ) then
3497 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
3498 else
3499 pragma Assert (Is_Floating_Point_Type (Typ));
3500 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
3501 end if;
3502
3503 -- Mixed-mode operations can appear in a non-static universal
3504 -- context, in which case the integer argument must be converted
3505 -- explicitly.
3506
3507 elsif Typ = Universal_Real
3508 and then Is_Integer_Type (Rtyp)
3509 then
3510 Rewrite (Right_Opnd (N),
3511 Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
3512
3513 Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
3514
3515 elsif Typ = Universal_Real
3516 and then Is_Integer_Type (Ltyp)
3517 then
3518 Rewrite (Left_Opnd (N),
3519 Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
3520
3521 Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
3522
3523 -- Non-fixed point cases, do zero divide and overflow checks
3524
3525 elsif Is_Integer_Type (Typ) then
3526 Apply_Divide_Check (N);
9dfe12ae 3527
3528 -- Check for 64-bit division available
3529
3530 if Esize (Ltyp) > 32
3531 and then not Support_64_Bit_Divides_On_Target
3532 then
3533 Error_Msg_CRT ("64-bit division", N);
3534 end if;
ee6ba406 3535 end if;
3536 end Expand_N_Op_Divide;
3537
3538 --------------------
3539 -- Expand_N_Op_Eq --
3540 --------------------
3541
3542 procedure Expand_N_Op_Eq (N : Node_Id) is
9dfe12ae 3543 Loc : constant Source_Ptr := Sloc (N);
3544 Typ : constant Entity_Id := Etype (N);
3545 Lhs : constant Node_Id := Left_Opnd (N);
3546 Rhs : constant Node_Id := Right_Opnd (N);
3547 Bodies : constant List_Id := New_List;
3548 A_Typ : constant Entity_Id := Etype (Lhs);
3549
ee6ba406 3550 Typl : Entity_Id := A_Typ;
3551 Op_Name : Entity_Id;
3552 Prim : Elmt_Id;
ee6ba406 3553
3554 procedure Build_Equality_Call (Eq : Entity_Id);
3555 -- If a constructed equality exists for the type or for its parent,
3556 -- build and analyze call, adding conversions if the operation is
3557 -- inherited.
3558
3559 -------------------------
3560 -- Build_Equality_Call --
3561 -------------------------
3562
3563 procedure Build_Equality_Call (Eq : Entity_Id) is
3564 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
3565 L_Exp : Node_Id := Relocate_Node (Lhs);
3566 R_Exp : Node_Id := Relocate_Node (Rhs);
3567
3568 begin
3569 if Base_Type (Op_Type) /= Base_Type (A_Typ)
3570 and then not Is_Class_Wide_Type (A_Typ)
3571 then
3572 L_Exp := OK_Convert_To (Op_Type, L_Exp);
3573 R_Exp := OK_Convert_To (Op_Type, R_Exp);
3574 end if;
3575
3576 Rewrite (N,
3577 Make_Function_Call (Loc,
3578 Name => New_Reference_To (Eq, Loc),
3579 Parameter_Associations => New_List (L_Exp, R_Exp)));
3580
3581 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3582 end Build_Equality_Call;
3583
3584 -- Start of processing for Expand_N_Op_Eq
3585
3586 begin
3587 Binary_Op_Validity_Checks (N);
3588
3589 if Ekind (Typl) = E_Private_Type then
3590 Typl := Underlying_Type (Typl);
3591
3592 elsif Ekind (Typl) = E_Private_Subtype then
3593 Typl := Underlying_Type (Base_Type (Typl));
3594 end if;
3595
3596 -- It may happen in error situations that the underlying type is not
3597 -- set. The error will be detected later, here we just defend the
3598 -- expander code.
3599
3600 if No (Typl) then
3601 return;
3602 end if;
3603
3604 Typl := Base_Type (Typl);
3605
3606 -- Vax float types
3607
3608 if Vax_Float (Typl) then
3609 Expand_Vax_Comparison (N);
3610 return;
3611
3612 -- Boolean types (requiring handling of non-standard case)
3613
3614 elsif Is_Boolean_Type (Typl) then
3615 Adjust_Condition (Left_Opnd (N));
3616 Adjust_Condition (Right_Opnd (N));
3617 Set_Etype (N, Standard_Boolean);
3618 Adjust_Result_Type (N, Typ);
3619
3620 -- Array types
3621
3622 elsif Is_Array_Type (Typl) then
3623
9dfe12ae 3624 -- If we are doing full validity checking, then expand out array
3625 -- comparisons to make sure that we check the array elements.
3626
3627 if Validity_Check_Operands then
3628 declare
3629 Save_Force_Validity_Checks : constant Boolean :=
3630 Force_Validity_Checks;
3631 begin
3632 Force_Validity_Checks := True;
3633 Rewrite (N,
3634 Expand_Array_Equality (N, Typl, A_Typ,
3635 Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
3636
3637 Insert_Actions (N, Bodies);
3638 Analyze_And_Resolve (N, Standard_Boolean);
3639 Force_Validity_Checks := Save_Force_Validity_Checks;
3640 end;
3641
ee6ba406 3642 -- Packed case
3643
9dfe12ae 3644 elsif Is_Bit_Packed_Array (Typl) then
ee6ba406 3645 Expand_Packed_Eq (N);
3646
3647 -- For non-floating-point elementary types, the primitive equality
3648 -- always applies, and block-bit comparison is fine. Floating-point
3649 -- is an exception because of negative zeroes.
3650
ee6ba406 3651 elsif Is_Elementary_Type (Component_Type (Typl))
3652 and then not Is_Floating_Point_Type (Component_Type (Typl))
9dfe12ae 3653 and then Support_Composite_Compare_On_Target
ee6ba406 3654 then
3655 null;
3656
3657 -- For composite and floating-point cases, expand equality loop
3658 -- to make sure of using proper comparisons for tagged types,
3659 -- and correctly handling the floating-point case.
3660
3661 else
3662 Rewrite (N,
3663 Expand_Array_Equality (N, Typl, A_Typ,
3664 Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
3665
3666 Insert_Actions (N, Bodies, Suppress => All_Checks);
3667 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3668 end if;
3669
3670 -- Record Types
3671
3672 elsif Is_Record_Type (Typl) then
3673
3674 -- For tagged types, use the primitive "="
3675
3676 if Is_Tagged_Type (Typl) then
3677
3678 -- If this is derived from an untagged private type completed
3679 -- with a tagged type, it does not have a full view, so we
3680 -- use the primitive operations of the private type.
3681 -- This check should no longer be necessary when these
3682 -- types receive their full views ???
3683
3684 if Is_Private_Type (A_Typ)
3685 and then not Is_Tagged_Type (A_Typ)
3686 and then Is_Derived_Type (A_Typ)
3687 and then No (Full_View (A_Typ))
3688 then
3689 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
3690
3691 while Chars (Node (Prim)) /= Name_Op_Eq loop
3692 Next_Elmt (Prim);
3693 pragma Assert (Present (Prim));
3694 end loop;
3695
3696 Op_Name := Node (Prim);
9dfe12ae 3697
3698 -- Find the type's predefined equality or an overriding
3699 -- user-defined equality. The reason for not simply calling
3700 -- Find_Prim_Op here is that there may be a user-defined
3701 -- overloaded equality op that precedes the equality that
3702 -- we want, so we have to explicitly search (e.g., there
3703 -- could be an equality with two different parameter types).
3704
ee6ba406 3705 else
9dfe12ae 3706 if Is_Class_Wide_Type (Typl) then
3707 Typl := Root_Type (Typl);
3708 end if;
3709
3710 Prim := First_Elmt (Primitive_Operations (Typl));
3711
3712 while Present (Prim) loop
3713 exit when Chars (Node (Prim)) = Name_Op_Eq
3714 and then Etype (First_Formal (Node (Prim))) =
3715 Etype (Next_Formal (First_Formal (Node (Prim))))
3716 and then Etype (Node (Prim)) = Standard_Boolean;
3717
3718 Next_Elmt (Prim);
3719 pragma Assert (Present (Prim));
3720 end loop;
3721
3722 Op_Name := Node (Prim);
ee6ba406 3723 end if;
3724
3725 Build_Equality_Call (Op_Name);
3726
3727 -- If a type support function is present (for complex cases), use it
3728
9dfe12ae 3729 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
3730 Build_Equality_Call
3731 (TSS (Root_Type (Typl), TSS_Composite_Equality));
ee6ba406 3732
3733 -- Otherwise expand the component by component equality. Note that
3734 -- we never use block-bit coparisons for records, because of the
3735 -- problems with gaps. The backend will often be able to recombine
3736 -- the separate comparisons that we generate here.
3737
3738 else
3739 Remove_Side_Effects (Lhs);
3740 Remove_Side_Effects (Rhs);
3741 Rewrite (N,
3742 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
3743
3744 Insert_Actions (N, Bodies, Suppress => All_Checks);
3745 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3746 end if;
3747 end if;
3748
3749 -- If we still have an equality comparison (i.e. it was not rewritten
3750 -- in some way), then we can test if result is needed at compile time).
3751
3752 if Nkind (N) = N_Op_Eq then
3753 Rewrite_Comparison (N);
3754 end if;
3755 end Expand_N_Op_Eq;
3756
3757 -----------------------
3758 -- Expand_N_Op_Expon --
3759 -----------------------
3760
3761 procedure Expand_N_Op_Expon (N : Node_Id) is
3762 Loc : constant Source_Ptr := Sloc (N);
3763 Typ : constant Entity_Id := Etype (N);
3764 Rtyp : constant Entity_Id := Root_Type (Typ);
3765 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
f15731c4 3766 Bastyp : constant Node_Id := Etype (Base);
ee6ba406 3767 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
3768 Exptyp : constant Entity_Id := Etype (Exp);
3769 Ovflo : constant Boolean := Do_Overflow_Check (N);
3770 Expv : Uint;
3771 Xnode : Node_Id;
3772 Temp : Node_Id;
3773 Rent : RE_Id;
3774 Ent : Entity_Id;
9dfe12ae 3775 Etyp : Entity_Id;
ee6ba406 3776
3777 begin
3778 Binary_Op_Validity_Checks (N);
3779
f15731c4 3780 -- If either operand is of a private type, then we have the use of
3781 -- an intrinsic operator, and we get rid of the privateness, by using
3782 -- root types of underlying types for the actual operation. Otherwise
3783 -- the private types will cause trouble if we expand multiplications
3784 -- or shifts etc. We also do this transformation if the result type
3785 -- is different from the base type.
3786
3787 if Is_Private_Type (Etype (Base))
3788 or else
3789 Is_Private_Type (Typ)
3790 or else
3791 Is_Private_Type (Exptyp)
3792 or else
3793 Rtyp /= Root_Type (Bastyp)
3794 then
3795 declare
3796 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
3797 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
3798
3799 begin
3800 Rewrite (N,
3801 Unchecked_Convert_To (Typ,
3802 Make_Op_Expon (Loc,
3803 Left_Opnd => Unchecked_Convert_To (Bt, Base),
3804 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
3805 Analyze_And_Resolve (N, Typ);
3806 return;
3807 end;
3808 end if;
3809
9dfe12ae 3810 -- Test for case of known right argument
ee6ba406 3811
3812 if Compile_Time_Known_Value (Exp) then
3813 Expv := Expr_Value (Exp);
3814
3815 -- We only fold small non-negative exponents. You might think we
3816 -- could fold small negative exponents for the real case, but we
3817 -- can't because we are required to raise Constraint_Error for
3818 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
3819 -- See ACVC test C4A012B.
3820
3821 if Expv >= 0 and then Expv <= 4 then
3822
3823 -- X ** 0 = 1 (or 1.0)
3824
3825 if Expv = 0 then
3826 if Ekind (Typ) in Integer_Kind then
3827 Xnode := Make_Integer_Literal (Loc, Intval => 1);
3828 else
3829 Xnode := Make_Real_Literal (Loc, Ureal_1);
3830 end if;
3831
3832 -- X ** 1 = X
3833
3834 elsif Expv = 1 then
3835 Xnode := Base;
3836
3837 -- X ** 2 = X * X
3838
3839 elsif Expv = 2 then
3840 Xnode :=
3841 Make_Op_Multiply (Loc,
3842 Left_Opnd => Duplicate_Subexpr (Base),
9dfe12ae 3843 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
ee6ba406 3844
3845 -- X ** 3 = X * X * X
3846
3847 elsif Expv = 3 then
3848 Xnode :=
3849 Make_Op_Multiply (Loc,
3850 Left_Opnd =>
3851 Make_Op_Multiply (Loc,
3852 Left_Opnd => Duplicate_Subexpr (Base),
9dfe12ae 3853 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
3854 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
ee6ba406 3855
3856 -- X ** 4 ->
3857 -- En : constant base'type := base * base;
3858 -- ...
3859 -- En * En
3860
3861 else -- Expv = 4
3862 Temp :=
3863 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3864
3865 Insert_Actions (N, New_List (
3866 Make_Object_Declaration (Loc,
3867 Defining_Identifier => Temp,
3868 Constant_Present => True,
3869 Object_Definition => New_Reference_To (Typ, Loc),
3870 Expression =>
3871 Make_Op_Multiply (Loc,
3872 Left_Opnd => Duplicate_Subexpr (Base),
9dfe12ae 3873 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
ee6ba406 3874
3875 Xnode :=
3876 Make_Op_Multiply (Loc,
3877 Left_Opnd => New_Reference_To (Temp, Loc),
3878 Right_Opnd => New_Reference_To (Temp, Loc));
3879 end if;
3880
3881 Rewrite (N, Xnode);
3882 Analyze_And_Resolve (N, Typ);
3883 return;
3884 end if;
3885 end if;
3886
3887 -- Case of (2 ** expression) appearing as an argument of an integer
3888 -- multiplication, or as the right argument of a division of a non-
9dfe12ae 3889 -- negative integer. In such cases we leave the node untouched, setting
ee6ba406 3890 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
3891 -- of the higher level node converts it into a shift.
3892
3893 if Nkind (Base) = N_Integer_Literal
3894 and then Intval (Base) = 2
3895 and then Is_Integer_Type (Root_Type (Exptyp))
3896 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
3897 and then Is_Unsigned_Type (Exptyp)
3898 and then not Ovflo
3899 and then Nkind (Parent (N)) in N_Binary_Op
3900 then
3901 declare
3902 P : constant Node_Id := Parent (N);
3903 L : constant Node_Id := Left_Opnd (P);
3904 R : constant Node_Id := Right_Opnd (P);
3905
3906 begin
3907 if (Nkind (P) = N_Op_Multiply
3908 and then
3909 ((Is_Integer_Type (Etype (L)) and then R = N)
3910 or else
3911 (Is_Integer_Type (Etype (R)) and then L = N))
3912 and then not Do_Overflow_Check (P))
3913
3914 or else
3915 (Nkind (P) = N_Op_Divide
3916 and then Is_Integer_Type (Etype (L))
3917 and then Is_Unsigned_Type (Etype (L))
3918 and then R = N
3919 and then not Do_Overflow_Check (P))
3920 then
3921 Set_Is_Power_Of_2_For_Shift (N);
3922 return;
3923 end if;
3924 end;
3925 end if;
3926
f15731c4 3927 -- Fall through if exponentiation must be done using a runtime routine
3928
f15731c4 3929 -- First deal with modular case
ee6ba406 3930
3931 if Is_Modular_Integer_Type (Rtyp) then
3932
3933 -- Non-binary case, we call the special exponentiation routine for
3934 -- the non-binary case, converting the argument to Long_Long_Integer
3935 -- and passing the modulus value. Then the result is converted back
3936 -- to the base type.
3937
3938 if Non_Binary_Modulus (Rtyp) then
ee6ba406 3939 Rewrite (N,
3940 Convert_To (Typ,
3941 Make_Function_Call (Loc,
3942 Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
3943 Parameter_Associations => New_List (
3944 Convert_To (Standard_Integer, Base),
3945 Make_Integer_Literal (Loc, Modulus (Rtyp)),
3946 Exp))));
3947
3948 -- Binary case, in this case, we call one of two routines, either
3949 -- the unsigned integer case, or the unsigned long long integer
3950 -- case, with a final "and" operation to do the required mod.
3951
3952 else
3953 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
3954 Ent := RTE (RE_Exp_Unsigned);
3955 else
3956 Ent := RTE (RE_Exp_Long_Long_Unsigned);
3957 end if;
3958
3959 Rewrite (N,
3960 Convert_To (Typ,
3961 Make_Op_And (Loc,
3962 Left_Opnd =>
3963 Make_Function_Call (Loc,
3964 Name => New_Reference_To (Ent, Loc),
3965 Parameter_Associations => New_List (
3966 Convert_To (Etype (First_Formal (Ent)), Base),
3967 Exp)),
3968 Right_Opnd =>
3969 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
3970
3971 end if;
3972
3973 -- Common exit point for modular type case
3974
3975 Analyze_And_Resolve (N, Typ);
3976 return;
3977
9dfe12ae 3978 -- Signed integer cases, done using either Integer or Long_Long_Integer.
3979 -- It is not worth having routines for Short_[Short_]Integer, since for
3980 -- most machines it would not help, and it would generate more code that
3981 -- might need certification in the HI-E case.
ee6ba406 3982
9dfe12ae 3983 -- In the integer cases, we have two routines, one for when overflow
3984 -- checks are required, and one when they are not required, since
3985 -- there is a real gain in ommitting checks on many machines.
ee6ba406 3986
9dfe12ae 3987 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
3988 or else (Rtyp = Base_Type (Standard_Long_Integer)
3989 and then
3990 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
3991 or else (Rtyp = Universal_Integer)
ee6ba406 3992 then
9dfe12ae 3993 Etyp := Standard_Long_Long_Integer;
3994
ee6ba406 3995 if Ovflo then
3996 Rent := RE_Exp_Long_Long_Integer;
3997 else
3998 Rent := RE_Exn_Long_Long_Integer;
3999 end if;
4000
9dfe12ae 4001 elsif Is_Signed_Integer_Type (Rtyp) then
4002 Etyp := Standard_Integer;
ee6ba406 4003
4004 if Ovflo then
9dfe12ae 4005 Rent := RE_Exp_Integer;
ee6ba406 4006 else
9dfe12ae 4007 Rent := RE_Exn_Integer;
ee6ba406 4008 end if;
9dfe12ae 4009
4010 -- Floating-point cases, always done using Long_Long_Float. We do not
4011 -- need separate routines for the overflow case here, since in the case
4012 -- of floating-point, we generate infinities anyway as a rule (either
4013 -- that or we automatically trap overflow), and if there is an infinity
4014 -- generated and a range check is required, the check will fail anyway.
4015
4016 else
4017 pragma Assert (Is_Floating_Point_Type (Rtyp));
4018 Etyp := Standard_Long_Long_Float;
4019 Rent := RE_Exn_Long_Long_Float;
ee6ba406 4020 end if;
4021
4022 -- Common processing for integer cases and floating-point cases.
9dfe12ae 4023 -- If we are in the right type, we can call runtime routine directly
ee6ba406 4024
9dfe12ae 4025 if Typ = Etyp
ee6ba406 4026 and then Rtyp /= Universal_Integer
4027 and then Rtyp /= Universal_Real
4028 then
4029 Rewrite (N,
4030 Make_Function_Call (Loc,
4031 Name => New_Reference_To (RTE (Rent), Loc),
4032 Parameter_Associations => New_List (Base, Exp)));
4033
4034 -- Otherwise we have to introduce conversions (conversions are also
9dfe12ae 4035 -- required in the universal cases, since the runtime routine is
4036 -- typed using one of the standard types.
ee6ba406 4037
4038 else
4039 Rewrite (N,
4040 Convert_To (Typ,
4041 Make_Function_Call (Loc,
4042 Name => New_Reference_To (RTE (Rent), Loc),
4043 Parameter_Associations => New_List (
9dfe12ae 4044 Convert_To (Etyp, Base),
ee6ba406 4045 Exp))));
4046 end if;
4047
4048 Analyze_And_Resolve (N, Typ);
4049 return;
4050
9dfe12ae 4051 exception
4052 when RE_Not_Available =>
4053 return;
ee6ba406 4054 end Expand_N_Op_Expon;
4055
4056 --------------------
4057 -- Expand_N_Op_Ge --
4058 --------------------
4059
4060 procedure Expand_N_Op_Ge (N : Node_Id) is
4061 Typ : constant Entity_Id := Etype (N);
4062 Op1 : constant Node_Id := Left_Opnd (N);
4063 Op2 : constant Node_Id := Right_Opnd (N);
4064 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4065
4066 begin
4067 Binary_Op_Validity_Checks (N);
4068
4069 if Vax_Float (Typ1) then
4070 Expand_Vax_Comparison (N);
4071 return;
4072
4073 elsif Is_Array_Type (Typ1) then
4074 Expand_Array_Comparison (N);
4075 return;
4076 end if;
4077
4078 if Is_Boolean_Type (Typ1) then
4079 Adjust_Condition (Op1);
4080 Adjust_Condition (Op2);
4081 Set_Etype (N, Standard_Boolean);
4082 Adjust_Result_Type (N, Typ);
4083 end if;
4084
4085 Rewrite_Comparison (N);
4086 end Expand_N_Op_Ge;
4087
4088 --------------------
4089 -- Expand_N_Op_Gt --
4090 --------------------
4091
4092 procedure Expand_N_Op_Gt (N : Node_Id) is
4093 Typ : constant Entity_Id := Etype (N);
4094 Op1 : constant Node_Id := Left_Opnd (N);
4095 Op2 : constant Node_Id := Right_Opnd (N);
4096 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4097
4098 begin
4099 Binary_Op_Validity_Checks (N);
4100
4101 if Vax_Float (Typ1) then
4102 Expand_Vax_Comparison (N);
4103 return;
4104
4105 elsif Is_Array_Type (Typ1) then
4106 Expand_Array_Comparison (N);
4107 return;
4108 end if;
4109
4110 if Is_Boolean_Type (Typ1) then
4111 Adjust_Condition (Op1);
4112 Adjust_Condition (Op2);
4113 Set_Etype (N, Standard_Boolean);
4114 Adjust_Result_Type (N, Typ);
4115 end if;
4116
4117 Rewrite_Comparison (N);
4118 end Expand_N_Op_Gt;
4119
4120 --------------------
4121 -- Expand_N_Op_Le --
4122 --------------------
4123
4124 procedure Expand_N_Op_Le (N : Node_Id) is
4125 Typ : constant Entity_Id := Etype (N);
4126 Op1 : constant Node_Id := Left_Opnd (N);
4127 Op2 : constant Node_Id := Right_Opnd (N);
4128 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4129
4130 begin
4131 Binary_Op_Validity_Checks (N);
4132
4133 if Vax_Float (Typ1) then
4134 Expand_Vax_Comparison (N);
4135 return;
4136
4137 elsif Is_Array_Type (Typ1) then
4138 Expand_Array_Comparison (N);
4139 return;
4140 end if;
4141
4142 if Is_Boolean_Type (Typ1) then
4143 Adjust_Condition (Op1);
4144 Adjust_Condition (Op2);
4145 Set_Etype (N, Standard_Boolean);
4146 Adjust_Result_Type (N, Typ);
4147 end if;
4148
4149 Rewrite_Comparison (N);
4150 end Expand_N_Op_Le;
4151
4152 --------------------
4153 -- Expand_N_Op_Lt --
4154 --------------------
4155
4156 procedure Expand_N_Op_Lt (N : Node_Id) is
4157 Typ : constant Entity_Id := Etype (N);
4158 Op1 : constant Node_Id := Left_Opnd (N);
4159 Op2 : constant Node_Id := Right_Opnd (N);
4160 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4161
4162 begin
4163 Binary_Op_Validity_Checks (N);
4164
4165 if Vax_Float (Typ1) then
4166 Expand_Vax_Comparison (N);
4167 return;
4168
4169 elsif Is_Array_Type (Typ1) then
4170 Expand_Array_Comparison (N);
4171 return;
4172 end if;
4173
4174 if Is_Boolean_Type (Typ1) then
4175 Adjust_Condition (Op1);
4176 Adjust_Condition (Op2);
4177 Set_Etype (N, Standard_Boolean);
4178 Adjust_Result_Type (N, Typ);
4179 end if;
4180
4181 Rewrite_Comparison (N);
4182 end Expand_N_Op_Lt;
4183
4184 -----------------------
4185 -- Expand_N_Op_Minus --
4186 -----------------------
4187
4188 procedure Expand_N_Op_Minus (N : Node_Id) is
4189 Loc : constant Source_Ptr := Sloc (N);
4190 Typ : constant Entity_Id := Etype (N);
4191
4192 begin
4193 Unary_Op_Validity_Checks (N);
4194
f15731c4 4195 if not Backend_Overflow_Checks_On_Target
ee6ba406 4196 and then Is_Signed_Integer_Type (Etype (N))
4197 and then Do_Overflow_Check (N)
4198 then
4199 -- Software overflow checking expands -expr into (0 - expr)
4200
4201 Rewrite (N,
4202 Make_Op_Subtract (Loc,
4203 Left_Opnd => Make_Integer_Literal (Loc, 0),
4204 Right_Opnd => Right_Opnd (N)));
4205
4206 Analyze_And_Resolve (N, Typ);
4207
4208 -- Vax floating-point types case
4209
4210 elsif Vax_Float (Etype (N)) then
4211 Expand_Vax_Arith (N);
4212 end if;
4213 end Expand_N_Op_Minus;
4214
4215 ---------------------
4216 -- Expand_N_Op_Mod --
4217 ---------------------
4218
4219 procedure Expand_N_Op_Mod (N : Node_Id) is
4220 Loc : constant Source_Ptr := Sloc (N);
9dfe12ae 4221 Typ : constant Entity_Id := Etype (N);
ee6ba406 4222 Left : constant Node_Id := Left_Opnd (N);
4223 Right : constant Node_Id := Right_Opnd (N);
4224 DOC : constant Boolean := Do_Overflow_Check (N);
4225 DDC : constant Boolean := Do_Division_Check (N);
4226
4227 LLB : Uint;
4228 Llo : Uint;
4229 Lhi : Uint;
4230 LOK : Boolean;
4231 Rlo : Uint;
4232 Rhi : Uint;
4233 ROK : Boolean;
4234
4235 begin
4236 Binary_Op_Validity_Checks (N);
4237
4238 Determine_Range (Right, ROK, Rlo, Rhi);
4239 Determine_Range (Left, LOK, Llo, Lhi);
4240
4241 -- Convert mod to rem if operands are known non-negative. We do this
4242 -- since it is quite likely that this will improve the quality of code,
4243 -- (the operation now corresponds to the hardware remainder), and it
4244 -- does not seem likely that it could be harmful.
4245
4246 if LOK and then Llo >= 0
4247 and then
4248 ROK and then Rlo >= 0
4249 then
4250 Rewrite (N,
4251 Make_Op_Rem (Sloc (N),
4252 Left_Opnd => Left_Opnd (N),
4253 Right_Opnd => Right_Opnd (N)));
4254
4255 -- Instead of reanalyzing the node we do the analysis manually.
4256 -- This avoids anomalies when the replacement is done in an
4257 -- instance and is epsilon more efficient.
4258
4259 Set_Entity (N, Standard_Entity (S_Op_Rem));
9dfe12ae 4260 Set_Etype (N, Typ);
ee6ba406 4261 Set_Do_Overflow_Check (N, DOC);
4262 Set_Do_Division_Check (N, DDC);
4263 Expand_N_Op_Rem (N);
4264 Set_Analyzed (N);
4265
4266 -- Otherwise, normal mod processing
4267
4268 else
4269 if Is_Integer_Type (Etype (N)) then
4270 Apply_Divide_Check (N);
4271 end if;
4272
9dfe12ae 4273 -- Apply optimization x mod 1 = 0. We don't really need that with
4274 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
4275 -- certainly harmless.
4276
4277 if Is_Integer_Type (Etype (N))
4278 and then Compile_Time_Known_Value (Right)
4279 and then Expr_Value (Right) = Uint_1
4280 then
4281 Rewrite (N, Make_Integer_Literal (Loc, 0));
4282 Analyze_And_Resolve (N, Typ);
4283 return;
4284 end if;
4285
ee6ba406 4286 -- Deal with annoying case of largest negative number remainder
4287 -- minus one. Gigi does not handle this case correctly, because
4288 -- it generates a divide instruction which may trap in this case.
4289
4290 -- In fact the check is quite easy, if the right operand is -1,
4291 -- then the mod value is always 0, and we can just ignore the
4292 -- left operand completely in this case.
4293
9dfe12ae 4294 -- The operand type may be private (e.g. in the expansion of an
4295 -- an intrinsic operation) so we must use the underlying type to
4296 -- get the bounds, and convert the literals explicitly.
4297
4298 LLB :=
4299 Expr_Value
4300 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
ee6ba406 4301
4302 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4303 and then
4304 ((not LOK) or else (Llo = LLB))
4305 then
4306 Rewrite (N,
4307 Make_Conditional_Expression (Loc,
4308 Expressions => New_List (
4309 Make_Op_Eq (Loc,
4310 Left_Opnd => Duplicate_Subexpr (Right),
4311 Right_Opnd =>
9dfe12ae 4312 Unchecked_Convert_To (Typ,
4313 Make_Integer_Literal (Loc, -1))),
4314 Unchecked_Convert_To (Typ,
4315 Make_Integer_Literal (Loc, Uint_0)),
ee6ba406 4316 Relocate_Node (N))));
4317
4318 Set_Analyzed (Next (Next (First (Expressions (N)))));
9dfe12ae 4319 Analyze_And_Resolve (N, Typ);
ee6ba406 4320 end if;
4321 end if;
4322 end Expand_N_Op_Mod;
4323
4324 --------------------------
4325 -- Expand_N_Op_Multiply --
4326 --------------------------
4327
4328 procedure Expand_N_Op_Multiply (N : Node_Id) is
4329 Loc : constant Source_Ptr := Sloc (N);
4330 Lop : constant Node_Id := Left_Opnd (N);
4331 Rop : constant Node_Id := Right_Opnd (N);
9dfe12ae 4332
4333 Lp2 : constant Boolean :=
4334 Nkind (Lop) = N_Op_Expon
4335 and then Is_Power_Of_2_For_Shift (Lop);
4336
4337 Rp2 : constant Boolean :=
4338 Nkind (Rop) = N_Op_Expon
4339 and then Is_Power_Of_2_For_Shift (Rop);
4340
ee6ba406 4341 Ltyp : constant Entity_Id := Etype (Lop);
4342 Rtyp : constant Entity_Id := Etype (Rop);
4343 Typ : Entity_Id := Etype (N);
4344
4345 begin
4346 Binary_Op_Validity_Checks (N);
4347
4348 -- Special optimizations for integer types
4349
4350 if Is_Integer_Type (Typ) then
4351
4352 -- N * 0 = 0 * N = 0 for integer types
4353
9dfe12ae 4354 if (Compile_Time_Known_Value (Rop)
4355 and then Expr_Value (Rop) = Uint_0)
ee6ba406 4356 or else
9dfe12ae 4357 (Compile_Time_Known_Value (Lop)
4358 and then Expr_Value (Lop) = Uint_0)
ee6ba406 4359 then
4360 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
4361 Analyze_And_Resolve (N, Typ);
4362 return;
4363 end if;
4364
4365 -- N * 1 = 1 * N = N for integer types
4366
9dfe12ae 4367 -- This optimisation is not done if we are going to
4368 -- rewrite the product 1 * 2 ** N to a shift.
4369
4370 if Compile_Time_Known_Value (Rop)
4371 and then Expr_Value (Rop) = Uint_1
4372 and then not Lp2
ee6ba406 4373 then
9dfe12ae 4374 Rewrite (N, Lop);
ee6ba406 4375 return;
4376
9dfe12ae 4377 elsif Compile_Time_Known_Value (Lop)
4378 and then Expr_Value (Lop) = Uint_1
4379 and then not Rp2
ee6ba406 4380 then
9dfe12ae 4381 Rewrite (N, Rop);
ee6ba406 4382 return;
4383 end if;
4384 end if;
4385
4386 -- Deal with VAX float case
4387
4388 if Vax_Float (Typ) then
4389 Expand_Vax_Arith (N);
4390 return;
4391 end if;
4392
4393 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
4394 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4395 -- operand is an integer, as required for this to work.
4396
9dfe12ae 4397 if Rp2 then
4398 if Lp2 then
ee6ba406 4399
9dfe12ae 4400 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
ee6ba406 4401
4402 Rewrite (N,
4403 Make_Op_Expon (Loc,
4404 Left_Opnd => Make_Integer_Literal (Loc, 2),
4405 Right_Opnd =>
4406 Make_Op_Add (Loc,
4407 Left_Opnd => Right_Opnd (Lop),
4408 Right_Opnd => Right_Opnd (Rop))));
4409 Analyze_And_Resolve (N, Typ);
4410 return;
4411
4412 else
4413 Rewrite (N,
4414 Make_Op_Shift_Left (Loc,
4415 Left_Opnd => Lop,
4416 Right_Opnd =>
4417 Convert_To (Standard_Natural, Right_Opnd (Rop))));
4418 Analyze_And_Resolve (N, Typ);
4419 return;
4420 end if;
4421
4422 -- Same processing for the operands the other way round
4423
9dfe12ae 4424 elsif Lp2 then
ee6ba406 4425 Rewrite (N,
4426 Make_Op_Shift_Left (Loc,
4427 Left_Opnd => Rop,
4428 Right_Opnd =>
4429 Convert_To (Standard_Natural, Right_Opnd (Lop))));
4430 Analyze_And_Resolve (N, Typ);
4431 return;
4432 end if;
4433
4434 -- Do required fixup of universal fixed operation
4435
4436 if Typ = Universal_Fixed then
4437 Fixup_Universal_Fixed_Operation (N);
4438 Typ := Etype (N);
4439 end if;
4440
4441 -- Multiplications with fixed-point results
4442
4443 if Is_Fixed_Point_Type (Typ) then
4444
4445 -- No special processing if Treat_Fixed_As_Integer is set,
4446 -- since from a semantic point of view such operations are
4447 -- simply integer operations and will be treated that way.
4448
4449 if not Treat_Fixed_As_Integer (N) then
4450
4451 -- Case of fixed * integer => fixed
4452
4453 if Is_Integer_Type (Rtyp) then
4454 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
4455
4456 -- Case of integer * fixed => fixed
4457
4458 elsif Is_Integer_Type (Ltyp) then
4459 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
4460
4461 -- Case of fixed * fixed => fixed
4462
4463 else
4464 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
4465 end if;
4466 end if;
4467
4468 -- Other cases of multiplication of fixed-point operands. Again
4469 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
4470
4471 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
4472 and then not Treat_Fixed_As_Integer (N)
4473 then
4474 if Is_Integer_Type (Typ) then
4475 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
4476 else
4477 pragma Assert (Is_Floating_Point_Type (Typ));
4478 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
4479 end if;
4480
4481 -- Mixed-mode operations can appear in a non-static universal
4482 -- context, in which case the integer argument must be converted
4483 -- explicitly.
4484
4485 elsif Typ = Universal_Real
4486 and then Is_Integer_Type (Rtyp)
4487 then
4488 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
4489
4490 Analyze_And_Resolve (Rop, Universal_Real);
4491
4492 elsif Typ = Universal_Real
4493 and then Is_Integer_Type (Ltyp)
4494 then
4495 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
4496
4497 Analyze_And_Resolve (Lop, Universal_Real);
4498
4499 -- Non-fixed point cases, check software overflow checking required
4500
4501 elsif Is_Signed_Integer_Type (Etype (N)) then
4502 Apply_Arithmetic_Overflow_Check (N);
4503 end if;
4504 end Expand_N_Op_Multiply;
4505
4506 --------------------
4507 -- Expand_N_Op_Ne --
4508 --------------------
4509
4510 -- Rewrite node as the negation of an equality operation, and reanalyze.
4511 -- The equality to be used is defined in the same scope and has the same
4512 -- signature. It must be set explicitly because in an instance it may not
4513 -- have the same visibility as in the generic unit.
4514
4515 procedure Expand_N_Op_Ne (N : Node_Id) is
4516 Loc : constant Source_Ptr := Sloc (N);
4517 Neg : Node_Id;
4518 Ne : constant Entity_Id := Entity (N);
4519
4520 begin
4521 Binary_Op_Validity_Checks (N);
4522
4523 Neg :=
4524 Make_Op_Not (Loc,
4525 Right_Opnd =>
4526 Make_Op_Eq (Loc,
4527 Left_Opnd => Left_Opnd (N),
4528 Right_Opnd => Right_Opnd (N)));
4529 Set_Paren_Count (Right_Opnd (Neg), 1);
4530
4531 if Scope (Ne) /= Standard_Standard then
4532 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
4533 end if;
4534
9dfe12ae 4535 -- For navigation purposes, the inequality is treated as an implicit
4536 -- reference to the corresponding equality. Preserve the Comes_From_
4537 -- source flag so that the proper Xref entry is generated.
4538
4539 Preserve_Comes_From_Source (Neg, N);
4540 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
ee6ba406 4541 Rewrite (N, Neg);
4542 Analyze_And_Resolve (N, Standard_Boolean);
4543 end Expand_N_Op_Ne;
4544
4545 ---------------------
4546 -- Expand_N_Op_Not --
4547 ---------------------
4548
4549 -- If the argument is other than a Boolean array type, there is no
4550 -- special expansion required.
4551
4552 -- For the packed case, we call the special routine in Exp_Pakd, except
4553 -- that if the component size is greater than one, we use the standard
4554 -- routine generating a gruesome loop (it is so peculiar to have packed
4555 -- arrays with non-standard Boolean representations anyway, so it does
4556 -- not matter that we do not handle this case efficiently).
4557
4558 -- For the unpacked case (and for the special packed case where we have
4559 -- non standard Booleans, as discussed above), we generate and insert
4560 -- into the tree the following function definition:
4561
4562 -- function Nnnn (A : arr) is
4563 -- B : arr;
4564 -- begin
4565 -- for J in a'range loop
4566 -- B (J) := not A (J);
4567 -- end loop;
4568 -- return B;
4569 -- end Nnnn;
4570
4571 -- Here arr is the actual subtype of the parameter (and hence always
4572 -- constrained). Then we replace the not with a call to this function.
4573
4574 procedure Expand_N_Op_Not (N : Node_Id) is
4575 Loc : constant Source_Ptr := Sloc (N);
4576 Typ : constant Entity_Id := Etype (N);
4577 Opnd : Node_Id;
4578 Arr : Entity_Id;
4579 A : Entity_Id;
4580 B : Entity_Id;
4581 J : Entity_Id;
4582 A_J : Node_Id;
4583 B_J : Node_Id;
4584
4585 Func_Name : Entity_Id;
4586 Loop_Statement : Node_Id;
4587
4588 begin
4589 Unary_Op_Validity_Checks (N);
4590
4591 -- For boolean operand, deal with non-standard booleans
4592
4593 if Is_Boolean_Type (Typ) then
4594 Adjust_Condition (Right_Opnd (N));
4595 Set_Etype (N, Standard_Boolean);
4596 Adjust_Result_Type (N, Typ);
4597 return;
4598 end if;
4599
4600 -- Only array types need any other processing
4601
4602 if not Is_Array_Type (Typ) then
4603 return;
4604 end if;
4605
4606 -- Case of array operand. If bit packed, handle it in Exp_Pakd
4607
4608 if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
4609 Expand_Packed_Not (N);
4610 return;
4611 end if;
4612
9dfe12ae 4613 -- Case of array operand which is not bit-packed. If the context is
4614 -- a safe assignment, call in-place operation, If context is a larger
4615 -- boolean expression in the context of a safe assignment, expansion is
4616 -- done by enclosing operation.
ee6ba406 4617
4618 Opnd := Relocate_Node (Right_Opnd (N));
4619 Convert_To_Actual_Subtype (Opnd);
4620 Arr := Etype (Opnd);
4621 Ensure_Defined (Arr, N);
4622
9dfe12ae 4623 if Nkind (Parent (N)) = N_Assignment_Statement then
4624 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
4625 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
4626 return;
4627
4628 -- Special case the negation of a binary operation.
4629
4630 elsif (Nkind (Opnd) = N_Op_And
4631 or else Nkind (Opnd) = N_Op_Or
4632 or else Nkind (Opnd) = N_Op_Xor)
4633 and then Safe_In_Place_Array_Op
4634 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
4635 then
4636 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
4637 return;
4638 end if;
4639
4640 elsif Nkind (Parent (N)) in N_Binary_Op
4641 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
4642 then
4643 declare
4644 Op1 : constant Node_Id := Left_Opnd (Parent (N));
4645 Op2 : constant Node_Id := Right_Opnd (Parent (N));
4646 Lhs : constant Node_Id := Name (Parent (Parent (N)));
4647
4648 begin
4649 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
4650 if N = Op1
4651 and then Nkind (Op2) = N_Op_Not
4652 then
4653 -- (not A) op (not B) can be reduced to a single call.
4654
4655 return;
4656
4657 elsif N = Op2
4658 and then Nkind (Parent (N)) = N_Op_Xor
4659 then
4660 -- A xor (not B) can also be special-cased.
4661
4662 return;
4663 end if;
4664 end if;
4665 end;
4666 end if;
4667
ee6ba406 4668 A := Make_Defining_Identifier (Loc, Name_uA);
4669 B := Make_Defining_Identifier (Loc, Name_uB);
4670 J := Make_Defining_Identifier (Loc, Name_uJ);
4671
4672 A_J :=
4673 Make_Indexed_Component (Loc,
4674 Prefix => New_Reference_To (A, Loc),
4675 Expressions => New_List (New_Reference_To (J, Loc)));
4676
4677 B_J :=
4678 Make_Indexed_Component (Loc,
4679 Prefix => New_Reference_To (B, Loc),
4680 Expressions => New_List (New_Reference_To (J, Loc)));
4681
4682 Loop_Statement :=
4683 Make_Implicit_Loop_Statement (N,
4684 Identifier => Empty,
4685
4686 Iteration_Scheme =>
4687 Make_Iteration_Scheme (Loc,
4688 Loop_Parameter_Specification =>
4689 Make_Loop_Parameter_Specification (Loc,
4690 Defining_Identifier => J,
4691 Discrete_Subtype_Definition =>
4692 Make_Attribute_Reference (Loc,
4693 Prefix => Make_Identifier (Loc, Chars (A)),
4694 Attribute_Name => Name_Range))),
4695
4696 Statements => New_List (
4697 Make_Assignment_Statement (Loc,
4698 Name => B_J,
4699 Expression => Make_Op_Not (Loc, A_J))));
4700
4701 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
4702 Set_Is_Inlined (Func_Name);
4703
4704 Insert_Action (N,
4705 Make_Subprogram_Body (Loc,
4706 Specification =>
4707 Make_Function_Specification (Loc,
4708 Defining_Unit_Name => Func_Name,
4709 Parameter_Specifications => New_List (
4710 Make_Parameter_Specification (Loc,
4711 Defining_Identifier => A,
4712 Parameter_Type => New_Reference_To (Typ, Loc))),
4713 Subtype_Mark => New_Reference_To (Typ, Loc)),
4714
4715 Declarations => New_List (
4716 Make_Object_Declaration (Loc,
4717 Defining_Identifier => B,
4718 Object_Definition => New_Reference_To (Arr, Loc))),
4719
4720 Handled_Statement_Sequence =>
4721 Make_Handled_Sequence_Of_Statements (Loc,
4722 Statements => New_List (
4723 Loop_Statement,
4724 Make_Return_Statement (Loc,
4725 Expression =>
4726 Make_Identifier (Loc, Chars (B)))))));
4727
4728 Rewrite (N,
4729 Make_Function_Call (Loc,
4730 Name => New_Reference_To (Func_Name, Loc),
4731 Parameter_Associations => New_List (Opnd)));
4732
4733 Analyze_And_Resolve (N, Typ);
4734 end Expand_N_Op_Not;
4735
4736 --------------------
4737 -- Expand_N_Op_Or --
4738 --------------------
4739
4740 procedure Expand_N_Op_Or (N : Node_Id) is
4741 Typ : constant Entity_Id := Etype (N);
4742
4743 begin
4744 Binary_Op_Validity_Checks (N);
4745
4746 if Is_Array_Type (Etype (N)) then
4747 Expand_Boolean_Operator (N);
4748
4749 elsif Is_Boolean_Type (Etype (N)) then
4750 Adjust_Condition (Left_Opnd (N));
4751 Adjust_Condition (Right_Opnd (N));
4752 Set_Etype (N, Standard_Boolean);
4753 Adjust_Result_Type (N, Typ);
4754 end if;
4755 end Expand_N_Op_Or;
4756
4757 ----------------------
4758 -- Expand_N_Op_Plus --
4759 ----------------------
4760
4761 procedure Expand_N_Op_Plus (N : Node_Id) is
4762 begin
4763 Unary_Op_Validity_Checks (N);
4764 end Expand_N_Op_Plus;
4765
4766 ---------------------
4767 -- Expand_N_Op_Rem --
4768 ---------------------
4769
4770 procedure Expand_N_Op_Rem (N : Node_Id) is
4771 Loc : constant Source_Ptr := Sloc (N);
9dfe12ae 4772 Typ : constant Entity_Id := Etype (N);
ee6ba406 4773
4774 Left : constant Node_Id := Left_Opnd (N);
4775 Right : constant Node_Id := Right_Opnd (N);
4776
4777 LLB : Uint;
4778 Llo : Uint;
4779 Lhi : Uint;
4780 LOK : Boolean;
4781 Rlo : Uint;
4782 Rhi : Uint;
4783 ROK : Boolean;
ee6ba406 4784
4785 begin
4786 Binary_Op_Validity_Checks (N);
4787
4788 if Is_Integer_Type (Etype (N)) then
4789 Apply_Divide_Check (N);
4790 end if;
4791
9dfe12ae 4792 -- Apply optimization x rem 1 = 0. We don't really need that with
4793 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
4794 -- certainly harmless.
4795
4796 if Is_Integer_Type (Etype (N))
4797 and then Compile_Time_Known_Value (Right)
4798 and then Expr_Value (Right) = Uint_1
4799 then
4800 Rewrite (N, Make_Integer_Literal (Loc, 0));
4801 Analyze_And_Resolve (N, Typ);
4802 return;
4803 end if;
4804
ee6ba406 4805 -- Deal with annoying case of largest negative number remainder
4806 -- minus one. Gigi does not handle this case correctly, because
4807 -- it generates a divide instruction which may trap in this case.
4808
4809 -- In fact the check is quite easy, if the right operand is -1,
4810 -- then the remainder is always 0, and we can just ignore the
4811 -- left operand completely in this case.
4812
4813 Determine_Range (Right, ROK, Rlo, Rhi);
4814 Determine_Range (Left, LOK, Llo, Lhi);
9dfe12ae 4815
4816 -- The operand type may be private (e.g. in the expansion of an
4817 -- an intrinsic operation) so we must use the underlying type to
4818 -- get the bounds, and convert the literals explicitly.
4819
4820 LLB :=
4821 Expr_Value
4822 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
4823
4824 -- Now perform the test, generating code only if needed
ee6ba406 4825
4826 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4827 and then
4828 ((not LOK) or else (Llo = LLB))
4829 then
4830 Rewrite (N,
4831 Make_Conditional_Expression (Loc,
4832 Expressions => New_List (
4833 Make_Op_Eq (Loc,
4834 Left_Opnd => Duplicate_Subexpr (Right),
4835 Right_Opnd =>
9dfe12ae 4836 Unchecked_Convert_To (Typ,
4837 Make_Integer_Literal (Loc, -1))),
ee6ba406 4838
9dfe12ae 4839 Unchecked_Convert_To (Typ,
4840 Make_Integer_Literal (Loc, Uint_0)),
ee6ba406 4841
4842 Relocate_Node (N))));
4843
4844 Set_Analyzed (Next (Next (First (Expressions (N)))));
4845 Analyze_And_Resolve (N, Typ);
4846 end if;
4847 end Expand_N_Op_Rem;
4848
4849 -----------------------------
4850 -- Expand_N_Op_Rotate_Left --
4851 -----------------------------
4852
4853 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
4854 begin
4855 Binary_Op_Validity_Checks (N);
4856 end Expand_N_Op_Rotate_Left;
4857
4858 ------------------------------
4859 -- Expand_N_Op_Rotate_Right --
4860 ------------------------------
4861
4862 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
4863 begin
4864 Binary_Op_Validity_Checks (N);
4865 end Expand_N_Op_Rotate_Right;
4866
4867 ----------------------------
4868 -- Expand_N_Op_Shift_Left --
4869 ----------------------------
4870
4871 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
4872 begin
4873 Binary_Op_Validity_Checks (N);
4874 end Expand_N_Op_Shift_Left;
4875
4876 -----------------------------
4877 -- Expand_N_Op_Shift_Right --
4878 -----------------------------
4879
4880 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
4881 begin
4882 Binary_Op_Validity_Checks (N);
4883 end Expand_N_Op_Shift_Right;
4884
4885 ----------------------------------------
4886 -- Expand_N_Op_Shift_Right_Arithmetic --
4887 ----------------------------------------
4888
4889 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
4890 begin
4891 Binary_Op_Validity_Checks (N);
4892 end Expand_N_Op_Shift_Right_Arithmetic;
4893
4894 --------------------------
4895 -- Expand_N_Op_Subtract --
4896 --------------------------
4897
4898 procedure Expand_N_Op_Subtract (N : Node_Id) is
4899 Typ : constant Entity_Id := Etype (N);
4900
4901 begin
4902 Binary_Op_Validity_Checks (N);
4903
4904 -- N - 0 = N for integer types
4905
4906 if Is_Integer_Type (Typ)
4907 and then Compile_Time_Known_Value (Right_Opnd (N))
4908 and then Expr_Value (Right_Opnd (N)) = 0
4909 then
4910 Rewrite (N, Left_Opnd (N));
4911 return;
4912 end if;
4913
4914 -- Arithemtic overflow checks for signed integer/fixed point types
4915
4916 if Is_Signed_Integer_Type (Typ)
4917 or else Is_Fixed_Point_Type (Typ)
4918 then
4919 Apply_Arithmetic_Overflow_Check (N);
4920
4921 -- Vax floating-point types case
4922
4923 elsif Vax_Float (Typ) then
4924 Expand_Vax_Arith (N);
4925 end if;
4926 end Expand_N_Op_Subtract;
4927
4928 ---------------------
4929 -- Expand_N_Op_Xor --
4930 ---------------------
4931
4932 procedure Expand_N_Op_Xor (N : Node_Id) is
4933 Typ : constant Entity_Id := Etype (N);
4934
4935 begin
4936 Binary_Op_Validity_Checks (N);
4937
4938 if Is_Array_Type (Etype (N)) then
4939 Expand_Boolean_Operator (N);
4940
4941 elsif Is_Boolean_Type (Etype (N)) then
4942 Adjust_Condition (Left_Opnd (N));
4943 Adjust_Condition (Right_Opnd (N));
4944 Set_Etype (N, Standard_Boolean);
4945 Adjust_Result_Type (N, Typ);
4946 end if;
4947 end Expand_N_Op_Xor;
4948
4949 ----------------------
4950 -- Expand_N_Or_Else --
4951 ----------------------
4952
4953 -- Expand into conditional expression if Actions present, and also
4954 -- deal with optimizing case of arguments being True or False.
4955
4956 procedure Expand_N_Or_Else (N : Node_Id) is
4957 Loc : constant Source_Ptr := Sloc (N);
4958 Typ : constant Entity_Id := Etype (N);
4959 Left : constant Node_Id := Left_Opnd (N);
4960 Right : constant Node_Id := Right_Opnd (N);
4961 Actlist : List_Id;
4962
4963 begin
4964 -- Deal with non-standard booleans
4965
4966 if Is_Boolean_Type (Typ) then
4967 Adjust_Condition (Left);
4968 Adjust_Condition (Right);
4969 Set_Etype (N, Standard_Boolean);
9dfe12ae 4970 end if;
ee6ba406 4971
4972 -- Check for cases of left argument is True or False
4973
9dfe12ae 4974 if Nkind (Left) = N_Identifier then
ee6ba406 4975
4976 -- If left argument is False, change (False or else Right) to Right.
4977 -- Any actions associated with Right will be executed unconditionally
4978 -- and can thus be inserted into the tree unconditionally.
4979
4980 if Entity (Left) = Standard_False then
4981 if Present (Actions (N)) then
4982 Insert_Actions (N, Actions (N));
4983 end if;
4984
4985 Rewrite (N, Right);
4986 Adjust_Result_Type (N, Typ);
4987 return;
4988
4989 -- If left argument is True, change (True and then Right) to
4990 -- True. In this case we can forget the actions associated with
4991 -- Right, since they will never be executed.
4992
4993 elsif Entity (Left) = Standard_True then
4994 Kill_Dead_Code (Right);
4995 Kill_Dead_Code (Actions (N));
4996 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4997 Adjust_Result_Type (N, Typ);
4998 return;
4999 end if;
5000 end if;
5001
5002 -- If Actions are present, we expand
5003
5004 -- left or else right
5005
5006 -- into
5007
5008 -- if left then True else right end
5009
5010 -- with the actions becoming the Else_Actions of the conditional
5011 -- expression. This conditional expression is then further expanded
5012 -- (and will eventually disappear)
5013
5014 if Present (Actions (N)) then
5015 Actlist := Actions (N);
5016 Rewrite (N,
5017 Make_Conditional_Expression (Loc,
5018 Expressions => New_List (
5019 Left,
5020 New_Occurrence_Of (Standard_True, Loc),
5021 Right)));
5022
5023 Set_Else_Actions (N, Actlist);
5024 Analyze_And_Resolve (N, Standard_Boolean);
5025 Adjust_Result_Type (N, Typ);
5026 return;
5027 end if;
5028
5029 -- No actions present, check for cases of right argument True/False
5030
5031 if Nkind (Right) = N_Identifier then
5032
5033 -- Change (Left or else False) to Left. Note that we know there
5034 -- are no actions associated with the True operand, since we
5035 -- just checked for this case above.
5036
5037 if Entity (Right) = Standard_False then
5038 Rewrite (N, Left);
5039
5040 -- Change (Left or else True) to True, making sure to preserve
5041 -- any side effects associated with the Left operand.
5042
5043 elsif Entity (Right) = Standard_True then
5044 Remove_Side_Effects (Left);
5045 Rewrite
5046 (N, New_Occurrence_Of (Standard_True, Loc));
5047 end if;
5048 end if;
5049
5050 Adjust_Result_Type (N, Typ);
5051 end Expand_N_Or_Else;
5052
5053 -----------------------------------
5054 -- Expand_N_Qualified_Expression --
5055 -----------------------------------
5056
5057 procedure Expand_N_Qualified_Expression (N : Node_Id) is
5058 Operand : constant Node_Id := Expression (N);
5059 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
5060
5061 begin
5062 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
5063 end Expand_N_Qualified_Expression;
5064
5065 ---------------------------------
5066 -- Expand_N_Selected_Component --
5067 ---------------------------------
5068
5069 -- If the selector is a discriminant of a concurrent object, rewrite the
5070 -- prefix to denote the corresponding record type.
5071
5072 procedure Expand_N_Selected_Component (N : Node_Id) is
5073 Loc : constant Source_Ptr := Sloc (N);
5074 Par : constant Node_Id := Parent (N);
5075 P : constant Node_Id := Prefix (N);
9dfe12ae 5076 Ptyp : Entity_Id := Underlying_Type (Etype (P));
ee6ba406 5077 Disc : Entity_Id;
ee6ba406 5078 New_N : Node_Id;
9dfe12ae 5079 Dcon : Elmt_Id;
ee6ba406 5080
5081 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
5082 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5083 -- unless the context of an assignment can provide size information.
9dfe12ae 5084 -- Don't we have a general routine that does this???
5085
5086 -----------------------
5087 -- In_Left_Hand_Side --
5088 -----------------------
ee6ba406 5089
5090 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
5091 begin
9dfe12ae 5092 return (Nkind (Parent (Comp)) = N_Assignment_Statement
5093 and then Comp = Name (Parent (Comp)))
5094 or else (Present (Parent (Comp))
5095 and then Nkind (Parent (Comp)) in N_Subexpr
5096 and then In_Left_Hand_Side (Parent (Comp)));
ee6ba406 5097 end In_Left_Hand_Side;
5098
9dfe12ae 5099 -- Start of processing for Expand_N_Selected_Component
5100
ee6ba406 5101 begin
9dfe12ae 5102 -- Insert explicit dereference if required
5103
5104 if Is_Access_Type (Ptyp) then
5105 Insert_Explicit_Dereference (P);
5106
5107 if Ekind (Etype (P)) = E_Private_Subtype
5108 and then Is_For_Access_Subtype (Etype (P))
5109 then
5110 Set_Etype (P, Base_Type (Etype (P)));
5111 end if;
5112
5113 Ptyp := Etype (P);
5114 end if;
5115
5116 -- Deal with discriminant check required
5117
ee6ba406 5118 if Do_Discriminant_Check (N) then
5119
5120 -- Present the discrminant checking function to the backend,
5121 -- so that it can inline the call to the function.
5122
5123 Add_Inlined_Body
5124 (Discriminant_Checking_Func
5125 (Original_Record_Component (Entity (Selector_Name (N)))));
ee6ba406 5126
9dfe12ae 5127 -- Now reset the flag and generate the call
ee6ba406 5128
9dfe12ae 5129 Set_Do_Discriminant_Check (N, False);
5130 Generate_Discriminant_Check (N);
ee6ba406 5131 end if;
5132
9dfe12ae 5133 -- Gigi cannot handle unchecked conversions that are the prefix of a
5134 -- selected component with discriminants. This must be checked during
5135 -- expansion, because during analysis the type of the selector is not
5136 -- known at the point the prefix is analyzed. If the conversion is the
5137 -- target of an assignment, then we cannot force the evaluation.
ee6ba406 5138
5139 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
5140 and then Has_Discriminants (Etype (N))
5141 and then not In_Left_Hand_Side (N)
5142 then
5143 Force_Evaluation (Prefix (N));
5144 end if;
5145
5146 -- Remaining processing applies only if selector is a discriminant
5147
5148 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
5149
5150 -- If the selector is a discriminant of a constrained record type,
9dfe12ae 5151 -- we may be able to rewrite the expression with the actual value
5152 -- of the discriminant, a useful optimization in some cases.
ee6ba406 5153
5154 if Is_Record_Type (Ptyp)
5155 and then Has_Discriminants (Ptyp)
5156 and then Is_Constrained (Ptyp)
ee6ba406 5157 then
9dfe12ae 5158 -- Do this optimization for discrete types only, and not for
5159 -- access types (access discriminants get us into trouble!)
ee6ba406 5160
9dfe12ae 5161 if not Is_Discrete_Type (Etype (N)) then
5162 null;
5163
5164 -- Don't do this on the left hand of an assignment statement.
5165 -- Normally one would think that references like this would
5166 -- not occur, but they do in generated code, and mean that
5167 -- we really do want to assign the discriminant!
5168
5169 elsif Nkind (Par) = N_Assignment_Statement
5170 and then Name (Par) = N
5171 then
5172 null;
5173
5174 -- Don't do this optimization for the prefix of an attribute
5175 -- or the operand of an object renaming declaration since these
5176 -- are contexts where we do not want the value anyway.
5177
5178 elsif (Nkind (Par) = N_Attribute_Reference
5179 and then Prefix (Par) = N)
5180 or else Is_Renamed_Object (N)
5181 then
5182 null;
5183
5184 -- Don't do this optimization if we are within the code for a
5185 -- discriminant check, since the whole point of such a check may
5186 -- be to verify the condition on which the code below depends!
5187
5188 elsif Is_In_Discriminant_Check (N) then
5189 null;
5190
5191 -- Green light to see if we can do the optimization. There is
5192 -- still one condition that inhibits the optimization below
5193 -- but now is the time to check the particular discriminant.
5194
5195 else
5196 -- Loop through discriminants to find the matching
5197 -- discriminant constraint to see if we can copy it.
5198
5199 Disc := First_Discriminant (Ptyp);
5200 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
5201 Discr_Loop : while Present (Dcon) loop
5202
5203 -- Check if this is the matching discriminant
5204
5205 if Disc = Entity (Selector_Name (N)) then
ee6ba406 5206
9dfe12ae 5207 -- Here we have the matching discriminant. Check for
5208 -- the case of a discriminant of a component that is
5209 -- constrained by an outer discriminant, which cannot
5210 -- be optimized away.
5211
5212 if
5213 Denotes_Discriminant
5214 (Node (Dcon), Check_Protected => True)
5215 then
5216 exit Discr_Loop;
ee6ba406 5217
5218 -- In the context of a case statement, the expression
5219 -- may have the base type of the discriminant, and we
5220 -- need to preserve the constraint to avoid spurious
5221 -- errors on missing cases.
5222
9dfe12ae 5223 elsif Nkind (Parent (N)) = N_Case_Statement
5224 and then Etype (Node (Dcon)) /= Etype (Disc)
ee6ba406 5225 then
9dfe12ae 5226 -- RBKD is suspicious of the following code. The
5227 -- call to New_Copy instead of New_Copy_Tree is
5228 -- suspicious, and the call to Analyze instead
5229 -- of Analyze_And_Resolve is also suspicious ???
5230
5231 -- Wouldn't it be good enough to do a perfectly
5232 -- normal Analyze_And_Resolve call using the
5233 -- subtype of the discriminant here???
5234
ee6ba406 5235 Rewrite (N,
5236 Make_Qualified_Expression (Loc,
9dfe12ae 5237 Subtype_Mark =>
5238 New_Occurrence_Of (Etype (Disc), Loc),
5239 Expression =>
5240 New_Copy (Node (Dcon))));
ee6ba406 5241 Analyze (N);
9dfe12ae 5242
5243 -- In case that comes out as a static expression,
5244 -- reset it (a selected component is never static).
5245
5246 Set_Is_Static_Expression (N, False);
5247 return;
5248
5249 -- Otherwise we can just copy the constraint, but the
5250 -- result is certainly not static!
5251
5252 -- Again the New_Copy here and the failure to even
5253 -- to an analyze call is uneasy ???
5254
ee6ba406 5255 else
9dfe12ae 5256 Rewrite (N, New_Copy (Node (Dcon)));
5257 Set_Is_Static_Expression (N, False);
5258 return;
ee6ba406 5259 end if;
ee6ba406 5260 end if;
5261
9dfe12ae 5262 Next_Elmt (Dcon);
5263 Next_Discriminant (Disc);
5264 end loop Discr_Loop;
ee6ba406 5265
9dfe12ae 5266 -- Note: the above loop should always find a matching
5267 -- discriminant, but if it does not, we just missed an
5268 -- optimization due to some glitch (perhaps a previous
5269 -- error), so ignore.
5270
5271 end if;
ee6ba406 5272 end if;
5273
5274 -- The only remaining processing is in the case of a discriminant of
5275 -- a concurrent object, where we rewrite the prefix to denote the
5276 -- corresponding record type. If the type is derived and has renamed
5277 -- discriminants, use corresponding discriminant, which is the one
5278 -- that appears in the corresponding record.
5279
5280 if not Is_Concurrent_Type (Ptyp) then
5281 return;
5282 end if;
5283
5284 Disc := Entity (Selector_Name (N));
5285
5286 if Is_Derived_Type (Ptyp)
5287 and then Present (Corresponding_Discriminant (Disc))
5288 then
5289 Disc := Corresponding_Discriminant (Disc);
5290 end if;
5291
5292 New_N :=
5293 Make_Selected_Component (Loc,
5294 Prefix =>
5295 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
5296 New_Copy_Tree (P)),
5297 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
5298
5299 Rewrite (N, New_N);
5300 Analyze (N);
5301 end if;
ee6ba406 5302 end Expand_N_Selected_Component;
5303
5304 --------------------
5305 -- Expand_N_Slice --
5306 --------------------
5307
5308 procedure Expand_N_Slice (N : Node_Id) is
5309 Loc : constant Source_Ptr := Sloc (N);
5310 Typ : constant Entity_Id := Etype (N);
5311 Pfx : constant Node_Id := Prefix (N);
5312 Ptp : Entity_Id := Etype (Pfx);
9dfe12ae 5313
5314 procedure Make_Temporary;
5315 -- Create a named variable for the value of the slice, in
5316 -- cases where the back-end cannot handle it properly, e.g.
5317 -- when packed types or unaligned slices are involved.
5318
5319 --------------------
5320 -- Make_Temporary --
5321 --------------------
5322
5323 procedure Make_Temporary is
5324 Decl : Node_Id;
5325 Ent : constant Entity_Id :=
5326 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
5327 begin
5328 Decl :=
5329 Make_Object_Declaration (Loc,
5330 Defining_Identifier => Ent,
5331 Object_Definition => New_Occurrence_Of (Typ, Loc));
5332
5333 Set_No_Initialization (Decl);
5334
5335 Insert_Actions (N, New_List (
5336 Decl,
5337 Make_Assignment_Statement (Loc,
5338 Name => New_Occurrence_Of (Ent, Loc),
5339 Expression => Relocate_Node (N))));
5340
5341 Rewrite (N, New_Occurrence_Of (Ent, Loc));
5342 Analyze_And_Resolve (N, Typ);
5343 end Make_Temporary;
5344
5345 -- Start of processing for Expand_N_Slice
ee6ba406 5346
5347 begin
5348 -- Special handling for access types
5349
5350 if Is_Access_Type (Ptp) then
5351
5352 -- Check for explicit dereference required for checked pool
5353
5354 Insert_Dereference_Action (Pfx);
5355
5356 -- If we have an access to a packed array type, then put in an
5357 -- explicit dereference. We do this in case the slice must be
5358 -- expanded, and we want to make sure we get an access check.
5359
5360 Ptp := Designated_Type (Ptp);
5361
5362 if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
5363 Rewrite (Pfx,
5364 Make_Explicit_Dereference (Sloc (N),
5365 Prefix => Relocate_Node (Pfx)));
5366
5367 Analyze_And_Resolve (Pfx, Ptp);
ee6ba406 5368 end if;
5369 end if;
5370
5371 -- Range checks are potentially also needed for cases involving
5372 -- a slice indexed by a subtype indication, but Do_Range_Check
5373 -- can currently only be set for expressions ???
5374
5375 if not Index_Checks_Suppressed (Ptp)
5376 and then (not Is_Entity_Name (Pfx)
5377 or else not Index_Checks_Suppressed (Entity (Pfx)))
5378 and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
5379 then
5380 Enable_Range_Check (Discrete_Range (N));
5381 end if;
5382
5383 -- The remaining case to be handled is packed slices. We can leave
5384 -- packed slices as they are in the following situations:
5385
5386 -- 1. Right or left side of an assignment (we can handle this
5387 -- situation correctly in the assignment statement expansion).
5388
5389 -- 2. Prefix of indexed component (the slide is optimized away
5390 -- in this case, see the start of Expand_N_Slice.
5391
5392 -- 3. Object renaming declaration, since we want the name of
5393 -- the slice, not the value.
5394
5395 -- 4. Argument to procedure call, since copy-in/copy-out handling
5396 -- may be required, and this is handled in the expansion of
5397 -- call itself.
5398
5399 -- 5. Prefix of an address attribute (this is an error which
5400 -- is caught elsewhere, and the expansion would intefere
5401 -- with generating the error message).
5402
5403 if Is_Packed (Typ)
5404 and then Nkind (Parent (N)) /= N_Assignment_Statement
9dfe12ae 5405 and then (Nkind (Parent (Parent (N))) /= N_Assignment_Statement
5406 or else
5407 Parent (N) /= Name (Parent (Parent (N))))
ee6ba406 5408 and then Nkind (Parent (N)) /= N_Indexed_Component
5409 and then not Is_Renamed_Object (N)
5410 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
5411 and then (Nkind (Parent (N)) /= N_Attribute_Reference
5412 or else
5413 Attribute_Name (Parent (N)) /= Name_Address)
5414 then
9dfe12ae 5415 Make_Temporary;
ee6ba406 5416
9dfe12ae 5417 -- Same transformation for actuals in a function call, where
5418 -- Expand_Actuals is not used.
ee6ba406 5419
9dfe12ae 5420 elsif Nkind (Parent (N)) = N_Function_Call
5421 and then Is_Possibly_Unaligned_Slice (N)
5422 then
5423 Make_Temporary;
ee6ba406 5424 end if;
5425 end Expand_N_Slice;
5426
5427 ------------------------------
5428 -- Expand_N_Type_Conversion --
5429 ------------------------------
5430
5431 procedure Expand_N_Type_Conversion (N : Node_Id) is
5432 Loc : constant Source_Ptr := Sloc (N);
5433 Operand : constant Node_Id := Expression (N);
5434 Target_Type : constant Entity_Id := Etype (N);
5435 Operand_Type : Entity_Id := Etype (Operand);
5436
5437 procedure Handle_Changed_Representation;
5438 -- This is called in the case of record and array type conversions
5439 -- to see if there is a change of representation to be handled.
5440 -- Change of representation is actually handled at the assignment
5441 -- statement level, and what this procedure does is rewrite node N
5442 -- conversion as an assignment to temporary. If there is no change
5443 -- of representation, then the conversion node is unchanged.
5444
5445 procedure Real_Range_Check;
5446 -- Handles generation of range check for real target value
5447
5448 -----------------------------------
5449 -- Handle_Changed_Representation --
5450 -----------------------------------
5451
5452 procedure Handle_Changed_Representation is
5453 Temp : Entity_Id;
5454 Decl : Node_Id;
5455 Odef : Node_Id;
5456 Disc : Node_Id;
5457 N_Ix : Node_Id;
5458 Cons : List_Id;
5459
5460 begin
5461 -- Nothing to do if no change of representation
5462
5463 if Same_Representation (Operand_Type, Target_Type) then
5464 return;
5465
5466 -- The real change of representation work is done by the assignment
5467 -- statement processing. So if this type conversion is appearing as
5468 -- the expression of an assignment statement, nothing needs to be
5469 -- done to the conversion.
5470
5471 elsif Nkind (Parent (N)) = N_Assignment_Statement then
5472 return;
5473
5474 -- Otherwise we need to generate a temporary variable, and do the
5475 -- change of representation assignment into that temporary variable.
5476 -- The conversion is then replaced by a reference to this variable.
5477
5478 else
5479 Cons := No_List;
5480
5481 -- If type is unconstrained we have to add a constraint,
5482 -- copied from the actual value of the left hand side.
5483
5484 if not Is_Constrained (Target_Type) then
5485 if Has_Discriminants (Operand_Type) then
5486 Disc := First_Discriminant (Operand_Type);
9dfe12ae 5487
5488 if Disc /= First_Stored_Discriminant (Operand_Type) then
5489 Disc := First_Stored_Discriminant (Operand_Type);
5490 end if;
5491
ee6ba406 5492 Cons := New_List;
5493 while Present (Disc) loop
5494 Append_To (Cons,
5495 Make_Selected_Component (Loc,
9dfe12ae 5496 Prefix => Duplicate_Subexpr_Move_Checks (Operand),
ee6ba406 5497 Selector_Name =>
5498 Make_Identifier (Loc, Chars (Disc))));
5499 Next_Discriminant (Disc);
5500 end loop;
5501
5502 elsif Is_Array_Type (Operand_Type) then
5503 N_Ix := First_Index (Target_Type);
5504 Cons := New_List;
5505
5506 for J in 1 .. Number_Dimensions (Operand_Type) loop
5507
5508 -- We convert the bounds explicitly. We use an unchecked
5509 -- conversion because bounds checks are done elsewhere.
5510
5511 Append_To (Cons,
5512 Make_Range (Loc,
5513 Low_Bound =>
5514 Unchecked_Convert_To (Etype (N_Ix),
5515 Make_Attribute_Reference (Loc,
5516 Prefix =>
9dfe12ae 5517 Duplicate_Subexpr_No_Checks
ee6ba406 5518 (Operand, Name_Req => True),
5519 Attribute_Name => Name_First,
5520 Expressions => New_List (
5521 Make_Integer_Literal (Loc, J)))),
5522
5523 High_Bound =>
5524 Unchecked_Convert_To (Etype (N_Ix),
5525 Make_Attribute_Reference (Loc,
5526 Prefix =>
9dfe12ae 5527 Duplicate_Subexpr_No_Checks
ee6ba406 5528 (Operand, Name_Req => True),
5529 Attribute_Name => Name_Last,
5530 Expressions => New_List (
5531 Make_Integer_Literal (Loc, J))))));
5532
5533 Next_Index (N_Ix);
5534 end loop;
5535 end if;
5536 end if;
5537
5538 Odef := New_Occurrence_Of (Target_Type, Loc);
5539
5540 if Present (Cons) then
5541 Odef :=
5542 Make_Subtype_Indication (Loc,
5543 Subtype_Mark => Odef,
5544 Constraint =>
5545 Make_Index_Or_Discriminant_Constraint (Loc,
5546 Constraints => Cons));
5547 end if;
5548
5549 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
5550 Decl :=
5551 Make_Object_Declaration (Loc,
5552 Defining_Identifier => Temp,
5553 Object_Definition => Odef);
5554
5555 Set_No_Initialization (Decl, True);
5556
5557 -- Insert required actions. It is essential to suppress checks
5558 -- since we have suppressed default initialization, which means
5559 -- that the variable we create may have no discriminants.
5560
5561 Insert_Actions (N,
5562 New_List (
5563 Decl,
5564 Make_Assignment_Statement (Loc,
5565 Name => New_Occurrence_Of (Temp, Loc),
5566 Expression => Relocate_Node (N))),
5567 Suppress => All_Checks);
5568
5569 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5570 return;
5571 end if;
5572 end Handle_Changed_Representation;
5573
5574 ----------------------
5575 -- Real_Range_Check --
5576 ----------------------
5577
5578 -- Case of conversions to floating-point or fixed-point. If range
5579 -- checks are enabled and the target type has a range constraint,
5580 -- we convert:
5581
5582 -- typ (x)
5583
5584 -- to
5585
5586 -- Tnn : typ'Base := typ'Base (x);
5587 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
5588 -- Tnn
5589
9dfe12ae 5590 -- This is necessary when there is a conversion of integer to float
5591 -- or to fixed-point to ensure that the correct checks are made. It
5592 -- is not necessary for float to float where it is enough to simply
5593 -- set the Do_Range_Check flag.
5594
ee6ba406 5595 procedure Real_Range_Check is
5596 Btyp : constant Entity_Id := Base_Type (Target_Type);
5597 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
5598 Hi : constant Node_Id := Type_High_Bound (Target_Type);
9dfe12ae 5599 Xtyp : constant Entity_Id := Etype (Operand);
ee6ba406 5600 Conv : Node_Id;
5601 Tnn : Entity_Id;
5602
5603 begin
5604 -- Nothing to do if conversion was rewritten
5605
5606 if Nkind (N) /= N_Type_Conversion then
5607 return;
5608 end if;
5609
5610 -- Nothing to do if range checks suppressed, or target has the
5611 -- same range as the base type (or is the base type).
5612
5613 if Range_Checks_Suppressed (Target_Type)
5614 or else (Lo = Type_Low_Bound (Btyp)
5615 and then
5616 Hi = Type_High_Bound (Btyp))
5617 then
5618 return;
5619 end if;
5620
5621 -- Nothing to do if expression is an entity on which checks
5622 -- have been suppressed.
5623
9dfe12ae 5624 if Is_Entity_Name (Operand)
5625 and then Range_Checks_Suppressed (Entity (Operand))
5626 then
5627 return;
5628 end if;
5629
5630 -- Nothing to do if bounds are all static and we can tell that
5631 -- the expression is within the bounds of the target. Note that
5632 -- if the operand is of an unconstrained floating-point type,
5633 -- then we do not trust it to be in range (might be infinite)
5634
5635 declare
5636 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
5637 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
5638
5639 begin
5640 if (not Is_Floating_Point_Type (Xtyp)
5641 or else Is_Constrained (Xtyp))
5642 and then Compile_Time_Known_Value (S_Lo)
5643 and then Compile_Time_Known_Value (S_Hi)
5644 and then Compile_Time_Known_Value (Hi)
5645 and then Compile_Time_Known_Value (Lo)
5646 then
5647 declare
5648 D_Lov : constant Ureal := Expr_Value_R (Lo);
5649 D_Hiv : constant Ureal := Expr_Value_R (Hi);
5650 S_Lov : Ureal;
5651 S_Hiv : Ureal;
5652
5653 begin
5654 if Is_Real_Type (Xtyp) then
5655 S_Lov := Expr_Value_R (S_Lo);
5656 S_Hiv := Expr_Value_R (S_Hi);
5657 else
5658 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
5659 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
5660 end if;
5661
5662 if D_Hiv > D_Lov
5663 and then S_Lov >= D_Lov
5664 and then S_Hiv <= D_Hiv
5665 then
5666 Set_Do_Range_Check (Operand, False);
5667 return;
5668 end if;
5669 end;
5670 end if;
5671 end;
5672
5673 -- For float to float conversions, we are done
5674
5675 if Is_Floating_Point_Type (Xtyp)
5676 and then
5677 Is_Floating_Point_Type (Btyp)
ee6ba406 5678 then
5679 return;
5680 end if;
5681
9dfe12ae 5682 -- Otherwise rewrite the conversion as described above
ee6ba406 5683
5684 Conv := Relocate_Node (N);
5685 Rewrite
5686 (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
5687 Set_Etype (Conv, Btyp);
5688
9dfe12ae 5689 -- Enable overflow except in the case of integer to float
5690 -- conversions, where it is never required, since we can
5691 -- never have overflow in this case.
ee6ba406 5692
9dfe12ae 5693 if not Is_Integer_Type (Etype (Operand)) then
5694 Enable_Overflow_Check (Conv);
ee6ba406 5695 end if;
5696
5697 Tnn :=
5698 Make_Defining_Identifier (Loc,
5699 Chars => New_Internal_Name ('T'));
5700
5701 Insert_Actions (N, New_List (
5702 Make_Object_Declaration (Loc,
5703 Defining_Identifier => Tnn,
5704 Object_Definition => New_Occurrence_Of (Btyp, Loc),
5705 Expression => Conv),
5706
5707 Make_Raise_Constraint_Error (Loc,
f15731c4 5708 Condition =>
5709 Make_Or_Else (Loc,
5710 Left_Opnd =>
5711 Make_Op_Lt (Loc,
5712 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
5713 Right_Opnd =>
5714 Make_Attribute_Reference (Loc,
5715 Attribute_Name => Name_First,
5716 Prefix =>
5717 New_Occurrence_Of (Target_Type, Loc))),
ee6ba406 5718
f15731c4 5719 Right_Opnd =>
5720 Make_Op_Gt (Loc,
5721 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
5722 Right_Opnd =>
5723 Make_Attribute_Reference (Loc,
5724 Attribute_Name => Name_Last,
5725 Prefix =>
5726 New_Occurrence_Of (Target_Type, Loc)))),
5727 Reason => CE_Range_Check_Failed)));
ee6ba406 5728
5729 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
5730 Analyze_And_Resolve (N, Btyp);
5731 end Real_Range_Check;
5732
5733 -- Start of processing for Expand_N_Type_Conversion
5734
5735 begin
5736 -- Nothing at all to do if conversion is to the identical type
5737 -- so remove the conversion completely, it is useless.
5738
5739 if Operand_Type = Target_Type then
9dfe12ae 5740 Rewrite (N, Relocate_Node (Operand));
ee6ba406 5741 return;
5742 end if;
5743
5744 -- Deal with Vax floating-point cases
5745
5746 if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
5747 Expand_Vax_Conversion (N);
5748 return;
5749 end if;
5750
5751 -- Nothing to do if this is the second argument of read. This
5752 -- is a "backwards" conversion that will be handled by the
5753 -- specialized code in attribute processing.
5754
5755 if Nkind (Parent (N)) = N_Attribute_Reference
5756 and then Attribute_Name (Parent (N)) = Name_Read
5757 and then Next (First (Expressions (Parent (N)))) = N
5758 then
5759 return;
5760 end if;
5761
5762 -- Here if we may need to expand conversion
5763
5764 -- Special case of converting from non-standard boolean type
5765
5766 if Is_Boolean_Type (Operand_Type)
5767 and then (Nonzero_Is_True (Operand_Type))
5768 then
5769 Adjust_Condition (Operand);
5770 Set_Etype (Operand, Standard_Boolean);
5771 Operand_Type := Standard_Boolean;
5772 end if;
5773
5774 -- Case of converting to an access type
5775
5776 if Is_Access_Type (Target_Type) then
5777
5778 -- Apply an accessibility check if the operand is an
5779 -- access parameter. Note that other checks may still
5780 -- need to be applied below (such as tagged type checks).
5781
5782 if Is_Entity_Name (Operand)
5783 and then Ekind (Entity (Operand)) in Formal_Kind
5784 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
5785 then
5786 Apply_Accessibility_Check (Operand, Target_Type);
5787
5788 -- If the level of the operand type is statically deeper
5789 -- then the level of the target type, then force Program_Error.
5790 -- Note that this can only occur for cases where the attribute
5791 -- is within the body of an instantiation (otherwise the
5792 -- conversion will already have been rejected as illegal).
5793 -- Note: warnings are issued by the analyzer for the instance
5794 -- cases.
5795
5796 elsif In_Instance_Body
f15731c4 5797 and then Type_Access_Level (Operand_Type) >
5798 Type_Access_Level (Target_Type)
ee6ba406 5799 then
f15731c4 5800 Rewrite (N,
5801 Make_Raise_Program_Error (Sloc (N),
5802 Reason => PE_Accessibility_Check_Failed));
ee6ba406 5803 Set_Etype (N, Target_Type);
5804
5805 -- When the operand is a selected access discriminant
5806 -- the check needs to be made against the level of the
5807 -- object denoted by the prefix of the selected name.
5808 -- Force Program_Error for this case as well (this
5809 -- accessibility violation can only happen if within
5810 -- the body of an instantiation).
5811
5812 elsif In_Instance_Body
5813 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
5814 and then Nkind (Operand) = N_Selected_Component
5815 and then Object_Access_Level (Operand) >
5816 Type_Access_Level (Target_Type)
5817 then
f15731c4 5818 Rewrite (N,
5819 Make_Raise_Program_Error (Sloc (N),
5820 Reason => PE_Accessibility_Check_Failed));
ee6ba406 5821 Set_Etype (N, Target_Type);
5822 end if;
5823 end if;
5824
5825 -- Case of conversions of tagged types and access to tagged types
5826
5827 -- When needed, that is to say when the expression is class-wide,
5828 -- Add runtime a tag check for (strict) downward conversion by using
5829 -- the membership test, generating:
5830
5831 -- [constraint_error when Operand not in Target_Type'Class]
5832
5833 -- or in the access type case
5834
5835 -- [constraint_error
5836 -- when Operand /= null
5837 -- and then Operand.all not in
5838 -- Designated_Type (Target_Type)'Class]
5839
5840 if (Is_Access_Type (Target_Type)
5841 and then Is_Tagged_Type (Designated_Type (Target_Type)))
5842 or else Is_Tagged_Type (Target_Type)
5843 then
5844 -- Do not do any expansion in the access type case if the
5845 -- parent is a renaming, since this is an error situation
5846 -- which will be caught by Sem_Ch8, and the expansion can
5847 -- intefere with this error check.
5848
5849 if Is_Access_Type (Target_Type)
5850 and then Is_Renamed_Object (N)
5851 then
5852 return;
5853 end if;
5854
5855 -- Oherwise, proceed with processing tagged conversion
5856
5857 declare
5858 Actual_Operand_Type : Entity_Id;
5859 Actual_Target_Type : Entity_Id;
5860
5861 Cond : Node_Id;
5862
5863 begin
5864 if Is_Access_Type (Target_Type) then
5865 Actual_Operand_Type := Designated_Type (Operand_Type);
5866 Actual_Target_Type := Designated_Type (Target_Type);
5867
5868 else
5869 Actual_Operand_Type := Operand_Type;
5870 Actual_Target_Type := Target_Type;
5871 end if;
5872
5873 if Is_Class_Wide_Type (Actual_Operand_Type)
5874 and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type
5875 and then Is_Ancestor
5876 (Root_Type (Actual_Operand_Type),
5877 Actual_Target_Type)
5878 and then not Tag_Checks_Suppressed (Actual_Target_Type)
5879 then
5880 -- The conversion is valid for any descendant of the
5881 -- target type
5882
5883 Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
5884
5885 if Is_Access_Type (Target_Type) then
5886 Cond :=
5887 Make_And_Then (Loc,
5888 Left_Opnd =>
5889 Make_Op_Ne (Loc,
9dfe12ae 5890 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
ee6ba406 5891 Right_Opnd => Make_Null (Loc)),
5892
5893 Right_Opnd =>
5894 Make_Not_In (Loc,
5895 Left_Opnd =>
5896 Make_Explicit_Dereference (Loc,
9dfe12ae 5897 Prefix =>
5898 Duplicate_Subexpr_No_Checks (Operand)),
ee6ba406 5899 Right_Opnd =>
5900 New_Reference_To (Actual_Target_Type, Loc)));
5901
5902 else
5903 Cond :=
5904 Make_Not_In (Loc,
9dfe12ae 5905 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
ee6ba406 5906 Right_Opnd =>
5907 New_Reference_To (Actual_Target_Type, Loc));
5908 end if;
5909
5910 Insert_Action (N,
5911 Make_Raise_Constraint_Error (Loc,
f15731c4 5912 Condition => Cond,
5913 Reason => CE_Tag_Check_Failed));
ee6ba406 5914
5915 Change_Conversion_To_Unchecked (N);
5916 Analyze_And_Resolve (N, Target_Type);
5917 end if;
5918 end;
5919
5920 -- Case of other access type conversions
5921
5922 elsif Is_Access_Type (Target_Type) then
5923 Apply_Constraint_Check (Operand, Target_Type);
5924
5925 -- Case of conversions from a fixed-point type
5926
5927 -- These conversions require special expansion and processing, found
5928 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
5929 -- set, since from a semantic point of view, these are simple integer
5930 -- conversions, which do not need further processing.
5931
5932 elsif Is_Fixed_Point_Type (Operand_Type)
5933 and then not Conversion_OK (N)
5934 then
5935 -- We should never see universal fixed at this case, since the
5936 -- expansion of the constituent divide or multiply should have
5937 -- eliminated the explicit mention of universal fixed.
5938
5939 pragma Assert (Operand_Type /= Universal_Fixed);
5940
5941 -- Check for special case of the conversion to universal real
5942 -- that occurs as a result of the use of a round attribute.
5943 -- In this case, the real type for the conversion is taken
5944 -- from the target type of the Round attribute and the
5945 -- result must be marked as rounded.
5946
5947 if Target_Type = Universal_Real
5948 and then Nkind (Parent (N)) = N_Attribute_Reference
5949 and then Attribute_Name (Parent (N)) = Name_Round
5950 then
5951 Set_Rounded_Result (N);
5952 Set_Etype (N, Etype (Parent (N)));
5953 end if;
5954
5955 -- Otherwise do correct fixed-conversion, but skip these if the
5956 -- Conversion_OK flag is set, because from a semantic point of
5957 -- view these are simple integer conversions needing no further
5958 -- processing (the backend will simply treat them as integers)
5959
5960 if not Conversion_OK (N) then
5961 if Is_Fixed_Point_Type (Etype (N)) then
5962 Expand_Convert_Fixed_To_Fixed (N);
5963 Real_Range_Check;
5964
5965 elsif Is_Integer_Type (Etype (N)) then
5966 Expand_Convert_Fixed_To_Integer (N);
5967
5968 else
5969 pragma Assert (Is_Floating_Point_Type (Etype (N)));
5970 Expand_Convert_Fixed_To_Float (N);
5971 Real_Range_Check;
5972 end if;
5973 end if;
5974
5975 -- Case of conversions to a fixed-point type
5976
5977 -- These conversions require special expansion and processing, found
5978 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
5979 -- is set, since from a semantic point of view, these are simple
5980 -- integer conversions, which do not need further processing.
5981
5982 elsif Is_Fixed_Point_Type (Target_Type)
5983 and then not Conversion_OK (N)
5984 then
5985 if Is_Integer_Type (Operand_Type) then
5986 Expand_Convert_Integer_To_Fixed (N);
5987 Real_Range_Check;
5988 else
5989 pragma Assert (Is_Floating_Point_Type (Operand_Type));
5990 Expand_Convert_Float_To_Fixed (N);
5991 Real_Range_Check;
5992 end if;
5993
5994 -- Case of float-to-integer conversions
5995
5996 -- We also handle float-to-fixed conversions with Conversion_OK set
5997 -- since semantically the fixed-point target is treated as though it
5998 -- were an integer in such cases.
5999
6000 elsif Is_Floating_Point_Type (Operand_Type)
6001 and then
6002 (Is_Integer_Type (Target_Type)
6003 or else
6004 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
6005 then
6006 -- Special processing required if the conversion is the expression
6007 -- of a Truncation attribute reference. In this case we replace:
6008
6009 -- ityp (ftyp'Truncation (x))
6010
6011 -- by
6012
6013 -- ityp (x)
6014
6015 -- with the Float_Truncate flag set. This is clearly more efficient.
6016
6017 if Nkind (Operand) = N_Attribute_Reference
6018 and then Attribute_Name (Operand) = Name_Truncation
6019 then
6020 Rewrite (Operand,
6021 Relocate_Node (First (Expressions (Operand))));
6022 Set_Float_Truncate (N, True);
6023 end if;
6024
6025 -- One more check here, gcc is still not able to do conversions of
6026 -- this type with proper overflow checking, and so gigi is doing an
6027 -- approximation of what is required by doing floating-point compares
6028 -- with the end-point. But that can lose precision in some cases, and
6029 -- give a wrong result. Converting the operand to Long_Long_Float is
6030 -- helpful, but still does not catch all cases with 64-bit integers
6031 -- on targets with only 64-bit floats ???
6032
9dfe12ae 6033 if Do_Range_Check (Operand) then
6034 Rewrite (Operand,
ee6ba406 6035 Make_Type_Conversion (Loc,
6036 Subtype_Mark =>
6037 New_Occurrence_Of (Standard_Long_Long_Float, Loc),
6038 Expression =>
9dfe12ae 6039 Relocate_Node (Operand)));
ee6ba406 6040
9dfe12ae 6041 Set_Etype (Operand, Standard_Long_Long_Float);
6042 Enable_Range_Check (Operand);
6043 Set_Do_Range_Check (Expression (Operand), False);
ee6ba406 6044 end if;
6045
6046 -- Case of array conversions
6047
6048 -- Expansion of array conversions, add required length/range checks
6049 -- but only do this if there is no change of representation. For
6050 -- handling of this case, see Handle_Changed_Representation.
6051
6052 elsif Is_Array_Type (Target_Type) then
6053
6054 if Is_Constrained (Target_Type) then
6055 Apply_Length_Check (Operand, Target_Type);
6056 else
6057 Apply_Range_Check (Operand, Target_Type);
6058 end if;
6059
6060 Handle_Changed_Representation;
6061
6062 -- Case of conversions of discriminated types
6063
6064 -- Add required discriminant checks if target is constrained. Again
6065 -- this change is skipped if we have a change of representation.
6066
6067 elsif Has_Discriminants (Target_Type)
6068 and then Is_Constrained (Target_Type)
6069 then
6070 Apply_Discriminant_Check (Operand, Target_Type);
6071 Handle_Changed_Representation;
6072
6073 -- Case of all other record conversions. The only processing required
6074 -- is to check for a change of representation requiring the special
6075 -- assignment processing.
6076
6077 elsif Is_Record_Type (Target_Type) then
6078 Handle_Changed_Representation;
6079
6080 -- Case of conversions of enumeration types
6081
6082 elsif Is_Enumeration_Type (Target_Type) then
6083
6084 -- Special processing is required if there is a change of
6085 -- representation (from enumeration representation clauses)
6086
6087 if not Same_Representation (Target_Type, Operand_Type) then
6088
6089 -- Convert: x(y) to x'val (ytyp'val (y))
6090
6091 Rewrite (N,
6092 Make_Attribute_Reference (Loc,
6093 Prefix => New_Occurrence_Of (Target_Type, Loc),
6094 Attribute_Name => Name_Val,
6095 Expressions => New_List (
6096 Make_Attribute_Reference (Loc,
6097 Prefix => New_Occurrence_Of (Operand_Type, Loc),
6098 Attribute_Name => Name_Pos,
6099 Expressions => New_List (Operand)))));
6100
6101 Analyze_And_Resolve (N, Target_Type);
6102 end if;
6103
6104 -- Case of conversions to floating-point
6105
6106 elsif Is_Floating_Point_Type (Target_Type) then
6107 Real_Range_Check;
6108
6109 -- The remaining cases require no front end processing
6110
6111 else
6112 null;
6113 end if;
6114
6115 -- At this stage, either the conversion node has been transformed
6116 -- into some other equivalent expression, or left as a conversion
6117 -- that can be handled by Gigi. The conversions that Gigi can handle
6118 -- are the following:
6119
6120 -- Conversions with no change of representation or type
6121
6122 -- Numeric conversions involving integer values, floating-point
6123 -- values, and fixed-point values. Fixed-point values are allowed
6124 -- only if Conversion_OK is set, i.e. if the fixed-point values
6125 -- are to be treated as integers.
6126
6127 -- No other conversions should be passed to Gigi.
6128
9dfe12ae 6129 -- The only remaining step is to generate a range check if we still
6130 -- have a type conversion at this stage and Do_Range_Check is set.
6131 -- For now we do this only for conversions of discrete types.
6132
6133 if Nkind (N) = N_Type_Conversion
6134 and then Is_Discrete_Type (Etype (N))
6135 then
6136 declare
6137 Expr : constant Node_Id := Expression (N);
6138 Ftyp : Entity_Id;
6139 Ityp : Entity_Id;
6140
6141 begin
6142 if Do_Range_Check (Expr)
6143 and then Is_Discrete_Type (Etype (Expr))
6144 then
6145 Set_Do_Range_Check (Expr, False);
6146
6147 -- Before we do a range check, we have to deal with treating
6148 -- a fixed-point operand as an integer. The way we do this
6149 -- is simply to do an unchecked conversion to an appropriate
6150 -- integer type large enough to hold the result.
6151
6152 -- This code is not active yet, because we are only dealing
6153 -- with discrete types so far ???
6154
6155 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
6156 and then Treat_Fixed_As_Integer (Expr)
6157 then
6158 Ftyp := Base_Type (Etype (Expr));
6159
6160 if Esize (Ftyp) >= Esize (Standard_Integer) then
6161 Ityp := Standard_Long_Long_Integer;
6162 else
6163 Ityp := Standard_Integer;
6164 end if;
6165
6166 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
6167 end if;
6168
6169 -- Reset overflow flag, since the range check will include
6170 -- dealing with possible overflow, and generate the check
6171
6172 Set_Do_Overflow_Check (N, False);
6173 Generate_Range_Check
6174 (Expr, Target_Type, CE_Range_Check_Failed);
6175 end if;
6176 end;
6177 end if;
ee6ba406 6178 end Expand_N_Type_Conversion;
6179
6180 -----------------------------------
6181 -- Expand_N_Unchecked_Expression --
6182 -----------------------------------
6183
6184 -- Remove the unchecked expression node from the tree. It's job was simply
6185 -- to make sure that its constituent expression was handled with checks
6186 -- off, and now that that is done, we can remove it from the tree, and
6187 -- indeed must, since gigi does not expect to see these nodes.
6188
6189 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
6190 Exp : constant Node_Id := Expression (N);
6191
6192 begin
6193 Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
6194 Rewrite (N, Exp);
6195 end Expand_N_Unchecked_Expression;
6196
6197 ----------------------------------------
6198 -- Expand_N_Unchecked_Type_Conversion --
6199 ----------------------------------------
6200
6201 -- If this cannot be handled by Gigi and we haven't already made
6202 -- a temporary for it, do it now.
6203
6204 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
6205 Target_Type : constant Entity_Id := Etype (N);
6206 Operand : constant Node_Id := Expression (N);
6207 Operand_Type : constant Entity_Id := Etype (Operand);
6208
6209 begin
6210 -- If we have a conversion of a compile time known value to a target
6211 -- type and the value is in range of the target type, then we can simply
6212 -- replace the construct by an integer literal of the correct type. We
6213 -- only apply this to integer types being converted. Possibly it may
6214 -- apply in other cases, but it is too much trouble to worry about.
6215
6216 -- Note that we do not do this transformation if the Kill_Range_Check
6217 -- flag is set, since then the value may be outside the expected range.
6218 -- This happens in the Normalize_Scalars case.
6219
6220 if Is_Integer_Type (Target_Type)
6221 and then Is_Integer_Type (Operand_Type)
6222 and then Compile_Time_Known_Value (Operand)
6223 and then not Kill_Range_Check (N)
6224 then
6225 declare
6226 Val : constant Uint := Expr_Value (Operand);
6227
6228 begin
6229 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
6230 and then
6231 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
6232 and then
6233 Val >= Expr_Value (Type_Low_Bound (Target_Type))
6234 and then
6235 Val <= Expr_Value (Type_High_Bound (Target_Type))
6236 then
6237 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
6238 Analyze_And_Resolve (N, Target_Type);
6239 return;
6240 end if;
6241 end;
6242 end if;
6243
6244 -- Nothing to do if conversion is safe
6245
6246 if Safe_Unchecked_Type_Conversion (N) then
6247 return;
6248 end if;
6249
6250 -- Otherwise force evaluation unless Assignment_OK flag is set (this
6251 -- flag indicates ??? -- more comments needed here)
6252
6253 if Assignment_OK (N) then
6254 null;
6255 else
6256 Force_Evaluation (N);
6257 end if;
6258 end Expand_N_Unchecked_Type_Conversion;
6259
6260 ----------------------------
6261 -- Expand_Record_Equality --
6262 ----------------------------
6263
6264 -- For non-variant records, Equality is expanded when needed into:
6265
6266 -- and then Lhs.Discr1 = Rhs.Discr1
6267 -- and then ...
6268 -- and then Lhs.Discrn = Rhs.Discrn
6269 -- and then Lhs.Cmp1 = Rhs.Cmp1
6270 -- and then ...
6271 -- and then Lhs.Cmpn = Rhs.Cmpn
6272
6273 -- The expression is folded by the back-end for adjacent fields. This
6274 -- function is called for tagged record in only one occasion: for imple-
6275 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
6276 -- otherwise the primitive "=" is used directly.
6277
6278 function Expand_Record_Equality
6279 (Nod : Node_Id;
6280 Typ : Entity_Id;
6281 Lhs : Node_Id;
6282 Rhs : Node_Id;
6283 Bodies : List_Id)
6284 return Node_Id
6285 is
6286 Loc : constant Source_Ptr := Sloc (Nod);
6287
6288 function Suitable_Element (C : Entity_Id) return Entity_Id;
6289 -- Return the first field to compare beginning with C, skipping the
6290 -- inherited components
6291
6292 function Suitable_Element (C : Entity_Id) return Entity_Id is
6293 begin
6294 if No (C) then
6295 return Empty;
6296
6297 elsif Ekind (C) /= E_Discriminant
6298 and then Ekind (C) /= E_Component
6299 then
6300 return Suitable_Element (Next_Entity (C));
6301
6302 elsif Is_Tagged_Type (Typ)
6303 and then C /= Original_Record_Component (C)
6304 then
6305 return Suitable_Element (Next_Entity (C));
6306
6307 elsif Chars (C) = Name_uController
6308 or else Chars (C) = Name_uTag
6309 then
6310 return Suitable_Element (Next_Entity (C));
6311
6312 else
6313 return C;
6314 end if;
6315 end Suitable_Element;
6316
6317 Result : Node_Id;
6318 C : Entity_Id;
6319
6320 First_Time : Boolean := True;
6321
6322 -- Start of processing for Expand_Record_Equality
6323
6324 begin
6325 -- Special processing for the unchecked union case, which will occur
6326 -- only in the context of tagged types and dynamic dispatching, since
6327 -- other cases are handled statically. We return True, but insert a
6328 -- raise Program_Error statement.
6329
6330 if Is_Unchecked_Union (Typ) then
6331
6332 -- If this is a component of an enclosing record, return the Raise
6333 -- statement directly.
6334
6335 if No (Parent (Lhs)) then
f15731c4 6336 Result :=
6337 Make_Raise_Program_Error (Loc,
6338 Reason => PE_Unchecked_Union_Restriction);
ee6ba406 6339 Set_Etype (Result, Standard_Boolean);
6340 return Result;
6341
6342 else
6343 Insert_Action (Lhs,
f15731c4 6344 Make_Raise_Program_Error (Loc,
6345 Reason => PE_Unchecked_Union_Restriction));
ee6ba406 6346 return New_Occurrence_Of (Standard_True, Loc);
6347 end if;
6348 end if;
6349
6350 -- Generates the following code: (assuming that Typ has one Discr and
6351 -- component C2 is also a record)
6352
6353 -- True
6354 -- and then Lhs.Discr1 = Rhs.Discr1
6355 -- and then Lhs.C1 = Rhs.C1
6356 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
6357 -- and then ...
6358 -- and then Lhs.Cmpn = Rhs.Cmpn
6359
6360 Result := New_Reference_To (Standard_True, Loc);
6361 C := Suitable_Element (First_Entity (Typ));
6362
6363 while Present (C) loop
6364
6365 declare
6366 New_Lhs : Node_Id;
6367 New_Rhs : Node_Id;
6368
6369 begin
6370 if First_Time then
6371 First_Time := False;
6372 New_Lhs := Lhs;
6373 New_Rhs := Rhs;
6374
6375 else
6376 New_Lhs := New_Copy_Tree (Lhs);
6377 New_Rhs := New_Copy_Tree (Rhs);
6378 end if;
6379
6380 Result :=
6381 Make_And_Then (Loc,
6382 Left_Opnd => Result,
6383 Right_Opnd =>
6384 Expand_Composite_Equality (Nod, Etype (C),
6385 Lhs =>
6386 Make_Selected_Component (Loc,
6387 Prefix => New_Lhs,
6388 Selector_Name => New_Reference_To (C, Loc)),
6389 Rhs =>
6390 Make_Selected_Component (Loc,
6391 Prefix => New_Rhs,
6392 Selector_Name => New_Reference_To (C, Loc)),
6393 Bodies => Bodies));
6394 end;
6395
6396 C := Suitable_Element (Next_Entity (C));
6397 end loop;
6398
6399 return Result;
6400 end Expand_Record_Equality;
6401
6402 -------------------------------------
6403 -- Fixup_Universal_Fixed_Operation --
6404 -------------------------------------
6405
6406 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
6407 Conv : constant Node_Id := Parent (N);
6408
6409 begin
6410 -- We must have a type conversion immediately above us
6411
6412 pragma Assert (Nkind (Conv) = N_Type_Conversion);
6413
6414 -- Normally the type conversion gives our target type. The exception
6415 -- occurs in the case of the Round attribute, where the conversion
6416 -- will be to universal real, and our real type comes from the Round
6417 -- attribute (as well as an indication that we must round the result)
6418
6419 if Nkind (Parent (Conv)) = N_Attribute_Reference
6420 and then Attribute_Name (Parent (Conv)) = Name_Round
6421 then
6422 Set_Etype (N, Etype (Parent (Conv)));
6423 Set_Rounded_Result (N);
6424
6425 -- Normal case where type comes from conversion above us
6426
6427 else
6428 Set_Etype (N, Etype (Conv));
6429 end if;
6430 end Fixup_Universal_Fixed_Operation;
6431
9dfe12ae 6432 ------------------------------
6433 -- Get_Allocator_Final_List --
6434 ------------------------------
6435
6436 function Get_Allocator_Final_List
6437 (N : Node_Id;
6438 T : Entity_Id;
6439 PtrT : Entity_Id)
6440 return Entity_Id
6441 is
6442 Loc : constant Source_Ptr := Sloc (N);
6443 Acc : Entity_Id;
6444
6445 begin
6446 -- If the context is an access parameter, we need to create
6447 -- a non-anonymous access type in order to have a usable
6448 -- final list, because there is otherwise no pool to which
6449 -- the allocated object can belong. We create both the type
6450 -- and the finalization chain here, because freezing an
6451 -- internal type does not create such a chain. The Final_Chain
6452 -- that is thus created is shared by the access parameter.
6453
6454 if Ekind (PtrT) = E_Anonymous_Access_Type then
6455 Acc := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
6456 Insert_Action (N,
6457 Make_Full_Type_Declaration (Loc,
6458 Defining_Identifier => Acc,
6459 Type_Definition =>
6460 Make_Access_To_Object_Definition (Loc,
6461 Subtype_Indication =>
6462 New_Occurrence_Of (T, Loc))));
6463
6464 Build_Final_List (N, Acc);
6465 Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc));
6466 return Find_Final_List (Acc);
6467
6468 else
6469 return Find_Final_List (PtrT);
6470 end if;
6471 end Get_Allocator_Final_List;
6472
ee6ba406 6473 -------------------------------
6474 -- Insert_Dereference_Action --
6475 -------------------------------
6476
6477 procedure Insert_Dereference_Action (N : Node_Id) is
6478 Loc : constant Source_Ptr := Sloc (N);
6479 Typ : constant Entity_Id := Etype (N);
6480 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
6481
6482 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
6483 -- return true if type of P is derived from Checked_Pool;
6484
6485 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
6486 T : Entity_Id;
6487
6488 begin
6489 if No (P) then
6490 return False;
6491 end if;
6492
6493 T := Etype (P);
6494 while T /= Etype (T) loop
6495 if Is_RTE (T, RE_Checked_Pool) then
6496 return True;
6497 else
6498 T := Etype (T);
6499 end if;
6500 end loop;
6501
6502 return False;
6503 end Is_Checked_Storage_Pool;
6504
6505 -- Start of processing for Insert_Dereference_Action
6506
6507 begin
6508 if not Comes_From_Source (Parent (N)) then
6509 return;
6510
6511 elsif not Is_Checked_Storage_Pool (Pool) then
6512 return;
6513 end if;
6514
6515 Insert_Action (N,
6516 Make_Procedure_Call_Statement (Loc,
6517 Name => New_Reference_To (
6518 Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
6519
6520 Parameter_Associations => New_List (
6521
6522 -- Pool
6523
6524 New_Reference_To (Pool, Loc),
6525
9dfe12ae 6526 -- Storage_Address. We use the attribute Pool_Address,
6527 -- which uses the pointer itself to find the address of
6528 -- the object, and which handles unconstrained arrays
6529 -- properly by computing the address of the template.
6530 -- i.e. the correct address of the corresponding allocation.
ee6ba406 6531
6532 Make_Attribute_Reference (Loc,
9dfe12ae 6533 Prefix => Duplicate_Subexpr_Move_Checks (N),
6534 Attribute_Name => Name_Pool_Address),
ee6ba406 6535
6536 -- Size_In_Storage_Elements
6537
6538 Make_Op_Divide (Loc,
6539 Left_Opnd =>
6540 Make_Attribute_Reference (Loc,
6541 Prefix =>
9dfe12ae 6542 Make_Explicit_Dereference (Loc,
6543 Duplicate_Subexpr_Move_Checks (N)),
ee6ba406 6544 Attribute_Name => Name_Size),
6545 Right_Opnd =>
6546 Make_Integer_Literal (Loc, System_Storage_Unit)),
6547
6548 -- Alignment
6549
6550 Make_Attribute_Reference (Loc,
6551 Prefix =>
9dfe12ae 6552 Make_Explicit_Dereference (Loc,
6553 Duplicate_Subexpr_Move_Checks (N)),
ee6ba406 6554 Attribute_Name => Name_Alignment))));
6555
9dfe12ae 6556 exception
6557 when RE_Not_Available =>
6558 return;
ee6ba406 6559 end Insert_Dereference_Action;
6560
6561 ------------------------------
6562 -- Make_Array_Comparison_Op --
6563 ------------------------------
6564
6565 -- This is a hand-coded expansion of the following generic function:
6566
6567 -- generic
6568 -- type elem is (<>);
6569 -- type index is (<>);
6570 -- type a is array (index range <>) of elem;
6571 --
6572 -- function Gnnn (X : a; Y: a) return boolean is
6573 -- J : index := Y'first;
6574 --
6575 -- begin
6576 -- if X'length = 0 then
6577 -- return false;
6578 --
6579 -- elsif Y'length = 0 then
6580 -- return true;
6581 --
6582 -- else
6583 -- for I in X'range loop
6584 -- if X (I) = Y (J) then
6585 -- if J = Y'last then
6586 -- exit;
6587 -- else
6588 -- J := index'succ (J);
6589 -- end if;
6590 --
6591 -- else
6592 -- return X (I) > Y (J);
6593 -- end if;
6594 -- end loop;
6595 --
6596 -- return X'length > Y'length;
6597 -- end if;
6598 -- end Gnnn;
6599
6600 -- Note that since we are essentially doing this expansion by hand, we
6601 -- do not need to generate an actual or formal generic part, just the
6602 -- instantiated function itself.
6603
6604 function Make_Array_Comparison_Op
6605 (Typ : Entity_Id;
6606 Nod : Node_Id)
6607 return Node_Id
6608 is
6609 Loc : constant Source_Ptr := Sloc (Nod);
6610
6611 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
6612 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
6613 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
6614 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
6615
6616 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
6617
6618 Loop_Statement : Node_Id;
6619 Loop_Body : Node_Id;
6620 If_Stat : Node_Id;
6621 Inner_If : Node_Id;
6622 Final_Expr : Node_Id;
6623 Func_Body : Node_Id;
6624 Func_Name : Entity_Id;
6625 Formals : List_Id;
6626 Length1 : Node_Id;
6627 Length2 : Node_Id;
6628
6629 begin
6630 -- if J = Y'last then
6631 -- exit;
6632 -- else
6633 -- J := index'succ (J);
6634 -- end if;
6635
6636 Inner_If :=
6637 Make_Implicit_If_Statement (Nod,
6638 Condition =>
6639 Make_Op_Eq (Loc,
6640 Left_Opnd => New_Reference_To (J, Loc),
6641 Right_Opnd =>
6642 Make_Attribute_Reference (Loc,
6643 Prefix => New_Reference_To (Y, Loc),
6644 Attribute_Name => Name_Last)),
6645
6646 Then_Statements => New_List (
6647 Make_Exit_Statement (Loc)),
6648
6649 Else_Statements =>
6650 New_List (
6651 Make_Assignment_Statement (Loc,
6652 Name => New_Reference_To (J, Loc),
6653 Expression =>
6654 Make_Attribute_Reference (Loc,
6655 Prefix => New_Reference_To (Index, Loc),
6656 Attribute_Name => Name_Succ,
6657 Expressions => New_List (New_Reference_To (J, Loc))))));
6658
6659 -- if X (I) = Y (J) then
6660 -- if ... end if;
6661 -- else
6662 -- return X (I) > Y (J);
6663 -- end if;
6664
6665 Loop_Body :=
6666 Make_Implicit_If_Statement (Nod,
6667 Condition =>
6668 Make_Op_Eq (Loc,
6669 Left_Opnd =>
6670 Make_Indexed_Component (Loc,
6671 Prefix => New_Reference_To (X, Loc),
6672 Expressions => New_List (New_Reference_To (I, Loc))),
6673
6674 Right_Opnd =>
6675 Make_Indexed_Component (Loc,
6676 Prefix => New_Reference_To (Y, Loc),
6677 Expressions => New_List (New_Reference_To (J, Loc)))),
6678
6679 Then_Statements => New_List (Inner_If),
6680
6681 Else_Statements => New_List (
6682 Make_Return_Statement (Loc,
6683 Expression =>
6684 Make_Op_Gt (Loc,
6685 Left_Opnd =>
6686 Make_Indexed_Component (Loc,
6687 Prefix => New_Reference_To (X, Loc),
6688 Expressions => New_List (New_Reference_To (I, Loc))),
6689
6690 Right_Opnd =>
6691 Make_Indexed_Component (Loc,
6692 Prefix => New_Reference_To (Y, Loc),
6693 Expressions => New_List (
6694 New_Reference_To (J, Loc)))))));
6695
6696 -- for I in X'range loop
6697 -- if ... end if;
6698 -- end loop;
6699
6700 Loop_Statement :=
6701 Make_Implicit_Loop_Statement (Nod,
6702 Identifier => Empty,
6703
6704 Iteration_Scheme =>
6705 Make_Iteration_Scheme (Loc,
6706 Loop_Parameter_Specification =>
6707 Make_Loop_Parameter_Specification (Loc,
6708 Defining_Identifier => I,
6709 Discrete_Subtype_Definition =>
6710 Make_Attribute_Reference (Loc,
6711 Prefix => New_Reference_To (X, Loc),
6712 Attribute_Name => Name_Range))),
6713
6714 Statements => New_List (Loop_Body));
6715
6716 -- if X'length = 0 then
6717 -- return false;
6718 -- elsif Y'length = 0 then
6719 -- return true;
6720 -- else
6721 -- for ... loop ... end loop;
6722 -- return X'length > Y'length;
6723 -- end if;
6724
6725 Length1 :=
6726 Make_Attribute_Reference (Loc,
6727 Prefix => New_Reference_To (X, Loc),
6728 Attribute_Name => Name_Length);
6729
6730 Length2 :=
6731 Make_Attribute_Reference (Loc,
6732 Prefix => New_Reference_To (Y, Loc),
6733 Attribute_Name => Name_Length);
6734
6735 Final_Expr :=
6736 Make_Op_Gt (Loc,
6737 Left_Opnd => Length1,
6738 Right_Opnd => Length2);
6739
6740 If_Stat :=
6741 Make_Implicit_If_Statement (Nod,
6742 Condition =>
6743 Make_Op_Eq (Loc,
6744 Left_Opnd =>
6745 Make_Attribute_Reference (Loc,
6746 Prefix => New_Reference_To (X, Loc),
6747 Attribute_Name => Name_Length),
6748 Right_Opnd =>
6749 Make_Integer_Literal (Loc, 0)),
6750
6751 Then_Statements =>
6752 New_List (
6753 Make_Return_Statement (Loc,
6754 Expression => New_Reference_To (Standard_False, Loc))),
6755
6756 Elsif_Parts => New_List (
6757 Make_Elsif_Part (Loc,
6758 Condition =>
6759 Make_Op_Eq (Loc,
6760 Left_Opnd =>
6761 Make_Attribute_Reference (Loc,
6762 Prefix => New_Reference_To (Y, Loc),
6763 Attribute_Name => Name_Length),
6764 Right_Opnd =>
6765 Make_Integer_Literal (Loc, 0)),
6766
6767 Then_Statements =>
6768 New_List (
6769 Make_Return_Statement (Loc,
6770 Expression => New_Reference_To (Standard_True, Loc))))),
6771
6772 Else_Statements => New_List (
6773 Loop_Statement,
6774 Make_Return_Statement (Loc,
6775 Expression => Final_Expr)));
6776
6777 -- (X : a; Y: a)
6778
6779 Formals := New_List (
6780 Make_Parameter_Specification (Loc,
6781 Defining_Identifier => X,
6782 Parameter_Type => New_Reference_To (Typ, Loc)),
6783
6784 Make_Parameter_Specification (Loc,
6785 Defining_Identifier => Y,
6786 Parameter_Type => New_Reference_To (Typ, Loc)));
6787
6788 -- function Gnnn (...) return boolean is
6789 -- J : index := Y'first;
6790 -- begin
6791 -- if ... end if;
6792 -- end Gnnn;
6793
6794 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
6795
6796 Func_Body :=
6797 Make_Subprogram_Body (Loc,
6798 Specification =>
6799 Make_Function_Specification (Loc,
6800 Defining_Unit_Name => Func_Name,
6801 Parameter_Specifications => Formals,
6802 Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
6803
6804 Declarations => New_List (
6805 Make_Object_Declaration (Loc,
6806 Defining_Identifier => J,
6807 Object_Definition => New_Reference_To (Index, Loc),
6808 Expression =>
6809 Make_Attribute_Reference (Loc,
6810 Prefix => New_Reference_To (Y, Loc),
6811 Attribute_Name => Name_First))),
6812
6813 Handled_Statement_Sequence =>
6814 Make_Handled_Sequence_Of_Statements (Loc,
6815 Statements => New_List (If_Stat)));
6816
6817 return Func_Body;
6818
6819 end Make_Array_Comparison_Op;
6820
6821 ---------------------------
6822 -- Make_Boolean_Array_Op --
6823 ---------------------------
6824
6825 -- For logical operations on boolean arrays, expand in line the
6826 -- following, replacing 'and' with 'or' or 'xor' where needed:
6827
6828 -- function Annn (A : typ; B: typ) return typ is
6829 -- C : typ;
6830 -- begin
6831 -- for J in A'range loop
6832 -- C (J) := A (J) op B (J);
6833 -- end loop;
6834 -- return C;
6835 -- end Annn;
6836
6837 -- Here typ is the boolean array type
6838
6839 function Make_Boolean_Array_Op
6840 (Typ : Entity_Id;
6841 N : Node_Id)
6842 return Node_Id
6843 is
6844 Loc : constant Source_Ptr := Sloc (N);
6845
6846 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
6847 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
6848 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
6849 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
6850
6851 A_J : Node_Id;
6852 B_J : Node_Id;
6853 C_J : Node_Id;
6854 Op : Node_Id;
6855
6856 Formals : List_Id;
6857 Func_Name : Entity_Id;
6858 Func_Body : Node_Id;
6859 Loop_Statement : Node_Id;
6860
6861 begin
6862 A_J :=
6863 Make_Indexed_Component (Loc,
6864 Prefix => New_Reference_To (A, Loc),
6865 Expressions => New_List (New_Reference_To (J, Loc)));
6866
6867 B_J :=
6868 Make_Indexed_Component (Loc,
6869 Prefix => New_Reference_To (B, Loc),
6870 Expressions => New_List (New_Reference_To (J, Loc)));
6871
6872 C_J :=
6873 Make_Indexed_Component (Loc,
6874 Prefix => New_Reference_To (C, Loc),
6875 Expressions => New_List (New_Reference_To (J, Loc)));
6876
6877 if Nkind (N) = N_Op_And then
6878 Op :=
6879 Make_Op_And (Loc,
6880 Left_Opnd => A_J,
6881 Right_Opnd => B_J);
6882
6883 elsif Nkind (N) = N_Op_Or then
6884 Op :=
6885 Make_Op_Or (Loc,
6886 Left_Opnd => A_J,
6887 Right_Opnd => B_J);
6888
6889 else
6890 Op :=
6891 Make_Op_Xor (Loc,
6892 Left_Opnd => A_J,
6893 Right_Opnd => B_J);
6894 end if;
6895
6896 Loop_Statement :=
6897 Make_Implicit_Loop_Statement (N,
6898 Identifier => Empty,
6899
6900 Iteration_Scheme =>
6901 Make_Iteration_Scheme (Loc,
6902 Loop_Parameter_Specification =>
6903 Make_Loop_Parameter_Specification (Loc,
6904 Defining_Identifier => J,
6905 Discrete_Subtype_Definition =>
6906 Make_Attribute_Reference (Loc,
6907 Prefix => New_Reference_To (A, Loc),
6908 Attribute_Name => Name_Range))),
6909
6910 Statements => New_List (
6911 Make_Assignment_Statement (Loc,
6912 Name => C_J,
6913 Expression => Op)));
6914
6915 Formals := New_List (
6916 Make_Parameter_Specification (Loc,
6917 Defining_Identifier => A,
6918 Parameter_Type => New_Reference_To (Typ, Loc)),
6919
6920 Make_Parameter_Specification (Loc,
6921 Defining_Identifier => B,
6922 Parameter_Type => New_Reference_To (Typ, Loc)));
6923
6924 Func_Name :=
6925 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6926 Set_Is_Inlined (Func_Name);
6927
6928 Func_Body :=
6929 Make_Subprogram_Body (Loc,
6930 Specification =>
6931 Make_Function_Specification (Loc,
6932 Defining_Unit_Name => Func_Name,
6933 Parameter_Specifications => Formals,
6934 Subtype_Mark => New_Reference_To (Typ, Loc)),
6935
6936 Declarations => New_List (
6937 Make_Object_Declaration (Loc,
6938 Defining_Identifier => C,
6939 Object_Definition => New_Reference_To (Typ, Loc))),
6940
6941 Handled_Statement_Sequence =>
6942 Make_Handled_Sequence_Of_Statements (Loc,
6943 Statements => New_List (
6944 Loop_Statement,
6945 Make_Return_Statement (Loc,
6946 Expression => New_Reference_To (C, Loc)))));
6947
6948 return Func_Body;
6949 end Make_Boolean_Array_Op;
6950
6951 ------------------------
6952 -- Rewrite_Comparison --
6953 ------------------------
6954
6955 procedure Rewrite_Comparison (N : Node_Id) is
6956 Typ : constant Entity_Id := Etype (N);
6957 Op1 : constant Node_Id := Left_Opnd (N);
6958 Op2 : constant Node_Id := Right_Opnd (N);
6959
6960 Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
6961 -- Res indicates if compare outcome can be determined at compile time
6962
6963 True_Result : Boolean;
6964 False_Result : Boolean;
6965
6966 begin
6967 case N_Op_Compare (Nkind (N)) is
6968 when N_Op_Eq =>
6969 True_Result := Res = EQ;
6970 False_Result := Res = LT or else Res = GT or else Res = NE;
6971
6972 when N_Op_Ge =>
6973 True_Result := Res in Compare_GE;
6974 False_Result := Res = LT;
6975
6976 when N_Op_Gt =>
6977 True_Result := Res = GT;
6978 False_Result := Res in Compare_LE;
6979
6980 when N_Op_Lt =>
6981 True_Result := Res = LT;
6982 False_Result := Res in Compare_GE;
6983
6984 when N_Op_Le =>
6985 True_Result := Res in Compare_LE;
6986 False_Result := Res = GT;
6987
6988 when N_Op_Ne =>
6989 True_Result := Res = NE;
6990 False_Result := Res = LT or else Res = GT or else Res = EQ;
6991 end case;
6992
6993 if True_Result then
6994 Rewrite (N,
6995 Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
6996 Analyze_And_Resolve (N, Typ);
f15731c4 6997 Warn_On_Known_Condition (N);
ee6ba406 6998
6999 elsif False_Result then
7000 Rewrite (N,
7001 Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
7002 Analyze_And_Resolve (N, Typ);
f15731c4 7003 Warn_On_Known_Condition (N);
ee6ba406 7004 end if;
7005 end Rewrite_Comparison;
7006
9dfe12ae 7007 ----------------------------
7008 -- Safe_In_Place_Array_Op --
7009 ----------------------------
7010
7011 function Safe_In_Place_Array_Op
7012 (Lhs : Node_Id;
7013 Op1 : Node_Id;
7014 Op2 : Node_Id)
7015 return Boolean
7016 is
7017 Target : Entity_Id;
7018
7019 function Is_Safe_Operand (Op : Node_Id) return Boolean;
7020 -- Operand is safe if it cannot overlap part of the target of the
7021 -- operation. If the operand and the target are identical, the operand
7022 -- is safe. The operand can be empty in the case of negation.
7023
7024 function Is_Unaliased (N : Node_Id) return Boolean;
7025 -- Check that N is a stand-alone entity.
7026
7027 ------------------
7028 -- Is_Unaliased --
7029 ------------------
7030
7031 function Is_Unaliased (N : Node_Id) return Boolean is
7032 begin
7033 return
7034 Is_Entity_Name (N)
7035 and then No (Address_Clause (Entity (N)))
7036 and then No (Renamed_Object (Entity (N)));
7037 end Is_Unaliased;
7038
7039 ---------------------
7040 -- Is_Safe_Operand --
7041 ---------------------
7042
7043 function Is_Safe_Operand (Op : Node_Id) return Boolean is
7044 begin
7045 if No (Op) then
7046 return True;
7047
7048 elsif Is_Entity_Name (Op) then
7049 return Is_Unaliased (Op);
7050
7051 elsif Nkind (Op) = N_Indexed_Component
7052 or else Nkind (Op) = N_Selected_Component
7053 then
7054 return Is_Unaliased (Prefix (Op));
7055
7056 elsif Nkind (Op) = N_Slice then
7057 return
7058 Is_Unaliased (Prefix (Op))
7059 and then Entity (Prefix (Op)) /= Target;
7060
7061 elsif Nkind (Op) = N_Op_Not then
7062 return Is_Safe_Operand (Right_Opnd (Op));
7063
7064 else
7065 return False;
7066 end if;
7067 end Is_Safe_Operand;
7068
7069 -- Start of processing for Is_Safe_In_Place_Array_Op
7070
7071 begin
7072 -- We skip this processing if the component size is not the
7073 -- same as a system storage unit (since at least for NOT
7074 -- this would cause problems).
7075
7076 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
7077 return False;
7078
7079 -- Cannot do in place stuff on Java_VM since cannot pass addresses
7080
7081 elsif Java_VM then
7082 return False;
7083
7084 -- Cannot do in place stuff if non-standard Boolean representation
7085
7086 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
7087 return False;
7088
7089 elsif not Is_Unaliased (Lhs) then
7090 return False;
7091 else
7092 Target := Entity (Lhs);
7093
7094 return
7095 Is_Safe_Operand (Op1)
7096 and then Is_Safe_Operand (Op2);
7097 end if;
7098 end Safe_In_Place_Array_Op;
7099
ee6ba406 7100 -----------------------
7101 -- Tagged_Membership --
7102 -----------------------
7103
7104 -- There are two different cases to consider depending on whether
7105 -- the right operand is a class-wide type or not. If not we just
7106 -- compare the actual tag of the left expr to the target type tag:
7107 --
7108 -- Left_Expr.Tag = Right_Type'Tag;
7109 --
7110 -- If it is a class-wide type we use the RT function CW_Membership which
7111 -- is usually implemented by looking in the ancestor tables contained in
7112 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7113
7114 function Tagged_Membership (N : Node_Id) return Node_Id is
7115 Left : constant Node_Id := Left_Opnd (N);
7116 Right : constant Node_Id := Right_Opnd (N);
7117 Loc : constant Source_Ptr := Sloc (N);
7118
7119 Left_Type : Entity_Id;
7120 Right_Type : Entity_Id;
7121 Obj_Tag : Node_Id;
7122
7123 begin
7124 Left_Type := Etype (Left);
7125 Right_Type := Etype (Right);
7126
7127 if Is_Class_Wide_Type (Left_Type) then
7128 Left_Type := Root_Type (Left_Type);
7129 end if;
7130
7131 Obj_Tag :=
7132 Make_Selected_Component (Loc,
7133 Prefix => Relocate_Node (Left),
7134 Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
7135
7136 if Is_Class_Wide_Type (Right_Type) then
7137 return
7138 Make_DT_Access_Action (Left_Type,
7139 Action => CW_Membership,
7140 Args => New_List (
7141 Obj_Tag,
7142 New_Reference_To (
7143 Access_Disp_Table (Root_Type (Right_Type)), Loc)));
7144 else
7145 return
7146 Make_Op_Eq (Loc,
7147 Left_Opnd => Obj_Tag,
7148 Right_Opnd =>
7149 New_Reference_To (Access_Disp_Table (Right_Type), Loc));
7150 end if;
7151
7152 end Tagged_Membership;
7153
7154 ------------------------------
7155 -- Unary_Op_Validity_Checks --
7156 ------------------------------
7157
7158 procedure Unary_Op_Validity_Checks (N : Node_Id) is
7159 begin
7160 if Validity_Checks_On and Validity_Check_Operands then
7161 Ensure_Valid (Right_Opnd (N));
7162 end if;
7163 end Unary_Op_Validity_Checks;
7164
7165end Exp_Ch4;
Mirror of https://gcc.gnu.org/git/gcc.git