?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
(extendsfdf2): Add pattern accidentally deleted when cirrus instructions were
[official-gcc.git] / gcc / ada / exp_util.adb
blobe1ed9be3075f54a5176008049ba8b5670728d9fd
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ U T I L --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 -- --
26 ------------------------------------------------------------------------------
27
28 with Atree; use Atree;
29 with Checks; use Checks;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Ch7; use Exp_Ch7;
34 with Exp_Ch11; use Exp_Ch11;
35 with Hostparm; use Hostparm;
36 with Inline; use Inline;
37 with Itypes; use Itypes;
38 with Lib; use Lib;
39 with Namet; use Namet;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
42 with Opt; use Opt;
43 with Restrict; use Restrict;
44 with Sem; use Sem;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Eval; use Sem_Eval;
47 with Sem_Res; use Sem_Res;
48 with Sem_Util; use Sem_Util;
49 with Sinfo; use Sinfo;
50 with Stand; use Stand;
51 with Stringt; use Stringt;
52 with Targparm; use Targparm;
53 with Tbuild; use Tbuild;
54 with Ttypes; use Ttypes;
55 with Uintp; use Uintp;
56 with Urealp; use Urealp;
57 with Validsw; use Validsw;
58
59 package body Exp_Util is
60
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
64
65 function Build_Task_Array_Image
66 (Loc : Source_Ptr;
67 Id_Ref : Node_Id;
68 A_Type : Entity_Id;
69 Dyn : Boolean := False)
70 return Node_Id;
71 -- Build function to generate the image string for a task that is an
72 -- array component, concatenating the images of each index. To avoid
73 -- storage leaks, the string is built with successive slice assignments.
74 -- The flag Dyn indicates whether this is called for the initialization
75 -- procedure of an array of tasks, or for the name of a dynamically
76 -- created task that is assigned to an indexed component.
77
78 function Build_Task_Image_Function
79 (Loc : Source_Ptr;
80 Decls : List_Id;
81 Stats : List_Id;
82 Res : Entity_Id)
83 return Node_Id;
84 -- Common processing for Task_Array_Image and Task_Record_Image.
85 -- Build function body that computes image.
86
87 procedure Build_Task_Image_Prefix
88 (Loc : Source_Ptr;
89 Len : out Entity_Id;
90 Res : out Entity_Id;
91 Pos : out Entity_Id;
92 Prefix : Entity_Id;
93 Sum : Node_Id;
94 Decls : in out List_Id;
95 Stats : in out List_Id);
96 -- Common processing for Task_Array_Image and Task_Record_Image.
97 -- Create local variables and assign prefix of name to result string.
98
99 function Build_Task_Record_Image
100 (Loc : Source_Ptr;
101 Id_Ref : Node_Id;
102 Dyn : Boolean := False)
103 return Node_Id;
104 -- Build function to generate the image string for a task that is a
105 -- record component. Concatenate name of variable with that of selector.
106 -- The flag Dyn indicates whether this is called for the initialization
107 -- procedure of record with task components, or for a dynamically
108 -- created task that is assigned to a selected component.
109
110 function Make_CW_Equivalent_Type
111 (T : Entity_Id;
112 E : Node_Id)
113 return Entity_Id;
114 -- T is a class-wide type entity, E is the initial expression node that
115 -- constrains T in case such as: " X: T := E" or "new T'(E)"
116 -- This function returns the entity of the Equivalent type and inserts
117 -- on the fly the necessary declaration such as:
118 -- type anon is record
119 -- _parent : Root_Type (T); constrained with E discriminants (if any)
120 -- Extension : String (1 .. expr to match size of E);
121 -- end record;
122 --
123 -- This record is compatible with any object of the class of T thanks
124 -- to the first field and has the same size as E thanks to the second.
125
126 function Make_Literal_Range
127 (Loc : Source_Ptr;
128 Literal_Typ : Entity_Id)
129 return Node_Id;
130 -- Produce a Range node whose bounds are:
131 -- Low_Bound (Literal_Type) ..
132 -- Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
133 -- this is used for expanding declarations like X : String := "sdfgdfg";
134
135 function New_Class_Wide_Subtype
136 (CW_Typ : Entity_Id;
137 N : Node_Id)
138 return Entity_Id;
139 -- Create an implicit subtype of CW_Typ attached to node N.
140
141 ----------------------
142 -- Adjust_Condition --
143 ----------------------
144
145 procedure Adjust_Condition (N : Node_Id) is
146 begin
147 if No (N) then
148 return;
149 end if;
150
151 declare
152 Loc : constant Source_Ptr := Sloc (N);
153 T : constant Entity_Id := Etype (N);
154 Ti : Entity_Id;
155
156 begin
157 -- For now, we simply ignore a call where the argument has no
158 -- type (probably case of unanalyzed condition), or has a type
159 -- that is not Boolean. This is because this is a pretty marginal
160 -- piece of functionality, and violations of these rules are
161 -- likely to be truly marginal (how much code uses Fortran Logical
162 -- as the barrier to a protected entry?) and we do not want to
163 -- blow up existing programs. We can change this to an assertion
164 -- after 3.12a is released ???
165
166 if No (T) or else not Is_Boolean_Type (T) then
167 return;
168 end if;
169
170 -- Apply validity checking if needed
171
172 if Validity_Checks_On and Validity_Check_Tests then
173 Ensure_Valid (N);
174 end if;
175
176 -- Immediate return if standard boolean, the most common case,
177 -- where nothing needs to be done.
178
179 if Base_Type (T) = Standard_Boolean then
180 return;
181 end if;
182
183 -- Case of zero/non-zero semantics or non-standard enumeration
184 -- representation. In each case, we rewrite the node as:
185
186 -- ityp!(N) /= False'Enum_Rep
187
188 -- where ityp is an integer type with large enough size to hold
189 -- any value of type T.
190
191 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
192 if Esize (T) <= Esize (Standard_Integer) then
193 Ti := Standard_Integer;
194 else
195 Ti := Standard_Long_Long_Integer;
196 end if;
197
198 Rewrite (N,
199 Make_Op_Ne (Loc,
200 Left_Opnd => Unchecked_Convert_To (Ti, N),
201 Right_Opnd =>
202 Make_Attribute_Reference (Loc,
203 Attribute_Name => Name_Enum_Rep,
204 Prefix =>
205 New_Occurrence_Of (First_Literal (T), Loc))));
206 Analyze_And_Resolve (N, Standard_Boolean);
207
208 else
209 Rewrite (N, Convert_To (Standard_Boolean, N));
210 Analyze_And_Resolve (N, Standard_Boolean);
211 end if;
212 end;
213 end Adjust_Condition;
214
215 ------------------------
216 -- Adjust_Result_Type --
217 ------------------------
218
219 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
220 begin
221 -- Ignore call if current type is not Standard.Boolean
222
223 if Etype (N) /= Standard_Boolean then
224 return;
225 end if;
226
227 -- If result is already of correct type, nothing to do. Note that
228 -- this will get the most common case where everything has a type
229 -- of Standard.Boolean.
230
231 if Base_Type (T) = Standard_Boolean then
232 return;
233
234 else
235 declare
236 KP : constant Node_Kind := Nkind (Parent (N));
237
238 begin
239 -- If result is to be used as a Condition in the syntax, no need
240 -- to convert it back, since if it was changed to Standard.Boolean
241 -- using Adjust_Condition, that is just fine for this usage.
242
243 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
244 return;
245
246 -- If result is an operand of another logical operation, no need
247 -- to reset its type, since Standard.Boolean is just fine, and
248 -- such operations always do Adjust_Condition on their operands.
249
250 elsif KP in N_Op_Boolean
251 or else KP = N_And_Then
252 or else KP = N_Or_Else
253 or else KP = N_Op_Not
254 then
255 return;
256
257 -- Otherwise we perform a conversion from the current type,
258 -- which must be Standard.Boolean, to the desired type.
259
260 else
261 Set_Analyzed (N);
262 Rewrite (N, Convert_To (T, N));
263 Analyze_And_Resolve (N, T);
264 end if;
265 end;
266 end if;
267 end Adjust_Result_Type;
268
269 --------------------------
270 -- Append_Freeze_Action --
271 --------------------------
272
273 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
274 Fnode : Node_Id := Freeze_Node (T);
275
276 begin
277 Ensure_Freeze_Node (T);
278 Fnode := Freeze_Node (T);
279
280 if not Present (Actions (Fnode)) then
281 Set_Actions (Fnode, New_List);
282 end if;
283
284 Append (N, Actions (Fnode));
285 end Append_Freeze_Action;
286
287 ---------------------------
288 -- Append_Freeze_Actions --
289 ---------------------------
290
291 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
292 Fnode : constant Node_Id := Freeze_Node (T);
293
294 begin
295 if No (L) then
296 return;
297
298 else
299 if No (Actions (Fnode)) then
300 Set_Actions (Fnode, L);
301
302 else
303 Append_List (L, Actions (Fnode));
304 end if;
305
306 end if;
307 end Append_Freeze_Actions;
308
309 ------------------------
310 -- Build_Runtime_Call --
311 ------------------------
312
313 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
314 begin
315 return
316 Make_Procedure_Call_Statement (Loc,
317 Name => New_Reference_To (RTE (RE), Loc));
318 end Build_Runtime_Call;
319
320 -----------------------------
321 -- Build_Task_Array_Image --
322 -----------------------------
323
324 -- This function generates the body for a function that constructs the
325 -- image string for a task that is an array component. The function is
326 -- local to the init_proc for the array type, and is called for each one
327 -- of the components. The constructed image has the form of an indexed
328 -- component, whose prefix is the outer variable of the array type.
329 -- The n-dimensional array type has known indices Index, Index2...
330 -- Id_Ref is an indexed component form created by the enclosing init_proc.
331 -- Its successive indices are Val1, Val2,.. which are the loop variables
332 -- in the loops that call the individual task init_proc on each component.
333
334 -- The generated function has the following structure:
335
336 -- function F return Task_Image_Type is
337 -- Pref : string := Task_Id.all;
338 -- T1 : String := Index1'Image (Val1);
339 -- ...
340 -- Tn : String := indexn'image (Valn);
341 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
342 -- -- Len includes commas and the end parentheses.
343 -- Res : String (1..Len);
344 -- Pos : Integer := Pref'Length;
345 --
346 -- begin
347 -- Res (1 .. Pos) := Pref;
348 -- Pos := Pos + 1;
349 -- Res (Pos) := '(';
350 -- Pos := Pos + 1;
351 -- Res (Pos .. Pos + T1'Length - 1) := T1;
352 -- Pos := Pos + T1'Length;
353 -- Res (Pos) := '.';
354 -- Pos := Pos + 1;
355 -- ...
356 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
357 -- Res (Len) := ')';
358 --
359 -- return new String (Res);
360 -- end F;
361 --
362 -- Needless to say, multidimensional arrays of tasks are rare enough
363 -- that the bulkiness of this code is not really a concern.
364
365 function Build_Task_Array_Image
366 (Loc : Source_Ptr;
367 Id_Ref : Node_Id;
368 A_Type : Entity_Id;
369 Dyn : Boolean := False)
370 return Node_Id
371 is
372 Dims : constant Nat := Number_Dimensions (A_Type);
373 -- Number of dimensions for array of tasks.
374
375 Temps : array (1 .. Dims) of Entity_Id;
376 -- Array of temporaries to hold string for each index.
377
378 Indx : Node_Id;
379 -- Index expression
380
381 Len : Entity_Id;
382 -- Total length of generated name
383
384 Pos : Entity_Id;
385 -- Running index for substring assignments
386
387 Pref : Entity_Id;
388 -- Name of enclosing variable, prefix of resulting name
389
390 P_Nam : Node_Id;
391 -- string expression for Pref.
392
393 Res : Entity_Id;
394 -- String to hold result
395
396 Val : Node_Id;
397 -- Value of successive indices
398
399 Sum : Node_Id;
400 -- Expression to compute total size of string
401
402 T : Entity_Id;
403 -- Entity for name at one index position
404
405 Decls : List_Id := New_List;
406 Stats : List_Id := New_List;
407
408 begin
409 Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
410
411 -- For a dynamic task, the name comes from the target variable.
412 -- For a static one it is a formal of the enclosing init_proc.
413
414 if Dyn then
415 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
416 P_Nam :=
417 Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
418 else
419 P_Nam :=
420 Make_Explicit_Dereference (Loc,
421 Prefix => Make_Identifier (Loc, Name_uTask_Id));
422 end if;
423
424 Append_To (Decls,
425 Make_Object_Declaration (Loc,
426 Defining_Identifier => Pref,
427 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
428 Expression => P_Nam));
429
430 Indx := First_Index (A_Type);
431 Val := First (Expressions (Id_Ref));
432
433 for J in 1 .. Dims loop
434 T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
435 Temps (J) := T;
436
437 Append_To (Decls,
438 Make_Object_Declaration (Loc,
439 Defining_Identifier => T,
440 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
441 Expression =>
442 Make_Attribute_Reference (Loc,
443 Attribute_Name => Name_Image,
444 Prefix =>
445 New_Occurrence_Of (Etype (Indx), Loc),
446 Expressions => New_List (
447 New_Copy_Tree (Val)))));
448
449 Next_Index (Indx);
450 Next (Val);
451 end loop;
452
453 Sum := Make_Integer_Literal (Loc, Dims + 1);
454
455 Sum :=
456 Make_Op_Add (Loc,
457 Left_Opnd => Sum,
458 Right_Opnd =>
459 Make_Attribute_Reference (Loc,
460 Attribute_Name => Name_Length,
461 Prefix =>
462 New_Occurrence_Of (Pref, Loc),
463 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
464
465 for J in 1 .. Dims loop
466 Sum :=
467 Make_Op_Add (Loc,
468 Left_Opnd => Sum,
469 Right_Opnd =>
470 Make_Attribute_Reference (Loc,
471 Attribute_Name => Name_Length,
472 Prefix =>
473 New_Occurrence_Of (Temps (J), Loc),
474 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
475 end loop;
476
477 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
478
479 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
480
481 Append_To (Stats,
482 Make_Assignment_Statement (Loc,
483 Name => Make_Indexed_Component (Loc,
484 Prefix => New_Occurrence_Of (Res, Loc),
485 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
486 Expression =>
487 Make_Character_Literal (Loc,
488 Chars => Name_Find,
489 Char_Literal_Value =>
490 Char_Code (Character'Pos ('(')))));
491
492 Append_To (Stats,
493 Make_Assignment_Statement (Loc,
494 Name => New_Occurrence_Of (Pos, Loc),
495 Expression =>
496 Make_Op_Add (Loc,
497 Left_Opnd => New_Occurrence_Of (Pos, Loc),
498 Right_Opnd => Make_Integer_Literal (Loc, 1))));
499
500 for J in 1 .. Dims loop
501
502 Append_To (Stats,
503 Make_Assignment_Statement (Loc,
504 Name => Make_Slice (Loc,
505 Prefix => New_Occurrence_Of (Res, Loc),
506 Discrete_Range =>
507 Make_Range (Loc,
508 Low_Bound => New_Occurrence_Of (Pos, Loc),
509 High_Bound => Make_Op_Subtract (Loc,
510 Left_Opnd =>
511 Make_Op_Add (Loc,
512 Left_Opnd => New_Occurrence_Of (Pos, Loc),
513 Right_Opnd =>
514 Make_Attribute_Reference (Loc,
515 Attribute_Name => Name_Length,
516 Prefix =>
517 New_Occurrence_Of (Temps (J), Loc),
518 Expressions =>
519 New_List (Make_Integer_Literal (Loc, 1)))),
520 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
521
522 Expression => New_Occurrence_Of (Temps (J), Loc)));
523
524 if J < Dims then
525 Append_To (Stats,
526 Make_Assignment_Statement (Loc,
527 Name => New_Occurrence_Of (Pos, Loc),
528 Expression =>
529 Make_Op_Add (Loc,
530 Left_Opnd => New_Occurrence_Of (Pos, Loc),
531 Right_Opnd =>
532 Make_Attribute_Reference (Loc,
533 Attribute_Name => Name_Length,
534 Prefix => New_Occurrence_Of (Temps (J), Loc),
535 Expressions =>
536 New_List (Make_Integer_Literal (Loc, 1))))));
537
538 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
539
540 Append_To (Stats,
541 Make_Assignment_Statement (Loc,
542 Name => Make_Indexed_Component (Loc,
543 Prefix => New_Occurrence_Of (Res, Loc),
544 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
545 Expression =>
546 Make_Character_Literal (Loc,
547 Chars => Name_Find,
548 Char_Literal_Value =>
549 Char_Code (Character'Pos (',')))));
550
551 Append_To (Stats,
552 Make_Assignment_Statement (Loc,
553 Name => New_Occurrence_Of (Pos, Loc),
554 Expression =>
555 Make_Op_Add (Loc,
556 Left_Opnd => New_Occurrence_Of (Pos, Loc),
557 Right_Opnd => Make_Integer_Literal (Loc, 1))));
558 end if;
559 end loop;
560
561 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
562
563 Append_To (Stats,
564 Make_Assignment_Statement (Loc,
565 Name => Make_Indexed_Component (Loc,
566 Prefix => New_Occurrence_Of (Res, Loc),
567 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
568 Expression =>
569 Make_Character_Literal (Loc,
570 Chars => Name_Find,
571 Char_Literal_Value =>
572 Char_Code (Character'Pos (')')))));
573 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
574 end Build_Task_Array_Image;
575
576 ----------------------------
577 -- Build_Task_Image_Decls --
578 ----------------------------
579
580 function Build_Task_Image_Decls
581 (Loc : Source_Ptr;
582 Id_Ref : Node_Id;
583 A_Type : Entity_Id)
584 return List_Id
585 is
586 T_Id : Entity_Id := Empty;
587 Decl : Node_Id;
588 Decls : List_Id := New_List;
589 Expr : Node_Id := Empty;
590 Fun : Node_Id := Empty;
591 Is_Dyn : constant Boolean :=
592 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
593 and then Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
594
595 begin
596 -- If Discard_Names is in effect, generate a dummy declaration only.
597
598 if Global_Discard_Names then
599 T_Id :=
600 Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
601
602 return
603 New_List (
604 Make_Object_Declaration (Loc,
605 Defining_Identifier => T_Id,
606 Object_Definition =>
607 New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc)));
608
609 else
610 if Nkind (Id_Ref) = N_Identifier
611 or else Nkind (Id_Ref) = N_Defining_Identifier
612 then
613 -- For a simple variable, the image of the task is the name
614 -- of the variable.
615
616 T_Id :=
617 Make_Defining_Identifier (Loc,
618 New_External_Name (Chars (Id_Ref), 'I'));
619
620 Get_Name_String (Chars (Id_Ref));
621
622 Expr :=
623 Make_Allocator (Loc,
624 Expression =>
625 Make_Qualified_Expression (Loc,
626 Subtype_Mark =>
627 New_Occurrence_Of (Standard_String, Loc),
628 Expression =>
629 Make_String_Literal
630 (Loc, Strval => String_From_Name_Buffer)));
631
632 elsif Nkind (Id_Ref) = N_Selected_Component then
633 T_Id :=
634 Make_Defining_Identifier (Loc,
635 New_External_Name (Chars (Selector_Name (Id_Ref)), 'I'));
636 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
637
638 elsif Nkind (Id_Ref) = N_Indexed_Component then
639 T_Id :=
640 Make_Defining_Identifier (Loc,
641 New_External_Name (Chars (A_Type), 'I'));
642
643 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
644 end if;
645 end if;
646
647 if Present (Fun) then
648 Append (Fun, Decls);
649
650 Expr :=
651 Make_Function_Call (Loc,
652 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
653 end if;
654
655 Decl := Make_Object_Declaration (Loc,
656 Defining_Identifier => T_Id,
657 Object_Definition =>
658 New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc),
659 Expression => Expr);
660
661 Append (Decl, Decls);
662 return Decls;
663 end Build_Task_Image_Decls;
664
665 -------------------------------
666 -- Build_Task_Image_Function --
667 -------------------------------
668
669 function Build_Task_Image_Function
670 (Loc : Source_Ptr;
671 Decls : List_Id;
672 Stats : List_Id;
673 Res : Entity_Id)
674 return Node_Id
675 is
676 Spec : Node_Id;
677
678 begin
679 Append_To (Stats,
680 Make_Return_Statement (Loc,
681 Expression =>
682 Make_Allocator (Loc,
683 Expression =>
684 Make_Qualified_Expression (Loc,
685 Subtype_Mark =>
686 New_Occurrence_Of (Standard_String, Loc),
687 Expression => New_Occurrence_Of (Res, Loc)))));
688
689 Spec := Make_Function_Specification (Loc,
690 Defining_Unit_Name =>
691 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
692 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc));
693
694 return Make_Subprogram_Body (Loc,
695 Specification => Spec,
696 Declarations => Decls,
697 Handled_Statement_Sequence =>
698 Make_Handled_Sequence_Of_Statements (Loc,
699 Statements => Stats));
700 end Build_Task_Image_Function;
701
702 -----------------------------
703 -- Build_Task_Image_Prefix --
704 -----------------------------
705
706 procedure Build_Task_Image_Prefix
707 (Loc : Source_Ptr;
708 Len : out Entity_Id;
709 Res : out Entity_Id;
710 Pos : out Entity_Id;
711 Prefix : Entity_Id;
712 Sum : Node_Id;
713 Decls : in out List_Id;
714 Stats : in out List_Id)
715 is
716 begin
717 Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
718
719 Append_To (Decls,
720 Make_Object_Declaration (Loc,
721 Defining_Identifier => Len,
722 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
723 Expression => Sum));
724
725 Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
726
727 Append_To (Decls,
728 Make_Object_Declaration (Loc,
729 Defining_Identifier => Res,
730 Object_Definition =>
731 Make_Subtype_Indication (Loc,
732 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
733 Constraint =>
734 Make_Index_Or_Discriminant_Constraint (Loc,
735 Constraints =>
736 New_List (
737 Make_Range (Loc,
738 Low_Bound => Make_Integer_Literal (Loc, 1),
739 High_Bound => New_Occurrence_Of (Len, Loc)))))));
740
741 Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
742
743 Append_To (Decls,
744 Make_Object_Declaration (Loc,
745 Defining_Identifier => Pos,
746 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
747
748 -- Pos := Prefix'Length;
749
750 Append_To (Stats,
751 Make_Assignment_Statement (Loc,
752 Name => New_Occurrence_Of (Pos, Loc),
753 Expression =>
754 Make_Attribute_Reference (Loc,
755 Attribute_Name => Name_Length,
756 Prefix => New_Occurrence_Of (Prefix, Loc),
757 Expressions =>
758 New_List (Make_Integer_Literal (Loc, 1)))));
759
760 -- Res (1 .. Pos) := Prefix;
761
762 Append_To (Stats,
763 Make_Assignment_Statement (Loc,
764 Name => Make_Slice (Loc,
765 Prefix => New_Occurrence_Of (Res, Loc),
766 Discrete_Range =>
767 Make_Range (Loc,
768 Low_Bound => Make_Integer_Literal (Loc, 1),
769 High_Bound => New_Occurrence_Of (Pos, Loc))),
770
771 Expression => New_Occurrence_Of (Prefix, Loc)));
772
773 Append_To (Stats,
774 Make_Assignment_Statement (Loc,
775 Name => New_Occurrence_Of (Pos, Loc),
776 Expression =>
777 Make_Op_Add (Loc,
778 Left_Opnd => New_Occurrence_Of (Pos, Loc),
779 Right_Opnd => Make_Integer_Literal (Loc, 1))));
780 end Build_Task_Image_Prefix;
781
782 -----------------------------
783 -- Build_Task_Record_Image --
784 -----------------------------
785
786 function Build_Task_Record_Image
787 (Loc : Source_Ptr;
788 Id_Ref : Node_Id;
789 Dyn : Boolean := False)
790 return Node_Id
791 is
792 Len : Entity_Id;
793 -- Total length of generated name
794
795 Pos : Entity_Id;
796 -- Index into result
797
798 Res : Entity_Id;
799 -- String to hold result
800
801 Pref : Entity_Id;
802 -- Name of enclosing variable, prefix of resulting name
803
804 P_Nam : Node_Id;
805 -- string expression for Pref.
806
807 Sum : Node_Id;
808 -- Expression to compute total size of string.
809
810 Sel : Entity_Id;
811 -- Entity for selector name
812
813 Decls : List_Id := New_List;
814 Stats : List_Id := New_List;
815
816 begin
817 Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
818
819 -- For a dynamic task, the name comes from the target variable.
820 -- For a static one it is a formal of the enclosing init_proc.
821
822 if Dyn then
823 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
824 P_Nam :=
825 Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
826 else
827 P_Nam :=
828 Make_Explicit_Dereference (Loc,
829 Prefix => Make_Identifier (Loc, Name_uTask_Id));
830 end if;
831
832 Append_To (Decls,
833 Make_Object_Declaration (Loc,
834 Defining_Identifier => Pref,
835 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
836 Expression => P_Nam));
837
838 Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
839
840 Get_Name_String (Chars (Selector_Name (Id_Ref)));
841
842 Append_To (Decls,
843 Make_Object_Declaration (Loc,
844 Defining_Identifier => Sel,
845 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
846 Expression =>
847 Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
848
849 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
850
851 Sum :=
852 Make_Op_Add (Loc,
853 Left_Opnd => Sum,
854 Right_Opnd =>
855 Make_Attribute_Reference (Loc,
856 Attribute_Name => Name_Length,
857 Prefix =>
858 New_Occurrence_Of (Pref, Loc),
859 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
860
861 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
862
863 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
864
865 -- Res (Pos) := '.';
866
867 Append_To (Stats,
868 Make_Assignment_Statement (Loc,
869 Name => Make_Indexed_Component (Loc,
870 Prefix => New_Occurrence_Of (Res, Loc),
871 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
872 Expression =>
873 Make_Character_Literal (Loc,
874 Chars => Name_Find,
875 Char_Literal_Value =>
876 Char_Code (Character'Pos ('.')))));
877
878 Append_To (Stats,
879 Make_Assignment_Statement (Loc,
880 Name => New_Occurrence_Of (Pos, Loc),
881 Expression =>
882 Make_Op_Add (Loc,
883 Left_Opnd => New_Occurrence_Of (Pos, Loc),
884 Right_Opnd => Make_Integer_Literal (Loc, 1))));
885
886 -- Res (Pos .. Len) := Selector;
887
888 Append_To (Stats,
889 Make_Assignment_Statement (Loc,
890 Name => Make_Slice (Loc,
891 Prefix => New_Occurrence_Of (Res, Loc),
892 Discrete_Range =>
893 Make_Range (Loc,
894 Low_Bound => New_Occurrence_Of (Pos, Loc),
895 High_Bound => New_Occurrence_Of (Len, Loc))),
896 Expression => New_Occurrence_Of (Sel, Loc)));
897
898 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
899 end Build_Task_Record_Image;
900
901 -------------------------------
902 -- Convert_To_Actual_Subtype --
903 -------------------------------
904
905 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
906 Act_ST : Entity_Id;
907
908 begin
909 Act_ST := Get_Actual_Subtype (Exp);
910
911 if Act_ST = Etype (Exp) then
912 return;
913
914 else
915 Rewrite (Exp,
916 Convert_To (Act_ST, Relocate_Node (Exp)));
917 Analyze_And_Resolve (Exp, Act_ST);
918 end if;
919 end Convert_To_Actual_Subtype;
920
921 -----------------------------------
922 -- Current_Sem_Unit_Declarations --
923 -----------------------------------
924
925 function Current_Sem_Unit_Declarations return List_Id is
926 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
927 Decls : List_Id;
928
929 begin
930 -- If the current unit is a package body, locate the visible
931 -- declarations of the package spec.
932
933 if Nkind (U) = N_Package_Body then
934 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
935 end if;
936
937 if Nkind (U) = N_Package_Declaration then
938 U := Specification (U);
939 Decls := Visible_Declarations (U);
940
941 if No (Decls) then
942 Decls := New_List;
943 Set_Visible_Declarations (U, Decls);
944 end if;
945
946 else
947 Decls := Declarations (U);
948
949 if No (Decls) then
950 Decls := New_List;
951 Set_Declarations (U, Decls);
952 end if;
953 end if;
954
955 return Decls;
956 end Current_Sem_Unit_Declarations;
957
958 -----------------------
959 -- Duplicate_Subexpr --
960 -----------------------
961
962 function Duplicate_Subexpr
963 (Exp : Node_Id;
964 Name_Req : Boolean := False)
965 return Node_Id
966 is
967 begin
968 Remove_Side_Effects (Exp, Name_Req);
969 return New_Copy_Tree (Exp);
970 end Duplicate_Subexpr;
971
972 ---------------------------------
973 -- Duplicate_Subexpr_No_Checks --
974 ---------------------------------
975
976 function Duplicate_Subexpr_No_Checks
977 (Exp : Node_Id;
978 Name_Req : Boolean := False)
979 return Node_Id
980 is
981 New_Exp : Node_Id;
982
983 begin
984 Remove_Side_Effects (Exp, Name_Req);
985 New_Exp := New_Copy_Tree (Exp);
986 Remove_Checks (New_Exp);
987 return New_Exp;
988 end Duplicate_Subexpr_No_Checks;
989
990 -----------------------------------
991 -- Duplicate_Subexpr_Move_Checks --
992 -----------------------------------
993
994 function Duplicate_Subexpr_Move_Checks
995 (Exp : Node_Id;
996 Name_Req : Boolean := False)
997 return Node_Id
998 is
999 New_Exp : Node_Id;
1000
1001 begin
1002 Remove_Side_Effects (Exp, Name_Req);
1003 New_Exp := New_Copy_Tree (Exp);
1004 Remove_Checks (Exp);
1005 return New_Exp;
1006 end Duplicate_Subexpr_Move_Checks;
1007
1008 --------------------
1009 -- Ensure_Defined --
1010 --------------------
1011
1012 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1013 IR : Node_Id;
1014 P : Node_Id;
1015
1016 begin
1017 if Is_Itype (Typ) then
1018 IR := Make_Itype_Reference (Sloc (N));
1019 Set_Itype (IR, Typ);
1020
1021 if not In_Open_Scopes (Scope (Typ))
1022 and then Is_Subprogram (Current_Scope)
1023 and then Scope (Current_Scope) /= Standard_Standard
1024 then
1025 -- Insert node in front of subprogram, to avoid scope anomalies
1026 -- in gigi.
1027
1028 P := Parent (N);
1029
1030 while Present (P)
1031 and then Nkind (P) /= N_Subprogram_Body
1032 loop
1033 P := Parent (P);
1034 end loop;
1035
1036 if Present (P) then
1037 Insert_Action (P, IR);
1038 else
1039 Insert_Action (N, IR);
1040 end if;
1041
1042 else
1043 Insert_Action (N, IR);
1044 end if;
1045 end if;
1046 end Ensure_Defined;
1047
1048 ---------------------
1049 -- Evolve_And_Then --
1050 ---------------------
1051
1052 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1053 begin
1054 if No (Cond) then
1055 Cond := Cond1;
1056 else
1057 Cond :=
1058 Make_And_Then (Sloc (Cond1),
1059 Left_Opnd => Cond,
1060 Right_Opnd => Cond1);
1061 end if;
1062 end Evolve_And_Then;
1063
1064 --------------------
1065 -- Evolve_Or_Else --
1066 --------------------
1067
1068 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1069 begin
1070 if No (Cond) then
1071 Cond := Cond1;
1072 else
1073 Cond :=
1074 Make_Or_Else (Sloc (Cond1),
1075 Left_Opnd => Cond,
1076 Right_Opnd => Cond1);
1077 end if;
1078 end Evolve_Or_Else;
1079
1080 ------------------------------
1081 -- Expand_Subtype_From_Expr --
1082 ------------------------------
1083
1084 -- This function is applicable for both static and dynamic allocation of
1085 -- objects which are constrained by an initial expression. Basically it
1086 -- transforms an unconstrained subtype indication into a constrained one.
1087 -- The expression may also be transformed in certain cases in order to
1088 -- avoid multiple evaulation. In the static allocation case, the general
1089 -- scheme is :
1090
1091 -- Val : T := Expr;
1092
1093 -- is transformed into
1094
1095 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1096 --
1097 -- Here are the main cases :
1098 --
1099 -- <if Expr is a Slice>
1100 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1101 --
1102 -- <elsif Expr is a String Literal>
1103 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1104 --
1105 -- <elsif Expr is Constrained>
1106 -- subtype T is Type_Of_Expr
1107 -- Val : T := Expr;
1108 --
1109 -- <elsif Expr is an entity_name>
1110 -- Val : T (constraints taken from Expr) := Expr;
1111 --
1112 -- <else>
1113 -- type Axxx is access all T;
1114 -- Rval : Axxx := Expr'ref;
1115 -- Val : T (constraints taken from Rval) := Rval.all;
1116
1117 -- ??? note: when the Expression is allocated in the secondary stack
1118 -- we could use it directly instead of copying it by declaring
1119 -- Val : T (...) renames Rval.all
1120
1121 procedure Expand_Subtype_From_Expr
1122 (N : Node_Id;
1123 Unc_Type : Entity_Id;
1124 Subtype_Indic : Node_Id;
1125 Exp : Node_Id)
1126 is
1127 Loc : constant Source_Ptr := Sloc (N);
1128 Exp_Typ : constant Entity_Id := Etype (Exp);
1129 T : Entity_Id;
1130
1131 begin
1132 -- In general we cannot build the subtype if expansion is disabled,
1133 -- because internal entities may not have been defined. However, to
1134 -- avoid some cascaded errors, we try to continue when the expression
1135 -- is an array (or string), because it is safe to compute the bounds.
1136 -- It is in fact required to do so even in a generic context, because
1137 -- there may be constants that depend on bounds of string literal.
1138
1139 if not Expander_Active
1140 and then (No (Etype (Exp))
1141 or else Base_Type (Etype (Exp)) /= Standard_String)
1142 then
1143 return;
1144 end if;
1145
1146 if Nkind (Exp) = N_Slice then
1147 declare
1148 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1149
1150 begin
1151 Rewrite (Subtype_Indic,
1152 Make_Subtype_Indication (Loc,
1153 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1154 Constraint =>
1155 Make_Index_Or_Discriminant_Constraint (Loc,
1156 Constraints => New_List
1157 (New_Reference_To (Slice_Type, Loc)))));
1158
1159 -- This subtype indication may be used later for contraint checks
1160 -- we better make sure that if a variable was used as a bound of
1161 -- of the original slice, its value is frozen.
1162
1163 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1164 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1165 end;
1166
1167 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1168 Rewrite (Subtype_Indic,
1169 Make_Subtype_Indication (Loc,
1170 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1171 Constraint =>
1172 Make_Index_Or_Discriminant_Constraint (Loc,
1173 Constraints => New_List (
1174 Make_Literal_Range (Loc,
1175 Literal_Typ => Exp_Typ)))));
1176
1177 elsif Is_Constrained (Exp_Typ)
1178 and then not Is_Class_Wide_Type (Unc_Type)
1179 then
1180 if Is_Itype (Exp_Typ) then
1181
1182 -- No need to generate a new one.
1183
1184 T := Exp_Typ;
1185
1186 else
1187 T :=
1188 Make_Defining_Identifier (Loc,
1189 Chars => New_Internal_Name ('T'));
1190
1191 Insert_Action (N,
1192 Make_Subtype_Declaration (Loc,
1193 Defining_Identifier => T,
1194 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
1195
1196 -- This type is marked as an itype even though it has an
1197 -- explicit declaration because otherwise it can be marked
1198 -- with Is_Generic_Actual_Type and generate spurious errors.
1199 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1200
1201 Set_Is_Itype (T);
1202 Set_Associated_Node_For_Itype (T, Exp);
1203 end if;
1204
1205 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1206
1207 -- nothing needs to be done for private types with unknown discriminants
1208 -- if the underlying type is not an unconstrained composite type.
1209
1210 elsif Is_Private_Type (Unc_Type)
1211 and then Has_Unknown_Discriminants (Unc_Type)
1212 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1213 or else Is_Constrained (Underlying_Type (Unc_Type)))
1214 then
1215 null;
1216
1217 else
1218 Remove_Side_Effects (Exp);
1219 Rewrite (Subtype_Indic,
1220 Make_Subtype_From_Expr (Exp, Unc_Type));
1221 end if;
1222 end Expand_Subtype_From_Expr;
1223
1224 ------------------
1225 -- Find_Prim_Op --
1226 ------------------
1227
1228 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1229 Prim : Elmt_Id;
1230 Typ : Entity_Id := T;
1231
1232 begin
1233 if Is_Class_Wide_Type (Typ) then
1234 Typ := Root_Type (Typ);
1235 end if;
1236
1237 Typ := Underlying_Type (Typ);
1238
1239 Prim := First_Elmt (Primitive_Operations (Typ));
1240 while Chars (Node (Prim)) /= Name loop
1241 Next_Elmt (Prim);
1242 pragma Assert (Present (Prim));
1243 end loop;
1244
1245 return Node (Prim);
1246 end Find_Prim_Op;
1247
1248 ----------------------
1249 -- Force_Evaluation --
1250 ----------------------
1251
1252 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1253 begin
1254 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1255 end Force_Evaluation;
1256
1257 ------------------------
1258 -- Generate_Poll_Call --
1259 ------------------------
1260
1261 procedure Generate_Poll_Call (N : Node_Id) is
1262 begin
1263 -- No poll call if polling not active
1264
1265 if not Polling_Required then
1266 return;
1267
1268 -- Otherwise generate require poll call
1269
1270 else
1271 Insert_Before_And_Analyze (N,
1272 Make_Procedure_Call_Statement (Sloc (N),
1273 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1274 end if;
1275 end Generate_Poll_Call;
1276
1277 --------------------
1278 -- Homonym_Number --
1279 --------------------
1280
1281 function Homonym_Number (Subp : Entity_Id) return Nat is
1282 Count : Nat;
1283 Hom : Entity_Id;
1284
1285 begin
1286 Count := 1;
1287 Hom := Homonym (Subp);
1288 while Present (Hom) loop
1289 if Scope (Hom) = Scope (Subp) then
1290 Count := Count + 1;
1291 end if;
1292
1293 Hom := Homonym (Hom);
1294 end loop;
1295
1296 return Count;
1297 end Homonym_Number;
1298
1299 ------------------------------
1300 -- In_Unconditional_Context --
1301 ------------------------------
1302
1303 function In_Unconditional_Context (Node : Node_Id) return Boolean is
1304 P : Node_Id;
1305
1306 begin
1307 P := Node;
1308 while Present (P) loop
1309 case Nkind (P) is
1310 when N_Subprogram_Body =>
1311 return True;
1312
1313 when N_If_Statement =>
1314 return False;
1315
1316 when N_Loop_Statement =>
1317 return False;
1318
1319 when N_Case_Statement =>
1320 return False;
1321
1322 when others =>
1323 P := Parent (P);
1324 end case;
1325 end loop;
1326
1327 return False;
1328 end In_Unconditional_Context;
1329
1330 -------------------
1331 -- Insert_Action --
1332 -------------------
1333
1334 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
1335 begin
1336 if Present (Ins_Action) then
1337 Insert_Actions (Assoc_Node, New_List (Ins_Action));
1338 end if;
1339 end Insert_Action;
1340
1341 -- Version with check(s) suppressed
1342
1343 procedure Insert_Action
1344 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
1345 is
1346 begin
1347 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
1348 end Insert_Action;
1349
1350 --------------------
1351 -- Insert_Actions --
1352 --------------------
1353
1354 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
1355 N : Node_Id;
1356 P : Node_Id;
1357
1358 Wrapped_Node : Node_Id := Empty;
1359
1360 begin
1361 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
1362 return;
1363 end if;
1364
1365 -- Ignore insert of actions from inside default expression in the
1366 -- special preliminary analyze mode. Any insertions at this point
1367 -- have no relevance, since we are only doing the analyze to freeze
1368 -- the types of any static expressions. See section "Handling of
1369 -- Default Expressions" in the spec of package Sem for further details.
1370
1371 if In_Default_Expression then
1372 return;
1373 end if;
1374
1375 -- If the action derives from stuff inside a record, then the actions
1376 -- are attached to the current scope, to be inserted and analyzed on
1377 -- exit from the scope. The reason for this is that we may also
1378 -- be generating freeze actions at the same time, and they must
1379 -- eventually be elaborated in the correct order.
1380
1381 if Is_Record_Type (Current_Scope)
1382 and then not Is_Frozen (Current_Scope)
1383 then
1384 if No (Scope_Stack.Table
1385 (Scope_Stack.Last).Pending_Freeze_Actions)
1386 then
1387 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
1388 Ins_Actions;
1389 else
1390 Append_List
1391 (Ins_Actions,
1392 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
1393 end if;
1394
1395 return;
1396 end if;
1397
1398 -- We now intend to climb up the tree to find the right point to
1399 -- insert the actions. We start at Assoc_Node, unless this node is
1400 -- a subexpression in which case we start with its parent. We do this
1401 -- for two reasons. First it speeds things up. Second, if Assoc_Node
1402 -- is itself one of the special nodes like N_And_Then, then we assume
1403 -- that an initial request to insert actions for such a node does not
1404 -- expect the actions to get deposited in the node for later handling
1405 -- when the node is expanded, since clearly the node is being dealt
1406 -- with by the caller. Note that in the subexpression case, N is
1407 -- always the child we came from.
1408
1409 -- N_Raise_xxx_Error is an annoying special case, it is a statement
1410 -- if it has type Standard_Void_Type, and a subexpression otherwise.
1411 -- otherwise. Procedure attribute references are also statements.
1412
1413 if Nkind (Assoc_Node) in N_Subexpr
1414 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
1415 or else Etype (Assoc_Node) /= Standard_Void_Type)
1416 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
1417 or else
1418 not Is_Procedure_Attribute_Name
1419 (Attribute_Name (Assoc_Node)))
1420 then
1421 P := Assoc_Node; -- ????? does not agree with above!
1422 N := Parent (Assoc_Node);
1423
1424 -- Non-subexpression case. Note that N is initially Empty in this
1425 -- case (N is only guaranteed Non-Empty in the subexpr case).
1426
1427 else
1428 P := Assoc_Node;
1429 N := Empty;
1430 end if;
1431
1432 -- Capture root of the transient scope
1433
1434 if Scope_Is_Transient then
1435 Wrapped_Node := Node_To_Be_Wrapped;
1436 end if;
1437
1438 loop
1439 pragma Assert (Present (P));
1440
1441 case Nkind (P) is
1442
1443 -- Case of right operand of AND THEN or OR ELSE. Put the actions
1444 -- in the Actions field of the right operand. They will be moved
1445 -- out further when the AND THEN or OR ELSE operator is expanded.
1446 -- Nothing special needs to be done for the left operand since
1447 -- in that case the actions are executed unconditionally.
1448
1449 when N_And_Then | N_Or_Else =>
1450 if N = Right_Opnd (P) then
1451 if Present (Actions (P)) then
1452 Insert_List_After_And_Analyze
1453 (Last (Actions (P)), Ins_Actions);
1454 else
1455 Set_Actions (P, Ins_Actions);
1456 Analyze_List (Actions (P));
1457 end if;
1458
1459 return;
1460 end if;
1461
1462 -- Then or Else operand of conditional expression. Add actions to
1463 -- Then_Actions or Else_Actions field as appropriate. The actions
1464 -- will be moved further out when the conditional is expanded.
1465
1466 when N_Conditional_Expression =>
1467 declare
1468 ThenX : constant Node_Id := Next (First (Expressions (P)));
1469 ElseX : constant Node_Id := Next (ThenX);
1470
1471 begin
1472 -- Actions belong to the then expression, temporarily
1473 -- place them as Then_Actions of the conditional expr.
1474 -- They will be moved to the proper place later when
1475 -- the conditional expression is expanded.
1476
1477 if N = ThenX then
1478 if Present (Then_Actions (P)) then
1479 Insert_List_After_And_Analyze
1480 (Last (Then_Actions (P)), Ins_Actions);
1481 else
1482 Set_Then_Actions (P, Ins_Actions);
1483 Analyze_List (Then_Actions (P));
1484 end if;
1485
1486 return;
1487
1488 -- Actions belong to the else expression, temporarily
1489 -- place them as Else_Actions of the conditional expr.
1490 -- They will be moved to the proper place later when
1491 -- the conditional expression is expanded.
1492
1493 elsif N = ElseX then
1494 if Present (Else_Actions (P)) then
1495 Insert_List_After_And_Analyze
1496 (Last (Else_Actions (P)), Ins_Actions);
1497 else
1498 Set_Else_Actions (P, Ins_Actions);
1499 Analyze_List (Else_Actions (P));
1500 end if;
1501
1502 return;
1503
1504 -- Actions belong to the condition. In this case they are
1505 -- unconditionally executed, and so we can continue the
1506 -- search for the proper insert point.
1507
1508 else
1509 null;
1510 end if;
1511 end;
1512
1513 -- Case of appearing in the condition of a while expression or
1514 -- elsif. We insert the actions into the Condition_Actions field.
1515 -- They will be moved further out when the while loop or elsif
1516 -- is analyzed.
1517
1518 when N_Iteration_Scheme |
1519 N_Elsif_Part
1520 =>
1521 if N = Condition (P) then
1522 if Present (Condition_Actions (P)) then
1523 Insert_List_After_And_Analyze
1524 (Last (Condition_Actions (P)), Ins_Actions);
1525 else
1526 Set_Condition_Actions (P, Ins_Actions);
1527
1528 -- Set the parent of the insert actions explicitly.
1529 -- This is not a syntactic field, but we need the
1530 -- parent field set, in particular so that freeze
1531 -- can understand that it is dealing with condition
1532 -- actions, and properly insert the freezing actions.
1533
1534 Set_Parent (Ins_Actions, P);
1535 Analyze_List (Condition_Actions (P));
1536 end if;
1537
1538 return;
1539 end if;
1540
1541 -- Statements, declarations, pragmas, representation clauses.
1542
1543 when
1544 -- Statements
1545
1546 N_Procedure_Call_Statement |
1547 N_Statement_Other_Than_Procedure_Call |
1548
1549 -- Pragmas
1550
1551 N_Pragma |
1552
1553 -- Representation_Clause
1554
1555 N_At_Clause |
1556 N_Attribute_Definition_Clause |
1557 N_Enumeration_Representation_Clause |
1558 N_Record_Representation_Clause |
1559
1560 -- Declarations
1561
1562 N_Abstract_Subprogram_Declaration |
1563 N_Entry_Body |
1564 N_Exception_Declaration |
1565 N_Exception_Renaming_Declaration |
1566 N_Formal_Object_Declaration |
1567 N_Formal_Subprogram_Declaration |
1568 N_Formal_Type_Declaration |
1569 N_Full_Type_Declaration |
1570 N_Function_Instantiation |
1571 N_Generic_Function_Renaming_Declaration |
1572 N_Generic_Package_Declaration |
1573 N_Generic_Package_Renaming_Declaration |
1574 N_Generic_Procedure_Renaming_Declaration |
1575 N_Generic_Subprogram_Declaration |
1576 N_Implicit_Label_Declaration |
1577 N_Incomplete_Type_Declaration |
1578 N_Number_Declaration |
1579 N_Object_Declaration |
1580 N_Object_Renaming_Declaration |
1581 N_Package_Body |
1582 N_Package_Body_Stub |
1583 N_Package_Declaration |
1584 N_Package_Instantiation |
1585 N_Package_Renaming_Declaration |
1586 N_Private_Extension_Declaration |
1587 N_Private_Type_Declaration |
1588 N_Procedure_Instantiation |
1589 N_Protected_Body_Stub |
1590 N_Protected_Type_Declaration |
1591 N_Single_Task_Declaration |
1592 N_Subprogram_Body |
1593 N_Subprogram_Body_Stub |
1594 N_Subprogram_Declaration |
1595 N_Subprogram_Renaming_Declaration |
1596 N_Subtype_Declaration |
1597 N_Task_Body |
1598 N_Task_Body_Stub |
1599 N_Task_Type_Declaration |
1600
1601 -- Freeze entity behaves like a declaration or statement
1602
1603 N_Freeze_Entity
1604 =>
1605 -- Do not insert here if the item is not a list member (this
1606 -- happens for example with a triggering statement, and the
1607 -- proper approach is to insert before the entire select).
1608
1609 if not Is_List_Member (P) then
1610 null;
1611
1612 -- Do not insert if parent of P is an N_Component_Association
1613 -- node (i.e. we are in the context of an N_Aggregate node.
1614 -- In this case we want to insert before the entire aggregate.
1615
1616 elsif Nkind (Parent (P)) = N_Component_Association then
1617 null;
1618
1619 -- Do not insert if the parent of P is either an N_Variant
1620 -- node or an N_Record_Definition node, meaning in either
1621 -- case that P is a member of a component list, and that
1622 -- therefore the actions should be inserted outside the
1623 -- complete record declaration.
1624
1625 elsif Nkind (Parent (P)) = N_Variant
1626 or else Nkind (Parent (P)) = N_Record_Definition
1627 then
1628 null;
1629
1630 -- Do not insert freeze nodes within the loop generated for
1631 -- an aggregate, because they may be elaborated too late for
1632 -- subsequent use in the back end: within a package spec the
1633 -- loop is part of the elaboration procedure and is only
1634 -- elaborated during the second pass.
1635 -- If the loop comes from source, or the entity is local to
1636 -- the loop itself it must remain within.
1637
1638 elsif Nkind (Parent (P)) = N_Loop_Statement
1639 and then not Comes_From_Source (Parent (P))
1640 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
1641 and then
1642 Scope (Entity (First (Ins_Actions))) /= Current_Scope
1643 then
1644 null;
1645
1646 -- Otherwise we can go ahead and do the insertion
1647
1648 elsif P = Wrapped_Node then
1649 Store_Before_Actions_In_Scope (Ins_Actions);
1650 return;
1651
1652 else
1653 Insert_List_Before_And_Analyze (P, Ins_Actions);
1654 return;
1655 end if;
1656
1657 -- A special case, N_Raise_xxx_Error can act either as a
1658 -- statement or a subexpression. We tell the difference
1659 -- by looking at the Etype. It is set to Standard_Void_Type
1660 -- in the statement case.
1661
1662 when
1663 N_Raise_xxx_Error =>
1664 if Etype (P) = Standard_Void_Type then
1665 if P = Wrapped_Node then
1666 Store_Before_Actions_In_Scope (Ins_Actions);
1667 else
1668 Insert_List_Before_And_Analyze (P, Ins_Actions);
1669 end if;
1670
1671 return;
1672
1673 -- In the subexpression case, keep climbing
1674
1675 else
1676 null;
1677 end if;
1678
1679 -- If a component association appears within a loop created for
1680 -- an array aggregate, attach the actions to the association so
1681 -- they can be subsequently inserted within the loop. For other
1682 -- component associations insert outside of the aggregate.
1683
1684 -- The list of loop_actions can in turn generate additional ones,
1685 -- that are inserted before the associated node. If the associated
1686 -- node is outside the aggregate, the new actions are collected
1687 -- at the end of the loop actions, to respect the order in which
1688 -- they are to be elaborated.
1689
1690 when
1691 N_Component_Association =>
1692 if Nkind (Parent (P)) = N_Aggregate
1693 and then Present (Aggregate_Bounds (Parent (P)))
1694 and then Nkind (First (Choices (P))) = N_Others_Choice
1695 then
1696 if No (Loop_Actions (P)) then
1697 Set_Loop_Actions (P, Ins_Actions);
1698 Analyze_List (Ins_Actions);
1699
1700 else
1701 declare
1702 Decl : Node_Id := Assoc_Node;
1703
1704 begin
1705 -- Check whether these actions were generated
1706 -- by a declaration that is part of the loop_
1707 -- actions for the component_association.
1708
1709 while Present (Decl) loop
1710 exit when Parent (Decl) = P
1711 and then Is_List_Member (Decl)
1712 and then
1713 List_Containing (Decl) = Loop_Actions (P);
1714 Decl := Parent (Decl);
1715 end loop;
1716
1717 if Present (Decl) then
1718 Insert_List_Before_And_Analyze
1719 (Decl, Ins_Actions);
1720 else
1721 Insert_List_After_And_Analyze
1722 (Last (Loop_Actions (P)), Ins_Actions);
1723 end if;
1724 end;
1725 end if;
1726
1727 return;
1728
1729 else
1730 null;
1731 end if;
1732
1733 -- Another special case, an attribute denoting a procedure call
1734
1735 when
1736 N_Attribute_Reference =>
1737 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
1738 if P = Wrapped_Node then
1739 Store_Before_Actions_In_Scope (Ins_Actions);
1740 else
1741 Insert_List_Before_And_Analyze (P, Ins_Actions);
1742 end if;
1743
1744 return;
1745
1746 -- In the subexpression case, keep climbing
1747
1748 else
1749 null;
1750 end if;
1751
1752 -- For all other node types, keep climbing tree
1753
1754 when
1755 N_Abortable_Part |
1756 N_Accept_Alternative |
1757 N_Access_Definition |
1758 N_Access_Function_Definition |
1759 N_Access_Procedure_Definition |
1760 N_Access_To_Object_Definition |
1761 N_Aggregate |
1762 N_Allocator |
1763 N_Case_Statement_Alternative |
1764 N_Character_Literal |
1765 N_Compilation_Unit |
1766 N_Compilation_Unit_Aux |
1767 N_Component_Clause |
1768 N_Component_Declaration |
1769 N_Component_List |
1770 N_Constrained_Array_Definition |
1771 N_Decimal_Fixed_Point_Definition |
1772 N_Defining_Character_Literal |
1773 N_Defining_Identifier |
1774 N_Defining_Operator_Symbol |
1775 N_Defining_Program_Unit_Name |
1776 N_Delay_Alternative |
1777 N_Delta_Constraint |
1778 N_Derived_Type_Definition |
1779 N_Designator |
1780 N_Digits_Constraint |
1781 N_Discriminant_Association |
1782 N_Discriminant_Specification |
1783 N_Empty |
1784 N_Entry_Body_Formal_Part |
1785 N_Entry_Call_Alternative |
1786 N_Entry_Declaration |
1787 N_Entry_Index_Specification |
1788 N_Enumeration_Type_Definition |
1789 N_Error |
1790 N_Exception_Handler |
1791 N_Expanded_Name |
1792 N_Explicit_Dereference |
1793 N_Extension_Aggregate |
1794 N_Floating_Point_Definition |
1795 N_Formal_Decimal_Fixed_Point_Definition |
1796 N_Formal_Derived_Type_Definition |
1797 N_Formal_Discrete_Type_Definition |
1798 N_Formal_Floating_Point_Definition |
1799 N_Formal_Modular_Type_Definition |
1800 N_Formal_Ordinary_Fixed_Point_Definition |
1801 N_Formal_Package_Declaration |
1802 N_Formal_Private_Type_Definition |
1803 N_Formal_Signed_Integer_Type_Definition |
1804 N_Function_Call |
1805 N_Function_Specification |
1806 N_Generic_Association |
1807 N_Handled_Sequence_Of_Statements |
1808 N_Identifier |
1809 N_In |
1810 N_Index_Or_Discriminant_Constraint |
1811 N_Indexed_Component |
1812 N_Integer_Literal |
1813 N_Itype_Reference |
1814 N_Label |
1815 N_Loop_Parameter_Specification |
1816 N_Mod_Clause |
1817 N_Modular_Type_Definition |
1818 N_Not_In |
1819 N_Null |
1820 N_Op_Abs |
1821 N_Op_Add |
1822 N_Op_And |
1823 N_Op_Concat |
1824 N_Op_Divide |
1825 N_Op_Eq |
1826 N_Op_Expon |
1827 N_Op_Ge |
1828 N_Op_Gt |
1829 N_Op_Le |
1830 N_Op_Lt |
1831 N_Op_Minus |
1832 N_Op_Mod |
1833 N_Op_Multiply |
1834 N_Op_Ne |
1835 N_Op_Not |
1836 N_Op_Or |
1837 N_Op_Plus |
1838 N_Op_Rem |
1839 N_Op_Rotate_Left |
1840 N_Op_Rotate_Right |
1841 N_Op_Shift_Left |
1842 N_Op_Shift_Right |
1843 N_Op_Shift_Right_Arithmetic |
1844 N_Op_Subtract |
1845 N_Op_Xor |
1846 N_Operator_Symbol |
1847 N_Ordinary_Fixed_Point_Definition |
1848 N_Others_Choice |
1849 N_Package_Specification |
1850 N_Parameter_Association |
1851 N_Parameter_Specification |
1852 N_Pragma_Argument_Association |
1853 N_Procedure_Specification |
1854 N_Protected_Body |
1855 N_Protected_Definition |
1856 N_Qualified_Expression |
1857 N_Range |
1858 N_Range_Constraint |
1859 N_Real_Literal |
1860 N_Real_Range_Specification |
1861 N_Record_Definition |
1862 N_Reference |
1863 N_Selected_Component |
1864 N_Signed_Integer_Type_Definition |
1865 N_Single_Protected_Declaration |
1866 N_Slice |
1867 N_String_Literal |
1868 N_Subprogram_Info |
1869 N_Subtype_Indication |
1870 N_Subunit |
1871 N_Task_Definition |
1872 N_Terminate_Alternative |
1873 N_Triggering_Alternative |
1874 N_Type_Conversion |
1875 N_Unchecked_Expression |
1876 N_Unchecked_Type_Conversion |
1877 N_Unconstrained_Array_Definition |
1878 N_Unused_At_End |
1879 N_Unused_At_Start |
1880 N_Use_Package_Clause |
1881 N_Use_Type_Clause |
1882 N_Variant |
1883 N_Variant_Part |
1884 N_Validate_Unchecked_Conversion |
1885 N_With_Clause |
1886 N_With_Type_Clause
1887 =>
1888 null;
1889
1890 end case;
1891
1892 -- Make sure that inserted actions stay in the transient scope
1893
1894 if P = Wrapped_Node then
1895 Store_Before_Actions_In_Scope (Ins_Actions);
1896 return;
1897 end if;
1898
1899 -- If we fall through above tests, keep climbing tree
1900
1901 N := P;
1902
1903 if Nkind (Parent (N)) = N_Subunit then
1904
1905 -- This is the proper body corresponding to a stub. Insertion
1906 -- must be done at the point of the stub, which is in the decla-
1907 -- tive part of the parent unit.
1908
1909 P := Corresponding_Stub (Parent (N));
1910
1911 else
1912 P := Parent (N);
1913 end if;
1914 end loop;
1915
1916 end Insert_Actions;
1917
1918 -- Version with check(s) suppressed
1919
1920 procedure Insert_Actions
1921 (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
1922 is
1923 begin
1924 if Suppress = All_Checks then
1925 declare
1926 Svg : constant Suppress_Record := Scope_Suppress;
1927
1928 begin
1929 Scope_Suppress := (others => True);
1930 Insert_Actions (Assoc_Node, Ins_Actions);
1931 Scope_Suppress := Svg;
1932 end;
1933
1934 else
1935 declare
1936 Svg : constant Boolean := Get_Scope_Suppress (Suppress);
1937
1938 begin
1939 Set_Scope_Suppress (Suppress, True);
1940 Insert_Actions (Assoc_Node, Ins_Actions);
1941 Set_Scope_Suppress (Suppress, Svg);
1942 end;
1943 end if;
1944 end Insert_Actions;
1945
1946 --------------------------
1947 -- Insert_Actions_After --
1948 --------------------------
1949
1950 procedure Insert_Actions_After
1951 (Assoc_Node : Node_Id;
1952 Ins_Actions : List_Id)
1953 is
1954 begin
1955 if Scope_Is_Transient
1956 and then Assoc_Node = Node_To_Be_Wrapped
1957 then
1958 Store_After_Actions_In_Scope (Ins_Actions);
1959 else
1960 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
1961 end if;
1962 end Insert_Actions_After;
1963
1964 ---------------------------------
1965 -- Insert_Library_Level_Action --
1966 ---------------------------------
1967
1968 procedure Insert_Library_Level_Action (N : Node_Id) is
1969 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
1970
1971 begin
1972 New_Scope (Cunit_Entity (Main_Unit));
1973
1974 if No (Actions (Aux)) then
1975 Set_Actions (Aux, New_List (N));
1976 else
1977 Append (N, Actions (Aux));
1978 end if;
1979
1980 Analyze (N);
1981 Pop_Scope;
1982 end Insert_Library_Level_Action;
1983
1984 ----------------------------------
1985 -- Insert_Library_Level_Actions --
1986 ----------------------------------
1987
1988 procedure Insert_Library_Level_Actions (L : List_Id) is
1989 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
1990
1991 begin
1992 if Is_Non_Empty_List (L) then
1993 New_Scope (Cunit_Entity (Main_Unit));
1994
1995 if No (Actions (Aux)) then
1996 Set_Actions (Aux, L);
1997 Analyze_List (L);
1998 else
1999 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2000 end if;
2001
2002 Pop_Scope;
2003 end if;
2004 end Insert_Library_Level_Actions;
2005
2006 ----------------------
2007 -- Inside_Init_Proc --
2008 ----------------------
2009
2010 function Inside_Init_Proc return Boolean is
2011 S : Entity_Id;
2012
2013 begin
2014 S := Current_Scope;
2015 while S /= Standard_Standard loop
2016 if Chars (S) = Name_uInit_Proc then
2017 return True;
2018 else
2019 S := Scope (S);
2020 end if;
2021 end loop;
2022
2023 return False;
2024 end Inside_Init_Proc;
2025
2026 --------------------------------
2027 -- Is_Ref_To_Bit_Packed_Array --
2028 --------------------------------
2029
2030 function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is
2031 Result : Boolean;
2032 Expr : Node_Id;
2033
2034 begin
2035 if Nkind (P) = N_Indexed_Component
2036 or else
2037 Nkind (P) = N_Selected_Component
2038 then
2039 if Is_Bit_Packed_Array (Etype (Prefix (P))) then
2040 Result := True;
2041 else
2042 Result := Is_Ref_To_Bit_Packed_Array (Prefix (P));
2043 end if;
2044
2045 if Result and then Nkind (P) = N_Indexed_Component then
2046 Expr := First (Expressions (P));
2047
2048 while Present (Expr) loop
2049 Force_Evaluation (Expr);
2050 Next (Expr);
2051 end loop;
2052 end if;
2053
2054 return Result;
2055
2056 else
2057 return False;
2058 end if;
2059 end Is_Ref_To_Bit_Packed_Array;
2060
2061 --------------------------------
2062 -- Is_Ref_To_Bit_Packed_Slce --
2063 --------------------------------
2064
2065 function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is
2066 begin
2067 if Nkind (P) = N_Slice
2068 and then Is_Bit_Packed_Array (Etype (Prefix (P)))
2069 then
2070 return True;
2071
2072 elsif Nkind (P) = N_Indexed_Component
2073 or else
2074 Nkind (P) = N_Selected_Component
2075 then
2076 return Is_Ref_To_Bit_Packed_Slice (Prefix (P));
2077
2078 else
2079 return False;
2080 end if;
2081 end Is_Ref_To_Bit_Packed_Slice;
2082
2083 -----------------------
2084 -- Is_Renamed_Object --
2085 -----------------------
2086
2087 function Is_Renamed_Object (N : Node_Id) return Boolean is
2088 Pnod : constant Node_Id := Parent (N);
2089 Kind : constant Node_Kind := Nkind (Pnod);
2090
2091 begin
2092 if Kind = N_Object_Renaming_Declaration then
2093 return True;
2094
2095 elsif Kind = N_Indexed_Component
2096 or else Kind = N_Selected_Component
2097 then
2098 return Is_Renamed_Object (Pnod);
2099
2100 else
2101 return False;
2102 end if;
2103 end Is_Renamed_Object;
2104
2105 ----------------------------
2106 -- Is_Untagged_Derivation --
2107 ----------------------------
2108
2109 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
2110 begin
2111 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
2112 or else
2113 (Is_Private_Type (T) and then Present (Full_View (T))
2114 and then not Is_Tagged_Type (Full_View (T))
2115 and then Is_Derived_Type (Full_View (T))
2116 and then Etype (Full_View (T)) /= T);
2117
2118 end Is_Untagged_Derivation;
2119
2120 --------------------
2121 -- Kill_Dead_Code --
2122 --------------------
2123
2124 procedure Kill_Dead_Code (N : Node_Id) is
2125 begin
2126 if Present (N) then
2127 Remove_Handler_Entries (N);
2128 Remove_Warning_Messages (N);
2129
2130 -- Recurse into block statements and bodies to process declarations
2131 -- and statements
2132
2133 if Nkind (N) = N_Block_Statement
2134 or else Nkind (N) = N_Subprogram_Body
2135 or else Nkind (N) = N_Package_Body
2136 then
2137 Kill_Dead_Code (Declarations (N));
2138 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
2139
2140 if Nkind (N) = N_Subprogram_Body then
2141 Set_Is_Eliminated (Defining_Entity (N));
2142 end if;
2143
2144 -- Recurse into composite statement to kill individual statements,
2145 -- in particular instantiations.
2146
2147 elsif Nkind (N) = N_If_Statement then
2148 Kill_Dead_Code (Then_Statements (N));
2149 Kill_Dead_Code (Elsif_Parts (N));
2150 Kill_Dead_Code (Else_Statements (N));
2151
2152 elsif Nkind (N) = N_Loop_Statement then
2153 Kill_Dead_Code (Statements (N));
2154
2155 elsif Nkind (N) = N_Case_Statement then
2156 declare
2157 Alt : Node_Id := First (Alternatives (N));
2158
2159 begin
2160 while Present (Alt) loop
2161 Kill_Dead_Code (Statements (Alt));
2162 Next (Alt);
2163 end loop;
2164 end;
2165
2166 -- Deal with dead instances caused by deleting instantiations
2167
2168 elsif Nkind (N) in N_Generic_Instantiation then
2169 Remove_Dead_Instance (N);
2170 end if;
2171
2172 Delete_Tree (N);
2173 end if;
2174 end Kill_Dead_Code;
2175
2176 -- Case where argument is a list of nodes to be killed
2177
2178 procedure Kill_Dead_Code (L : List_Id) is
2179 N : Node_Id;
2180
2181 begin
2182 if Is_Non_Empty_List (L) then
2183 loop
2184 N := Remove_Head (L);
2185 exit when No (N);
2186 Kill_Dead_Code (N);
2187 end loop;
2188 end if;
2189 end Kill_Dead_Code;
2190
2191 ------------------------
2192 -- Known_Non_Negative --
2193 ------------------------
2194
2195 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
2196 begin
2197 if Is_OK_Static_Expression (Opnd)
2198 and then Expr_Value (Opnd) >= 0
2199 then
2200 return True;
2201
2202 else
2203 declare
2204 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
2205
2206 begin
2207 return
2208 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
2209 end;
2210 end if;
2211 end Known_Non_Negative;
2212
2213 --------------------------
2214 -- Target_Has_Fixed_Ops --
2215 --------------------------
2216
2217 Integer_Sized_Small : Ureal;
2218 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
2219 -- function is called (we don't want to compute it more than once!)
2220
2221 Long_Integer_Sized_Small : Ureal;
2222 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
2223 -- functoin is called (we don't want to compute it more than once)
2224
2225 First_Time_For_THFO : Boolean := True;
2226 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
2227
2228 function Target_Has_Fixed_Ops
2229 (Left_Typ : Entity_Id;
2230 Right_Typ : Entity_Id;
2231 Result_Typ : Entity_Id)
2232 return Boolean
2233 is
2234 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
2235 -- Return True if the given type is a fixed-point type with a small
2236 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
2237 -- an absolute value less than 1.0. This is currently limited
2238 -- to fixed-point types that map to Integer or Long_Integer.
2239
2240 ------------------------
2241 -- Is_Fractional_Type --
2242 ------------------------
2243
2244 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
2245 begin
2246 if Esize (Typ) = Standard_Integer_Size then
2247 return Small_Value (Typ) = Integer_Sized_Small;
2248
2249 elsif Esize (Typ) = Standard_Long_Integer_Size then
2250 return Small_Value (Typ) = Long_Integer_Sized_Small;
2251
2252 else
2253 return False;
2254 end if;
2255 end Is_Fractional_Type;
2256
2257 -- Start of processing for Target_Has_Fixed_Ops
2258
2259 begin
2260 -- Return False if Fractional_Fixed_Ops_On_Target is false
2261
2262 if not Fractional_Fixed_Ops_On_Target then
2263 return False;
2264 end if;
2265
2266 -- Here the target has Fractional_Fixed_Ops, if first time, compute
2267 -- standard constants used by Is_Fractional_Type.
2268
2269 if First_Time_For_THFO then
2270 First_Time_For_THFO := False;
2271
2272 Integer_Sized_Small :=
2273 UR_From_Components
2274 (Num => Uint_1,
2275 Den => UI_From_Int (Standard_Integer_Size - 1),
2276 Rbase => 2);
2277
2278 Long_Integer_Sized_Small :=
2279 UR_From_Components
2280 (Num => Uint_1,
2281 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
2282 Rbase => 2);
2283 end if;
2284
2285 -- Return True if target supports fixed-by-fixed multiply/divide
2286 -- for fractional fixed-point types (see Is_Fractional_Type) and
2287 -- the operand and result types are equivalent fractional types.
2288
2289 return Is_Fractional_Type (Base_Type (Left_Typ))
2290 and then Is_Fractional_Type (Base_Type (Right_Typ))
2291 and then Is_Fractional_Type (Base_Type (Result_Typ))
2292 and then Esize (Left_Typ) = Esize (Right_Typ)
2293 and then Esize (Left_Typ) = Esize (Result_Typ);
2294 end Target_Has_Fixed_Ops;
2295
2296 -----------------------------
2297 -- Make_CW_Equivalent_Type --
2298 -----------------------------
2299
2300 -- Create a record type used as an equivalent of any member
2301 -- of the class which takes its size from exp.
2302
2303 -- Generate the following code:
2304
2305 -- type Equiv_T is record
2306 -- _parent : T (List of discriminant constaints taken from Exp);
2307 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'size) / Storage_Unit);
2308 -- end Equiv_T;
2309
2310 function Make_CW_Equivalent_Type
2311 (T : Entity_Id;
2312 E : Node_Id)
2313 return Entity_Id
2314 is
2315 Loc : constant Source_Ptr := Sloc (E);
2316 Root_Typ : constant Entity_Id := Root_Type (T);
2317 Equiv_Type : Entity_Id;
2318 Range_Type : Entity_Id;
2319 Str_Type : Entity_Id;
2320 List_Def : List_Id := Empty_List;
2321 Constr_Root : Entity_Id;
2322 Sizexpr : Node_Id;
2323
2324 begin
2325 if not Has_Discriminants (Root_Typ) then
2326 Constr_Root := Root_Typ;
2327 else
2328 Constr_Root :=
2329 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2330
2331 -- subtype cstr__n is T (List of discr constraints taken from Exp)
2332
2333 Append_To (List_Def,
2334 Make_Subtype_Declaration (Loc,
2335 Defining_Identifier => Constr_Root,
2336 Subtype_Indication =>
2337 Make_Subtype_From_Expr (E, Root_Typ)));
2338 end if;
2339
2340 -- subtype rg__xx is Storage_Offset range
2341 -- (Expr'size - typ'size) / Storage_Unit
2342
2343 Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
2344
2345 Sizexpr :=
2346 Make_Op_Subtract (Loc,
2347 Left_Opnd =>
2348 Make_Attribute_Reference (Loc,
2349 Prefix =>
2350 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
2351 Attribute_Name => Name_Size),
2352 Right_Opnd =>
2353 Make_Attribute_Reference (Loc,
2354 Prefix => New_Reference_To (Constr_Root, Loc),
2355 Attribute_Name => Name_Size));
2356
2357 Set_Paren_Count (Sizexpr, 1);
2358
2359 Append_To (List_Def,
2360 Make_Subtype_Declaration (Loc,
2361 Defining_Identifier => Range_Type,
2362 Subtype_Indication =>
2363 Make_Subtype_Indication (Loc,
2364 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
2365 Constraint => Make_Range_Constraint (Loc,
2366 Range_Expression =>
2367 Make_Range (Loc,
2368 Low_Bound => Make_Integer_Literal (Loc, 1),
2369 High_Bound =>
2370 Make_Op_Divide (Loc,
2371 Left_Opnd => Sizexpr,
2372 Right_Opnd => Make_Integer_Literal (Loc,
2373 Intval => System_Storage_Unit)))))));
2374
2375 -- subtype str__nn is Storage_Array (rg__x);
2376
2377 Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2378 Append_To (List_Def,
2379 Make_Subtype_Declaration (Loc,
2380 Defining_Identifier => Str_Type,
2381 Subtype_Indication =>
2382 Make_Subtype_Indication (Loc,
2383 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
2384 Constraint =>
2385 Make_Index_Or_Discriminant_Constraint (Loc,
2386 Constraints =>
2387 New_List (New_Reference_To (Range_Type, Loc))))));
2388
2389 -- type Equiv_T is record
2390 -- _parent : Tnn;
2391 -- E : Str_Type;
2392 -- end Equiv_T;
2393
2394 Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2395
2396 -- Avoid the generation of an init procedure
2397
2398 Set_Is_Frozen (Equiv_Type);
2399
2400 Set_Ekind (Equiv_Type, E_Record_Type);
2401 Set_Parent_Subtype (Equiv_Type, Constr_Root);
2402
2403 Append_To (List_Def,
2404 Make_Full_Type_Declaration (Loc,
2405 Defining_Identifier => Equiv_Type,
2406
2407 Type_Definition =>
2408 Make_Record_Definition (Loc,
2409 Component_List => Make_Component_List (Loc,
2410 Component_Items => New_List (
2411 Make_Component_Declaration (Loc,
2412 Defining_Identifier =>
2413 Make_Defining_Identifier (Loc, Name_uParent),
2414 Subtype_Indication => New_Reference_To (Constr_Root, Loc)),
2415
2416 Make_Component_Declaration (Loc,
2417 Defining_Identifier =>
2418 Make_Defining_Identifier (Loc,
2419 Chars => New_Internal_Name ('C')),
2420 Subtype_Indication => New_Reference_To (Str_Type, Loc))),
2421 Variant_Part => Empty))));
2422
2423 Insert_Actions (E, List_Def);
2424 return Equiv_Type;
2425 end Make_CW_Equivalent_Type;
2426
2427 ------------------------
2428 -- Make_Literal_Range --
2429 ------------------------
2430
2431 function Make_Literal_Range
2432 (Loc : Source_Ptr;
2433 Literal_Typ : Entity_Id)
2434 return Node_Id
2435 is
2436 Lo : Node_Id :=
2437 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
2438
2439 begin
2440 Set_Analyzed (Lo, False);
2441
2442 return
2443 Make_Range (Loc,
2444 Low_Bound => Lo,
2445
2446 High_Bound =>
2447 Make_Op_Subtract (Loc,
2448 Left_Opnd =>
2449 Make_Op_Add (Loc,
2450 Left_Opnd => New_Copy_Tree (Lo),
2451 Right_Opnd =>
2452 Make_Integer_Literal (Loc,
2453 String_Literal_Length (Literal_Typ))),
2454 Right_Opnd => Make_Integer_Literal (Loc, 1)));
2455 end Make_Literal_Range;
2456
2457 ----------------------------
2458 -- Make_Subtype_From_Expr --
2459 ----------------------------
2460
2461 -- 1. If Expr is an uncontrained array expression, creates
2462 -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
2463
2464 -- 2. If Expr is a unconstrained discriminated type expression, creates
2465 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
2466
2467 -- 3. If Expr is class-wide, creates an implicit class wide subtype
2468
2469 function Make_Subtype_From_Expr
2470 (E : Node_Id;
2471 Unc_Typ : Entity_Id)
2472 return Node_Id
2473 is
2474 Loc : constant Source_Ptr := Sloc (E);
2475 List_Constr : List_Id := New_List;
2476 D : Entity_Id;
2477
2478 Full_Subtyp : Entity_Id;
2479 Priv_Subtyp : Entity_Id;
2480 Utyp : Entity_Id;
2481 Full_Exp : Node_Id;
2482
2483 begin
2484 if Is_Private_Type (Unc_Typ)
2485 and then Has_Unknown_Discriminants (Unc_Typ)
2486 then
2487 -- Prepare the subtype completion
2488
2489 Utyp := Underlying_Type (Unc_Typ);
2490 Full_Subtyp := Make_Defining_Identifier (Loc,
2491 New_Internal_Name ('C'));
2492 Full_Exp :=
2493 Unchecked_Convert_To
2494 (Utyp, Duplicate_Subexpr_No_Checks (E));
2495 Set_Parent (Full_Exp, Parent (E));
2496
2497 Priv_Subtyp :=
2498 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2499
2500 Insert_Action (E,
2501 Make_Subtype_Declaration (Loc,
2502 Defining_Identifier => Full_Subtyp,
2503 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
2504
2505 -- Define the dummy private subtype
2506
2507 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
2508 Set_Etype (Priv_Subtyp, Unc_Typ);
2509 Set_Scope (Priv_Subtyp, Full_Subtyp);
2510 Set_Is_Constrained (Priv_Subtyp);
2511 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
2512 Set_Is_Itype (Priv_Subtyp);
2513 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
2514
2515 if Is_Tagged_Type (Priv_Subtyp) then
2516 Set_Class_Wide_Type
2517 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
2518 Set_Primitive_Operations (Priv_Subtyp,
2519 Primitive_Operations (Unc_Typ));
2520 end if;
2521
2522 Set_Full_View (Priv_Subtyp, Full_Subtyp);
2523
2524 return New_Reference_To (Priv_Subtyp, Loc);
2525
2526 elsif Is_Array_Type (Unc_Typ) then
2527 for J in 1 .. Number_Dimensions (Unc_Typ) loop
2528 Append_To (List_Constr,
2529 Make_Range (Loc,
2530 Low_Bound =>
2531 Make_Attribute_Reference (Loc,
2532 Prefix => Duplicate_Subexpr_No_Checks (E),
2533 Attribute_Name => Name_First,
2534 Expressions => New_List (
2535 Make_Integer_Literal (Loc, J))),
2536
2537 High_Bound =>
2538 Make_Attribute_Reference (Loc,
2539 Prefix => Duplicate_Subexpr_No_Checks (E),
2540 Attribute_Name => Name_Last,
2541 Expressions => New_List (
2542 Make_Integer_Literal (Loc, J)))));
2543 end loop;
2544
2545 elsif Is_Class_Wide_Type (Unc_Typ) then
2546 declare
2547 CW_Subtype : Entity_Id;
2548 EQ_Typ : Entity_Id := Empty;
2549
2550 begin
2551 -- A class-wide equivalent type is not needed when Java_VM
2552 -- because the JVM back end handles the class-wide object
2553 -- initialization itself (and doesn't need or want the
2554 -- additional intermediate type to handle the assignment).
2555
2556 if Expander_Active and then not Java_VM then
2557 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
2558 end if;
2559
2560 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
2561 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
2562 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
2563
2564 return New_Occurrence_Of (CW_Subtype, Loc);
2565 end;
2566
2567 else
2568 D := First_Discriminant (Unc_Typ);
2569 while (Present (D)) loop
2570
2571 Append_To (List_Constr,
2572 Make_Selected_Component (Loc,
2573 Prefix => Duplicate_Subexpr_No_Checks (E),
2574 Selector_Name => New_Reference_To (D, Loc)));
2575
2576 Next_Discriminant (D);
2577 end loop;
2578 end if;
2579
2580 return
2581 Make_Subtype_Indication (Loc,
2582 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
2583 Constraint =>
2584 Make_Index_Or_Discriminant_Constraint (Loc,
2585 Constraints => List_Constr));
2586 end Make_Subtype_From_Expr;
2587
2588 -----------------------------
2589 -- May_Generate_Large_Temp --
2590 -----------------------------
2591
2592 -- At the current time, the only types that we return False for (i.e.
2593 -- where we decide we know they cannot generate large temps) are ones
2594 -- where we know the size is 128 bits or less at compile time, and we
2595 -- are still not doing a thorough job on arrays and records ???
2596
2597 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
2598 begin
2599 if not Stack_Checking_Enabled then
2600 return False;
2601
2602 elsif not Size_Known_At_Compile_Time (Typ) then
2603 return False;
2604
2605 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
2606 return False;
2607
2608 elsif Is_Array_Type (Typ)
2609 and then Present (Packed_Array_Type (Typ))
2610 then
2611 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
2612
2613 -- We could do more here to find other small types ???
2614
2615 else
2616 return True;
2617 end if;
2618 end May_Generate_Large_Temp;
2619
2620 ----------------------------
2621 -- New_Class_Wide_Subtype --
2622 ----------------------------
2623
2624 function New_Class_Wide_Subtype
2625 (CW_Typ : Entity_Id;
2626 N : Node_Id)
2627 return Entity_Id
2628 is
2629 Res : Entity_Id := Create_Itype (E_Void, N);
2630 Res_Name : constant Name_Id := Chars (Res);
2631 Res_Scope : Entity_Id := Scope (Res);
2632
2633 begin
2634 Copy_Node (CW_Typ, Res);
2635 Set_Sloc (Res, Sloc (N));
2636 Set_Is_Itype (Res);
2637 Set_Associated_Node_For_Itype (Res, N);
2638 Set_Is_Public (Res, False); -- By default, may be changed below.
2639 Set_Public_Status (Res);
2640 Set_Chars (Res, Res_Name);
2641 Set_Scope (Res, Res_Scope);
2642 Set_Ekind (Res, E_Class_Wide_Subtype);
2643 Set_Next_Entity (Res, Empty);
2644 Set_Etype (Res, Base_Type (CW_Typ));
2645 Set_Freeze_Node (Res, Empty);
2646 return (Res);
2647 end New_Class_Wide_Subtype;
2648
2649 -------------------------
2650 -- Remove_Side_Effects --
2651 -------------------------
2652
2653 procedure Remove_Side_Effects
2654 (Exp : Node_Id;
2655 Name_Req : Boolean := False;
2656 Variable_Ref : Boolean := False)
2657 is
2658 Loc : constant Source_Ptr := Sloc (Exp);
2659 Exp_Type : constant Entity_Id := Etype (Exp);
2660 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
2661 Def_Id : Entity_Id;
2662 Ref_Type : Entity_Id;
2663 Res : Node_Id;
2664 Ptr_Typ_Decl : Node_Id;
2665 New_Exp : Node_Id;
2666 E : Node_Id;
2667
2668 function Side_Effect_Free (N : Node_Id) return Boolean;
2669 -- Determines if the tree N represents an expession that is known
2670 -- not to have side effects, and for which no processing is required.
2671
2672 function Side_Effect_Free (L : List_Id) return Boolean;
2673 -- Determines if all elements of the list L are side effect free
2674
2675 function Mutable_Dereference (N : Node_Id) return Boolean;
2676 -- If a selected component involves an implicit dereference and
2677 -- the type of the prefix is not an_access_to_constant, the node
2678 -- must be evaluated because it may be affected by a subsequent
2679 -- assignment.
2680
2681 -------------------------
2682 -- Mutable_Dereference --
2683 -------------------------
2684
2685 function Mutable_Dereference (N : Node_Id) return Boolean is
2686 begin
2687 return Nkind (N) = N_Selected_Component
2688 and then Is_Access_Type (Etype (Prefix (N)))
2689 and then not Is_Access_Constant (Etype (Prefix (N)))
2690 and then Variable_Ref;
2691 end Mutable_Dereference;
2692
2693 ----------------------
2694 -- Side_Effect_Free --
2695 ----------------------
2696
2697 function Side_Effect_Free (N : Node_Id) return Boolean is
2698 K : constant Node_Kind := Nkind (N);
2699
2700 begin
2701 -- Note on checks that could raise Constraint_Error. Strictly, if
2702 -- we take advantage of 11.6, these checks do not count as side
2703 -- effects. However, we would just as soon consider that they are
2704 -- side effects, since the backend CSE does not work very well on
2705 -- expressions which can raise Constraint_Error. On the other
2706 -- hand, if we do not consider them to be side effect free, then
2707 -- we get some awkward expansions in -gnato mode, resulting in
2708 -- code insertions at a point where we do not have a clear model
2709 -- for performing the insertions. See 4908-002/comment for details.
2710
2711 -- An attribute reference is side effect free if its expressions
2712 -- are side effect free and its prefix is (could be a dereference
2713 -- or an indexed retrieval for example).
2714
2715 if K = N_Attribute_Reference then
2716 return Side_Effect_Free (Expressions (N))
2717 and then (Is_Entity_Name (Prefix (N))
2718 or else Side_Effect_Free (Prefix (N)));
2719
2720 -- An entity is side effect free unless it is a function call, or
2721 -- a reference to a volatile variable and Name_Req is False. If
2722 -- Name_Req is True then we can't help returning a name which
2723 -- effectively allows multiple references in any case.
2724
2725 elsif Is_Entity_Name (N)
2726 and then Ekind (Entity (N)) /= E_Function
2727 and then (not Is_Volatile (Entity (N)) or else Name_Req)
2728 then
2729 -- If the entity is a constant, it is definitely side effect
2730 -- free. Note that the test of Is_Variable (N) below might
2731 -- be expected to catch this case, but it does not, because
2732 -- this test goes to the original tree, and we may have
2733 -- already rewritten a variable node with a constant as
2734 -- a result of an earlier Force_Evaluation call.
2735
2736 if Ekind (Entity (N)) = E_Constant then
2737 return True;
2738
2739 -- If the Variable_Ref flag is set, any variable reference is
2740 -- is considered a side-effect
2741
2742 elsif Variable_Ref then
2743 return not Is_Variable (N);
2744
2745 else
2746 return True;
2747 end if;
2748
2749 -- A value known at compile time is always side effect free
2750
2751 elsif Compile_Time_Known_Value (N) then
2752 return True;
2753
2754 -- Literals are always side-effect free
2755
2756 elsif (K = N_Integer_Literal
2757 or else K = N_Real_Literal
2758 or else K = N_Character_Literal
2759 or else K = N_String_Literal
2760 or else K = N_Null)
2761 and then not Raises_Constraint_Error (N)
2762 then
2763 return True;
2764
2765 -- A type conversion or qualification is side effect free if the
2766 -- expression to be converted is side effect free.
2767
2768 elsif K = N_Type_Conversion or else K = N_Qualified_Expression then
2769 return Side_Effect_Free (Expression (N));
2770
2771 -- An unchecked type conversion is never side effect free since we
2772 -- need to check whether it is safe.
2773 -- effect free if its argument is side effect free.
2774
2775 elsif K = N_Unchecked_Type_Conversion then
2776 if Safe_Unchecked_Type_Conversion (N) then
2777 return Side_Effect_Free (Expression (N));
2778 else
2779 return False;
2780 end if;
2781
2782 -- A unary operator is side effect free if the operand
2783 -- is side effect free.
2784
2785 elsif K in N_Unary_Op then
2786 return Side_Effect_Free (Right_Opnd (N));
2787
2788 -- A binary operator is side effect free if and both operands
2789 -- are side effect free.
2790
2791 elsif K in N_Binary_Op then
2792 return Side_Effect_Free (Left_Opnd (N))
2793 and then Side_Effect_Free (Right_Opnd (N));
2794
2795 -- An explicit dereference or selected component is side effect
2796 -- free if its prefix is side effect free.
2797
2798 elsif K = N_Explicit_Dereference
2799 or else K = N_Selected_Component
2800 then
2801 return Side_Effect_Free (Prefix (N))
2802 and then not Mutable_Dereference (Prefix (N));
2803
2804 -- An indexed component can be copied if the prefix is copyable
2805 -- and all the indexing expressions are copyable and there is
2806 -- no access check and no range checks.
2807
2808 elsif K = N_Indexed_Component then
2809 return Side_Effect_Free (Prefix (N))
2810 and then Side_Effect_Free (Expressions (N));
2811
2812 elsif K = N_Unchecked_Expression then
2813 return Side_Effect_Free (Expression (N));
2814
2815 -- A call to _rep_to_pos is side effect free, since we generate
2816 -- this pure function call ourselves. Moreover it is critically
2817 -- important to make this exception, since otherwise we can
2818 -- have discriminants in array components which don't look
2819 -- side effect free in the case of an array whose index type
2820 -- is an enumeration type with an enumeration rep clause.
2821
2822 elsif K = N_Function_Call
2823 and then Nkind (Name (N)) = N_Identifier
2824 and then Chars (Name (N)) = Name_uRep_To_Pos
2825 then
2826 return True;
2827
2828 -- We consider that anything else has side effects. This is a bit
2829 -- crude, but we are pretty close for most common cases, and we
2830 -- are certainly correct (i.e. we never return True when the
2831 -- answer should be False).
2832
2833 else
2834 return False;
2835 end if;
2836 end Side_Effect_Free;
2837
2838 function Side_Effect_Free (L : List_Id) return Boolean is
2839 N : Node_Id;
2840
2841 begin
2842 if L = No_List or else L = Error_List then
2843 return True;
2844
2845 else
2846 N := First (L);
2847
2848 while Present (N) loop
2849 if not Side_Effect_Free (N) then
2850 return False;
2851 else
2852 Next (N);
2853 end if;
2854 end loop;
2855
2856 return True;
2857 end if;
2858 end Side_Effect_Free;
2859
2860 -- Start of processing for Remove_Side_Effects
2861
2862 begin
2863 -- If we are side effect free already or expansion is disabled,
2864 -- there is nothing to do.
2865
2866 if Side_Effect_Free (Exp) or else not Expander_Active then
2867 return;
2868 end if;
2869
2870 -- All the must not have any checks
2871
2872 Scope_Suppress := (others => True);
2873
2874 -- If the expression has the form v.all then we can just capture
2875 -- the pointer, and then do an explicit dereference on the result.
2876
2877 if Nkind (Exp) = N_Explicit_Dereference then
2878 Def_Id :=
2879 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2880 Res :=
2881 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
2882
2883 Insert_Action (Exp,
2884 Make_Object_Declaration (Loc,
2885 Defining_Identifier => Def_Id,
2886 Object_Definition =>
2887 New_Reference_To (Etype (Prefix (Exp)), Loc),
2888 Constant_Present => True,
2889 Expression => Relocate_Node (Prefix (Exp))));
2890
2891 -- If this is a type conversion, leave the type conversion and remove
2892 -- the side effects in the expression. This is important in several
2893 -- circumstances: for change of representations, and also when this
2894 -- is a view conversion to a smaller object, where gigi can end up
2895 -- its own temporary of the wrong size.
2896
2897 -- ??? this transformation is inhibited for elementary types that are
2898 -- not involved in a change of representation because it causes
2899 -- regressions that are not fully understood yet.
2900
2901 elsif Nkind (Exp) = N_Type_Conversion
2902 and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
2903 or else Nkind (Parent (Exp)) = N_Assignment_Statement)
2904 then
2905 Remove_Side_Effects (Expression (Exp), Variable_Ref);
2906 Scope_Suppress := Svg_Suppress;
2907 return;
2908
2909 -- For expressions that denote objects, we can use a renaming scheme.
2910 -- We skip using this if we have a volatile variable and we do not
2911 -- have Nam_Req set true (see comments above for Side_Effect_Free).
2912 -- We also skip this scheme for class-wide expressions in order to
2913 -- avoid recursive expension (see Expand_N_Object_Renaming_Declaration)
2914 -- If the object is a function call, we need to create a temporary and
2915 -- not a renaming.
2916
2917 elsif Is_Object_Reference (Exp)
2918 and then Nkind (Exp) /= N_Function_Call
2919 and then not Variable_Ref
2920 and then (Name_Req
2921 or else not Is_Entity_Name (Exp)
2922 or else not Is_Volatile (Entity (Exp)))
2923 and then not Is_Class_Wide_Type (Exp_Type)
2924 then
2925 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2926
2927 if Nkind (Exp) = N_Selected_Component
2928 and then Nkind (Prefix (Exp)) = N_Function_Call
2929 and then Is_Array_Type (Etype (Exp))
2930 then
2931 -- Avoid generating a variable-sized temporary, by generating
2932 -- the renaming declaration just for the function call. The
2933 -- transformation could be refined to apply only when the array
2934 -- component is constrained by a discriminant???
2935
2936 Res :=
2937 Make_Selected_Component (Loc,
2938 Prefix => New_Occurrence_Of (Def_Id, Loc),
2939 Selector_Name => Selector_Name (Exp));
2940
2941 Insert_Action (Exp,
2942 Make_Object_Renaming_Declaration (Loc,
2943 Defining_Identifier => Def_Id,
2944 Subtype_Mark =>
2945 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
2946 Name => Relocate_Node (Prefix (Exp))));
2947 else
2948 Res := New_Reference_To (Def_Id, Loc);
2949
2950 Insert_Action (Exp,
2951 Make_Object_Renaming_Declaration (Loc,
2952 Defining_Identifier => Def_Id,
2953 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
2954 Name => Relocate_Node (Exp)));
2955 end if;
2956
2957 -- If it is a scalar type, just make a copy.
2958
2959 elsif Is_Elementary_Type (Exp_Type) then
2960 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2961 Set_Etype (Def_Id, Exp_Type);
2962 Res := New_Reference_To (Def_Id, Loc);
2963
2964 E :=
2965 Make_Object_Declaration (Loc,
2966 Defining_Identifier => Def_Id,
2967 Object_Definition => New_Reference_To (Exp_Type, Loc),
2968 Constant_Present => True,
2969 Expression => Relocate_Node (Exp));
2970
2971 Set_Assignment_OK (E);
2972 Insert_Action (Exp, E);
2973
2974 -- If this is an unchecked conversion that Gigi can't handle, make
2975 -- a copy or a use a renaming to capture the value.
2976
2977 elsif (Nkind (Exp) = N_Unchecked_Type_Conversion
2978 and then not Safe_Unchecked_Type_Conversion (Exp))
2979 then
2980 if Controlled_Type (Etype (Exp)) then
2981 -- Use a renaming to capture the expression, rather than create
2982 -- a controlled temporary.
2983
2984 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2985 Res := New_Reference_To (Def_Id, Loc);
2986
2987 Insert_Action (Exp,
2988 Make_Object_Renaming_Declaration (Loc,
2989 Defining_Identifier => Def_Id,
2990 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
2991 Name => Relocate_Node (Exp)));
2992
2993 else
2994 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2995 Set_Etype (Def_Id, Exp_Type);
2996 Res := New_Reference_To (Def_Id, Loc);
2997
2998 E :=
2999 Make_Object_Declaration (Loc,
3000 Defining_Identifier => Def_Id,
3001 Object_Definition => New_Reference_To (Exp_Type, Loc),
3002 Constant_Present => True,
3003 Expression => Relocate_Node (Exp));
3004
3005 Set_Assignment_OK (E);
3006 Insert_Action (Exp, E);
3007 end if;
3008
3009 -- Otherwise we generate a reference to the value
3010
3011 else
3012 Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3013
3014 Ptr_Typ_Decl :=
3015 Make_Full_Type_Declaration (Loc,
3016 Defining_Identifier => Ref_Type,
3017 Type_Definition =>
3018 Make_Access_To_Object_Definition (Loc,
3019 All_Present => True,
3020 Subtype_Indication =>
3021 New_Reference_To (Exp_Type, Loc)));
3022
3023 E := Exp;
3024 Insert_Action (Exp, Ptr_Typ_Decl);
3025
3026 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3027 Set_Etype (Def_Id, Exp_Type);
3028
3029 Res :=
3030 Make_Explicit_Dereference (Loc,
3031 Prefix => New_Reference_To (Def_Id, Loc));
3032
3033 if Nkind (E) = N_Explicit_Dereference then
3034 New_Exp := Relocate_Node (Prefix (E));
3035 else
3036 E := Relocate_Node (E);
3037 New_Exp := Make_Reference (Loc, E);
3038 end if;
3039
3040 if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then
3041 Set_Expansion_Delayed (E, False);
3042 Set_Analyzed (E, False);
3043 end if;
3044
3045 Insert_Action (Exp,
3046 Make_Object_Declaration (Loc,
3047 Defining_Identifier => Def_Id,
3048 Object_Definition => New_Reference_To (Ref_Type, Loc),
3049 Expression => New_Exp));
3050 end if;
3051
3052 -- Preserve the Assignment_OK flag in all copies, since at least
3053 -- one copy may be used in a context where this flag must be set
3054 -- (otherwise why would the flag be set in the first place).
3055
3056 Set_Assignment_OK (Res, Assignment_OK (Exp));
3057
3058 -- Finally rewrite the original expression and we are done
3059
3060 Rewrite (Exp, Res);
3061 Analyze_And_Resolve (Exp, Exp_Type);
3062 Scope_Suppress := Svg_Suppress;
3063 end Remove_Side_Effects;
3064
3065 ------------------------------------
3066 -- Safe_Unchecked_Type_Conversion --
3067 ------------------------------------
3068
3069 -- Note: this function knows quite a bit about the exact requirements
3070 -- of Gigi with respect to unchecked type conversions, and its code
3071 -- must be coordinated with any changes in Gigi in this area.
3072
3073 -- The above requirements should be documented in Sinfo ???
3074
3075 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
3076 Otyp : Entity_Id;
3077 Ityp : Entity_Id;
3078 Oalign : Uint;
3079 Ialign : Uint;
3080 Pexp : constant Node_Id := Parent (Exp);
3081
3082 begin
3083 -- If the expression is the RHS of an assignment or object declaration
3084 -- we are always OK because there will always be a target.
3085
3086 -- Object renaming declarations, (generated for view conversions of
3087 -- actuals in inlined calls), like object declarations, provide an
3088 -- explicit type, and are safe as well.
3089
3090 if (Nkind (Pexp) = N_Assignment_Statement
3091 and then Expression (Pexp) = Exp)
3092 or else Nkind (Pexp) = N_Object_Declaration
3093 or else Nkind (Pexp) = N_Object_Renaming_Declaration
3094 then
3095 return True;
3096
3097 -- If the expression is the prefix of an N_Selected_Component
3098 -- we should also be OK because GCC knows to look inside the
3099 -- conversion except if the type is discriminated. We assume
3100 -- that we are OK anyway if the type is not set yet or if it is
3101 -- controlled since we can't afford to introduce a temporary in
3102 -- this case.
3103
3104 elsif Nkind (Pexp) = N_Selected_Component
3105 and then Prefix (Pexp) = Exp
3106 then
3107 if No (Etype (Pexp)) then
3108 return True;
3109 else
3110 return
3111 not Has_Discriminants (Etype (Pexp))
3112 or else Is_Constrained (Etype (Pexp));
3113 end if;
3114 end if;
3115
3116 -- Set the output type, this comes from Etype if it is set, otherwise
3117 -- we take it from the subtype mark, which we assume was already
3118 -- fully analyzed.
3119
3120 if Present (Etype (Exp)) then
3121 Otyp := Etype (Exp);
3122 else
3123 Otyp := Entity (Subtype_Mark (Exp));
3124 end if;
3125
3126 -- The input type always comes from the expression, and we assume
3127 -- this is indeed always analyzed, so we can simply get the Etype.
3128
3129 Ityp := Etype (Expression (Exp));
3130
3131 -- Initialize alignments to unknown so far
3132
3133 Oalign := No_Uint;
3134 Ialign := No_Uint;
3135
3136 -- Replace a concurrent type by its corresponding record type
3137 -- and each type by its underlying type and do the tests on those.
3138 -- The original type may be a private type whose completion is a
3139 -- concurrent type, so find the underlying type first.
3140
3141 if Present (Underlying_Type (Otyp)) then
3142 Otyp := Underlying_Type (Otyp);
3143 end if;
3144
3145 if Present (Underlying_Type (Ityp)) then
3146 Ityp := Underlying_Type (Ityp);
3147 end if;
3148
3149 if Is_Concurrent_Type (Otyp) then
3150 Otyp := Corresponding_Record_Type (Otyp);
3151 end if;
3152
3153 if Is_Concurrent_Type (Ityp) then
3154 Ityp := Corresponding_Record_Type (Ityp);
3155 end if;
3156
3157 -- If the base types are the same, we know there is no problem since
3158 -- this conversion will be a noop.
3159
3160 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
3161 return True;
3162
3163 -- If the size of output type is known at compile time, there is
3164 -- never a problem. Note that unconstrained records are considered
3165 -- to be of known size, but we can't consider them that way here,
3166 -- because we are talking about the actual size of the object.
3167
3168 -- We also make sure that in addition to the size being known, we do
3169 -- not have a case which might generate an embarrassingly large temp
3170 -- in stack checking mode.
3171
3172 elsif Size_Known_At_Compile_Time (Otyp)
3173 and then not May_Generate_Large_Temp (Otyp)
3174 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
3175 then
3176 return True;
3177
3178 -- If either type is tagged, then we know the alignment is OK so
3179 -- Gigi will be able to use pointer punning.
3180
3181 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
3182 return True;
3183
3184 -- If either type is a limited record type, we cannot do a copy, so
3185 -- say safe since there's nothing else we can do.
3186
3187 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
3188 return True;
3189
3190 -- Conversions to and from packed array types are always ignored and
3191 -- hence are safe.
3192
3193 elsif Is_Packed_Array_Type (Otyp)
3194 or else Is_Packed_Array_Type (Ityp)
3195 then
3196 return True;
3197 end if;
3198
3199 -- The only other cases known to be safe is if the input type's
3200 -- alignment is known to be at least the maximum alignment for the
3201 -- target or if both alignments are known and the output type's
3202 -- alignment is no stricter than the input's. We can use the alignment
3203 -- of the component type of an array if a type is an unpacked
3204 -- array type.
3205
3206 if Present (Alignment_Clause (Otyp)) then
3207 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
3208
3209 elsif Is_Array_Type (Otyp)
3210 and then Present (Alignment_Clause (Component_Type (Otyp)))
3211 then
3212 Oalign := Expr_Value (Expression (Alignment_Clause
3213 (Component_Type (Otyp))));
3214 end if;
3215
3216 if Present (Alignment_Clause (Ityp)) then
3217 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
3218
3219 elsif Is_Array_Type (Ityp)
3220 and then Present (Alignment_Clause (Component_Type (Ityp)))
3221 then
3222 Ialign := Expr_Value (Expression (Alignment_Clause
3223 (Component_Type (Ityp))));
3224 end if;
3225
3226 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
3227 return True;
3228
3229 elsif Ialign /= No_Uint and then Oalign /= No_Uint
3230 and then Ialign <= Oalign
3231 then
3232 return True;
3233
3234 -- Otherwise, Gigi cannot handle this and we must make a temporary.
3235
3236 else
3237 return False;
3238 end if;
3239
3240 end Safe_Unchecked_Type_Conversion;
3241
3242 --------------------------
3243 -- Set_Elaboration_Flag --
3244 --------------------------
3245
3246 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
3247 Loc : constant Source_Ptr := Sloc (N);
3248 Asn : Node_Id;
3249
3250 begin
3251 if Present (Elaboration_Entity (Spec_Id)) then
3252
3253 -- Nothing to do if at the compilation unit level, because in this
3254 -- case the flag is set by the binder generated elaboration routine.
3255
3256 if Nkind (Parent (N)) = N_Compilation_Unit then
3257 null;
3258
3259 -- Here we do need to generate an assignment statement
3260
3261 else
3262 Check_Restriction (No_Elaboration_Code, N);
3263 Asn :=
3264 Make_Assignment_Statement (Loc,
3265 Name => New_Occurrence_Of (Elaboration_Entity (Spec_Id), Loc),
3266 Expression => New_Occurrence_Of (Standard_True, Loc));
3267
3268 if Nkind (Parent (N)) = N_Subunit then
3269 Insert_After (Corresponding_Stub (Parent (N)), Asn);
3270 else
3271 Insert_After (N, Asn);
3272 end if;
3273
3274 Analyze (Asn);
3275 end if;
3276 end if;
3277 end Set_Elaboration_Flag;
3278
3279 ----------------------------
3280 -- Wrap_Cleanup_Procedure --
3281 ----------------------------
3282
3283 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
3284 Loc : constant Source_Ptr := Sloc (N);
3285 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
3286 Stmts : constant List_Id := Statements (Stseq);
3287
3288 begin
3289 if Abort_Allowed then
3290 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
3291 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
3292 end if;
3293 end Wrap_Cleanup_Procedure;
3294
3295 end Exp_Util;
Mirror of the offical gcc git repository hosted at gcc.gnu.org