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