?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* tree-cfg.c (tree_find_edge_insert_loc): Handle naked RETURN_EXPR.
[official-gcc.git] / gcc / ada / exp_util.adb
blobebef01d303bd694cccf63a1813f1e711bad74dd8
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-2005 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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_Aggr; use Exp_Aggr;
33 with Exp_Ch7; use Exp_Ch7;
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 Rident; use Rident;
44 with Sem; use Sem;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Eval; use Sem_Eval;
47 with Sem_Res; use Sem_Res;
48 with Sem_Type; use Sem_Type;
49 with Sem_Util; use Sem_Util;
50 with Snames; use Snames;
51 with Stand; use Stand;
52 with Stringt; use Stringt;
53 with Targparm; use Targparm;
54 with Tbuild; use Tbuild;
55 with Ttypes; use Ttypes;
56 with Uintp; use Uintp;
57 with Urealp; use Urealp;
58 with Validsw; use Validsw;
59
60 package body Exp_Util is
61
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
65
66 function Build_Task_Array_Image
67 (Loc : Source_Ptr;
68 Id_Ref : Node_Id;
69 A_Type : Entity_Id;
70 Dyn : Boolean := False) return Node_Id;
71 -- Build function to generate the image string for a task that is an
72 -- array component, concatenating the images of each index. To avoid
73 -- storage leaks, the string is built with successive slice assignments.
74 -- The flag Dyn indicates whether this is called for the initialization
75 -- procedure of an array of tasks, or for the name of a dynamically
76 -- created task that is assigned to an indexed component.
77
78 function Build_Task_Image_Function
79 (Loc : Source_Ptr;
80 Decls : List_Id;
81 Stats : List_Id;
82 Res : Entity_Id) 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) return Node_Id;
102 -- Build function to generate the image string for a task that is a
103 -- record component. Concatenate name of variable with that of selector.
104 -- The flag Dyn indicates whether this is called for the initialization
105 -- procedure of record with task components, or for a dynamically
106 -- created task that is assigned to a selected component.
107
108 function Make_CW_Equivalent_Type
109 (T : Entity_Id;
110 E : Node_Id) return Entity_Id;
111 -- T is a class-wide type entity, E is the initial expression node that
112 -- constrains T in case such as: " X: T := E" or "new T'(E)"
113 -- This function returns the entity of the Equivalent type and inserts
114 -- on the fly the necessary declaration such as:
115 --
116 -- type anon is record
117 -- _parent : Root_Type (T); constrained with E discriminants (if any)
118 -- Extension : String (1 .. expr to match size of E);
119 -- end record;
120 --
121 -- This record is compatible with any object of the class of T thanks
122 -- to the first field and has the same size as E thanks to the second.
123
124 function Make_Literal_Range
125 (Loc : Source_Ptr;
126 Literal_Typ : Entity_Id) return Node_Id;
127 -- Produce a Range node whose bounds are:
128 -- Low_Bound (Literal_Type) ..
129 -- Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
130 -- this is used for expanding declarations like X : String := "sdfgdfg";
131
132 function New_Class_Wide_Subtype
133 (CW_Typ : Entity_Id;
134 N : Node_Id) return Entity_Id;
135 -- Create an implicit subtype of CW_Typ attached to node N
136
137 ----------------------
138 -- Adjust_Condition --
139 ----------------------
140
141 procedure Adjust_Condition (N : Node_Id) is
142 begin
143 if No (N) then
144 return;
145 end if;
146
147 declare
148 Loc : constant Source_Ptr := Sloc (N);
149 T : constant Entity_Id := Etype (N);
150 Ti : Entity_Id;
151
152 begin
153 -- For now, we simply ignore a call where the argument has no
154 -- type (probably case of unanalyzed condition), or has a type
155 -- that is not Boolean. This is because this is a pretty marginal
156 -- piece of functionality, and violations of these rules are
157 -- likely to be truly marginal (how much code uses Fortran Logical
158 -- as the barrier to a protected entry?) and we do not want to
159 -- blow up existing programs. We can change this to an assertion
160 -- after 3.12a is released ???
161
162 if No (T) or else not Is_Boolean_Type (T) then
163 return;
164 end if;
165
166 -- Apply validity checking if needed
167
168 if Validity_Checks_On and Validity_Check_Tests then
169 Ensure_Valid (N);
170 end if;
171
172 -- Immediate return if standard boolean, the most common case,
173 -- where nothing needs to be done.
174
175 if Base_Type (T) = Standard_Boolean then
176 return;
177 end if;
178
179 -- Case of zero/non-zero semantics or non-standard enumeration
180 -- representation. In each case, we rewrite the node as:
181
182 -- ityp!(N) /= False'Enum_Rep
183
184 -- where ityp is an integer type with large enough size to hold
185 -- any value of type T.
186
187 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
188 if Esize (T) <= Esize (Standard_Integer) then
189 Ti := Standard_Integer;
190 else
191 Ti := Standard_Long_Long_Integer;
192 end if;
193
194 Rewrite (N,
195 Make_Op_Ne (Loc,
196 Left_Opnd => Unchecked_Convert_To (Ti, N),
197 Right_Opnd =>
198 Make_Attribute_Reference (Loc,
199 Attribute_Name => Name_Enum_Rep,
200 Prefix =>
201 New_Occurrence_Of (First_Literal (T), Loc))));
202 Analyze_And_Resolve (N, Standard_Boolean);
203
204 else
205 Rewrite (N, Convert_To (Standard_Boolean, N));
206 Analyze_And_Resolve (N, Standard_Boolean);
207 end if;
208 end;
209 end Adjust_Condition;
210
211 ------------------------
212 -- Adjust_Result_Type --
213 ------------------------
214
215 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
216 begin
217 -- Ignore call if current type is not Standard.Boolean
218
219 if Etype (N) /= Standard_Boolean then
220 return;
221 end if;
222
223 -- If result is already of correct type, nothing to do. Note that
224 -- this will get the most common case where everything has a type
225 -- of Standard.Boolean.
226
227 if Base_Type (T) = Standard_Boolean then
228 return;
229
230 else
231 declare
232 KP : constant Node_Kind := Nkind (Parent (N));
233
234 begin
235 -- If result is to be used as a Condition in the syntax, no need
236 -- to convert it back, since if it was changed to Standard.Boolean
237 -- using Adjust_Condition, that is just fine for this usage.
238
239 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
240 return;
241
242 -- If result is an operand of another logical operation, no need
243 -- to reset its type, since Standard.Boolean is just fine, and
244 -- such operations always do Adjust_Condition on their operands.
245
246 elsif KP in N_Op_Boolean
247 or else KP = N_And_Then
248 or else KP = N_Or_Else
249 or else KP = N_Op_Not
250 then
251 return;
252
253 -- Otherwise we perform a conversion from the current type,
254 -- which must be Standard.Boolean, to the desired type.
255
256 else
257 Set_Analyzed (N);
258 Rewrite (N, Convert_To (T, N));
259 Analyze_And_Resolve (N, T);
260 end if;
261 end;
262 end if;
263 end Adjust_Result_Type;
264
265 --------------------------
266 -- Append_Freeze_Action --
267 --------------------------
268
269 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
270 Fnode : Node_Id := Freeze_Node (T);
271
272 begin
273 Ensure_Freeze_Node (T);
274 Fnode := Freeze_Node (T);
275
276 if not Present (Actions (Fnode)) then
277 Set_Actions (Fnode, New_List);
278 end if;
279
280 Append (N, Actions (Fnode));
281 end Append_Freeze_Action;
282
283 ---------------------------
284 -- Append_Freeze_Actions --
285 ---------------------------
286
287 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
288 Fnode : constant Node_Id := Freeze_Node (T);
289
290 begin
291 if No (L) then
292 return;
293
294 else
295 if No (Actions (Fnode)) then
296 Set_Actions (Fnode, L);
297
298 else
299 Append_List (L, Actions (Fnode));
300 end if;
301
302 end if;
303 end Append_Freeze_Actions;
304
305 ------------------------
306 -- Build_Runtime_Call --
307 ------------------------
308
309 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
310 begin
311 -- If entity is not available, we can skip making the call (this avoids
312 -- junk duplicated error messages in a number of cases).
313
314 if not RTE_Available (RE) then
315 return Make_Null_Statement (Loc);
316 else
317 return
318 Make_Procedure_Call_Statement (Loc,
319 Name => New_Reference_To (RTE (RE), Loc));
320 end if;
321 end Build_Runtime_Call;
322
323 ----------------------------
324 -- Build_Task_Array_Image --
325 ----------------------------
326
327 -- This function generates the body for a function that constructs the
328 -- image string for a task that is an array component. The function is
329 -- local to the init proc for the array type, and is called for each one
330 -- of the components. The constructed image has the form of an indexed
331 -- component, whose prefix is the outer variable of the array type.
332 -- The n-dimensional array type has known indices Index, Index2...
333 -- Id_Ref is an indexed component form created by the enclosing init proc.
334 -- Its successive indices are Val1, Val2,.. which are the loop variables
335 -- in the loops that call the individual task init proc on each component.
336
337 -- The generated function has the following structure:
338
339 -- function F return String is
340 -- Pref : string renames Task_Name;
341 -- T1 : String := Index1'Image (Val1);
342 -- ...
343 -- Tn : String := indexn'image (Valn);
344 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
345 -- -- Len includes commas and the end parentheses.
346 -- Res : String (1..Len);
347 -- Pos : Integer := Pref'Length;
348 --
349 -- begin
350 -- Res (1 .. Pos) := Pref;
351 -- Pos := Pos + 1;
352 -- Res (Pos) := '(';
353 -- Pos := Pos + 1;
354 -- Res (Pos .. Pos + T1'Length - 1) := T1;
355 -- Pos := Pos + T1'Length;
356 -- Res (Pos) := '.';
357 -- Pos := Pos + 1;
358 -- ...
359 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
360 -- Res (Len) := ')';
361 --
362 -- return Res;
363 -- end F;
364 --
365 -- Needless to say, multidimensional arrays of tasks are rare enough
366 -- that the bulkiness of this code is not really a concern.
367
368 function Build_Task_Array_Image
369 (Loc : Source_Ptr;
370 Id_Ref : Node_Id;
371 A_Type : Entity_Id;
372 Dyn : Boolean := False) return Node_Id
373 is
374 Dims : constant Nat := Number_Dimensions (A_Type);
375 -- Number of dimensions for array of tasks
376
377 Temps : array (1 .. Dims) of Entity_Id;
378 -- Array of temporaries to hold string for each index
379
380 Indx : Node_Id;
381 -- Index expression
382
383 Len : Entity_Id;
384 -- Total length of generated name
385
386 Pos : Entity_Id;
387 -- Running index for substring assignments
388
389 Pref : Entity_Id;
390 -- Name of enclosing variable, prefix of resulting name
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 Append_To (Decls,
416 Make_Object_Declaration (Loc,
417 Defining_Identifier => Pref,
418 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
419 Expression =>
420 Make_String_Literal (Loc,
421 Strval => String_From_Name_Buffer)));
422
423 else
424 Append_To (Decls,
425 Make_Object_Renaming_Declaration (Loc,
426 Defining_Identifier => Pref,
427 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
428 Name => Make_Identifier (Loc, Name_uTask_Name)));
429 end if;
430
431 Indx := First_Index (A_Type);
432 Val := First (Expressions (Id_Ref));
433
434 for J in 1 .. Dims loop
435 T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
436 Temps (J) := T;
437
438 Append_To (Decls,
439 Make_Object_Declaration (Loc,
440 Defining_Identifier => T,
441 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
442 Expression =>
443 Make_Attribute_Reference (Loc,
444 Attribute_Name => Name_Image,
445 Prefix =>
446 New_Occurrence_Of (Etype (Indx), Loc),
447 Expressions => New_List (
448 New_Copy_Tree (Val)))));
449
450 Next_Index (Indx);
451 Next (Val);
452 end loop;
453
454 Sum := Make_Integer_Literal (Loc, Dims + 1);
455
456 Sum :=
457 Make_Op_Add (Loc,
458 Left_Opnd => Sum,
459 Right_Opnd =>
460 Make_Attribute_Reference (Loc,
461 Attribute_Name => Name_Length,
462 Prefix =>
463 New_Occurrence_Of (Pref, Loc),
464 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
465
466 for J in 1 .. Dims loop
467 Sum :=
468 Make_Op_Add (Loc,
469 Left_Opnd => Sum,
470 Right_Opnd =>
471 Make_Attribute_Reference (Loc,
472 Attribute_Name => Name_Length,
473 Prefix =>
474 New_Occurrence_Of (Temps (J), Loc),
475 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
476 end loop;
477
478 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
479
480 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
481
482 Append_To (Stats,
483 Make_Assignment_Statement (Loc,
484 Name => Make_Indexed_Component (Loc,
485 Prefix => New_Occurrence_Of (Res, Loc),
486 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
487 Expression =>
488 Make_Character_Literal (Loc,
489 Chars => Name_Find,
490 Char_Literal_Value =>
491 UI_From_Int (Character'Pos ('(')))));
492
493 Append_To (Stats,
494 Make_Assignment_Statement (Loc,
495 Name => New_Occurrence_Of (Pos, Loc),
496 Expression =>
497 Make_Op_Add (Loc,
498 Left_Opnd => New_Occurrence_Of (Pos, Loc),
499 Right_Opnd => Make_Integer_Literal (Loc, 1))));
500
501 for J in 1 .. Dims loop
502
503 Append_To (Stats,
504 Make_Assignment_Statement (Loc,
505 Name => Make_Slice (Loc,
506 Prefix => New_Occurrence_Of (Res, Loc),
507 Discrete_Range =>
508 Make_Range (Loc,
509 Low_Bound => New_Occurrence_Of (Pos, Loc),
510 High_Bound => Make_Op_Subtract (Loc,
511 Left_Opnd =>
512 Make_Op_Add (Loc,
513 Left_Opnd => New_Occurrence_Of (Pos, Loc),
514 Right_Opnd =>
515 Make_Attribute_Reference (Loc,
516 Attribute_Name => Name_Length,
517 Prefix =>
518 New_Occurrence_Of (Temps (J), Loc),
519 Expressions =>
520 New_List (Make_Integer_Literal (Loc, 1)))),
521 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
522
523 Expression => New_Occurrence_Of (Temps (J), Loc)));
524
525 if J < Dims then
526 Append_To (Stats,
527 Make_Assignment_Statement (Loc,
528 Name => New_Occurrence_Of (Pos, Loc),
529 Expression =>
530 Make_Op_Add (Loc,
531 Left_Opnd => New_Occurrence_Of (Pos, Loc),
532 Right_Opnd =>
533 Make_Attribute_Reference (Loc,
534 Attribute_Name => Name_Length,
535 Prefix => New_Occurrence_Of (Temps (J), Loc),
536 Expressions =>
537 New_List (Make_Integer_Literal (Loc, 1))))));
538
539 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
540
541 Append_To (Stats,
542 Make_Assignment_Statement (Loc,
543 Name => Make_Indexed_Component (Loc,
544 Prefix => New_Occurrence_Of (Res, Loc),
545 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
546 Expression =>
547 Make_Character_Literal (Loc,
548 Chars => Name_Find,
549 Char_Literal_Value =>
550 UI_From_Int (Character'Pos (',')))));
551
552 Append_To (Stats,
553 Make_Assignment_Statement (Loc,
554 Name => New_Occurrence_Of (Pos, Loc),
555 Expression =>
556 Make_Op_Add (Loc,
557 Left_Opnd => New_Occurrence_Of (Pos, Loc),
558 Right_Opnd => Make_Integer_Literal (Loc, 1))));
559 end if;
560 end loop;
561
562 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
563
564 Append_To (Stats,
565 Make_Assignment_Statement (Loc,
566 Name => Make_Indexed_Component (Loc,
567 Prefix => New_Occurrence_Of (Res, Loc),
568 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
569 Expression =>
570 Make_Character_Literal (Loc,
571 Chars => Name_Find,
572 Char_Literal_Value =>
573 UI_From_Int (Character'Pos (')')))));
574 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
575 end Build_Task_Array_Image;
576
577 ----------------------------
578 -- Build_Task_Image_Decls --
579 ----------------------------
580
581 function Build_Task_Image_Decls
582 (Loc : Source_Ptr;
583 Id_Ref : Node_Id;
584 A_Type : Entity_Id) return List_Id
585 is
586 Decls : constant List_Id := New_List;
587 T_Id : Entity_Id := Empty;
588 Decl : Node_Id;
589 Expr : Node_Id := Empty;
590 Fun : Node_Id := Empty;
591 Is_Dyn : constant Boolean :=
592 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
593 and then
594 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
595
596 begin
597 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
598 -- generate a dummy declaration only.
599
600 if Restriction_Active (No_Implicit_Heap_Allocations)
601 or else Global_Discard_Names
602 then
603 T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
604 Name_Len := 0;
605
606 return
607 New_List (
608 Make_Object_Declaration (Loc,
609 Defining_Identifier => T_Id,
610 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
611 Expression =>
612 Make_String_Literal (Loc,
613 Strval => String_From_Name_Buffer)));
614
615 else
616 if Nkind (Id_Ref) = N_Identifier
617 or else Nkind (Id_Ref) = N_Defining_Identifier
618 then
619 -- For a simple variable, the image of the task is built from
620 -- the name of the variable. To avoid possible conflict with
621 -- the anonymous type created for a single protected object,
622 -- add a numeric suffix.
623
624 T_Id :=
625 Make_Defining_Identifier (Loc,
626 New_External_Name (Chars (Id_Ref), 'T', 1));
627
628 Get_Name_String (Chars (Id_Ref));
629
630 Expr :=
631 Make_String_Literal (Loc,
632 Strval => String_From_Name_Buffer);
633
634 elsif Nkind (Id_Ref) = N_Selected_Component then
635 T_Id :=
636 Make_Defining_Identifier (Loc,
637 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
638 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
639
640 elsif Nkind (Id_Ref) = N_Indexed_Component then
641 T_Id :=
642 Make_Defining_Identifier (Loc,
643 New_External_Name (Chars (A_Type), 'N'));
644
645 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
646 end if;
647 end if;
648
649 if Present (Fun) then
650 Append (Fun, Decls);
651 Expr := Make_Function_Call (Loc,
652 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
653 end if;
654
655 Decl := Make_Object_Declaration (Loc,
656 Defining_Identifier => T_Id,
657 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
658 Constant_Present => True,
659 Expression => Expr);
660
661 Append (Decl, Decls);
662 return Decls;
663 end Build_Task_Image_Decls;
664
665 -------------------------------
666 -- Build_Task_Image_Function --
667 -------------------------------
668
669 function Build_Task_Image_Function
670 (Loc : Source_Ptr;
671 Decls : List_Id;
672 Stats : List_Id;
673 Res : Entity_Id) return Node_Id
674 is
675 Spec : Node_Id;
676
677 begin
678 Append_To (Stats,
679 Make_Return_Statement (Loc,
680 Expression => New_Occurrence_Of (Res, Loc)));
681
682 Spec := Make_Function_Specification (Loc,
683 Defining_Unit_Name =>
684 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
685 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
686
687 -- Calls to 'Image use the secondary stack, which must be cleaned
688 -- up after the task name is built.
689
690 Set_Uses_Sec_Stack (Defining_Unit_Name (Spec));
691
692 return Make_Subprogram_Body (Loc,
693 Specification => Spec,
694 Declarations => Decls,
695 Handled_Statement_Sequence =>
696 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
697 end Build_Task_Image_Function;
698
699 -----------------------------
700 -- Build_Task_Image_Prefix --
701 -----------------------------
702
703 procedure Build_Task_Image_Prefix
704 (Loc : Source_Ptr;
705 Len : out Entity_Id;
706 Res : out Entity_Id;
707 Pos : out Entity_Id;
708 Prefix : Entity_Id;
709 Sum : Node_Id;
710 Decls : in out List_Id;
711 Stats : in out List_Id)
712 is
713 begin
714 Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
715
716 Append_To (Decls,
717 Make_Object_Declaration (Loc,
718 Defining_Identifier => Len,
719 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
720 Expression => Sum));
721
722 Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
723
724 Append_To (Decls,
725 Make_Object_Declaration (Loc,
726 Defining_Identifier => Res,
727 Object_Definition =>
728 Make_Subtype_Indication (Loc,
729 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
730 Constraint =>
731 Make_Index_Or_Discriminant_Constraint (Loc,
732 Constraints =>
733 New_List (
734 Make_Range (Loc,
735 Low_Bound => Make_Integer_Literal (Loc, 1),
736 High_Bound => New_Occurrence_Of (Len, Loc)))))));
737
738 Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
739
740 Append_To (Decls,
741 Make_Object_Declaration (Loc,
742 Defining_Identifier => Pos,
743 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
744
745 -- Pos := Prefix'Length;
746
747 Append_To (Stats,
748 Make_Assignment_Statement (Loc,
749 Name => New_Occurrence_Of (Pos, Loc),
750 Expression =>
751 Make_Attribute_Reference (Loc,
752 Attribute_Name => Name_Length,
753 Prefix => New_Occurrence_Of (Prefix, Loc),
754 Expressions =>
755 New_List (Make_Integer_Literal (Loc, 1)))));
756
757 -- Res (1 .. Pos) := Prefix;
758
759 Append_To (Stats,
760 Make_Assignment_Statement (Loc,
761 Name => Make_Slice (Loc,
762 Prefix => New_Occurrence_Of (Res, Loc),
763 Discrete_Range =>
764 Make_Range (Loc,
765 Low_Bound => Make_Integer_Literal (Loc, 1),
766 High_Bound => New_Occurrence_Of (Pos, Loc))),
767
768 Expression => New_Occurrence_Of (Prefix, Loc)));
769
770 Append_To (Stats,
771 Make_Assignment_Statement (Loc,
772 Name => New_Occurrence_Of (Pos, Loc),
773 Expression =>
774 Make_Op_Add (Loc,
775 Left_Opnd => New_Occurrence_Of (Pos, Loc),
776 Right_Opnd => Make_Integer_Literal (Loc, 1))));
777 end Build_Task_Image_Prefix;
778
779 -----------------------------
780 -- Build_Task_Record_Image --
781 -----------------------------
782
783 function Build_Task_Record_Image
784 (Loc : Source_Ptr;
785 Id_Ref : Node_Id;
786 Dyn : Boolean := False) return Node_Id
787 is
788 Len : Entity_Id;
789 -- Total length of generated name
790
791 Pos : Entity_Id;
792 -- Index into result
793
794 Res : Entity_Id;
795 -- String to hold result
796
797 Pref : Entity_Id;
798 -- Name of enclosing variable, prefix of resulting name
799
800 Sum : Node_Id;
801 -- Expression to compute total size of string
802
803 Sel : Entity_Id;
804 -- Entity for selector name
805
806 Decls : List_Id := New_List;
807 Stats : List_Id := New_List;
808
809 begin
810 Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
811
812 -- For a dynamic task, the name comes from the target variable.
813 -- For a static one it is a formal of the enclosing init proc.
814
815 if Dyn then
816 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
817 Append_To (Decls,
818 Make_Object_Declaration (Loc,
819 Defining_Identifier => Pref,
820 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
821 Expression =>
822 Make_String_Literal (Loc,
823 Strval => String_From_Name_Buffer)));
824
825 else
826 Append_To (Decls,
827 Make_Object_Renaming_Declaration (Loc,
828 Defining_Identifier => Pref,
829 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
830 Name => Make_Identifier (Loc, Name_uTask_Name)));
831 end if;
832
833 Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
834
835 Get_Name_String (Chars (Selector_Name (Id_Ref)));
836
837 Append_To (Decls,
838 Make_Object_Declaration (Loc,
839 Defining_Identifier => Sel,
840 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
841 Expression =>
842 Make_String_Literal (Loc,
843 Strval => String_From_Name_Buffer)));
844
845 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
846
847 Sum :=
848 Make_Op_Add (Loc,
849 Left_Opnd => Sum,
850 Right_Opnd =>
851 Make_Attribute_Reference (Loc,
852 Attribute_Name => Name_Length,
853 Prefix =>
854 New_Occurrence_Of (Pref, Loc),
855 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
856
857 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
858
859 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
860
861 -- Res (Pos) := '.';
862
863 Append_To (Stats,
864 Make_Assignment_Statement (Loc,
865 Name => Make_Indexed_Component (Loc,
866 Prefix => New_Occurrence_Of (Res, Loc),
867 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
868 Expression =>
869 Make_Character_Literal (Loc,
870 Chars => Name_Find,
871 Char_Literal_Value =>
872 UI_From_Int (Character'Pos ('.')))));
873
874 Append_To (Stats,
875 Make_Assignment_Statement (Loc,
876 Name => New_Occurrence_Of (Pos, Loc),
877 Expression =>
878 Make_Op_Add (Loc,
879 Left_Opnd => New_Occurrence_Of (Pos, Loc),
880 Right_Opnd => Make_Integer_Literal (Loc, 1))));
881
882 -- Res (Pos .. Len) := Selector;
883
884 Append_To (Stats,
885 Make_Assignment_Statement (Loc,
886 Name => Make_Slice (Loc,
887 Prefix => New_Occurrence_Of (Res, Loc),
888 Discrete_Range =>
889 Make_Range (Loc,
890 Low_Bound => New_Occurrence_Of (Pos, Loc),
891 High_Bound => New_Occurrence_Of (Len, Loc))),
892 Expression => New_Occurrence_Of (Sel, Loc)));
893
894 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
895 end Build_Task_Record_Image;
896
897 ----------------------------------
898 -- Component_May_Be_Bit_Aligned --
899 ----------------------------------
900
901 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
902 begin
903 -- If no component clause, then everything is fine, since the
904 -- back end never bit-misaligns by default, even if there is
905 -- a pragma Packed for the record.
906
907 if No (Component_Clause (Comp)) then
908 return False;
909 end if;
910
911 -- It is only array and record types that cause trouble
912
913 if not Is_Record_Type (Etype (Comp))
914 and then not Is_Array_Type (Etype (Comp))
915 then
916 return False;
917
918 -- If we know that we have a small (64 bits or less) record
919 -- or bit-packed array, then everything is fine, since the
920 -- back end can handle these cases correctly.
921
922 elsif Esize (Comp) <= 64
923 and then (Is_Record_Type (Etype (Comp))
924 or else Is_Bit_Packed_Array (Etype (Comp)))
925 then
926 return False;
927
928 -- Otherwise if the component is not byte aligned, we
929 -- know we have the nasty unaligned case.
930
931 elsif Normalized_First_Bit (Comp) /= Uint_0
932 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
933 then
934 return True;
935
936 -- If we are large and byte aligned, then OK at this level
937
938 else
939 return False;
940 end if;
941 end Component_May_Be_Bit_Aligned;
942
943 -------------------------------
944 -- Convert_To_Actual_Subtype --
945 -------------------------------
946
947 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
948 Act_ST : Entity_Id;
949
950 begin
951 Act_ST := Get_Actual_Subtype (Exp);
952
953 if Act_ST = Etype (Exp) then
954 return;
955
956 else
957 Rewrite (Exp,
958 Convert_To (Act_ST, Relocate_Node (Exp)));
959 Analyze_And_Resolve (Exp, Act_ST);
960 end if;
961 end Convert_To_Actual_Subtype;
962
963 -----------------------------------
964 -- Current_Sem_Unit_Declarations --
965 -----------------------------------
966
967 function Current_Sem_Unit_Declarations return List_Id is
968 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
969 Decls : List_Id;
970
971 begin
972 -- If the current unit is a package body, locate the visible
973 -- declarations of the package spec.
974
975 if Nkind (U) = N_Package_Body then
976 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
977 end if;
978
979 if Nkind (U) = N_Package_Declaration then
980 U := Specification (U);
981 Decls := Visible_Declarations (U);
982
983 if No (Decls) then
984 Decls := New_List;
985 Set_Visible_Declarations (U, Decls);
986 end if;
987
988 else
989 Decls := Declarations (U);
990
991 if No (Decls) then
992 Decls := New_List;
993 Set_Declarations (U, Decls);
994 end if;
995 end if;
996
997 return Decls;
998 end Current_Sem_Unit_Declarations;
999
1000 -----------------------
1001 -- Duplicate_Subexpr --
1002 -----------------------
1003
1004 function Duplicate_Subexpr
1005 (Exp : Node_Id;
1006 Name_Req : Boolean := False) return Node_Id
1007 is
1008 begin
1009 Remove_Side_Effects (Exp, Name_Req);
1010 return New_Copy_Tree (Exp);
1011 end Duplicate_Subexpr;
1012
1013 ---------------------------------
1014 -- Duplicate_Subexpr_No_Checks --
1015 ---------------------------------
1016
1017 function Duplicate_Subexpr_No_Checks
1018 (Exp : Node_Id;
1019 Name_Req : Boolean := False) return Node_Id
1020 is
1021 New_Exp : Node_Id;
1022
1023 begin
1024 Remove_Side_Effects (Exp, Name_Req);
1025 New_Exp := New_Copy_Tree (Exp);
1026 Remove_Checks (New_Exp);
1027 return New_Exp;
1028 end Duplicate_Subexpr_No_Checks;
1029
1030 -----------------------------------
1031 -- Duplicate_Subexpr_Move_Checks --
1032 -----------------------------------
1033
1034 function Duplicate_Subexpr_Move_Checks
1035 (Exp : Node_Id;
1036 Name_Req : Boolean := False) return Node_Id
1037 is
1038 New_Exp : Node_Id;
1039
1040 begin
1041 Remove_Side_Effects (Exp, Name_Req);
1042 New_Exp := New_Copy_Tree (Exp);
1043 Remove_Checks (Exp);
1044 return New_Exp;
1045 end Duplicate_Subexpr_Move_Checks;
1046
1047 --------------------
1048 -- Ensure_Defined --
1049 --------------------
1050
1051 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1052 IR : Node_Id;
1053 P : Node_Id;
1054
1055 begin
1056 if Is_Itype (Typ) then
1057 IR := Make_Itype_Reference (Sloc (N));
1058 Set_Itype (IR, Typ);
1059
1060 if not In_Open_Scopes (Scope (Typ))
1061 and then Is_Subprogram (Current_Scope)
1062 and then Scope (Current_Scope) /= Standard_Standard
1063 then
1064 -- Insert node in front of subprogram, to avoid scope anomalies
1065 -- in gigi.
1066
1067 P := Parent (N);
1068 while Present (P)
1069 and then Nkind (P) /= N_Subprogram_Body
1070 loop
1071 P := Parent (P);
1072 end loop;
1073
1074 if Present (P) then
1075 Insert_Action (P, IR);
1076 else
1077 Insert_Action (N, IR);
1078 end if;
1079
1080 else
1081 Insert_Action (N, IR);
1082 end if;
1083 end if;
1084 end Ensure_Defined;
1085
1086 ---------------------
1087 -- Evolve_And_Then --
1088 ---------------------
1089
1090 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1091 begin
1092 if No (Cond) then
1093 Cond := Cond1;
1094 else
1095 Cond :=
1096 Make_And_Then (Sloc (Cond1),
1097 Left_Opnd => Cond,
1098 Right_Opnd => Cond1);
1099 end if;
1100 end Evolve_And_Then;
1101
1102 --------------------
1103 -- Evolve_Or_Else --
1104 --------------------
1105
1106 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1107 begin
1108 if No (Cond) then
1109 Cond := Cond1;
1110 else
1111 Cond :=
1112 Make_Or_Else (Sloc (Cond1),
1113 Left_Opnd => Cond,
1114 Right_Opnd => Cond1);
1115 end if;
1116 end Evolve_Or_Else;
1117
1118 ------------------------------
1119 -- Expand_Subtype_From_Expr --
1120 ------------------------------
1121
1122 -- This function is applicable for both static and dynamic allocation of
1123 -- objects which are constrained by an initial expression. Basically it
1124 -- transforms an unconstrained subtype indication into a constrained one.
1125 -- The expression may also be transformed in certain cases in order to
1126 -- avoid multiple evaulation. In the static allocation case, the general
1127 -- scheme is :
1128
1129 -- Val : T := Expr;
1130
1131 -- is transformed into
1132
1133 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1134 --
1135 -- Here are the main cases :
1136 --
1137 -- <if Expr is a Slice>
1138 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1139 --
1140 -- <elsif Expr is a String Literal>
1141 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1142 --
1143 -- <elsif Expr is Constrained>
1144 -- subtype T is Type_Of_Expr
1145 -- Val : T := Expr;
1146 --
1147 -- <elsif Expr is an entity_name>
1148 -- Val : T (constraints taken from Expr) := Expr;
1149 --
1150 -- <else>
1151 -- type Axxx is access all T;
1152 -- Rval : Axxx := Expr'ref;
1153 -- Val : T (constraints taken from Rval) := Rval.all;
1154
1155 -- ??? note: when the Expression is allocated in the secondary stack
1156 -- we could use it directly instead of copying it by declaring
1157 -- Val : T (...) renames Rval.all
1158
1159 procedure Expand_Subtype_From_Expr
1160 (N : Node_Id;
1161 Unc_Type : Entity_Id;
1162 Subtype_Indic : Node_Id;
1163 Exp : Node_Id)
1164 is
1165 Loc : constant Source_Ptr := Sloc (N);
1166 Exp_Typ : constant Entity_Id := Etype (Exp);
1167 T : Entity_Id;
1168
1169 begin
1170 -- In general we cannot build the subtype if expansion is disabled,
1171 -- because internal entities may not have been defined. However, to
1172 -- avoid some cascaded errors, we try to continue when the expression
1173 -- is an array (or string), because it is safe to compute the bounds.
1174 -- It is in fact required to do so even in a generic context, because
1175 -- there may be constants that depend on bounds of string literal.
1176
1177 if not Expander_Active
1178 and then (No (Etype (Exp))
1179 or else Base_Type (Etype (Exp)) /= Standard_String)
1180 then
1181 return;
1182 end if;
1183
1184 if Nkind (Exp) = N_Slice then
1185 declare
1186 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1187
1188 begin
1189 Rewrite (Subtype_Indic,
1190 Make_Subtype_Indication (Loc,
1191 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1192 Constraint =>
1193 Make_Index_Or_Discriminant_Constraint (Loc,
1194 Constraints => New_List
1195 (New_Reference_To (Slice_Type, Loc)))));
1196
1197 -- This subtype indication may be used later for contraint checks
1198 -- we better make sure that if a variable was used as a bound of
1199 -- of the original slice, its value is frozen.
1200
1201 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1202 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1203 end;
1204
1205 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1206 Rewrite (Subtype_Indic,
1207 Make_Subtype_Indication (Loc,
1208 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1209 Constraint =>
1210 Make_Index_Or_Discriminant_Constraint (Loc,
1211 Constraints => New_List (
1212 Make_Literal_Range (Loc,
1213 Literal_Typ => Exp_Typ)))));
1214
1215 elsif Is_Constrained (Exp_Typ)
1216 and then not Is_Class_Wide_Type (Unc_Type)
1217 then
1218 if Is_Itype (Exp_Typ) then
1219
1220 -- Within an initialization procedure, a selected component
1221 -- denotes a component of the enclosing record, and it appears
1222 -- as an actual in a call to its own initialization procedure.
1223 -- If this component depends on the outer discriminant, we must
1224 -- generate the proper actual subtype for it.
1225
1226 if Nkind (Exp) = N_Selected_Component
1227 and then Within_Init_Proc
1228 then
1229 declare
1230 Decl : constant Node_Id :=
1231 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
1232 begin
1233 if Present (Decl) then
1234 Insert_Action (N, Decl);
1235 T := Defining_Identifier (Decl);
1236 else
1237 T := Exp_Typ;
1238 end if;
1239 end;
1240
1241 -- No need to generate a new one (new what???)
1242
1243 else
1244 T := Exp_Typ;
1245 end if;
1246
1247 else
1248 T :=
1249 Make_Defining_Identifier (Loc,
1250 Chars => New_Internal_Name ('T'));
1251
1252 Insert_Action (N,
1253 Make_Subtype_Declaration (Loc,
1254 Defining_Identifier => T,
1255 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
1256
1257 -- This type is marked as an itype even though it has an
1258 -- explicit declaration because otherwise it can be marked
1259 -- with Is_Generic_Actual_Type and generate spurious errors.
1260 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1261
1262 Set_Is_Itype (T);
1263 Set_Associated_Node_For_Itype (T, Exp);
1264 end if;
1265
1266 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1267
1268 -- nothing needs to be done for private types with unknown discriminants
1269 -- if the underlying type is not an unconstrained composite type.
1270
1271 elsif Is_Private_Type (Unc_Type)
1272 and then Has_Unknown_Discriminants (Unc_Type)
1273 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1274 or else Is_Constrained (Underlying_Type (Unc_Type)))
1275 then
1276 null;
1277
1278 -- Nothing to be done if the type of the expression is limited, because
1279 -- in this case the expression cannot be copied, and its use can only
1280 -- be by reference and there is no need for the actual subtype.
1281
1282 elsif Is_Limited_Type (Exp_Typ) then
1283 null;
1284
1285 else
1286 Remove_Side_Effects (Exp);
1287 Rewrite (Subtype_Indic,
1288 Make_Subtype_From_Expr (Exp, Unc_Type));
1289 end if;
1290 end Expand_Subtype_From_Expr;
1291
1292 ------------------------
1293 -- Find_Interface_Tag --
1294 ------------------------
1295
1296 function Find_Interface_ADT
1297 (T : Entity_Id;
1298 Iface : Entity_Id) return Entity_Id
1299 is
1300 ADT : Elmt_Id;
1301 Found : Boolean := False;
1302 Typ : Entity_Id := T;
1303
1304 procedure Find_Secondary_Table (Typ : Entity_Id);
1305 -- Comment required ???
1306
1307 --------------------------
1308 -- Find_Secondary_Table --
1309 --------------------------
1310
1311 procedure Find_Secondary_Table (Typ : Entity_Id) is
1312 AI_Elmt : Elmt_Id;
1313 AI : Node_Id;
1314
1315 begin
1316 if Etype (Typ) /= Typ then
1317 Find_Secondary_Table (Etype (Typ));
1318 end if;
1319
1320 if Present (Abstract_Interfaces (Typ))
1321 and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
1322 then
1323 AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1324 while Present (AI_Elmt) loop
1325 AI := Node (AI_Elmt);
1326
1327 if AI = Iface or else Is_Ancestor (Iface, AI) then
1328 Found := True;
1329 return;
1330 end if;
1331
1332 Next_Elmt (ADT);
1333 Next_Elmt (AI_Elmt);
1334 end loop;
1335 end if;
1336 end Find_Secondary_Table;
1337
1338 -- Start of processing for Find_Interface_Tag
1339
1340 begin
1341 -- Handle private types
1342
1343 if Has_Private_Declaration (Typ)
1344 and then Present (Full_View (Typ))
1345 then
1346 Typ := Full_View (Typ);
1347 end if;
1348
1349 -- Handle access types
1350
1351 if Is_Access_Type (Typ) then
1352 Typ := Directly_Designated_Type (Typ);
1353 end if;
1354
1355 -- Handle task and protected types implementing interfaces
1356
1357 if Ekind (Typ) = E_Protected_Type
1358 or else Ekind (Typ) = E_Task_Type
1359 then
1360 Typ := Corresponding_Record_Type (Typ);
1361 end if;
1362
1363 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
1364 pragma Assert (Present (Node (ADT)));
1365 Find_Secondary_Table (Typ);
1366 pragma Assert (Found);
1367 return Node (ADT);
1368 end Find_Interface_ADT;
1369
1370 ------------------------
1371 -- Find_Interface_Tag --
1372 ------------------------
1373
1374 function Find_Interface_Tag
1375 (T : Entity_Id;
1376 Iface : Entity_Id) return Entity_Id
1377 is
1378 AI_Tag : Entity_Id;
1379 Found : Boolean := False;
1380 Typ : Entity_Id := T;
1381
1382 procedure Find_Tag (Typ : in Entity_Id);
1383 -- Internal subprogram used to recursively climb to the ancestors
1384
1385 -----------------
1386 -- Find_AI_Tag --
1387 -----------------
1388
1389 procedure Find_Tag (Typ : in Entity_Id) is
1390 AI_Elmt : Elmt_Id;
1391 AI : Node_Id;
1392
1393 begin
1394 -- Check if the interface is an immediate ancestor of the type and
1395 -- therefore shares the main tag.
1396
1397 if Typ = Iface then
1398 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1399 AI_Tag := First_Tag_Component (Typ);
1400 Found := True;
1401 return;
1402 end if;
1403
1404 -- Climb to the root type
1405
1406 if Etype (Typ) /= Typ then
1407 Find_Tag (Etype (Typ));
1408 end if;
1409
1410 -- Traverse the list of interfaces implemented by the type
1411
1412 if not Found
1413 and then Present (Abstract_Interfaces (Typ))
1414 and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
1415 then
1416 -- Skip the tag associated with the primary table
1417
1418 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1419 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1420 pragma Assert (Present (AI_Tag));
1421
1422 AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1423 while Present (AI_Elmt) loop
1424 AI := Node (AI_Elmt);
1425
1426 if AI = Iface or else Is_Ancestor (Iface, AI) then
1427 Found := True;
1428 return;
1429 end if;
1430
1431 AI_Tag := Next_Tag_Component (AI_Tag);
1432 Next_Elmt (AI_Elmt);
1433 end loop;
1434 end if;
1435 end Find_Tag;
1436
1437 -- Start of processing for Find_Interface_Tag
1438
1439 begin
1440 -- Handle private types
1441
1442 if Has_Private_Declaration (Typ)
1443 and then Present (Full_View (Typ))
1444 then
1445 Typ := Full_View (Typ);
1446 end if;
1447
1448 -- Handle access types
1449
1450 if Is_Access_Type (Typ) then
1451 Typ := Directly_Designated_Type (Typ);
1452 end if;
1453
1454 -- Handle task and protected types implementing interfaces
1455
1456 if Is_Concurrent_Type (Typ) then
1457 Typ := Corresponding_Record_Type (Typ);
1458 end if;
1459
1460 if Is_Class_Wide_Type (Typ) then
1461 Typ := Etype (Typ);
1462 end if;
1463
1464 -- Handle entities from the limited view
1465
1466 if Ekind (Typ) = E_Incomplete_Type then
1467 pragma Assert (Present (Non_Limited_View (Typ)));
1468 Typ := Non_Limited_View (Typ);
1469 end if;
1470
1471 Find_Tag (Typ);
1472 pragma Assert (Found);
1473 return AI_Tag;
1474 end Find_Interface_Tag;
1475
1476 ------------------
1477 -- Find_Prim_Op --
1478 ------------------
1479
1480 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1481 Prim : Elmt_Id;
1482 Typ : Entity_Id := T;
1483
1484 begin
1485 if Is_Class_Wide_Type (Typ) then
1486 Typ := Root_Type (Typ);
1487 end if;
1488
1489 Typ := Underlying_Type (Typ);
1490
1491 Prim := First_Elmt (Primitive_Operations (Typ));
1492 while Chars (Node (Prim)) /= Name loop
1493 Next_Elmt (Prim);
1494 pragma Assert (Present (Prim));
1495 end loop;
1496
1497 return Node (Prim);
1498 end Find_Prim_Op;
1499
1500 function Find_Prim_Op
1501 (T : Entity_Id;
1502 Name : TSS_Name_Type) return Entity_Id
1503 is
1504 Prim : Elmt_Id;
1505 Typ : Entity_Id := T;
1506
1507 begin
1508 if Is_Class_Wide_Type (Typ) then
1509 Typ := Root_Type (Typ);
1510 end if;
1511
1512 Typ := Underlying_Type (Typ);
1513
1514 Prim := First_Elmt (Primitive_Operations (Typ));
1515 while not Is_TSS (Node (Prim), Name) loop
1516 Next_Elmt (Prim);
1517 pragma Assert (Present (Prim));
1518 end loop;
1519
1520 return Node (Prim);
1521 end Find_Prim_Op;
1522
1523 ----------------------
1524 -- Force_Evaluation --
1525 ----------------------
1526
1527 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1528 begin
1529 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1530 end Force_Evaluation;
1531
1532 ------------------------
1533 -- Generate_Poll_Call --
1534 ------------------------
1535
1536 procedure Generate_Poll_Call (N : Node_Id) is
1537 begin
1538 -- No poll call if polling not active
1539
1540 if not Polling_Required then
1541 return;
1542
1543 -- Otherwise generate require poll call
1544
1545 else
1546 Insert_Before_And_Analyze (N,
1547 Make_Procedure_Call_Statement (Sloc (N),
1548 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1549 end if;
1550 end Generate_Poll_Call;
1551
1552 ---------------------------------
1553 -- Get_Current_Value_Condition --
1554 ---------------------------------
1555
1556 procedure Get_Current_Value_Condition
1557 (Var : Node_Id;
1558 Op : out Node_Kind;
1559 Val : out Node_Id)
1560 is
1561 Loc : constant Source_Ptr := Sloc (Var);
1562 CV : constant Node_Id := Current_Value (Entity (Var));
1563 Sens : Boolean;
1564 Stm : Node_Id;
1565 Cond : Node_Id;
1566
1567 begin
1568 Op := N_Empty;
1569 Val := Empty;
1570
1571 -- If statement. Condition is known true in THEN section, known False
1572 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
1573
1574 if Nkind (CV) = N_If_Statement then
1575
1576 -- Before start of IF statement
1577
1578 if Loc < Sloc (CV) then
1579 return;
1580
1581 -- After end of IF statement
1582
1583 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1584 return;
1585 end if;
1586
1587 -- At this stage we know that we are within the IF statement, but
1588 -- unfortunately, the tree does not record the SLOC of the ELSE so
1589 -- we cannot use a simple SLOC comparison to distinguish between
1590 -- the then/else statements, so we have to climb the tree.
1591
1592 declare
1593 N : Node_Id;
1594
1595 begin
1596 N := Parent (Var);
1597 while Parent (N) /= CV loop
1598 N := Parent (N);
1599
1600 -- If we fall off the top of the tree, then that's odd, but
1601 -- perhaps it could occur in some error situation, and the
1602 -- safest response is simply to assume that the outcome of the
1603 -- condition is unknown. No point in bombing during an attempt
1604 -- to optimize things.
1605
1606 if No (N) then
1607 return;
1608 end if;
1609 end loop;
1610
1611 -- Now we have N pointing to a node whose parent is the IF
1612 -- statement in question, so now we can tell if we are within
1613 -- the THEN statements.
1614
1615 if Is_List_Member (N)
1616 and then List_Containing (N) = Then_Statements (CV)
1617 then
1618 Sens := True;
1619
1620 -- Otherwise we must be in ELSIF or ELSE part
1621
1622 else
1623 Sens := False;
1624 end if;
1625 end;
1626
1627 -- ELSIF part. Condition is known true within the referenced ELSIF,
1628 -- known False in any subsequent ELSIF or ELSE part, and unknown before
1629 -- the ELSE part or after the IF statement.
1630
1631 elsif Nkind (CV) = N_Elsif_Part then
1632 Stm := Parent (CV);
1633
1634 -- Before start of ELSIF part
1635
1636 if Loc < Sloc (CV) then
1637 return;
1638
1639 -- After end of IF statement
1640
1641 elsif Loc >= Sloc (Stm) +
1642 Text_Ptr (UI_To_Int (End_Span (Stm)))
1643 then
1644 return;
1645 end if;
1646
1647 -- Again we lack the SLOC of the ELSE, so we need to climb the tree
1648 -- to see if we are within the ELSIF part in question.
1649
1650 declare
1651 N : Node_Id;
1652
1653 begin
1654 N := Parent (Var);
1655 while Parent (N) /= Stm loop
1656 N := Parent (N);
1657
1658 -- If we fall off the top of the tree, then that's odd, but
1659 -- perhaps it could occur in some error situation, and the
1660 -- safest response is simply to assume that the outcome of the
1661 -- condition is unknown. No point in bombing during an attempt
1662 -- to optimize things.
1663
1664 if No (N) then
1665 return;
1666 end if;
1667 end loop;
1668
1669 -- Now we have N pointing to a node whose parent is the IF
1670 -- statement in question, so see if is the ELSIF part we want.
1671 -- the THEN statements.
1672
1673 if N = CV then
1674 Sens := True;
1675
1676 -- Otherwise we must be in susbequent ELSIF or ELSE part
1677
1678 else
1679 Sens := False;
1680 end if;
1681 end;
1682
1683 -- All other cases of Current_Value settings
1684
1685 else
1686 return;
1687 end if;
1688
1689 -- If we fall through here, then we have a reportable condition, Sens is
1690 -- True if the condition is true and False if it needs inverting.
1691
1692 -- Deal with NOT operators, inverting sense
1693
1694 Cond := Condition (CV);
1695 while Nkind (Cond) = N_Op_Not loop
1696 Cond := Right_Opnd (Cond);
1697 Sens := not Sens;
1698 end loop;
1699
1700 -- Now we must have a relational operator
1701
1702 pragma Assert (Entity (Var) = Entity (Left_Opnd (Cond)));
1703 Val := Right_Opnd (Cond);
1704 Op := Nkind (Cond);
1705
1706 if Sens = False then
1707 case Op is
1708 when N_Op_Eq => Op := N_Op_Ne;
1709 when N_Op_Ne => Op := N_Op_Eq;
1710 when N_Op_Lt => Op := N_Op_Ge;
1711 when N_Op_Gt => Op := N_Op_Le;
1712 when N_Op_Le => Op := N_Op_Gt;
1713 when N_Op_Ge => Op := N_Op_Lt;
1714
1715 -- No other entry should be possible
1716
1717 when others =>
1718 raise Program_Error;
1719 end case;
1720 end if;
1721 end Get_Current_Value_Condition;
1722
1723 --------------------
1724 -- Homonym_Number --
1725 --------------------
1726
1727 function Homonym_Number (Subp : Entity_Id) return Nat is
1728 Count : Nat;
1729 Hom : Entity_Id;
1730
1731 begin
1732 Count := 1;
1733 Hom := Homonym (Subp);
1734 while Present (Hom) loop
1735 if Scope (Hom) = Scope (Subp) then
1736 Count := Count + 1;
1737 end if;
1738
1739 Hom := Homonym (Hom);
1740 end loop;
1741
1742 return Count;
1743 end Homonym_Number;
1744
1745 ----------------------------------
1746 -- Implements_Limited_Interface --
1747 ----------------------------------
1748
1749 function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is
1750 function Contains_Limited_Interface
1751 (Ifaces : Elist_Id) return Boolean;
1752 -- Given a list of interfaces, determine whether one of them is limited
1753
1754 --------------------------------
1755 -- Contains_Limited_Interface --
1756 --------------------------------
1757
1758 function Contains_Limited_Interface
1759 (Ifaces : Elist_Id) return Boolean
1760 is
1761 Iface_Elmt : Elmt_Id;
1762
1763 begin
1764 if not Present (Ifaces) then
1765 return False;
1766 end if;
1767
1768 Iface_Elmt := First_Elmt (Ifaces);
1769
1770 while Present (Iface_Elmt) loop
1771 if Is_Limited_Record (Node (Iface_Elmt)) then
1772 return True;
1773 end if;
1774
1775 Iface_Elmt := Next_Elmt (Iface_Elmt);
1776 end loop;
1777
1778 return False;
1779 end Contains_Limited_Interface;
1780
1781 -- Start of processing for Implements_Limited_Interface
1782
1783 begin
1784 -- Typ is a derived type and may implement a limited interface
1785 -- through its parent subtype. Check the parent subtype as well
1786 -- as any interfaces explicitly implemented at this level.
1787
1788 if Ekind (Typ) = E_Record_Type
1789 and then Present (Parent_Subtype (Typ))
1790 then
1791 return Contains_Limited_Interface (Abstract_Interfaces (Typ))
1792 or else Implements_Limited_Interface (Parent_Subtype (Typ));
1793
1794 -- Typ is an abstract type derived from some interface
1795
1796 elsif Is_Abstract (Typ) then
1797 return Is_Interface (Etype (Typ))
1798 and then Is_Limited_Record (Etype (Typ));
1799
1800 -- Typ may directly implement some interface
1801
1802 else
1803 return Contains_Limited_Interface (Abstract_Interfaces (Typ));
1804 end if;
1805 end Implements_Limited_Interface;
1806
1807 ------------------------------
1808 -- In_Unconditional_Context --
1809 ------------------------------
1810
1811 function In_Unconditional_Context (Node : Node_Id) return Boolean is
1812 P : Node_Id;
1813
1814 begin
1815 P := Node;
1816 while Present (P) loop
1817 case Nkind (P) is
1818 when N_Subprogram_Body =>
1819 return True;
1820
1821 when N_If_Statement =>
1822 return False;
1823
1824 when N_Loop_Statement =>
1825 return False;
1826
1827 when N_Case_Statement =>
1828 return False;
1829
1830 when others =>
1831 P := Parent (P);
1832 end case;
1833 end loop;
1834
1835 return False;
1836 end In_Unconditional_Context;
1837
1838 -------------------
1839 -- Insert_Action --
1840 -------------------
1841
1842 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
1843 begin
1844 if Present (Ins_Action) then
1845 Insert_Actions (Assoc_Node, New_List (Ins_Action));
1846 end if;
1847 end Insert_Action;
1848
1849 -- Version with check(s) suppressed
1850
1851 procedure Insert_Action
1852 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
1853 is
1854 begin
1855 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
1856 end Insert_Action;
1857
1858 --------------------
1859 -- Insert_Actions --
1860 --------------------
1861
1862 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
1863 N : Node_Id;
1864 P : Node_Id;
1865
1866 Wrapped_Node : Node_Id := Empty;
1867
1868 begin
1869 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
1870 return;
1871 end if;
1872
1873 -- Ignore insert of actions from inside default expression in the
1874 -- special preliminary analyze mode. Any insertions at this point
1875 -- have no relevance, since we are only doing the analyze to freeze
1876 -- the types of any static expressions. See section "Handling of
1877 -- Default Expressions" in the spec of package Sem for further details.
1878
1879 if In_Default_Expression then
1880 return;
1881 end if;
1882
1883 -- If the action derives from stuff inside a record, then the actions
1884 -- are attached to the current scope, to be inserted and analyzed on
1885 -- exit from the scope. The reason for this is that we may also
1886 -- be generating freeze actions at the same time, and they must
1887 -- eventually be elaborated in the correct order.
1888
1889 if Is_Record_Type (Current_Scope)
1890 and then not Is_Frozen (Current_Scope)
1891 then
1892 if No (Scope_Stack.Table
1893 (Scope_Stack.Last).Pending_Freeze_Actions)
1894 then
1895 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
1896 Ins_Actions;
1897 else
1898 Append_List
1899 (Ins_Actions,
1900 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
1901 end if;
1902
1903 return;
1904 end if;
1905
1906 -- We now intend to climb up the tree to find the right point to
1907 -- insert the actions. We start at Assoc_Node, unless this node is
1908 -- a subexpression in which case we start with its parent. We do this
1909 -- for two reasons. First it speeds things up. Second, if Assoc_Node
1910 -- is itself one of the special nodes like N_And_Then, then we assume
1911 -- that an initial request to insert actions for such a node does not
1912 -- expect the actions to get deposited in the node for later handling
1913 -- when the node is expanded, since clearly the node is being dealt
1914 -- with by the caller. Note that in the subexpression case, N is
1915 -- always the child we came from.
1916
1917 -- N_Raise_xxx_Error is an annoying special case, it is a statement
1918 -- if it has type Standard_Void_Type, and a subexpression otherwise.
1919 -- otherwise. Procedure attribute references are also statements.
1920
1921 if Nkind (Assoc_Node) in N_Subexpr
1922 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
1923 or else Etype (Assoc_Node) /= Standard_Void_Type)
1924 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
1925 or else
1926 not Is_Procedure_Attribute_Name
1927 (Attribute_Name (Assoc_Node)))
1928 then
1929 P := Assoc_Node; -- ??? does not agree with above!
1930 N := Parent (Assoc_Node);
1931
1932 -- Non-subexpression case. Note that N is initially Empty in this
1933 -- case (N is only guaranteed Non-Empty in the subexpr case).
1934
1935 else
1936 P := Assoc_Node;
1937 N := Empty;
1938 end if;
1939
1940 -- Capture root of the transient scope
1941
1942 if Scope_Is_Transient then
1943 Wrapped_Node := Node_To_Be_Wrapped;
1944 end if;
1945
1946 loop
1947 pragma Assert (Present (P));
1948
1949 case Nkind (P) is
1950
1951 -- Case of right operand of AND THEN or OR ELSE. Put the actions
1952 -- in the Actions field of the right operand. They will be moved
1953 -- out further when the AND THEN or OR ELSE operator is expanded.
1954 -- Nothing special needs to be done for the left operand since
1955 -- in that case the actions are executed unconditionally.
1956
1957 when N_And_Then | N_Or_Else =>
1958 if N = Right_Opnd (P) then
1959 if Present (Actions (P)) then
1960 Insert_List_After_And_Analyze
1961 (Last (Actions (P)), Ins_Actions);
1962 else
1963 Set_Actions (P, Ins_Actions);
1964 Analyze_List (Actions (P));
1965 end if;
1966
1967 return;
1968 end if;
1969
1970 -- Then or Else operand of conditional expression. Add actions to
1971 -- Then_Actions or Else_Actions field as appropriate. The actions
1972 -- will be moved further out when the conditional is expanded.
1973
1974 when N_Conditional_Expression =>
1975 declare
1976 ThenX : constant Node_Id := Next (First (Expressions (P)));
1977 ElseX : constant Node_Id := Next (ThenX);
1978
1979 begin
1980 -- Actions belong to the then expression, temporarily
1981 -- place them as Then_Actions of the conditional expr.
1982 -- They will be moved to the proper place later when
1983 -- the conditional expression is expanded.
1984
1985 if N = ThenX then
1986 if Present (Then_Actions (P)) then
1987 Insert_List_After_And_Analyze
1988 (Last (Then_Actions (P)), Ins_Actions);
1989 else
1990 Set_Then_Actions (P, Ins_Actions);
1991 Analyze_List (Then_Actions (P));
1992 end if;
1993
1994 return;
1995
1996 -- Actions belong to the else expression, temporarily
1997 -- place them as Else_Actions of the conditional expr.
1998 -- They will be moved to the proper place later when
1999 -- the conditional expression is expanded.
2000
2001 elsif N = ElseX then
2002 if Present (Else_Actions (P)) then
2003 Insert_List_After_And_Analyze
2004 (Last (Else_Actions (P)), Ins_Actions);
2005 else
2006 Set_Else_Actions (P, Ins_Actions);
2007 Analyze_List (Else_Actions (P));
2008 end if;
2009
2010 return;
2011
2012 -- Actions belong to the condition. In this case they are
2013 -- unconditionally executed, and so we can continue the
2014 -- search for the proper insert point.
2015
2016 else
2017 null;
2018 end if;
2019 end;
2020
2021 -- Case of appearing in the condition of a while expression or
2022 -- elsif. We insert the actions into the Condition_Actions field.
2023 -- They will be moved further out when the while loop or elsif
2024 -- is analyzed.
2025
2026 when N_Iteration_Scheme |
2027 N_Elsif_Part
2028 =>
2029 if N = Condition (P) then
2030 if Present (Condition_Actions (P)) then
2031 Insert_List_After_And_Analyze
2032 (Last (Condition_Actions (P)), Ins_Actions);
2033 else
2034 Set_Condition_Actions (P, Ins_Actions);
2035
2036 -- Set the parent of the insert actions explicitly.
2037 -- This is not a syntactic field, but we need the
2038 -- parent field set, in particular so that freeze
2039 -- can understand that it is dealing with condition
2040 -- actions, and properly insert the freezing actions.
2041
2042 Set_Parent (Ins_Actions, P);
2043 Analyze_List (Condition_Actions (P));
2044 end if;
2045
2046 return;
2047 end if;
2048
2049 -- Statements, declarations, pragmas, representation clauses
2050
2051 when
2052 -- Statements
2053
2054 N_Procedure_Call_Statement |
2055 N_Statement_Other_Than_Procedure_Call |
2056
2057 -- Pragmas
2058
2059 N_Pragma |
2060
2061 -- Representation_Clause
2062
2063 N_At_Clause |
2064 N_Attribute_Definition_Clause |
2065 N_Enumeration_Representation_Clause |
2066 N_Record_Representation_Clause |
2067
2068 -- Declarations
2069
2070 N_Abstract_Subprogram_Declaration |
2071 N_Entry_Body |
2072 N_Exception_Declaration |
2073 N_Exception_Renaming_Declaration |
2074 N_Formal_Abstract_Subprogram_Declaration |
2075 N_Formal_Concrete_Subprogram_Declaration |
2076 N_Formal_Object_Declaration |
2077 N_Formal_Type_Declaration |
2078 N_Full_Type_Declaration |
2079 N_Function_Instantiation |
2080 N_Generic_Function_Renaming_Declaration |
2081 N_Generic_Package_Declaration |
2082 N_Generic_Package_Renaming_Declaration |
2083 N_Generic_Procedure_Renaming_Declaration |
2084 N_Generic_Subprogram_Declaration |
2085 N_Implicit_Label_Declaration |
2086 N_Incomplete_Type_Declaration |
2087 N_Number_Declaration |
2088 N_Object_Declaration |
2089 N_Object_Renaming_Declaration |
2090 N_Package_Body |
2091 N_Package_Body_Stub |
2092 N_Package_Declaration |
2093 N_Package_Instantiation |
2094 N_Package_Renaming_Declaration |
2095 N_Private_Extension_Declaration |
2096 N_Private_Type_Declaration |
2097 N_Procedure_Instantiation |
2098 N_Protected_Body_Stub |
2099 N_Protected_Type_Declaration |
2100 N_Single_Task_Declaration |
2101 N_Subprogram_Body |
2102 N_Subprogram_Body_Stub |
2103 N_Subprogram_Declaration |
2104 N_Subprogram_Renaming_Declaration |
2105 N_Subtype_Declaration |
2106 N_Task_Body |
2107 N_Task_Body_Stub |
2108 N_Task_Type_Declaration |
2109
2110 -- Freeze entity behaves like a declaration or statement
2111
2112 N_Freeze_Entity
2113 =>
2114 -- Do not insert here if the item is not a list member (this
2115 -- happens for example with a triggering statement, and the
2116 -- proper approach is to insert before the entire select).
2117
2118 if not Is_List_Member (P) then
2119 null;
2120
2121 -- Do not insert if parent of P is an N_Component_Association
2122 -- node (i.e. we are in the context of an N_Aggregate node.
2123 -- In this case we want to insert before the entire aggregate.
2124
2125 elsif Nkind (Parent (P)) = N_Component_Association then
2126 null;
2127
2128 -- Do not insert if the parent of P is either an N_Variant
2129 -- node or an N_Record_Definition node, meaning in either
2130 -- case that P is a member of a component list, and that
2131 -- therefore the actions should be inserted outside the
2132 -- complete record declaration.
2133
2134 elsif Nkind (Parent (P)) = N_Variant
2135 or else Nkind (Parent (P)) = N_Record_Definition
2136 then
2137 null;
2138
2139 -- Do not insert freeze nodes within the loop generated for
2140 -- an aggregate, because they may be elaborated too late for
2141 -- subsequent use in the back end: within a package spec the
2142 -- loop is part of the elaboration procedure and is only
2143 -- elaborated during the second pass.
2144 -- If the loop comes from source, or the entity is local to
2145 -- the loop itself it must remain within.
2146
2147 elsif Nkind (Parent (P)) = N_Loop_Statement
2148 and then not Comes_From_Source (Parent (P))
2149 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
2150 and then
2151 Scope (Entity (First (Ins_Actions))) /= Current_Scope
2152 then
2153 null;
2154
2155 -- Otherwise we can go ahead and do the insertion
2156
2157 elsif P = Wrapped_Node then
2158 Store_Before_Actions_In_Scope (Ins_Actions);
2159 return;
2160
2161 else
2162 Insert_List_Before_And_Analyze (P, Ins_Actions);
2163 return;
2164 end if;
2165
2166 -- A special case, N_Raise_xxx_Error can act either as a
2167 -- statement or a subexpression. We tell the difference
2168 -- by looking at the Etype. It is set to Standard_Void_Type
2169 -- in the statement case.
2170
2171 when
2172 N_Raise_xxx_Error =>
2173 if Etype (P) = Standard_Void_Type then
2174 if P = Wrapped_Node then
2175 Store_Before_Actions_In_Scope (Ins_Actions);
2176 else
2177 Insert_List_Before_And_Analyze (P, Ins_Actions);
2178 end if;
2179
2180 return;
2181
2182 -- In the subexpression case, keep climbing
2183
2184 else
2185 null;
2186 end if;
2187
2188 -- If a component association appears within a loop created for
2189 -- an array aggregate, attach the actions to the association so
2190 -- they can be subsequently inserted within the loop. For other
2191 -- component associations insert outside of the aggregate. For
2192 -- an association that will generate a loop, its Loop_Actions
2193 -- attribute is already initialized (see exp_aggr.adb).
2194
2195 -- The list of loop_actions can in turn generate additional ones,
2196 -- that are inserted before the associated node. If the associated
2197 -- node is outside the aggregate, the new actions are collected
2198 -- at the end of the loop actions, to respect the order in which
2199 -- they are to be elaborated.
2200
2201 when
2202 N_Component_Association =>
2203 if Nkind (Parent (P)) = N_Aggregate
2204 and then Present (Loop_Actions (P))
2205 then
2206 if Is_Empty_List (Loop_Actions (P)) then
2207 Set_Loop_Actions (P, Ins_Actions);
2208 Analyze_List (Ins_Actions);
2209
2210 else
2211 declare
2212 Decl : Node_Id;
2213
2214 begin
2215 -- Check whether these actions were generated
2216 -- by a declaration that is part of the loop_
2217 -- actions for the component_association.
2218
2219 Decl := Assoc_Node;
2220 while Present (Decl) loop
2221 exit when Parent (Decl) = P
2222 and then Is_List_Member (Decl)
2223 and then
2224 List_Containing (Decl) = Loop_Actions (P);
2225 Decl := Parent (Decl);
2226 end loop;
2227
2228 if Present (Decl) then
2229 Insert_List_Before_And_Analyze
2230 (Decl, Ins_Actions);
2231 else
2232 Insert_List_After_And_Analyze
2233 (Last (Loop_Actions (P)), Ins_Actions);
2234 end if;
2235 end;
2236 end if;
2237
2238 return;
2239
2240 else
2241 null;
2242 end if;
2243
2244 -- Another special case, an attribute denoting a procedure call
2245
2246 when
2247 N_Attribute_Reference =>
2248 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
2249 if P = Wrapped_Node then
2250 Store_Before_Actions_In_Scope (Ins_Actions);
2251 else
2252 Insert_List_Before_And_Analyze (P, Ins_Actions);
2253 end if;
2254
2255 return;
2256
2257 -- In the subexpression case, keep climbing
2258
2259 else
2260 null;
2261 end if;
2262
2263 -- For all other node types, keep climbing tree
2264
2265 when
2266 N_Abortable_Part |
2267 N_Accept_Alternative |
2268 N_Access_Definition |
2269 N_Access_Function_Definition |
2270 N_Access_Procedure_Definition |
2271 N_Access_To_Object_Definition |
2272 N_Aggregate |
2273 N_Allocator |
2274 N_Case_Statement_Alternative |
2275 N_Character_Literal |
2276 N_Compilation_Unit |
2277 N_Compilation_Unit_Aux |
2278 N_Component_Clause |
2279 N_Component_Declaration |
2280 N_Component_Definition |
2281 N_Component_List |
2282 N_Constrained_Array_Definition |
2283 N_Decimal_Fixed_Point_Definition |
2284 N_Defining_Character_Literal |
2285 N_Defining_Identifier |
2286 N_Defining_Operator_Symbol |
2287 N_Defining_Program_Unit_Name |
2288 N_Delay_Alternative |
2289 N_Delta_Constraint |
2290 N_Derived_Type_Definition |
2291 N_Designator |
2292 N_Digits_Constraint |
2293 N_Discriminant_Association |
2294 N_Discriminant_Specification |
2295 N_Empty |
2296 N_Entry_Body_Formal_Part |
2297 N_Entry_Call_Alternative |
2298 N_Entry_Declaration |
2299 N_Entry_Index_Specification |
2300 N_Enumeration_Type_Definition |
2301 N_Error |
2302 N_Exception_Handler |
2303 N_Expanded_Name |
2304 N_Explicit_Dereference |
2305 N_Extension_Aggregate |
2306 N_Floating_Point_Definition |
2307 N_Formal_Decimal_Fixed_Point_Definition |
2308 N_Formal_Derived_Type_Definition |
2309 N_Formal_Discrete_Type_Definition |
2310 N_Formal_Floating_Point_Definition |
2311 N_Formal_Modular_Type_Definition |
2312 N_Formal_Ordinary_Fixed_Point_Definition |
2313 N_Formal_Package_Declaration |
2314 N_Formal_Private_Type_Definition |
2315 N_Formal_Signed_Integer_Type_Definition |
2316 N_Function_Call |
2317 N_Function_Specification |
2318 N_Generic_Association |
2319 N_Handled_Sequence_Of_Statements |
2320 N_Identifier |
2321 N_In |
2322 N_Index_Or_Discriminant_Constraint |
2323 N_Indexed_Component |
2324 N_Integer_Literal |
2325 N_Itype_Reference |
2326 N_Label |
2327 N_Loop_Parameter_Specification |
2328 N_Mod_Clause |
2329 N_Modular_Type_Definition |
2330 N_Not_In |
2331 N_Null |
2332 N_Op_Abs |
2333 N_Op_Add |
2334 N_Op_And |
2335 N_Op_Concat |
2336 N_Op_Divide |
2337 N_Op_Eq |
2338 N_Op_Expon |
2339 N_Op_Ge |
2340 N_Op_Gt |
2341 N_Op_Le |
2342 N_Op_Lt |
2343 N_Op_Minus |
2344 N_Op_Mod |
2345 N_Op_Multiply |
2346 N_Op_Ne |
2347 N_Op_Not |
2348 N_Op_Or |
2349 N_Op_Plus |
2350 N_Op_Rem |
2351 N_Op_Rotate_Left |
2352 N_Op_Rotate_Right |
2353 N_Op_Shift_Left |
2354 N_Op_Shift_Right |
2355 N_Op_Shift_Right_Arithmetic |
2356 N_Op_Subtract |
2357 N_Op_Xor |
2358 N_Operator_Symbol |
2359 N_Ordinary_Fixed_Point_Definition |
2360 N_Others_Choice |
2361 N_Package_Specification |
2362 N_Parameter_Association |
2363 N_Parameter_Specification |
2364 N_Pragma_Argument_Association |
2365 N_Procedure_Specification |
2366 N_Protected_Body |
2367 N_Protected_Definition |
2368 N_Qualified_Expression |
2369 N_Range |
2370 N_Range_Constraint |
2371 N_Real_Literal |
2372 N_Real_Range_Specification |
2373 N_Record_Definition |
2374 N_Reference |
2375 N_Selected_Component |
2376 N_Signed_Integer_Type_Definition |
2377 N_Single_Protected_Declaration |
2378 N_Slice |
2379 N_String_Literal |
2380 N_Subprogram_Info |
2381 N_Subtype_Indication |
2382 N_Subunit |
2383 N_Task_Definition |
2384 N_Terminate_Alternative |
2385 N_Triggering_Alternative |
2386 N_Type_Conversion |
2387 N_Unchecked_Expression |
2388 N_Unchecked_Type_Conversion |
2389 N_Unconstrained_Array_Definition |
2390 N_Unused_At_End |
2391 N_Unused_At_Start |
2392 N_Use_Package_Clause |
2393 N_Use_Type_Clause |
2394 N_Variant |
2395 N_Variant_Part |
2396 N_Validate_Unchecked_Conversion |
2397 N_With_Clause |
2398 N_With_Type_Clause
2399 =>
2400 null;
2401
2402 end case;
2403
2404 -- Make sure that inserted actions stay in the transient scope
2405
2406 if P = Wrapped_Node then
2407 Store_Before_Actions_In_Scope (Ins_Actions);
2408 return;
2409 end if;
2410
2411 -- If we fall through above tests, keep climbing tree
2412
2413 N := P;
2414
2415 if Nkind (Parent (N)) = N_Subunit then
2416
2417 -- This is the proper body corresponding to a stub. Insertion
2418 -- must be done at the point of the stub, which is in the decla-
2419 -- tive part of the parent unit.
2420
2421 P := Corresponding_Stub (Parent (N));
2422
2423 else
2424 P := Parent (N);
2425 end if;
2426 end loop;
2427
2428 end Insert_Actions;
2429
2430 -- Version with check(s) suppressed
2431
2432 procedure Insert_Actions
2433 (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
2434 is
2435 begin
2436 if Suppress = All_Checks then
2437 declare
2438 Svg : constant Suppress_Array := Scope_Suppress;
2439
2440 begin
2441 Scope_Suppress := (others => True);
2442 Insert_Actions (Assoc_Node, Ins_Actions);
2443 Scope_Suppress := Svg;
2444 end;
2445
2446 else
2447 declare
2448 Svg : constant Boolean := Scope_Suppress (Suppress);
2449
2450 begin
2451 Scope_Suppress (Suppress) := True;
2452 Insert_Actions (Assoc_Node, Ins_Actions);
2453 Scope_Suppress (Suppress) := Svg;
2454 end;
2455 end if;
2456 end Insert_Actions;
2457
2458 --------------------------
2459 -- Insert_Actions_After --
2460 --------------------------
2461
2462 procedure Insert_Actions_After
2463 (Assoc_Node : Node_Id;
2464 Ins_Actions : List_Id)
2465 is
2466 begin
2467 if Scope_Is_Transient
2468 and then Assoc_Node = Node_To_Be_Wrapped
2469 then
2470 Store_After_Actions_In_Scope (Ins_Actions);
2471 else
2472 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2473 end if;
2474 end Insert_Actions_After;
2475
2476 ---------------------------------
2477 -- Insert_Library_Level_Action --
2478 ---------------------------------
2479
2480 procedure Insert_Library_Level_Action (N : Node_Id) is
2481 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2482
2483 begin
2484 New_Scope (Cunit_Entity (Main_Unit));
2485
2486 if No (Actions (Aux)) then
2487 Set_Actions (Aux, New_List (N));
2488 else
2489 Append (N, Actions (Aux));
2490 end if;
2491
2492 Analyze (N);
2493 Pop_Scope;
2494 end Insert_Library_Level_Action;
2495
2496 ----------------------------------
2497 -- Insert_Library_Level_Actions --
2498 ----------------------------------
2499
2500 procedure Insert_Library_Level_Actions (L : List_Id) is
2501 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2502
2503 begin
2504 if Is_Non_Empty_List (L) then
2505 New_Scope (Cunit_Entity (Main_Unit));
2506
2507 if No (Actions (Aux)) then
2508 Set_Actions (Aux, L);
2509 Analyze_List (L);
2510 else
2511 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2512 end if;
2513
2514 Pop_Scope;
2515 end if;
2516 end Insert_Library_Level_Actions;
2517
2518 ----------------------
2519 -- Inside_Init_Proc --
2520 ----------------------
2521
2522 function Inside_Init_Proc return Boolean is
2523 S : Entity_Id;
2524
2525 begin
2526 S := Current_Scope;
2527 while Present (S)
2528 and then S /= Standard_Standard
2529 loop
2530 if Is_Init_Proc (S) then
2531 return True;
2532 else
2533 S := Scope (S);
2534 end if;
2535 end loop;
2536
2537 return False;
2538 end Inside_Init_Proc;
2539
2540 ----------------------------
2541 -- Is_All_Null_Statements --
2542 ----------------------------
2543
2544 function Is_All_Null_Statements (L : List_Id) return Boolean is
2545 Stm : Node_Id;
2546
2547 begin
2548 Stm := First (L);
2549 while Present (Stm) loop
2550 if Nkind (Stm) /= N_Null_Statement then
2551 return False;
2552 end if;
2553
2554 Next (Stm);
2555 end loop;
2556
2557 return True;
2558 end Is_All_Null_Statements;
2559
2560 ------------------------
2561 -- Is_Default_Prim_Op --
2562 ------------------------
2563
2564 function Is_Predefined_Dispatching_Operation
2565 (Subp : Entity_Id) return Boolean
2566 is
2567 TSS_Name : TSS_Name_Type;
2568 E : Entity_Id := Subp;
2569 begin
2570 pragma Assert (Is_Dispatching_Operation (Subp));
2571
2572 -- Handle overriden subprograms
2573
2574 while Present (Alias (E)) loop
2575 E := Alias (E);
2576 end loop;
2577
2578 Get_Name_String (Chars (E));
2579
2580 if Name_Len > TSS_Name_Type'Last then
2581 TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
2582 .. Name_Len));
2583 if Chars (E) = Name_uSize
2584 or else Chars (E) = Name_uAlignment
2585 or else TSS_Name = TSS_Stream_Read
2586 or else TSS_Name = TSS_Stream_Write
2587 or else TSS_Name = TSS_Stream_Input
2588 or else TSS_Name = TSS_Stream_Output
2589 or else Chars (E) = Name_Op_Eq
2590 or else Chars (E) = Name_uAssign
2591 or else TSS_Name = TSS_Deep_Adjust
2592 or else TSS_Name = TSS_Deep_Finalize
2593 or else Chars (E) = Name_uDisp_Asynchronous_Select
2594 or else Chars (E) = Name_uDisp_Conditional_Select
2595 or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
2596 or else Chars (E) = Name_uDisp_Timed_Select
2597 then
2598 return True;
2599 end if;
2600 end if;
2601
2602 return False;
2603 end Is_Predefined_Dispatching_Operation;
2604
2605 ----------------------------------
2606 -- Is_Possibly_Unaligned_Object --
2607 ----------------------------------
2608
2609 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
2610 T : constant Entity_Id := Etype (N);
2611
2612 begin
2613 -- If renamed object, apply test to underlying object
2614
2615 if Is_Entity_Name (N)
2616 and then Is_Object (Entity (N))
2617 and then Present (Renamed_Object (Entity (N)))
2618 then
2619 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
2620 end if;
2621
2622 -- Tagged and controlled types and aliased types are always aligned,
2623 -- as are concurrent types.
2624
2625 if Is_Aliased (T)
2626 or else Has_Controlled_Component (T)
2627 or else Is_Concurrent_Type (T)
2628 or else Is_Tagged_Type (T)
2629 or else Is_Controlled (T)
2630 then
2631 return False;
2632 end if;
2633
2634 -- If this is an element of a packed array, may be unaligned
2635
2636 if Is_Ref_To_Bit_Packed_Array (N) then
2637 return True;
2638 end if;
2639
2640 -- Case of component reference
2641
2642 if Nkind (N) = N_Selected_Component then
2643 declare
2644 P : constant Node_Id := Prefix (N);
2645 C : constant Entity_Id := Entity (Selector_Name (N));
2646 M : Nat;
2647 S : Nat;
2648
2649 begin
2650 -- If component reference is for an array with non-static bounds,
2651 -- then it is always aligned: we can only process unaligned
2652 -- arrays with static bounds (more accurately bounds known at
2653 -- compile time).
2654
2655 if Is_Array_Type (T)
2656 and then not Compile_Time_Known_Bounds (T)
2657 then
2658 return False;
2659 end if;
2660
2661 -- If component is aliased, it is definitely properly aligned
2662
2663 if Is_Aliased (C) then
2664 return False;
2665 end if;
2666
2667 -- If component is for a type implemented as a scalar, and the
2668 -- record is packed, and the component is other than the first
2669 -- component of the record, then the component may be unaligned.
2670
2671 if Is_Packed (Etype (P))
2672 and then Represented_As_Scalar (Etype (C))
2673 and then First_Entity (Scope (C)) /= C
2674 then
2675 return True;
2676 end if;
2677
2678 -- Compute maximum possible alignment for T
2679
2680 -- If alignment is known, then that settles things
2681
2682 if Known_Alignment (T) then
2683 M := UI_To_Int (Alignment (T));
2684
2685 -- If alignment is not known, tentatively set max alignment
2686
2687 else
2688 M := Ttypes.Maximum_Alignment;
2689
2690 -- We can reduce this if the Esize is known since the default
2691 -- alignment will never be more than the smallest power of 2
2692 -- that does not exceed this Esize value.
2693
2694 if Known_Esize (T) then
2695 S := UI_To_Int (Esize (T));
2696
2697 while (M / 2) >= S loop
2698 M := M / 2;
2699 end loop;
2700 end if;
2701 end if;
2702
2703 -- If the component reference is for a record that has a specified
2704 -- alignment, and we either know it is too small, or cannot tell,
2705 -- then the component may be unaligned
2706
2707 if Known_Alignment (Etype (P))
2708 and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
2709 and then M > Alignment (Etype (P))
2710 then
2711 return True;
2712 end if;
2713
2714 -- Case of component clause present which may specify an
2715 -- unaligned position.
2716
2717 if Present (Component_Clause (C)) then
2718
2719 -- Otherwise we can do a test to make sure that the actual
2720 -- start position in the record, and the length, are both
2721 -- consistent with the required alignment. If not, we know
2722 -- that we are unaligned.
2723
2724 declare
2725 Align_In_Bits : constant Nat := M * System_Storage_Unit;
2726 begin
2727 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
2728 or else Esize (C) mod Align_In_Bits /= 0
2729 then
2730 return True;
2731 end if;
2732 end;
2733 end if;
2734
2735 -- Otherwise, for a component reference, test prefix
2736
2737 return Is_Possibly_Unaligned_Object (P);
2738 end;
2739
2740 -- If not a component reference, must be aligned
2741
2742 else
2743 return False;
2744 end if;
2745 end Is_Possibly_Unaligned_Object;
2746
2747 ---------------------------------
2748 -- Is_Possibly_Unaligned_Slice --
2749 ---------------------------------
2750
2751 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
2752 begin
2753 -- ??? GCC3 will eventually handle strings with arbitrary alignments,
2754 -- but for now the following check must be disabled.
2755
2756 -- if get_gcc_version >= 3 then
2757 -- return False;
2758 -- end if;
2759
2760 -- For renaming case, go to renamed object
2761
2762 if Is_Entity_Name (N)
2763 and then Is_Object (Entity (N))
2764 and then Present (Renamed_Object (Entity (N)))
2765 then
2766 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
2767 end if;
2768
2769 -- The reference must be a slice
2770
2771 if Nkind (N) /= N_Slice then
2772 return False;
2773 end if;
2774
2775 -- Always assume the worst for a nested record component with a
2776 -- component clause, which gigi/gcc does not appear to handle well.
2777 -- It is not clear why this special test is needed at all ???
2778
2779 if Nkind (Prefix (N)) = N_Selected_Component
2780 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
2781 and then
2782 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
2783 then
2784 return True;
2785 end if;
2786
2787 -- We only need to worry if the target has strict alignment
2788
2789 if not Target_Strict_Alignment then
2790 return False;
2791 end if;
2792
2793 -- If it is a slice, then look at the array type being sliced
2794
2795 declare
2796 Sarr : constant Node_Id := Prefix (N);
2797 -- Prefix of the slice, i.e. the array being sliced
2798
2799 Styp : constant Entity_Id := Etype (Prefix (N));
2800 -- Type of the array being sliced
2801
2802 Pref : Node_Id;
2803 Ptyp : Entity_Id;
2804
2805 begin
2806 -- The problems arise if the array object that is being sliced
2807 -- is a component of a record or array, and we cannot guarantee
2808 -- the alignment of the array within its containing object.
2809
2810 -- To investigate this, we look at successive prefixes to see
2811 -- if we have a worrisome indexed or selected component.
2812
2813 Pref := Sarr;
2814 loop
2815 -- Case of array is part of an indexed component reference
2816
2817 if Nkind (Pref) = N_Indexed_Component then
2818 Ptyp := Etype (Prefix (Pref));
2819
2820 -- The only problematic case is when the array is packed,
2821 -- in which case we really know nothing about the alignment
2822 -- of individual components.
2823
2824 if Is_Bit_Packed_Array (Ptyp) then
2825 return True;
2826 end if;
2827
2828 -- Case of array is part of a selected component reference
2829
2830 elsif Nkind (Pref) = N_Selected_Component then
2831 Ptyp := Etype (Prefix (Pref));
2832
2833 -- We are definitely in trouble if the record in question
2834 -- has an alignment, and either we know this alignment is
2835 -- inconsistent with the alignment of the slice, or we
2836 -- don't know what the alignment of the slice should be.
2837
2838 if Known_Alignment (Ptyp)
2839 and then (Unknown_Alignment (Styp)
2840 or else Alignment (Styp) > Alignment (Ptyp))
2841 then
2842 return True;
2843 end if;
2844
2845 -- We are in potential trouble if the record type is packed.
2846 -- We could special case when we know that the array is the
2847 -- first component, but that's not such a simple case ???
2848
2849 if Is_Packed (Ptyp) then
2850 return True;
2851 end if;
2852
2853 -- We are in trouble if there is a component clause, and
2854 -- either we do not know the alignment of the slice, or
2855 -- the alignment of the slice is inconsistent with the
2856 -- bit position specified by the component clause.
2857
2858 declare
2859 Field : constant Entity_Id := Entity (Selector_Name (Pref));
2860 begin
2861 if Present (Component_Clause (Field))
2862 and then
2863 (Unknown_Alignment (Styp)
2864 or else
2865 (Component_Bit_Offset (Field) mod
2866 (System_Storage_Unit * Alignment (Styp))) /= 0)
2867 then
2868 return True;
2869 end if;
2870 end;
2871
2872 -- For cases other than selected or indexed components we
2873 -- know we are OK, since no issues arise over alignment.
2874
2875 else
2876 return False;
2877 end if;
2878
2879 -- We processed an indexed component or selected component
2880 -- reference that looked safe, so keep checking prefixes.
2881
2882 Pref := Prefix (Pref);
2883 end loop;
2884 end;
2885 end Is_Possibly_Unaligned_Slice;
2886
2887 --------------------------------
2888 -- Is_Ref_To_Bit_Packed_Array --
2889 --------------------------------
2890
2891 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
2892 Result : Boolean;
2893 Expr : Node_Id;
2894
2895 begin
2896 if Is_Entity_Name (N)
2897 and then Is_Object (Entity (N))
2898 and then Present (Renamed_Object (Entity (N)))
2899 then
2900 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
2901 end if;
2902
2903 if Nkind (N) = N_Indexed_Component
2904 or else
2905 Nkind (N) = N_Selected_Component
2906 then
2907 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
2908 Result := True;
2909 else
2910 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
2911 end if;
2912
2913 if Result and then Nkind (N) = N_Indexed_Component then
2914 Expr := First (Expressions (N));
2915 while Present (Expr) loop
2916 Force_Evaluation (Expr);
2917 Next (Expr);
2918 end loop;
2919 end if;
2920
2921 return Result;
2922
2923 else
2924 return False;
2925 end if;
2926 end Is_Ref_To_Bit_Packed_Array;
2927
2928 --------------------------------
2929 -- Is_Ref_To_Bit_Packed_Slice --
2930 --------------------------------
2931
2932 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
2933 begin
2934 if Is_Entity_Name (N)
2935 and then Is_Object (Entity (N))
2936 and then Present (Renamed_Object (Entity (N)))
2937 then
2938 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
2939 end if;
2940
2941 if Nkind (N) = N_Slice
2942 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
2943 then
2944 return True;
2945
2946 elsif Nkind (N) = N_Indexed_Component
2947 or else
2948 Nkind (N) = N_Selected_Component
2949 then
2950 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
2951
2952 else
2953 return False;
2954 end if;
2955 end Is_Ref_To_Bit_Packed_Slice;
2956
2957 -----------------------
2958 -- Is_Renamed_Object --
2959 -----------------------
2960
2961 function Is_Renamed_Object (N : Node_Id) return Boolean is
2962 Pnod : constant Node_Id := Parent (N);
2963 Kind : constant Node_Kind := Nkind (Pnod);
2964
2965 begin
2966 if Kind = N_Object_Renaming_Declaration then
2967 return True;
2968
2969 elsif Kind = N_Indexed_Component
2970 or else Kind = N_Selected_Component
2971 then
2972 return Is_Renamed_Object (Pnod);
2973
2974 else
2975 return False;
2976 end if;
2977 end Is_Renamed_Object;
2978
2979 ----------------------------
2980 -- Is_Untagged_Derivation --
2981 ----------------------------
2982
2983 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
2984 begin
2985 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
2986 or else
2987 (Is_Private_Type (T) and then Present (Full_View (T))
2988 and then not Is_Tagged_Type (Full_View (T))
2989 and then Is_Derived_Type (Full_View (T))
2990 and then Etype (Full_View (T)) /= T);
2991
2992 end Is_Untagged_Derivation;
2993
2994 --------------------
2995 -- Kill_Dead_Code --
2996 --------------------
2997
2998 procedure Kill_Dead_Code (N : Node_Id) is
2999 begin
3000 if Present (N) then
3001 Remove_Warning_Messages (N);
3002
3003 -- Recurse into block statements and bodies to process declarations
3004 -- and statements
3005
3006 if Nkind (N) = N_Block_Statement
3007 or else Nkind (N) = N_Subprogram_Body
3008 or else Nkind (N) = N_Package_Body
3009 then
3010 Kill_Dead_Code (Declarations (N));
3011 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
3012
3013 if Nkind (N) = N_Subprogram_Body then
3014 Set_Is_Eliminated (Defining_Entity (N));
3015 end if;
3016
3017 elsif Nkind (N) = N_Package_Declaration then
3018 Kill_Dead_Code (Visible_Declarations (Specification (N)));
3019 Kill_Dead_Code (Private_Declarations (Specification (N)));
3020
3021 declare
3022 E : Entity_Id := First_Entity (Defining_Entity (N));
3023 begin
3024 while Present (E) loop
3025 if Ekind (E) = E_Operator then
3026 Set_Is_Eliminated (E);
3027 end if;
3028
3029 Next_Entity (E);
3030 end loop;
3031 end;
3032
3033 -- Recurse into composite statement to kill individual statements,
3034 -- in particular instantiations.
3035
3036 elsif Nkind (N) = N_If_Statement then
3037 Kill_Dead_Code (Then_Statements (N));
3038 Kill_Dead_Code (Elsif_Parts (N));
3039 Kill_Dead_Code (Else_Statements (N));
3040
3041 elsif Nkind (N) = N_Loop_Statement then
3042 Kill_Dead_Code (Statements (N));
3043
3044 elsif Nkind (N) = N_Case_Statement then
3045 declare
3046 Alt : Node_Id;
3047 begin
3048 Alt := First (Alternatives (N));
3049 while Present (Alt) loop
3050 Kill_Dead_Code (Statements (Alt));
3051 Next (Alt);
3052 end loop;
3053 end;
3054
3055 elsif Nkind (N) = N_Case_Statement_Alternative then
3056 Kill_Dead_Code (Statements (N));
3057
3058 -- Deal with dead instances caused by deleting instantiations
3059
3060 elsif Nkind (N) in N_Generic_Instantiation then
3061 Remove_Dead_Instance (N);
3062 end if;
3063
3064 Delete_Tree (N);
3065 end if;
3066 end Kill_Dead_Code;
3067
3068 -- Case where argument is a list of nodes to be killed
3069
3070 procedure Kill_Dead_Code (L : List_Id) is
3071 N : Node_Id;
3072
3073 begin
3074 if Is_Non_Empty_List (L) then
3075 loop
3076 N := Remove_Head (L);
3077 exit when No (N);
3078 Kill_Dead_Code (N);
3079 end loop;
3080 end if;
3081 end Kill_Dead_Code;
3082
3083 ------------------------
3084 -- Known_Non_Negative --
3085 ------------------------
3086
3087 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
3088 begin
3089 if Is_OK_Static_Expression (Opnd)
3090 and then Expr_Value (Opnd) >= 0
3091 then
3092 return True;
3093
3094 else
3095 declare
3096 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
3097
3098 begin
3099 return
3100 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
3101 end;
3102 end if;
3103 end Known_Non_Negative;
3104
3105 --------------------
3106 -- Known_Non_Null --
3107 --------------------
3108
3109 function Known_Non_Null (N : Node_Id) return Boolean is
3110 begin
3111 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))));
3112
3113 -- Case of entity for which Is_Known_Non_Null is True
3114
3115 if Is_Entity_Name (N) and then Is_Known_Non_Null (Entity (N)) then
3116
3117 -- If the entity is aliased or volatile, then we decide that
3118 -- we don't know it is really non-null even if the sequential
3119 -- flow indicates that it is, since such variables can be
3120 -- changed without us noticing.
3121
3122 if Is_Aliased (Entity (N))
3123 or else Treat_As_Volatile (Entity (N))
3124 then
3125 return False;
3126
3127 -- For all other cases, the flag is decisive
3128
3129 else
3130 return True;
3131 end if;
3132
3133 -- True if access attribute
3134
3135 elsif Nkind (N) = N_Attribute_Reference
3136 and then (Attribute_Name (N) = Name_Access
3137 or else
3138 Attribute_Name (N) = Name_Unchecked_Access
3139 or else
3140 Attribute_Name (N) = Name_Unrestricted_Access)
3141 then
3142 return True;
3143
3144 -- True if allocator
3145
3146 elsif Nkind (N) = N_Allocator then
3147 return True;
3148
3149 -- For a conversion, true if expression is known non-null
3150
3151 elsif Nkind (N) = N_Type_Conversion then
3152 return Known_Non_Null (Expression (N));
3153
3154 -- One more case is when Current_Value references a condition
3155 -- that ensures a non-null value.
3156
3157 elsif Is_Entity_Name (N) then
3158 declare
3159 Op : Node_Kind;
3160 Val : Node_Id;
3161
3162 begin
3163 Get_Current_Value_Condition (N, Op, Val);
3164 return Op = N_Op_Ne and then Nkind (Val) = N_Null;
3165 end;
3166
3167 -- Above are all cases where the value could be determined to be
3168 -- non-null. In all other cases, we don't know, so return False.
3169
3170 else
3171 return False;
3172 end if;
3173 end Known_Non_Null;
3174
3175 -----------------------------
3176 -- Make_CW_Equivalent_Type --
3177 -----------------------------
3178
3179 -- Create a record type used as an equivalent of any member
3180 -- of the class which takes its size from exp.
3181
3182 -- Generate the following code:
3183
3184 -- type Equiv_T is record
3185 -- _parent : T (List of discriminant constaints taken from Exp);
3186 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3187 -- end Equiv_T;
3188 --
3189 -- ??? Note that this type does not guarantee same alignment as all
3190 -- derived types
3191
3192 function Make_CW_Equivalent_Type
3193 (T : Entity_Id;
3194 E : Node_Id) return Entity_Id
3195 is
3196 Loc : constant Source_Ptr := Sloc (E);
3197 Root_Typ : constant Entity_Id := Root_Type (T);
3198 List_Def : constant List_Id := Empty_List;
3199 Equiv_Type : Entity_Id;
3200 Range_Type : Entity_Id;
3201 Str_Type : Entity_Id;
3202 Constr_Root : Entity_Id;
3203 Sizexpr : Node_Id;
3204
3205 begin
3206 if not Has_Discriminants (Root_Typ) then
3207 Constr_Root := Root_Typ;
3208 else
3209 Constr_Root :=
3210 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3211
3212 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3213
3214 Append_To (List_Def,
3215 Make_Subtype_Declaration (Loc,
3216 Defining_Identifier => Constr_Root,
3217 Subtype_Indication =>
3218 Make_Subtype_From_Expr (E, Root_Typ)));
3219 end if;
3220
3221 -- subtype rg__xx is Storage_Offset range
3222 -- (Expr'size - typ'size) / Storage_Unit
3223
3224 Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
3225
3226 Sizexpr :=
3227 Make_Op_Subtract (Loc,
3228 Left_Opnd =>
3229 Make_Attribute_Reference (Loc,
3230 Prefix =>
3231 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3232 Attribute_Name => Name_Size),
3233 Right_Opnd =>
3234 Make_Attribute_Reference (Loc,
3235 Prefix => New_Reference_To (Constr_Root, Loc),
3236 Attribute_Name => Name_Object_Size));
3237
3238 Set_Paren_Count (Sizexpr, 1);
3239
3240 Append_To (List_Def,
3241 Make_Subtype_Declaration (Loc,
3242 Defining_Identifier => Range_Type,
3243 Subtype_Indication =>
3244 Make_Subtype_Indication (Loc,
3245 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
3246 Constraint => Make_Range_Constraint (Loc,
3247 Range_Expression =>
3248 Make_Range (Loc,
3249 Low_Bound => Make_Integer_Literal (Loc, 1),
3250 High_Bound =>
3251 Make_Op_Divide (Loc,
3252 Left_Opnd => Sizexpr,
3253 Right_Opnd => Make_Integer_Literal (Loc,
3254 Intval => System_Storage_Unit)))))));
3255
3256 -- subtype str__nn is Storage_Array (rg__x);
3257
3258 Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3259 Append_To (List_Def,
3260 Make_Subtype_Declaration (Loc,
3261 Defining_Identifier => Str_Type,
3262 Subtype_Indication =>
3263 Make_Subtype_Indication (Loc,
3264 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3265 Constraint =>
3266 Make_Index_Or_Discriminant_Constraint (Loc,
3267 Constraints =>
3268 New_List (New_Reference_To (Range_Type, Loc))))));
3269
3270 -- type Equiv_T is record
3271 -- _parent : Tnn;
3272 -- E : Str_Type;
3273 -- end Equiv_T;
3274
3275 Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3276
3277 -- When the target requires front-end layout, it's necessary to allow
3278 -- the equivalent type to be frozen so that layout can occur (when the
3279 -- associated class-wide subtype is frozen, the equivalent type will
3280 -- be frozen, see freeze.adb). For other targets, Gigi wants to have
3281 -- the equivalent type marked as frozen and deals with this type itself.
3282 -- In the Gigi case this will also avoid the generation of an init
3283 -- procedure for the type.
3284
3285 if not Frontend_Layout_On_Target then
3286 Set_Is_Frozen (Equiv_Type);
3287 end if;
3288
3289 Set_Ekind (Equiv_Type, E_Record_Type);
3290 Set_Parent_Subtype (Equiv_Type, Constr_Root);
3291
3292 Append_To (List_Def,
3293 Make_Full_Type_Declaration (Loc,
3294 Defining_Identifier => Equiv_Type,
3295
3296 Type_Definition =>
3297 Make_Record_Definition (Loc,
3298 Component_List => Make_Component_List (Loc,
3299 Component_Items => New_List (
3300 Make_Component_Declaration (Loc,
3301 Defining_Identifier =>
3302 Make_Defining_Identifier (Loc, Name_uParent),
3303 Component_Definition =>
3304 Make_Component_Definition (Loc,
3305 Aliased_Present => False,
3306 Subtype_Indication =>
3307 New_Reference_To (Constr_Root, Loc))),
3308
3309 Make_Component_Declaration (Loc,
3310 Defining_Identifier =>
3311 Make_Defining_Identifier (Loc,
3312 Chars => New_Internal_Name ('C')),
3313 Component_Definition =>
3314 Make_Component_Definition (Loc,
3315 Aliased_Present => False,
3316 Subtype_Indication =>
3317 New_Reference_To (Str_Type, Loc)))),
3318
3319 Variant_Part => Empty))));
3320
3321 Insert_Actions (E, List_Def);
3322 return Equiv_Type;
3323 end Make_CW_Equivalent_Type;
3324
3325 ------------------------
3326 -- Make_Literal_Range --
3327 ------------------------
3328
3329 function Make_Literal_Range
3330 (Loc : Source_Ptr;
3331 Literal_Typ : Entity_Id) return Node_Id
3332 is
3333 Lo : constant Node_Id :=
3334 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
3335
3336 begin
3337 Set_Analyzed (Lo, False);
3338
3339 return
3340 Make_Range (Loc,
3341 Low_Bound => Lo,
3342
3343 High_Bound =>
3344 Make_Op_Subtract (Loc,
3345 Left_Opnd =>
3346 Make_Op_Add (Loc,
3347 Left_Opnd => New_Copy_Tree (Lo),
3348 Right_Opnd =>
3349 Make_Integer_Literal (Loc,
3350 String_Literal_Length (Literal_Typ))),
3351 Right_Opnd => Make_Integer_Literal (Loc, 1)));
3352 end Make_Literal_Range;
3353
3354 ----------------------------
3355 -- Make_Subtype_From_Expr --
3356 ----------------------------
3357
3358 -- 1. If Expr is an uncontrained array expression, creates
3359 -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
3360
3361 -- 2. If Expr is a unconstrained discriminated type expression, creates
3362 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3363
3364 -- 3. If Expr is class-wide, creates an implicit class wide subtype
3365
3366 function Make_Subtype_From_Expr
3367 (E : Node_Id;
3368 Unc_Typ : Entity_Id) return Node_Id
3369 is
3370 Loc : constant Source_Ptr := Sloc (E);
3371 List_Constr : constant List_Id := New_List;
3372 D : Entity_Id;
3373
3374 Full_Subtyp : Entity_Id;
3375 Priv_Subtyp : Entity_Id;
3376 Utyp : Entity_Id;
3377 Full_Exp : Node_Id;
3378
3379 begin
3380 if Is_Private_Type (Unc_Typ)
3381 and then Has_Unknown_Discriminants (Unc_Typ)
3382 then
3383 -- Prepare the subtype completion, Go to base type to
3384 -- find underlying type.
3385
3386 Utyp := Underlying_Type (Base_Type (Unc_Typ));
3387 Full_Subtyp := Make_Defining_Identifier (Loc,
3388 New_Internal_Name ('C'));
3389 Full_Exp :=
3390 Unchecked_Convert_To
3391 (Utyp, Duplicate_Subexpr_No_Checks (E));
3392 Set_Parent (Full_Exp, Parent (E));
3393
3394 Priv_Subtyp :=
3395 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3396
3397 Insert_Action (E,
3398 Make_Subtype_Declaration (Loc,
3399 Defining_Identifier => Full_Subtyp,
3400 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
3401
3402 -- Define the dummy private subtype
3403
3404 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
3405 Set_Etype (Priv_Subtyp, Unc_Typ);
3406 Set_Scope (Priv_Subtyp, Full_Subtyp);
3407 Set_Is_Constrained (Priv_Subtyp);
3408 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
3409 Set_Is_Itype (Priv_Subtyp);
3410 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
3411
3412 if Is_Tagged_Type (Priv_Subtyp) then
3413 Set_Class_Wide_Type
3414 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
3415 Set_Primitive_Operations (Priv_Subtyp,
3416 Primitive_Operations (Unc_Typ));
3417 end if;
3418
3419 Set_Full_View (Priv_Subtyp, Full_Subtyp);
3420
3421 return New_Reference_To (Priv_Subtyp, Loc);
3422
3423 elsif Is_Array_Type (Unc_Typ) then
3424 for J in 1 .. Number_Dimensions (Unc_Typ) loop
3425 Append_To (List_Constr,
3426 Make_Range (Loc,
3427 Low_Bound =>
3428 Make_Attribute_Reference (Loc,
3429 Prefix => Duplicate_Subexpr_No_Checks (E),
3430 Attribute_Name => Name_First,
3431 Expressions => New_List (
3432 Make_Integer_Literal (Loc, J))),
3433
3434 High_Bound =>
3435 Make_Attribute_Reference (Loc,
3436 Prefix => Duplicate_Subexpr_No_Checks (E),
3437 Attribute_Name => Name_Last,
3438 Expressions => New_List (
3439 Make_Integer_Literal (Loc, J)))));
3440 end loop;
3441
3442 elsif Is_Class_Wide_Type (Unc_Typ) then
3443 declare
3444 CW_Subtype : Entity_Id;
3445 EQ_Typ : Entity_Id := Empty;
3446
3447 begin
3448 -- A class-wide equivalent type is not needed when Java_VM
3449 -- because the JVM back end handles the class-wide object
3450 -- initialization itself (and doesn't need or want the
3451 -- additional intermediate type to handle the assignment).
3452
3453 if Expander_Active and then not Java_VM then
3454 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
3455 end if;
3456
3457 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
3458 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
3459
3460 if Present (EQ_Typ) then
3461 Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
3462 end if;
3463
3464 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
3465
3466 return New_Occurrence_Of (CW_Subtype, Loc);
3467 end;
3468
3469 -- Comment needed (what case is this ???)
3470
3471 else
3472 D := First_Discriminant (Unc_Typ);
3473 while Present (D) loop
3474 Append_To (List_Constr,
3475 Make_Selected_Component (Loc,
3476 Prefix => Duplicate_Subexpr_No_Checks (E),
3477 Selector_Name => New_Reference_To (D, Loc)));
3478
3479 Next_Discriminant (D);
3480 end loop;
3481 end if;
3482
3483 return
3484 Make_Subtype_Indication (Loc,
3485 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
3486 Constraint =>
3487 Make_Index_Or_Discriminant_Constraint (Loc,
3488 Constraints => List_Constr));
3489 end Make_Subtype_From_Expr;
3490
3491 -----------------------------
3492 -- May_Generate_Large_Temp --
3493 -----------------------------
3494
3495 -- At the current time, the only types that we return False for (i.e.
3496 -- where we decide we know they cannot generate large temps) are ones
3497 -- where we know the size is 256 bits or less at compile time, and we
3498 -- are still not doing a thorough job on arrays and records ???
3499
3500 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
3501 begin
3502 if not Size_Known_At_Compile_Time (Typ) then
3503 return False;
3504
3505 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
3506 return False;
3507
3508 elsif Is_Array_Type (Typ)
3509 and then Present (Packed_Array_Type (Typ))
3510 then
3511 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
3512
3513 -- We could do more here to find other small types ???
3514
3515 else
3516 return True;
3517 end if;
3518 end May_Generate_Large_Temp;
3519
3520 ----------------------------
3521 -- New_Class_Wide_Subtype --
3522 ----------------------------
3523
3524 function New_Class_Wide_Subtype
3525 (CW_Typ : Entity_Id;
3526 N : Node_Id) return Entity_Id
3527 is
3528 Res : constant Entity_Id := Create_Itype (E_Void, N);
3529 Res_Name : constant Name_Id := Chars (Res);
3530 Res_Scope : constant Entity_Id := Scope (Res);
3531
3532 begin
3533 Copy_Node (CW_Typ, Res);
3534 Set_Sloc (Res, Sloc (N));
3535 Set_Is_Itype (Res);
3536 Set_Associated_Node_For_Itype (Res, N);
3537 Set_Is_Public (Res, False); -- By default, may be changed below.
3538 Set_Public_Status (Res);
3539 Set_Chars (Res, Res_Name);
3540 Set_Scope (Res, Res_Scope);
3541 Set_Ekind (Res, E_Class_Wide_Subtype);
3542 Set_Next_Entity (Res, Empty);
3543 Set_Etype (Res, Base_Type (CW_Typ));
3544
3545 -- For targets where front-end layout is required, reset the Is_Frozen
3546 -- status of the subtype to False (it can be implicitly set to true
3547 -- from the copy of the class-wide type). For other targets, Gigi
3548 -- doesn't want the class-wide subtype to go through the freezing
3549 -- process (though it's unclear why that causes problems and it would
3550 -- be nice to allow freezing to occur normally for all targets ???).
3551
3552 if Frontend_Layout_On_Target then
3553 Set_Is_Frozen (Res, False);
3554 end if;
3555
3556 Set_Freeze_Node (Res, Empty);
3557 return (Res);
3558 end New_Class_Wide_Subtype;
3559
3560 -------------------------
3561 -- Remove_Side_Effects --
3562 -------------------------
3563
3564 procedure Remove_Side_Effects
3565 (Exp : Node_Id;
3566 Name_Req : Boolean := False;
3567 Variable_Ref : Boolean := False)
3568 is
3569 Loc : constant Source_Ptr := Sloc (Exp);
3570 Exp_Type : constant Entity_Id := Etype (Exp);
3571 Svg_Suppress : constant Suppress_Array := Scope_Suppress;
3572 Def_Id : Entity_Id;
3573 Ref_Type : Entity_Id;
3574 Res : Node_Id;
3575 Ptr_Typ_Decl : Node_Id;
3576 New_Exp : Node_Id;
3577 E : Node_Id;
3578
3579 function Side_Effect_Free (N : Node_Id) return Boolean;
3580 -- Determines if the tree N represents an expression that is known
3581 -- not to have side effects, and for which no processing is required.
3582
3583 function Side_Effect_Free (L : List_Id) return Boolean;
3584 -- Determines if all elements of the list L are side effect free
3585
3586 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
3587 -- The argument N is a construct where the Prefix is dereferenced
3588 -- if it is a an access type and the result is a variable. The call
3589 -- returns True if the construct is side effect free (not considering
3590 -- side effects in other than the prefix which are to be tested by the
3591 -- caller).
3592
3593 function Within_In_Parameter (N : Node_Id) return Boolean;
3594 -- Determines if N is a subcomponent of a composite in-parameter.
3595 -- If so, N is not side-effect free when the actual is global and
3596 -- modifiable indirectly from within a subprogram, because it may
3597 -- be passed by reference. The front-end must be conservative here
3598 -- and assume that this may happen with any array or record type.
3599 -- On the other hand, we cannot create temporaries for all expressions
3600 -- for which this condition is true, for various reasons that might
3601 -- require clearing up ??? For example, descriminant references that
3602 -- appear out of place, or spurious type errors with class-wide
3603 -- expressions. As a result, we limit the transformation to loop
3604 -- bounds, which is so far the only case that requires it.
3605
3606 -----------------------------
3607 -- Safe_Prefixed_Reference --
3608 -----------------------------
3609
3610 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
3611 begin
3612 -- If prefix is not side effect free, definitely not safe
3613
3614 if not Side_Effect_Free (Prefix (N)) then
3615 return False;
3616
3617 -- If the prefix is of an access type that is not access-to-constant,
3618 -- then this construct is a variable reference, which means it is to
3619 -- be considered to have side effects if Variable_Ref is set True
3620 -- Exception is an access to an entity that is a constant or an
3621 -- in-parameter which does not come from source, and is the result
3622 -- of a previous removal of side-effects.
3623
3624 elsif Is_Access_Type (Etype (Prefix (N)))
3625 and then not Is_Access_Constant (Etype (Prefix (N)))
3626 and then Variable_Ref
3627 then
3628 if not Is_Entity_Name (Prefix (N)) then
3629 return False;
3630 else
3631 return Ekind (Entity (Prefix (N))) = E_Constant
3632 or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
3633 end if;
3634
3635 -- The following test is the simplest way of solving a complex
3636 -- problem uncovered by BB08-010: Side effect on loop bound that
3637 -- is a subcomponent of a global variable:
3638 -- If a loop bound is a subcomponent of a global variable, a
3639 -- modification of that variable within the loop may incorrectly
3640 -- affect the execution of the loop.
3641
3642 elsif not
3643 (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
3644 or else not Within_In_Parameter (Prefix (N)))
3645 then
3646 return False;
3647
3648 -- All other cases are side effect free
3649
3650 else
3651 return True;
3652 end if;
3653 end Safe_Prefixed_Reference;
3654
3655 ----------------------
3656 -- Side_Effect_Free --
3657 ----------------------
3658
3659 function Side_Effect_Free (N : Node_Id) return Boolean is
3660 begin
3661 -- Note on checks that could raise Constraint_Error. Strictly, if
3662 -- we take advantage of 11.6, these checks do not count as side
3663 -- effects. However, we would just as soon consider that they are
3664 -- side effects, since the backend CSE does not work very well on
3665 -- expressions which can raise Constraint_Error. On the other
3666 -- hand, if we do not consider them to be side effect free, then
3667 -- we get some awkward expansions in -gnato mode, resulting in
3668 -- code insertions at a point where we do not have a clear model
3669 -- for performing the insertions. See 4908-002/comment for details.
3670
3671 -- Special handling for entity names
3672
3673 if Is_Entity_Name (N) then
3674
3675 -- If the entity is a constant, it is definitely side effect
3676 -- free. Note that the test of Is_Variable (N) below might
3677 -- be expected to catch this case, but it does not, because
3678 -- this test goes to the original tree, and we may have
3679 -- already rewritten a variable node with a constant as
3680 -- a result of an earlier Force_Evaluation call.
3681
3682 if Ekind (Entity (N)) = E_Constant
3683 or else Ekind (Entity (N)) = E_In_Parameter
3684 then
3685 return True;
3686
3687 -- Functions are not side effect free
3688
3689 elsif Ekind (Entity (N)) = E_Function then
3690 return False;
3691
3692 -- Variables are considered to be a side effect if Variable_Ref
3693 -- is set or if we have a volatile variable and Name_Req is off.
3694 -- If Name_Req is True then we can't help returning a name which
3695 -- effectively allows multiple references in any case.
3696
3697 elsif Is_Variable (N) then
3698 return not Variable_Ref
3699 and then (not Treat_As_Volatile (Entity (N))
3700 or else Name_Req);
3701
3702 -- Any other entity (e.g. a subtype name) is definitely side
3703 -- effect free.
3704
3705 else
3706 return True;
3707 end if;
3708
3709 -- A value known at compile time is always side effect free
3710
3711 elsif Compile_Time_Known_Value (N) then
3712 return True;
3713 end if;
3714
3715 -- For other than entity names and compile time known values,
3716 -- check the node kind for special processing.
3717
3718 case Nkind (N) is
3719
3720 -- An attribute reference is side effect free if its expressions
3721 -- are side effect free and its prefix is side effect free or
3722 -- is an entity reference.
3723
3724 -- Is this right? what about x'first where x is a variable???
3725
3726 when N_Attribute_Reference =>
3727 return Side_Effect_Free (Expressions (N))
3728 and then (Is_Entity_Name (Prefix (N))
3729 or else Side_Effect_Free (Prefix (N)));
3730
3731 -- A binary operator is side effect free if and both operands
3732 -- are side effect free. For this purpose binary operators
3733 -- include membership tests and short circuit forms
3734
3735 when N_Binary_Op |
3736 N_In |
3737 N_Not_In |
3738 N_And_Then |
3739 N_Or_Else =>
3740 return Side_Effect_Free (Left_Opnd (N))
3741 and then Side_Effect_Free (Right_Opnd (N));
3742
3743 -- An explicit dereference is side effect free only if it is
3744 -- a side effect free prefixed reference.
3745
3746 when N_Explicit_Dereference =>
3747 return Safe_Prefixed_Reference (N);
3748
3749 -- A call to _rep_to_pos is side effect free, since we generate
3750 -- this pure function call ourselves. Moreover it is critically
3751 -- important to make this exception, since otherwise we can
3752 -- have discriminants in array components which don't look
3753 -- side effect free in the case of an array whose index type
3754 -- is an enumeration type with an enumeration rep clause.
3755
3756 -- All other function calls are not side effect free
3757
3758 when N_Function_Call =>
3759 return Nkind (Name (N)) = N_Identifier
3760 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
3761 and then
3762 Side_Effect_Free (First (Parameter_Associations (N)));
3763
3764 -- An indexed component is side effect free if it is a side
3765 -- effect free prefixed reference and all the indexing
3766 -- expressions are side effect free.
3767
3768 when N_Indexed_Component =>
3769 return Side_Effect_Free (Expressions (N))
3770 and then Safe_Prefixed_Reference (N);
3771
3772 -- A type qualification is side effect free if the expression
3773 -- is side effect free.
3774
3775 when N_Qualified_Expression =>
3776 return Side_Effect_Free (Expression (N));
3777
3778 -- A selected component is side effect free only if it is a
3779 -- side effect free prefixed reference.
3780
3781 when N_Selected_Component =>
3782 return Safe_Prefixed_Reference (N);
3783
3784 -- A range is side effect free if the bounds are side effect free
3785
3786 when N_Range =>
3787 return Side_Effect_Free (Low_Bound (N))
3788 and then Side_Effect_Free (High_Bound (N));
3789
3790 -- A slice is side effect free if it is a side effect free
3791 -- prefixed reference and the bounds are side effect free.
3792
3793 when N_Slice =>
3794 return Side_Effect_Free (Discrete_Range (N))
3795 and then Safe_Prefixed_Reference (N);
3796
3797 -- A type conversion is side effect free if the expression
3798 -- to be converted is side effect free.
3799
3800 when N_Type_Conversion =>
3801 return Side_Effect_Free (Expression (N));
3802
3803 -- A unary operator is side effect free if the operand
3804 -- is side effect free.
3805
3806 when N_Unary_Op =>
3807 return Side_Effect_Free (Right_Opnd (N));
3808
3809 -- An unchecked type conversion is side effect free only if it
3810 -- is safe and its argument is side effect free.
3811
3812 when N_Unchecked_Type_Conversion =>
3813 return Safe_Unchecked_Type_Conversion (N)
3814 and then Side_Effect_Free (Expression (N));
3815
3816 -- An unchecked expression is side effect free if its expression
3817 -- is side effect free.
3818
3819 when N_Unchecked_Expression =>
3820 return Side_Effect_Free (Expression (N));
3821
3822 -- A literal is side effect free
3823
3824 when N_Character_Literal |
3825 N_Integer_Literal |
3826 N_Real_Literal |
3827 N_String_Literal =>
3828 return True;
3829
3830 -- We consider that anything else has side effects. This is a bit
3831 -- crude, but we are pretty close for most common cases, and we
3832 -- are certainly correct (i.e. we never return True when the
3833 -- answer should be False).
3834
3835 when others =>
3836 return False;
3837 end case;
3838 end Side_Effect_Free;
3839
3840 -- A list is side effect free if all elements of the list are
3841 -- side effect free.
3842
3843 function Side_Effect_Free (L : List_Id) return Boolean is
3844 N : Node_Id;
3845
3846 begin
3847 if L = No_List or else L = Error_List then
3848 return True;
3849
3850 else
3851 N := First (L);
3852 while Present (N) loop
3853 if not Side_Effect_Free (N) then
3854 return False;
3855 else
3856 Next (N);
3857 end if;
3858 end loop;
3859
3860 return True;
3861 end if;
3862 end Side_Effect_Free;
3863
3864 -------------------------
3865 -- Within_In_Parameter --
3866 -------------------------
3867
3868 function Within_In_Parameter (N : Node_Id) return Boolean is
3869 begin
3870 if not Comes_From_Source (N) then
3871 return False;
3872
3873 elsif Is_Entity_Name (N) then
3874 return
3875 Ekind (Entity (N)) = E_In_Parameter;
3876
3877 elsif Nkind (N) = N_Indexed_Component
3878 or else Nkind (N) = N_Selected_Component
3879 then
3880 return Within_In_Parameter (Prefix (N));
3881 else
3882
3883 return False;
3884 end if;
3885 end Within_In_Parameter;
3886
3887 -- Start of processing for Remove_Side_Effects
3888
3889 begin
3890 -- If we are side effect free already or expansion is disabled,
3891 -- there is nothing to do.
3892
3893 if Side_Effect_Free (Exp) or else not Expander_Active then
3894 return;
3895 end if;
3896
3897 -- All this must not have any checks
3898
3899 Scope_Suppress := (others => True);
3900
3901 -- If it is a scalar type and we need to capture the value, just
3902 -- make a copy. Likewise for a function call. And if we have a
3903 -- volatile variable and Nam_Req is not set (see comments above
3904 -- for Side_Effect_Free).
3905
3906 if Is_Elementary_Type (Exp_Type)
3907 and then (Variable_Ref
3908 or else Nkind (Exp) = N_Function_Call
3909 or else (not Name_Req
3910 and then Is_Entity_Name (Exp)
3911 and then Treat_As_Volatile (Entity (Exp))))
3912 then
3913
3914 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3915 Set_Etype (Def_Id, Exp_Type);
3916 Res := New_Reference_To (Def_Id, Loc);
3917
3918 E :=
3919 Make_Object_Declaration (Loc,
3920 Defining_Identifier => Def_Id,
3921 Object_Definition => New_Reference_To (Exp_Type, Loc),
3922 Constant_Present => True,
3923 Expression => Relocate_Node (Exp));
3924
3925 Set_Assignment_OK (E);
3926 Insert_Action (Exp, E);
3927
3928 -- If the expression has the form v.all then we can just capture
3929 -- the pointer, and then do an explicit dereference on the result.
3930
3931 elsif Nkind (Exp) = N_Explicit_Dereference then
3932 Def_Id :=
3933 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3934 Res :=
3935 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
3936
3937 Insert_Action (Exp,
3938 Make_Object_Declaration (Loc,
3939 Defining_Identifier => Def_Id,
3940 Object_Definition =>
3941 New_Reference_To (Etype (Prefix (Exp)), Loc),
3942 Constant_Present => True,
3943 Expression => Relocate_Node (Prefix (Exp))));
3944
3945 -- Similar processing for an unchecked conversion of an expression
3946 -- of the form v.all, where we want the same kind of treatment.
3947
3948 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
3949 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
3950 then
3951 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
3952 Scope_Suppress := Svg_Suppress;
3953 return;
3954
3955 -- If this is a type conversion, leave the type conversion and remove
3956 -- the side effects in the expression. This is important in several
3957 -- circumstances: for change of representations, and also when this
3958 -- is a view conversion to a smaller object, where gigi can end up
3959 -- creating its own temporary of the wrong size.
3960
3961 -- ??? this transformation is inhibited for elementary types that are
3962 -- not involved in a change of representation because it causes
3963 -- regressions that are not fully understood yet.
3964
3965 elsif Nkind (Exp) = N_Type_Conversion
3966 and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
3967 or else Nkind (Parent (Exp)) = N_Assignment_Statement)
3968 then
3969 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
3970 Scope_Suppress := Svg_Suppress;
3971 return;
3972
3973 -- If this is an unchecked conversion that Gigi can't handle, make
3974 -- a copy or a use a renaming to capture the value.
3975
3976 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
3977 and then not Safe_Unchecked_Type_Conversion (Exp)
3978 then
3979 if Controlled_Type (Etype (Exp)) then
3980
3981 -- Use a renaming to capture the expression, rather than create
3982 -- a controlled temporary.
3983
3984 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3985 Res := New_Reference_To (Def_Id, Loc);
3986
3987 Insert_Action (Exp,
3988 Make_Object_Renaming_Declaration (Loc,
3989 Defining_Identifier => Def_Id,
3990 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
3991 Name => Relocate_Node (Exp)));
3992
3993 else
3994 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3995 Set_Etype (Def_Id, Exp_Type);
3996 Res := New_Reference_To (Def_Id, Loc);
3997
3998 E :=
3999 Make_Object_Declaration (Loc,
4000 Defining_Identifier => Def_Id,
4001 Object_Definition => New_Reference_To (Exp_Type, Loc),
4002 Constant_Present => not Is_Variable (Exp),
4003 Expression => Relocate_Node (Exp));
4004
4005 Set_Assignment_OK (E);
4006 Insert_Action (Exp, E);
4007 end if;
4008
4009 -- For expressions that denote objects, we can use a renaming scheme.
4010 -- We skip using this if we have a volatile variable and we do not
4011 -- have Nam_Req set true (see comments above for Side_Effect_Free).
4012
4013 elsif Is_Object_Reference (Exp)
4014 and then Nkind (Exp) /= N_Function_Call
4015 and then (Name_Req
4016 or else not Is_Entity_Name (Exp)
4017 or else not Treat_As_Volatile (Entity (Exp)))
4018 then
4019 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4020
4021 if Nkind (Exp) = N_Selected_Component
4022 and then Nkind (Prefix (Exp)) = N_Function_Call
4023 and then Is_Array_Type (Etype (Exp))
4024 then
4025 -- Avoid generating a variable-sized temporary, by generating
4026 -- the renaming declaration just for the function call. The
4027 -- transformation could be refined to apply only when the array
4028 -- component is constrained by a discriminant???
4029
4030 Res :=
4031 Make_Selected_Component (Loc,
4032 Prefix => New_Occurrence_Of (Def_Id, Loc),
4033 Selector_Name => Selector_Name (Exp));
4034
4035 Insert_Action (Exp,
4036 Make_Object_Renaming_Declaration (Loc,
4037 Defining_Identifier => Def_Id,
4038 Subtype_Mark =>
4039 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
4040 Name => Relocate_Node (Prefix (Exp))));
4041
4042 else
4043 Res := New_Reference_To (Def_Id, Loc);
4044
4045 Insert_Action (Exp,
4046 Make_Object_Renaming_Declaration (Loc,
4047 Defining_Identifier => Def_Id,
4048 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
4049 Name => Relocate_Node (Exp)));
4050
4051 end if;
4052
4053 -- The temporary must be elaborated by gigi, and is of course
4054 -- not to be replaced in-line by the expression it renames,
4055 -- which would defeat the purpose of removing the side-effect.
4056
4057 Set_Is_Renaming_Of_Object (Def_Id, False);
4058
4059 -- Otherwise we generate a reference to the value
4060
4061 else
4062 Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4063
4064 Ptr_Typ_Decl :=
4065 Make_Full_Type_Declaration (Loc,
4066 Defining_Identifier => Ref_Type,
4067 Type_Definition =>
4068 Make_Access_To_Object_Definition (Loc,
4069 All_Present => True,
4070 Subtype_Indication =>
4071 New_Reference_To (Exp_Type, Loc)));
4072
4073 E := Exp;
4074 Insert_Action (Exp, Ptr_Typ_Decl);
4075
4076 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4077 Set_Etype (Def_Id, Exp_Type);
4078
4079 Res :=
4080 Make_Explicit_Dereference (Loc,
4081 Prefix => New_Reference_To (Def_Id, Loc));
4082
4083 if Nkind (E) = N_Explicit_Dereference then
4084 New_Exp := Relocate_Node (Prefix (E));
4085 else
4086 E := Relocate_Node (E);
4087 New_Exp := Make_Reference (Loc, E);
4088 end if;
4089
4090 if Is_Delayed_Aggregate (E) then
4091
4092 -- The expansion of nested aggregates is delayed until the
4093 -- enclosing aggregate is expanded. As aggregates are often
4094 -- qualified, the predicate applies to qualified expressions
4095 -- as well, indicating that the enclosing aggregate has not
4096 -- been expanded yet. At this point the aggregate is part of
4097 -- a stand-alone declaration, and must be fully expanded.
4098
4099 if Nkind (E) = N_Qualified_Expression then
4100 Set_Expansion_Delayed (Expression (E), False);
4101 Set_Analyzed (Expression (E), False);
4102 else
4103 Set_Expansion_Delayed (E, False);
4104 end if;
4105
4106 Set_Analyzed (E, False);
4107 end if;
4108
4109 Insert_Action (Exp,
4110 Make_Object_Declaration (Loc,
4111 Defining_Identifier => Def_Id,
4112 Object_Definition => New_Reference_To (Ref_Type, Loc),
4113 Expression => New_Exp));
4114 end if;
4115
4116 -- Preserve the Assignment_OK flag in all copies, since at least
4117 -- one copy may be used in a context where this flag must be set
4118 -- (otherwise why would the flag be set in the first place).
4119
4120 Set_Assignment_OK (Res, Assignment_OK (Exp));
4121
4122 -- Finally rewrite the original expression and we are done
4123
4124 Rewrite (Exp, Res);
4125 Analyze_And_Resolve (Exp, Exp_Type);
4126 Scope_Suppress := Svg_Suppress;
4127 end Remove_Side_Effects;
4128
4129 ---------------------------
4130 -- Represented_As_Scalar --
4131 ---------------------------
4132
4133 function Represented_As_Scalar (T : Entity_Id) return Boolean is
4134 UT : constant Entity_Id := Underlying_Type (T);
4135 begin
4136 return Is_Scalar_Type (UT)
4137 or else (Is_Bit_Packed_Array (UT)
4138 and then Is_Scalar_Type (Packed_Array_Type (UT)));
4139 end Represented_As_Scalar;
4140
4141 ------------------------------------
4142 -- Safe_Unchecked_Type_Conversion --
4143 ------------------------------------
4144
4145 -- Note: this function knows quite a bit about the exact requirements
4146 -- of Gigi with respect to unchecked type conversions, and its code
4147 -- must be coordinated with any changes in Gigi in this area.
4148
4149 -- The above requirements should be documented in Sinfo ???
4150
4151 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
4152 Otyp : Entity_Id;
4153 Ityp : Entity_Id;
4154 Oalign : Uint;
4155 Ialign : Uint;
4156 Pexp : constant Node_Id := Parent (Exp);
4157
4158 begin
4159 -- If the expression is the RHS of an assignment or object declaration
4160 -- we are always OK because there will always be a target.
4161
4162 -- Object renaming declarations, (generated for view conversions of
4163 -- actuals in inlined calls), like object declarations, provide an
4164 -- explicit type, and are safe as well.
4165
4166 if (Nkind (Pexp) = N_Assignment_Statement
4167 and then Expression (Pexp) = Exp)
4168 or else Nkind (Pexp) = N_Object_Declaration
4169 or else Nkind (Pexp) = N_Object_Renaming_Declaration
4170 then
4171 return True;
4172
4173 -- If the expression is the prefix of an N_Selected_Component
4174 -- we should also be OK because GCC knows to look inside the
4175 -- conversion except if the type is discriminated. We assume
4176 -- that we are OK anyway if the type is not set yet or if it is
4177 -- controlled since we can't afford to introduce a temporary in
4178 -- this case.
4179
4180 elsif Nkind (Pexp) = N_Selected_Component
4181 and then Prefix (Pexp) = Exp
4182 then
4183 if No (Etype (Pexp)) then
4184 return True;
4185 else
4186 return
4187 not Has_Discriminants (Etype (Pexp))
4188 or else Is_Constrained (Etype (Pexp));
4189 end if;
4190 end if;
4191
4192 -- Set the output type, this comes from Etype if it is set, otherwise
4193 -- we take it from the subtype mark, which we assume was already
4194 -- fully analyzed.
4195
4196 if Present (Etype (Exp)) then
4197 Otyp := Etype (Exp);
4198 else
4199 Otyp := Entity (Subtype_Mark (Exp));
4200 end if;
4201
4202 -- The input type always comes from the expression, and we assume
4203 -- this is indeed always analyzed, so we can simply get the Etype.
4204
4205 Ityp := Etype (Expression (Exp));
4206
4207 -- Initialize alignments to unknown so far
4208
4209 Oalign := No_Uint;
4210 Ialign := No_Uint;
4211
4212 -- Replace a concurrent type by its corresponding record type
4213 -- and each type by its underlying type and do the tests on those.
4214 -- The original type may be a private type whose completion is a
4215 -- concurrent type, so find the underlying type first.
4216
4217 if Present (Underlying_Type (Otyp)) then
4218 Otyp := Underlying_Type (Otyp);
4219 end if;
4220
4221 if Present (Underlying_Type (Ityp)) then
4222 Ityp := Underlying_Type (Ityp);
4223 end if;
4224
4225 if Is_Concurrent_Type (Otyp) then
4226 Otyp := Corresponding_Record_Type (Otyp);
4227 end if;
4228
4229 if Is_Concurrent_Type (Ityp) then
4230 Ityp := Corresponding_Record_Type (Ityp);
4231 end if;
4232
4233 -- If the base types are the same, we know there is no problem since
4234 -- this conversion will be a noop.
4235
4236 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
4237 return True;
4238
4239 -- Same if this is an upwards conversion of an untagged type, and there
4240 -- are no constraints involved (could be more general???)
4241
4242 elsif Etype (Ityp) = Otyp
4243 and then not Is_Tagged_Type (Ityp)
4244 and then not Has_Discriminants (Ityp)
4245 and then No (First_Rep_Item (Base_Type (Ityp)))
4246 then
4247 return True;
4248
4249 -- If the size of output type is known at compile time, there is
4250 -- never a problem. Note that unconstrained records are considered
4251 -- to be of known size, but we can't consider them that way here,
4252 -- because we are talking about the actual size of the object.
4253
4254 -- We also make sure that in addition to the size being known, we do
4255 -- not have a case which might generate an embarrassingly large temp
4256 -- in stack checking mode.
4257
4258 elsif Size_Known_At_Compile_Time (Otyp)
4259 and then
4260 (not Stack_Checking_Enabled
4261 or else not May_Generate_Large_Temp (Otyp))
4262 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
4263 then
4264 return True;
4265
4266 -- If either type is tagged, then we know the alignment is OK so
4267 -- Gigi will be able to use pointer punning.
4268
4269 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
4270 return True;
4271
4272 -- If either type is a limited record type, we cannot do a copy, so
4273 -- say safe since there's nothing else we can do.
4274
4275 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
4276 return True;
4277
4278 -- Conversions to and from packed array types are always ignored and
4279 -- hence are safe.
4280
4281 elsif Is_Packed_Array_Type (Otyp)
4282 or else Is_Packed_Array_Type (Ityp)
4283 then
4284 return True;
4285 end if;
4286
4287 -- The only other cases known to be safe is if the input type's
4288 -- alignment is known to be at least the maximum alignment for the
4289 -- target or if both alignments are known and the output type's
4290 -- alignment is no stricter than the input's. We can use the alignment
4291 -- of the component type of an array if a type is an unpacked
4292 -- array type.
4293
4294 if Present (Alignment_Clause (Otyp)) then
4295 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
4296
4297 elsif Is_Array_Type (Otyp)
4298 and then Present (Alignment_Clause (Component_Type (Otyp)))
4299 then
4300 Oalign := Expr_Value (Expression (Alignment_Clause
4301 (Component_Type (Otyp))));
4302 end if;
4303
4304 if Present (Alignment_Clause (Ityp)) then
4305 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
4306
4307 elsif Is_Array_Type (Ityp)
4308 and then Present (Alignment_Clause (Component_Type (Ityp)))
4309 then
4310 Ialign := Expr_Value (Expression (Alignment_Clause
4311 (Component_Type (Ityp))));
4312 end if;
4313
4314 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
4315 return True;
4316
4317 elsif Ialign /= No_Uint and then Oalign /= No_Uint
4318 and then Ialign <= Oalign
4319 then
4320 return True;
4321
4322 -- Otherwise, Gigi cannot handle this and we must make a temporary
4323
4324 else
4325 return False;
4326 end if;
4327
4328 end Safe_Unchecked_Type_Conversion;
4329
4330 --------------------------
4331 -- Set_Elaboration_Flag --
4332 --------------------------
4333
4334 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
4335 Loc : constant Source_Ptr := Sloc (N);
4336 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
4337 Asn : Node_Id;
4338
4339 begin
4340 if Present (Ent) then
4341
4342 -- Nothing to do if at the compilation unit level, because in this
4343 -- case the flag is set by the binder generated elaboration routine.
4344
4345 if Nkind (Parent (N)) = N_Compilation_Unit then
4346 null;
4347
4348 -- Here we do need to generate an assignment statement
4349
4350 else
4351 Check_Restriction (No_Elaboration_Code, N);
4352 Asn :=
4353 Make_Assignment_Statement (Loc,
4354 Name => New_Occurrence_Of (Ent, Loc),
4355 Expression => New_Occurrence_Of (Standard_True, Loc));
4356
4357 if Nkind (Parent (N)) = N_Subunit then
4358 Insert_After (Corresponding_Stub (Parent (N)), Asn);
4359 else
4360 Insert_After (N, Asn);
4361 end if;
4362
4363 Analyze (Asn);
4364
4365 -- Kill current value indication. This is necessary because
4366 -- the tests of this flag are inserted out of sequence and must
4367 -- not pick up bogus indications of the wrong constant value.
4368
4369 Set_Current_Value (Ent, Empty);
4370 end if;
4371 end if;
4372 end Set_Elaboration_Flag;
4373
4374 --------------------------
4375 -- Target_Has_Fixed_Ops --
4376 --------------------------
4377
4378 Integer_Sized_Small : Ureal;
4379 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
4380 -- function is called (we don't want to compute it more than once!)
4381
4382 Long_Integer_Sized_Small : Ureal;
4383 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
4384 -- functoin is called (we don't want to compute it more than once)
4385
4386 First_Time_For_THFO : Boolean := True;
4387 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
4388
4389 function Target_Has_Fixed_Ops
4390 (Left_Typ : Entity_Id;
4391 Right_Typ : Entity_Id;
4392 Result_Typ : Entity_Id) return Boolean
4393 is
4394 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
4395 -- Return True if the given type is a fixed-point type with a small
4396 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
4397 -- an absolute value less than 1.0. This is currently limited
4398 -- to fixed-point types that map to Integer or Long_Integer.
4399
4400 ------------------------
4401 -- Is_Fractional_Type --
4402 ------------------------
4403
4404 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
4405 begin
4406 if Esize (Typ) = Standard_Integer_Size then
4407 return Small_Value (Typ) = Integer_Sized_Small;
4408
4409 elsif Esize (Typ) = Standard_Long_Integer_Size then
4410 return Small_Value (Typ) = Long_Integer_Sized_Small;
4411
4412 else
4413 return False;
4414 end if;
4415 end Is_Fractional_Type;
4416
4417 -- Start of processing for Target_Has_Fixed_Ops
4418
4419 begin
4420 -- Return False if Fractional_Fixed_Ops_On_Target is false
4421
4422 if not Fractional_Fixed_Ops_On_Target then
4423 return False;
4424 end if;
4425
4426 -- Here the target has Fractional_Fixed_Ops, if first time, compute
4427 -- standard constants used by Is_Fractional_Type.
4428
4429 if First_Time_For_THFO then
4430 First_Time_For_THFO := False;
4431
4432 Integer_Sized_Small :=
4433 UR_From_Components
4434 (Num => Uint_1,
4435 Den => UI_From_Int (Standard_Integer_Size - 1),
4436 Rbase => 2);
4437
4438 Long_Integer_Sized_Small :=
4439 UR_From_Components
4440 (Num => Uint_1,
4441 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
4442 Rbase => 2);
4443 end if;
4444
4445 -- Return True if target supports fixed-by-fixed multiply/divide
4446 -- for fractional fixed-point types (see Is_Fractional_Type) and
4447 -- the operand and result types are equivalent fractional types.
4448
4449 return Is_Fractional_Type (Base_Type (Left_Typ))
4450 and then Is_Fractional_Type (Base_Type (Right_Typ))
4451 and then Is_Fractional_Type (Base_Type (Result_Typ))
4452 and then Esize (Left_Typ) = Esize (Right_Typ)
4453 and then Esize (Left_Typ) = Esize (Result_Typ);
4454 end Target_Has_Fixed_Ops;
4455
4456 ------------------------------------------
4457 -- Type_May_Have_Bit_Aligned_Components --
4458 ------------------------------------------
4459
4460 function Type_May_Have_Bit_Aligned_Components
4461 (Typ : Entity_Id) return Boolean
4462 is
4463 begin
4464 -- Array type, check component type
4465
4466 if Is_Array_Type (Typ) then
4467 return
4468 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
4469
4470 -- Record type, check components
4471
4472 elsif Is_Record_Type (Typ) then
4473 declare
4474 E : Entity_Id;
4475
4476 begin
4477 E := First_Entity (Typ);
4478 while Present (E) loop
4479 if Ekind (E) = E_Component
4480 or else Ekind (E) = E_Discriminant
4481 then
4482 if Component_May_Be_Bit_Aligned (E)
4483 or else
4484 Type_May_Have_Bit_Aligned_Components (Etype (E))
4485 then
4486 return True;
4487 end if;
4488 end if;
4489
4490 Next_Entity (E);
4491 end loop;
4492
4493 return False;
4494 end;
4495
4496 -- Type other than array or record is always OK
4497
4498 else
4499 return False;
4500 end if;
4501 end Type_May_Have_Bit_Aligned_Components;
4502
4503 ----------------------------
4504 -- Wrap_Cleanup_Procedure --
4505 ----------------------------
4506
4507 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
4508 Loc : constant Source_Ptr := Sloc (N);
4509 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
4510 Stmts : constant List_Id := Statements (Stseq);
4511
4512 begin
4513 if Abort_Allowed then
4514 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
4515 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4516 end if;
4517 end Wrap_Cleanup_Procedure;
4518
4519 end Exp_Util;
Mirror of the offical gcc git repository hosted at gcc.gnu.org