?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Remove old autovect-branch by moving to "dead" directory.
[official-gcc.git] / old-autovect-branch / gcc / ada / exp_util.adb
blob997fc7b7b9012c7153ebed0296df0c8e29a73695
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 for derived types with unknown discriminants if
1279 -- the parent type also has unknown discriminants.
1280
1281 elsif Is_Record_Type (Unc_Type)
1282 and then not Is_Class_Wide_Type (Unc_Type)
1283 and then Has_Unknown_Discriminants (Unc_Type)
1284 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
1285 then
1286 null;
1287
1288 -- Nothing to be done if the type of the expression is limited, because
1289 -- in this case the expression cannot be copied, and its use can only
1290 -- be by reference and there is no need for the actual subtype.
1291
1292 elsif Is_Limited_Type (Exp_Typ) then
1293 null;
1294
1295 else
1296 Remove_Side_Effects (Exp);
1297 Rewrite (Subtype_Indic,
1298 Make_Subtype_From_Expr (Exp, Unc_Type));
1299 end if;
1300 end Expand_Subtype_From_Expr;
1301
1302 --------------------------------
1303 -- Find_Implemented_Interface --
1304 --------------------------------
1305
1306 -- Given the following code (XXX denotes irrelevant value):
1307
1308 -- type Limd_Iface is limited interface;
1309 -- type Prot_Iface is protected interface;
1310 -- type Sync_Iface is synchronized interface;
1311
1312 -- type Parent_Subtype is new Limd_Iface and Sync_Iface with ...
1313 -- type Child_Subtype is new Parent_Subtype and Prot_Iface with ...
1314
1315 -- The following calls will return the following values:
1316
1317 -- Find_Implemented_Interface
1318 -- (Child_Subtype, Synchronized_Interface, False) -> Empty
1319
1320 -- Find_Implemented_Interface
1321 -- (Child_Subtype, Synchronized_Interface, True) -> Sync_Iface
1322
1323 -- Find_Implemented_Interface
1324 -- (Child_Subtype, Any_Synchronized_Interface, XXX) -> Prot_Iface
1325
1326 -- Find_Implemented_Interface
1327 -- (Child_Subtype, Any_Limited_Interface, XXX) -> Prot_Iface
1328
1329 function Find_Implemented_Interface
1330 (Typ : Entity_Id;
1331 Kind : Interface_Kind;
1332 Check_Parent : Boolean := False) return Entity_Id
1333 is
1334 Iface_Elmt : Elmt_Id;
1335
1336 function Interface_In_Kind
1337 (I : Entity_Id;
1338 Kind : Interface_Kind) return Boolean;
1339 -- Determine whether an interface falls into a specified kind
1340
1341 -----------------------
1342 -- Interface_In_Kind --
1343 -----------------------
1344
1345 function Interface_In_Kind
1346 (I : Entity_Id;
1347 Kind : Interface_Kind) return Boolean is
1348 begin
1349 if Is_Limited_Interface (I)
1350 and then (Kind = Any_Interface
1351 or else Kind = Any_Limited_Interface
1352 or else Kind = Limited_Interface)
1353 then
1354 return True;
1355
1356 elsif Is_Protected_Interface (I)
1357 and then (Kind = Any_Interface
1358 or else Kind = Any_Limited_Interface
1359 or else Kind = Any_Synchronized_Interface
1360 or else Kind = Protected_Interface)
1361 then
1362 return True;
1363
1364 elsif Is_Synchronized_Interface (I)
1365 and then (Kind = Any_Interface
1366 or else Kind = Any_Limited_Interface
1367 or else Kind = Synchronized_Interface)
1368 then
1369 return True;
1370
1371 elsif Is_Task_Interface (I)
1372 and then (Kind = Any_Interface
1373 or else Kind = Any_Limited_Interface
1374 or else Kind = Any_Synchronized_Interface
1375 or else Kind = Task_Interface)
1376 then
1377 return True;
1378
1379 -- Regular interface. This should be the last kind to check since
1380 -- all of the previous cases have their Is_Interface flags set.
1381
1382 elsif Is_Interface (I)
1383 and then (Kind = Any_Interface
1384 or else Kind = Iface)
1385 then
1386 return True;
1387
1388 else
1389 return False;
1390 end if;
1391 end Interface_In_Kind;
1392
1393 -- Start of processing for Find_Implemented_Interface
1394
1395 begin
1396 if not Is_Tagged_Type (Typ) then
1397 return Empty;
1398 end if;
1399
1400 -- Implementations of the form:
1401 -- Typ is new Interface ...
1402
1403 if Is_Interface (Etype (Typ))
1404 and then Interface_In_Kind (Etype (Typ), Kind)
1405 then
1406 return Etype (Typ);
1407 end if;
1408
1409 -- Implementations of the form:
1410 -- Typ is new Typ_Parent and Interface ...
1411
1412 if Present (Abstract_Interfaces (Typ)) then
1413 Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1414 while Present (Iface_Elmt) loop
1415 if Interface_In_Kind (Node (Iface_Elmt), Kind) then
1416 return Node (Iface_Elmt);
1417 end if;
1418
1419 Iface_Elmt := Next_Elmt (Iface_Elmt);
1420 end loop;
1421 end if;
1422
1423 -- Typ is a derived type and may implement a limited interface
1424 -- through its parent subtype. Check the parent subtype as well
1425 -- as any interfaces explicitly implemented at this level.
1426
1427 if Check_Parent
1428 and then Ekind (Typ) = E_Record_Type
1429 and then Present (Parent_Subtype (Typ))
1430 then
1431 return Find_Implemented_Interface (
1432 Parent_Subtype (Typ), Kind, Check_Parent);
1433 end if;
1434
1435 -- Typ does not implement a limited interface either at this level or
1436 -- in any of its parent subtypes.
1437
1438 return Empty;
1439 end Find_Implemented_Interface;
1440
1441 ------------------------
1442 -- Find_Interface_ADT --
1443 ------------------------
1444
1445 function Find_Interface_ADT
1446 (T : Entity_Id;
1447 Iface : Entity_Id) return Entity_Id
1448 is
1449 ADT : Elmt_Id;
1450 Found : Boolean := False;
1451 Typ : Entity_Id := T;
1452
1453 procedure Find_Secondary_Table (Typ : Entity_Id);
1454 -- Internal subprogram used to recursively climb to the ancestors
1455
1456 --------------------------
1457 -- Find_Secondary_Table --
1458 --------------------------
1459
1460 procedure Find_Secondary_Table (Typ : Entity_Id) is
1461 AI_Elmt : Elmt_Id;
1462 AI : Node_Id;
1463
1464 begin
1465 -- Climb to the ancestor (if any) handling private types
1466
1467 if Present (Full_View (Etype (Typ))) then
1468 if Full_View (Etype (Typ)) /= Typ then
1469 Find_Secondary_Table (Full_View (Etype (Typ)));
1470 end if;
1471
1472 elsif Etype (Typ) /= Typ then
1473 Find_Secondary_Table (Etype (Typ));
1474 end if;
1475
1476 -- If we already found it there is nothing else to do
1477
1478 if Found then
1479 return;
1480 end if;
1481
1482 if Present (Abstract_Interfaces (Typ))
1483 and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
1484 then
1485 AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1486 while Present (AI_Elmt) loop
1487 AI := Node (AI_Elmt);
1488
1489 if AI = Iface or else Is_Ancestor (Iface, AI) then
1490 Found := True;
1491 return;
1492 end if;
1493
1494 Next_Elmt (ADT);
1495 Next_Elmt (AI_Elmt);
1496 end loop;
1497 end if;
1498 end Find_Secondary_Table;
1499
1500 -- Start of processing for Find_Interface_Tag
1501
1502 begin
1503 -- Handle private types
1504
1505 if Has_Private_Declaration (Typ)
1506 and then Present (Full_View (Typ))
1507 then
1508 Typ := Full_View (Typ);
1509 end if;
1510
1511 -- Handle access types
1512
1513 if Is_Access_Type (Typ) then
1514 Typ := Directly_Designated_Type (Typ);
1515 end if;
1516
1517 -- Handle task and protected types implementing interfaces
1518
1519 if Ekind (Typ) = E_Protected_Type
1520 or else Ekind (Typ) = E_Task_Type
1521 then
1522 Typ := Corresponding_Record_Type (Typ);
1523 end if;
1524
1525 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
1526 pragma Assert (Present (Node (ADT)));
1527 Find_Secondary_Table (Typ);
1528 pragma Assert (Found);
1529 return Node (ADT);
1530 end Find_Interface_ADT;
1531
1532 ------------------------
1533 -- Find_Interface_Tag --
1534 ------------------------
1535
1536 function Find_Interface_Tag
1537 (T : Entity_Id;
1538 Iface : Entity_Id) return Entity_Id
1539 is
1540 AI_Tag : Entity_Id;
1541 Found : Boolean := False;
1542 Typ : Entity_Id := T;
1543
1544 procedure Find_Tag (Typ : in Entity_Id);
1545 -- Internal subprogram used to recursively climb to the ancestors
1546
1547 --------------
1548 -- Find_Tag --
1549 --------------
1550
1551 procedure Find_Tag (Typ : in Entity_Id) is
1552 AI_Elmt : Elmt_Id;
1553 AI : Node_Id;
1554
1555 begin
1556 -- Check if the interface is an immediate ancestor of the type and
1557 -- therefore shares the main tag.
1558
1559 if Typ = Iface then
1560 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1561 AI_Tag := First_Tag_Component (Typ);
1562 Found := True;
1563 return;
1564 end if;
1565
1566 -- Climb to the root type handling private types
1567
1568 if Present (Full_View (Etype (Typ))) then
1569 if Full_View (Etype (Typ)) /= Typ then
1570 Find_Tag (Full_View (Etype (Typ)));
1571 end if;
1572
1573 elsif Etype (Typ) /= Typ then
1574 Find_Tag (Etype (Typ));
1575 end if;
1576
1577 -- Traverse the list of interfaces implemented by the type
1578
1579 if not Found
1580 and then Present (Abstract_Interfaces (Typ))
1581 and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
1582 then
1583 -- Skip the tag associated with the primary table
1584
1585 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1586 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1587 pragma Assert (Present (AI_Tag));
1588
1589 AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1590 while Present (AI_Elmt) loop
1591 AI := Node (AI_Elmt);
1592
1593 if AI = Iface or else Is_Ancestor (Iface, AI) then
1594 Found := True;
1595 return;
1596 end if;
1597
1598 AI_Tag := Next_Tag_Component (AI_Tag);
1599 Next_Elmt (AI_Elmt);
1600 end loop;
1601 end if;
1602 end Find_Tag;
1603
1604 -- Start of processing for Find_Interface_Tag
1605
1606 begin
1607 pragma Assert (Is_Interface (Iface));
1608
1609 -- Handle private types
1610
1611 if Has_Private_Declaration (Typ)
1612 and then Present (Full_View (Typ))
1613 then
1614 Typ := Full_View (Typ);
1615 end if;
1616
1617 -- Handle access types
1618
1619 if Is_Access_Type (Typ) then
1620 Typ := Directly_Designated_Type (Typ);
1621 end if;
1622
1623 -- Handle task and protected types implementing interfaces
1624
1625 if Is_Concurrent_Type (Typ) then
1626 Typ := Corresponding_Record_Type (Typ);
1627 end if;
1628
1629 if Is_Class_Wide_Type (Typ) then
1630 Typ := Etype (Typ);
1631 end if;
1632
1633 -- Handle entities from the limited view
1634
1635 if Ekind (Typ) = E_Incomplete_Type then
1636 pragma Assert (Present (Non_Limited_View (Typ)));
1637 Typ := Non_Limited_View (Typ);
1638 end if;
1639
1640 Find_Tag (Typ);
1641 pragma Assert (Found);
1642 return AI_Tag;
1643 end Find_Interface_Tag;
1644
1645 --------------------
1646 -- Find_Interface --
1647 --------------------
1648
1649 function Find_Interface
1650 (T : Entity_Id;
1651 Comp : Entity_Id) return Entity_Id
1652 is
1653 AI_Tag : Entity_Id;
1654 Found : Boolean := False;
1655 Iface : Entity_Id;
1656 Typ : Entity_Id := T;
1657
1658 procedure Find_Iface (Typ : in Entity_Id);
1659 -- Internal subprogram used to recursively climb to the ancestors
1660
1661 ----------------
1662 -- Find_Iface --
1663 ----------------
1664
1665 procedure Find_Iface (Typ : in Entity_Id) is
1666 AI_Elmt : Elmt_Id;
1667
1668 begin
1669 -- Climb to the root type
1670
1671 if Etype (Typ) /= Typ then
1672 Find_Iface (Etype (Typ));
1673 end if;
1674
1675 -- Traverse the list of interfaces implemented by the type
1676
1677 if not Found
1678 and then Present (Abstract_Interfaces (Typ))
1679 and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
1680 then
1681 -- Skip the tag associated with the primary table
1682
1683 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1684 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1685 pragma Assert (Present (AI_Tag));
1686
1687 AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1688 while Present (AI_Elmt) loop
1689 if AI_Tag = Comp then
1690 Iface := Node (AI_Elmt);
1691 Found := True;
1692 return;
1693 end if;
1694
1695 AI_Tag := Next_Tag_Component (AI_Tag);
1696 Next_Elmt (AI_Elmt);
1697 end loop;
1698 end if;
1699 end Find_Iface;
1700
1701 -- Start of processing for Find_Interface
1702
1703 begin
1704 -- Handle private types
1705
1706 if Has_Private_Declaration (Typ)
1707 and then Present (Full_View (Typ))
1708 then
1709 Typ := Full_View (Typ);
1710 end if;
1711
1712 -- Handle access types
1713
1714 if Is_Access_Type (Typ) then
1715 Typ := Directly_Designated_Type (Typ);
1716 end if;
1717
1718 -- Handle task and protected types implementing interfaces
1719
1720 if Is_Concurrent_Type (Typ) then
1721 Typ := Corresponding_Record_Type (Typ);
1722 end if;
1723
1724 if Is_Class_Wide_Type (Typ) then
1725 Typ := Etype (Typ);
1726 end if;
1727
1728 -- Handle entities from the limited view
1729
1730 if Ekind (Typ) = E_Incomplete_Type then
1731 pragma Assert (Present (Non_Limited_View (Typ)));
1732 Typ := Non_Limited_View (Typ);
1733 end if;
1734
1735 Find_Iface (Typ);
1736 pragma Assert (Found);
1737 return Iface;
1738 end Find_Interface;
1739
1740 ------------------
1741 -- Find_Prim_Op --
1742 ------------------
1743
1744 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1745 Prim : Elmt_Id;
1746 Typ : Entity_Id := T;
1747
1748 begin
1749 if Is_Class_Wide_Type (Typ) then
1750 Typ := Root_Type (Typ);
1751 end if;
1752
1753 Typ := Underlying_Type (Typ);
1754
1755 Prim := First_Elmt (Primitive_Operations (Typ));
1756 while Chars (Node (Prim)) /= Name loop
1757 Next_Elmt (Prim);
1758 pragma Assert (Present (Prim));
1759 end loop;
1760
1761 return Node (Prim);
1762 end Find_Prim_Op;
1763
1764 function Find_Prim_Op
1765 (T : Entity_Id;
1766 Name : TSS_Name_Type) return Entity_Id
1767 is
1768 Prim : Elmt_Id;
1769 Typ : Entity_Id := T;
1770
1771 begin
1772 if Is_Class_Wide_Type (Typ) then
1773 Typ := Root_Type (Typ);
1774 end if;
1775
1776 Typ := Underlying_Type (Typ);
1777
1778 Prim := First_Elmt (Primitive_Operations (Typ));
1779 while not Is_TSS (Node (Prim), Name) loop
1780 Next_Elmt (Prim);
1781 pragma Assert (Present (Prim));
1782 end loop;
1783
1784 return Node (Prim);
1785 end Find_Prim_Op;
1786
1787 ----------------------
1788 -- Force_Evaluation --
1789 ----------------------
1790
1791 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1792 begin
1793 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1794 end Force_Evaluation;
1795
1796 ------------------------
1797 -- Generate_Poll_Call --
1798 ------------------------
1799
1800 procedure Generate_Poll_Call (N : Node_Id) is
1801 begin
1802 -- No poll call if polling not active
1803
1804 if not Polling_Required then
1805 return;
1806
1807 -- Otherwise generate require poll call
1808
1809 else
1810 Insert_Before_And_Analyze (N,
1811 Make_Procedure_Call_Statement (Sloc (N),
1812 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1813 end if;
1814 end Generate_Poll_Call;
1815
1816 ---------------------------------
1817 -- Get_Current_Value_Condition --
1818 ---------------------------------
1819
1820 procedure Get_Current_Value_Condition
1821 (Var : Node_Id;
1822 Op : out Node_Kind;
1823 Val : out Node_Id)
1824 is
1825 Loc : constant Source_Ptr := Sloc (Var);
1826 CV : constant Node_Id := Current_Value (Entity (Var));
1827 Sens : Boolean;
1828 Stm : Node_Id;
1829 Cond : Node_Id;
1830
1831 begin
1832 Op := N_Empty;
1833 Val := Empty;
1834
1835 -- If statement. Condition is known true in THEN section, known False
1836 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
1837
1838 if Nkind (CV) = N_If_Statement then
1839
1840 -- Before start of IF statement
1841
1842 if Loc < Sloc (CV) then
1843 return;
1844
1845 -- After end of IF statement
1846
1847 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1848 return;
1849 end if;
1850
1851 -- At this stage we know that we are within the IF statement, but
1852 -- unfortunately, the tree does not record the SLOC of the ELSE so
1853 -- we cannot use a simple SLOC comparison to distinguish between
1854 -- the then/else statements, so we have to climb the tree.
1855
1856 declare
1857 N : Node_Id;
1858
1859 begin
1860 N := Parent (Var);
1861 while Parent (N) /= CV loop
1862 N := Parent (N);
1863
1864 -- If we fall off the top of the tree, then that's odd, but
1865 -- perhaps it could occur in some error situation, and the
1866 -- safest response is simply to assume that the outcome of the
1867 -- condition is unknown. No point in bombing during an attempt
1868 -- to optimize things.
1869
1870 if No (N) then
1871 return;
1872 end if;
1873 end loop;
1874
1875 -- Now we have N pointing to a node whose parent is the IF
1876 -- statement in question, so now we can tell if we are within
1877 -- the THEN statements.
1878
1879 if Is_List_Member (N)
1880 and then List_Containing (N) = Then_Statements (CV)
1881 then
1882 Sens := True;
1883
1884 -- Otherwise we must be in ELSIF or ELSE part
1885
1886 else
1887 Sens := False;
1888 end if;
1889 end;
1890
1891 -- ELSIF part. Condition is known true within the referenced ELSIF,
1892 -- known False in any subsequent ELSIF or ELSE part, and unknown before
1893 -- the ELSE part or after the IF statement.
1894
1895 elsif Nkind (CV) = N_Elsif_Part then
1896 Stm := Parent (CV);
1897
1898 -- Before start of ELSIF part
1899
1900 if Loc < Sloc (CV) then
1901 return;
1902
1903 -- After end of IF statement
1904
1905 elsif Loc >= Sloc (Stm) +
1906 Text_Ptr (UI_To_Int (End_Span (Stm)))
1907 then
1908 return;
1909 end if;
1910
1911 -- Again we lack the SLOC of the ELSE, so we need to climb the tree
1912 -- to see if we are within the ELSIF part in question.
1913
1914 declare
1915 N : Node_Id;
1916
1917 begin
1918 N := Parent (Var);
1919 while Parent (N) /= Stm loop
1920 N := Parent (N);
1921
1922 -- If we fall off the top of the tree, then that's odd, but
1923 -- perhaps it could occur in some error situation, and the
1924 -- safest response is simply to assume that the outcome of the
1925 -- condition is unknown. No point in bombing during an attempt
1926 -- to optimize things.
1927
1928 if No (N) then
1929 return;
1930 end if;
1931 end loop;
1932
1933 -- Now we have N pointing to a node whose parent is the IF
1934 -- statement in question, so see if is the ELSIF part we want.
1935 -- the THEN statements.
1936
1937 if N = CV then
1938 Sens := True;
1939
1940 -- Otherwise we must be in susbequent ELSIF or ELSE part
1941
1942 else
1943 Sens := False;
1944 end if;
1945 end;
1946
1947 -- All other cases of Current_Value settings
1948
1949 else
1950 return;
1951 end if;
1952
1953 -- If we fall through here, then we have a reportable condition, Sens is
1954 -- True if the condition is true and False if it needs inverting.
1955
1956 -- Deal with NOT operators, inverting sense
1957
1958 Cond := Condition (CV);
1959 while Nkind (Cond) = N_Op_Not loop
1960 Cond := Right_Opnd (Cond);
1961 Sens := not Sens;
1962 end loop;
1963
1964 -- Now we must have a relational operator
1965
1966 pragma Assert (Entity (Var) = Entity (Left_Opnd (Cond)));
1967 Val := Right_Opnd (Cond);
1968 Op := Nkind (Cond);
1969
1970 if Sens = False then
1971 case Op is
1972 when N_Op_Eq => Op := N_Op_Ne;
1973 when N_Op_Ne => Op := N_Op_Eq;
1974 when N_Op_Lt => Op := N_Op_Ge;
1975 when N_Op_Gt => Op := N_Op_Le;
1976 when N_Op_Le => Op := N_Op_Gt;
1977 when N_Op_Ge => Op := N_Op_Lt;
1978
1979 -- No other entry should be possible
1980
1981 when others =>
1982 raise Program_Error;
1983 end case;
1984 end if;
1985 end Get_Current_Value_Condition;
1986
1987 --------------------
1988 -- Homonym_Number --
1989 --------------------
1990
1991 function Homonym_Number (Subp : Entity_Id) return Nat is
1992 Count : Nat;
1993 Hom : Entity_Id;
1994
1995 begin
1996 Count := 1;
1997 Hom := Homonym (Subp);
1998 while Present (Hom) loop
1999 if Scope (Hom) = Scope (Subp) then
2000 Count := Count + 1;
2001 end if;
2002
2003 Hom := Homonym (Hom);
2004 end loop;
2005
2006 return Count;
2007 end Homonym_Number;
2008
2009 --------------------------
2010 -- Implements_Interface --
2011 --------------------------
2012
2013 function Implements_Interface
2014 (Typ : Entity_Id;
2015 Kind : Interface_Kind;
2016 Check_Parent : Boolean := False) return Boolean is
2017 begin
2018 return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty;
2019 end Implements_Interface;
2020
2021 ------------------------------
2022 -- In_Unconditional_Context --
2023 ------------------------------
2024
2025 function In_Unconditional_Context (Node : Node_Id) return Boolean is
2026 P : Node_Id;
2027
2028 begin
2029 P := Node;
2030 while Present (P) loop
2031 case Nkind (P) is
2032 when N_Subprogram_Body =>
2033 return True;
2034
2035 when N_If_Statement =>
2036 return False;
2037
2038 when N_Loop_Statement =>
2039 return False;
2040
2041 when N_Case_Statement =>
2042 return False;
2043
2044 when others =>
2045 P := Parent (P);
2046 end case;
2047 end loop;
2048
2049 return False;
2050 end In_Unconditional_Context;
2051
2052 -------------------
2053 -- Insert_Action --
2054 -------------------
2055
2056 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
2057 begin
2058 if Present (Ins_Action) then
2059 Insert_Actions (Assoc_Node, New_List (Ins_Action));
2060 end if;
2061 end Insert_Action;
2062
2063 -- Version with check(s) suppressed
2064
2065 procedure Insert_Action
2066 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
2067 is
2068 begin
2069 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
2070 end Insert_Action;
2071
2072 --------------------
2073 -- Insert_Actions --
2074 --------------------
2075
2076 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
2077 N : Node_Id;
2078 P : Node_Id;
2079
2080 Wrapped_Node : Node_Id := Empty;
2081
2082 begin
2083 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
2084 return;
2085 end if;
2086
2087 -- Ignore insert of actions from inside default expression in the
2088 -- special preliminary analyze mode. Any insertions at this point
2089 -- have no relevance, since we are only doing the analyze to freeze
2090 -- the types of any static expressions. See section "Handling of
2091 -- Default Expressions" in the spec of package Sem for further details.
2092
2093 if In_Default_Expression then
2094 return;
2095 end if;
2096
2097 -- If the action derives from stuff inside a record, then the actions
2098 -- are attached to the current scope, to be inserted and analyzed on
2099 -- exit from the scope. The reason for this is that we may also
2100 -- be generating freeze actions at the same time, and they must
2101 -- eventually be elaborated in the correct order.
2102
2103 if Is_Record_Type (Current_Scope)
2104 and then not Is_Frozen (Current_Scope)
2105 then
2106 if No (Scope_Stack.Table
2107 (Scope_Stack.Last).Pending_Freeze_Actions)
2108 then
2109 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
2110 Ins_Actions;
2111 else
2112 Append_List
2113 (Ins_Actions,
2114 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
2115 end if;
2116
2117 return;
2118 end if;
2119
2120 -- We now intend to climb up the tree to find the right point to
2121 -- insert the actions. We start at Assoc_Node, unless this node is
2122 -- a subexpression in which case we start with its parent. We do this
2123 -- for two reasons. First it speeds things up. Second, if Assoc_Node
2124 -- is itself one of the special nodes like N_And_Then, then we assume
2125 -- that an initial request to insert actions for such a node does not
2126 -- expect the actions to get deposited in the node for later handling
2127 -- when the node is expanded, since clearly the node is being dealt
2128 -- with by the caller. Note that in the subexpression case, N is
2129 -- always the child we came from.
2130
2131 -- N_Raise_xxx_Error is an annoying special case, it is a statement
2132 -- if it has type Standard_Void_Type, and a subexpression otherwise.
2133 -- otherwise. Procedure attribute references are also statements.
2134
2135 if Nkind (Assoc_Node) in N_Subexpr
2136 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
2137 or else Etype (Assoc_Node) /= Standard_Void_Type)
2138 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
2139 or else
2140 not Is_Procedure_Attribute_Name
2141 (Attribute_Name (Assoc_Node)))
2142 then
2143 P := Assoc_Node; -- ??? does not agree with above!
2144 N := Parent (Assoc_Node);
2145
2146 -- Non-subexpression case. Note that N is initially Empty in this
2147 -- case (N is only guaranteed Non-Empty in the subexpr case).
2148
2149 else
2150 P := Assoc_Node;
2151 N := Empty;
2152 end if;
2153
2154 -- Capture root of the transient scope
2155
2156 if Scope_Is_Transient then
2157 Wrapped_Node := Node_To_Be_Wrapped;
2158 end if;
2159
2160 loop
2161 pragma Assert (Present (P));
2162
2163 case Nkind (P) is
2164
2165 -- Case of right operand of AND THEN or OR ELSE. Put the actions
2166 -- in the Actions field of the right operand. They will be moved
2167 -- out further when the AND THEN or OR ELSE operator is expanded.
2168 -- Nothing special needs to be done for the left operand since
2169 -- in that case the actions are executed unconditionally.
2170
2171 when N_And_Then | N_Or_Else =>
2172 if N = Right_Opnd (P) then
2173 if Present (Actions (P)) then
2174 Insert_List_After_And_Analyze
2175 (Last (Actions (P)), Ins_Actions);
2176 else
2177 Set_Actions (P, Ins_Actions);
2178 Analyze_List (Actions (P));
2179 end if;
2180
2181 return;
2182 end if;
2183
2184 -- Then or Else operand of conditional expression. Add actions to
2185 -- Then_Actions or Else_Actions field as appropriate. The actions
2186 -- will be moved further out when the conditional is expanded.
2187
2188 when N_Conditional_Expression =>
2189 declare
2190 ThenX : constant Node_Id := Next (First (Expressions (P)));
2191 ElseX : constant Node_Id := Next (ThenX);
2192
2193 begin
2194 -- Actions belong to the then expression, temporarily
2195 -- place them as Then_Actions of the conditional expr.
2196 -- They will be moved to the proper place later when
2197 -- the conditional expression is expanded.
2198
2199 if N = ThenX then
2200 if Present (Then_Actions (P)) then
2201 Insert_List_After_And_Analyze
2202 (Last (Then_Actions (P)), Ins_Actions);
2203 else
2204 Set_Then_Actions (P, Ins_Actions);
2205 Analyze_List (Then_Actions (P));
2206 end if;
2207
2208 return;
2209
2210 -- Actions belong to the else expression, temporarily
2211 -- place them as Else_Actions of the conditional expr.
2212 -- They will be moved to the proper place later when
2213 -- the conditional expression is expanded.
2214
2215 elsif N = ElseX then
2216 if Present (Else_Actions (P)) then
2217 Insert_List_After_And_Analyze
2218 (Last (Else_Actions (P)), Ins_Actions);
2219 else
2220 Set_Else_Actions (P, Ins_Actions);
2221 Analyze_List (Else_Actions (P));
2222 end if;
2223
2224 return;
2225
2226 -- Actions belong to the condition. In this case they are
2227 -- unconditionally executed, and so we can continue the
2228 -- search for the proper insert point.
2229
2230 else
2231 null;
2232 end if;
2233 end;
2234
2235 -- Case of appearing in the condition of a while expression or
2236 -- elsif. We insert the actions into the Condition_Actions field.
2237 -- They will be moved further out when the while loop or elsif
2238 -- is analyzed.
2239
2240 when N_Iteration_Scheme |
2241 N_Elsif_Part
2242 =>
2243 if N = Condition (P) then
2244 if Present (Condition_Actions (P)) then
2245 Insert_List_After_And_Analyze
2246 (Last (Condition_Actions (P)), Ins_Actions);
2247 else
2248 Set_Condition_Actions (P, Ins_Actions);
2249
2250 -- Set the parent of the insert actions explicitly.
2251 -- This is not a syntactic field, but we need the
2252 -- parent field set, in particular so that freeze
2253 -- can understand that it is dealing with condition
2254 -- actions, and properly insert the freezing actions.
2255
2256 Set_Parent (Ins_Actions, P);
2257 Analyze_List (Condition_Actions (P));
2258 end if;
2259
2260 return;
2261 end if;
2262
2263 -- Statements, declarations, pragmas, representation clauses
2264
2265 when
2266 -- Statements
2267
2268 N_Procedure_Call_Statement |
2269 N_Statement_Other_Than_Procedure_Call |
2270
2271 -- Pragmas
2272
2273 N_Pragma |
2274
2275 -- Representation_Clause
2276
2277 N_At_Clause |
2278 N_Attribute_Definition_Clause |
2279 N_Enumeration_Representation_Clause |
2280 N_Record_Representation_Clause |
2281
2282 -- Declarations
2283
2284 N_Abstract_Subprogram_Declaration |
2285 N_Entry_Body |
2286 N_Exception_Declaration |
2287 N_Exception_Renaming_Declaration |
2288 N_Formal_Abstract_Subprogram_Declaration |
2289 N_Formal_Concrete_Subprogram_Declaration |
2290 N_Formal_Object_Declaration |
2291 N_Formal_Type_Declaration |
2292 N_Full_Type_Declaration |
2293 N_Function_Instantiation |
2294 N_Generic_Function_Renaming_Declaration |
2295 N_Generic_Package_Declaration |
2296 N_Generic_Package_Renaming_Declaration |
2297 N_Generic_Procedure_Renaming_Declaration |
2298 N_Generic_Subprogram_Declaration |
2299 N_Implicit_Label_Declaration |
2300 N_Incomplete_Type_Declaration |
2301 N_Number_Declaration |
2302 N_Object_Declaration |
2303 N_Object_Renaming_Declaration |
2304 N_Package_Body |
2305 N_Package_Body_Stub |
2306 N_Package_Declaration |
2307 N_Package_Instantiation |
2308 N_Package_Renaming_Declaration |
2309 N_Private_Extension_Declaration |
2310 N_Private_Type_Declaration |
2311 N_Procedure_Instantiation |
2312 N_Protected_Body_Stub |
2313 N_Protected_Type_Declaration |
2314 N_Single_Task_Declaration |
2315 N_Subprogram_Body |
2316 N_Subprogram_Body_Stub |
2317 N_Subprogram_Declaration |
2318 N_Subprogram_Renaming_Declaration |
2319 N_Subtype_Declaration |
2320 N_Task_Body |
2321 N_Task_Body_Stub |
2322 N_Task_Type_Declaration |
2323
2324 -- Freeze entity behaves like a declaration or statement
2325
2326 N_Freeze_Entity
2327 =>
2328 -- Do not insert here if the item is not a list member (this
2329 -- happens for example with a triggering statement, and the
2330 -- proper approach is to insert before the entire select).
2331
2332 if not Is_List_Member (P) then
2333 null;
2334
2335 -- Do not insert if parent of P is an N_Component_Association
2336 -- node (i.e. we are in the context of an N_Aggregate node.
2337 -- In this case we want to insert before the entire aggregate.
2338
2339 elsif Nkind (Parent (P)) = N_Component_Association then
2340 null;
2341
2342 -- Do not insert if the parent of P is either an N_Variant
2343 -- node or an N_Record_Definition node, meaning in either
2344 -- case that P is a member of a component list, and that
2345 -- therefore the actions should be inserted outside the
2346 -- complete record declaration.
2347
2348 elsif Nkind (Parent (P)) = N_Variant
2349 or else Nkind (Parent (P)) = N_Record_Definition
2350 then
2351 null;
2352
2353 -- Do not insert freeze nodes within the loop generated for
2354 -- an aggregate, because they may be elaborated too late for
2355 -- subsequent use in the back end: within a package spec the
2356 -- loop is part of the elaboration procedure and is only
2357 -- elaborated during the second pass.
2358 -- If the loop comes from source, or the entity is local to
2359 -- the loop itself it must remain within.
2360
2361 elsif Nkind (Parent (P)) = N_Loop_Statement
2362 and then not Comes_From_Source (Parent (P))
2363 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
2364 and then
2365 Scope (Entity (First (Ins_Actions))) /= Current_Scope
2366 then
2367 null;
2368
2369 -- Otherwise we can go ahead and do the insertion
2370
2371 elsif P = Wrapped_Node then
2372 Store_Before_Actions_In_Scope (Ins_Actions);
2373 return;
2374
2375 else
2376 Insert_List_Before_And_Analyze (P, Ins_Actions);
2377 return;
2378 end if;
2379
2380 -- A special case, N_Raise_xxx_Error can act either as a
2381 -- statement or a subexpression. We tell the difference
2382 -- by looking at the Etype. It is set to Standard_Void_Type
2383 -- in the statement case.
2384
2385 when
2386 N_Raise_xxx_Error =>
2387 if Etype (P) = Standard_Void_Type then
2388 if P = Wrapped_Node then
2389 Store_Before_Actions_In_Scope (Ins_Actions);
2390 else
2391 Insert_List_Before_And_Analyze (P, Ins_Actions);
2392 end if;
2393
2394 return;
2395
2396 -- In the subexpression case, keep climbing
2397
2398 else
2399 null;
2400 end if;
2401
2402 -- If a component association appears within a loop created for
2403 -- an array aggregate, attach the actions to the association so
2404 -- they can be subsequently inserted within the loop. For other
2405 -- component associations insert outside of the aggregate. For
2406 -- an association that will generate a loop, its Loop_Actions
2407 -- attribute is already initialized (see exp_aggr.adb).
2408
2409 -- The list of loop_actions can in turn generate additional ones,
2410 -- that are inserted before the associated node. If the associated
2411 -- node is outside the aggregate, the new actions are collected
2412 -- at the end of the loop actions, to respect the order in which
2413 -- they are to be elaborated.
2414
2415 when
2416 N_Component_Association =>
2417 if Nkind (Parent (P)) = N_Aggregate
2418 and then Present (Loop_Actions (P))
2419 then
2420 if Is_Empty_List (Loop_Actions (P)) then
2421 Set_Loop_Actions (P, Ins_Actions);
2422 Analyze_List (Ins_Actions);
2423
2424 else
2425 declare
2426 Decl : Node_Id;
2427
2428 begin
2429 -- Check whether these actions were generated
2430 -- by a declaration that is part of the loop_
2431 -- actions for the component_association.
2432
2433 Decl := Assoc_Node;
2434 while Present (Decl) loop
2435 exit when Parent (Decl) = P
2436 and then Is_List_Member (Decl)
2437 and then
2438 List_Containing (Decl) = Loop_Actions (P);
2439 Decl := Parent (Decl);
2440 end loop;
2441
2442 if Present (Decl) then
2443 Insert_List_Before_And_Analyze
2444 (Decl, Ins_Actions);
2445 else
2446 Insert_List_After_And_Analyze
2447 (Last (Loop_Actions (P)), Ins_Actions);
2448 end if;
2449 end;
2450 end if;
2451
2452 return;
2453
2454 else
2455 null;
2456 end if;
2457
2458 -- Another special case, an attribute denoting a procedure call
2459
2460 when
2461 N_Attribute_Reference =>
2462 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
2463 if P = Wrapped_Node then
2464 Store_Before_Actions_In_Scope (Ins_Actions);
2465 else
2466 Insert_List_Before_And_Analyze (P, Ins_Actions);
2467 end if;
2468
2469 return;
2470
2471 -- In the subexpression case, keep climbing
2472
2473 else
2474 null;
2475 end if;
2476
2477 -- For all other node types, keep climbing tree
2478
2479 when
2480 N_Abortable_Part |
2481 N_Accept_Alternative |
2482 N_Access_Definition |
2483 N_Access_Function_Definition |
2484 N_Access_Procedure_Definition |
2485 N_Access_To_Object_Definition |
2486 N_Aggregate |
2487 N_Allocator |
2488 N_Case_Statement_Alternative |
2489 N_Character_Literal |
2490 N_Compilation_Unit |
2491 N_Compilation_Unit_Aux |
2492 N_Component_Clause |
2493 N_Component_Declaration |
2494 N_Component_Definition |
2495 N_Component_List |
2496 N_Constrained_Array_Definition |
2497 N_Decimal_Fixed_Point_Definition |
2498 N_Defining_Character_Literal |
2499 N_Defining_Identifier |
2500 N_Defining_Operator_Symbol |
2501 N_Defining_Program_Unit_Name |
2502 N_Delay_Alternative |
2503 N_Delta_Constraint |
2504 N_Derived_Type_Definition |
2505 N_Designator |
2506 N_Digits_Constraint |
2507 N_Discriminant_Association |
2508 N_Discriminant_Specification |
2509 N_Empty |
2510 N_Entry_Body_Formal_Part |
2511 N_Entry_Call_Alternative |
2512 N_Entry_Declaration |
2513 N_Entry_Index_Specification |
2514 N_Enumeration_Type_Definition |
2515 N_Error |
2516 N_Exception_Handler |
2517 N_Expanded_Name |
2518 N_Explicit_Dereference |
2519 N_Extension_Aggregate |
2520 N_Floating_Point_Definition |
2521 N_Formal_Decimal_Fixed_Point_Definition |
2522 N_Formal_Derived_Type_Definition |
2523 N_Formal_Discrete_Type_Definition |
2524 N_Formal_Floating_Point_Definition |
2525 N_Formal_Modular_Type_Definition |
2526 N_Formal_Ordinary_Fixed_Point_Definition |
2527 N_Formal_Package_Declaration |
2528 N_Formal_Private_Type_Definition |
2529 N_Formal_Signed_Integer_Type_Definition |
2530 N_Function_Call |
2531 N_Function_Specification |
2532 N_Generic_Association |
2533 N_Handled_Sequence_Of_Statements |
2534 N_Identifier |
2535 N_In |
2536 N_Index_Or_Discriminant_Constraint |
2537 N_Indexed_Component |
2538 N_Integer_Literal |
2539 N_Itype_Reference |
2540 N_Label |
2541 N_Loop_Parameter_Specification |
2542 N_Mod_Clause |
2543 N_Modular_Type_Definition |
2544 N_Not_In |
2545 N_Null |
2546 N_Op_Abs |
2547 N_Op_Add |
2548 N_Op_And |
2549 N_Op_Concat |
2550 N_Op_Divide |
2551 N_Op_Eq |
2552 N_Op_Expon |
2553 N_Op_Ge |
2554 N_Op_Gt |
2555 N_Op_Le |
2556 N_Op_Lt |
2557 N_Op_Minus |
2558 N_Op_Mod |
2559 N_Op_Multiply |
2560 N_Op_Ne |
2561 N_Op_Not |
2562 N_Op_Or |
2563 N_Op_Plus |
2564 N_Op_Rem |
2565 N_Op_Rotate_Left |
2566 N_Op_Rotate_Right |
2567 N_Op_Shift_Left |
2568 N_Op_Shift_Right |
2569 N_Op_Shift_Right_Arithmetic |
2570 N_Op_Subtract |
2571 N_Op_Xor |
2572 N_Operator_Symbol |
2573 N_Ordinary_Fixed_Point_Definition |
2574 N_Others_Choice |
2575 N_Package_Specification |
2576 N_Parameter_Association |
2577 N_Parameter_Specification |
2578 N_Pragma_Argument_Association |
2579 N_Procedure_Specification |
2580 N_Protected_Body |
2581 N_Protected_Definition |
2582 N_Qualified_Expression |
2583 N_Range |
2584 N_Range_Constraint |
2585 N_Real_Literal |
2586 N_Real_Range_Specification |
2587 N_Record_Definition |
2588 N_Reference |
2589 N_Selected_Component |
2590 N_Signed_Integer_Type_Definition |
2591 N_Single_Protected_Declaration |
2592 N_Slice |
2593 N_String_Literal |
2594 N_Subprogram_Info |
2595 N_Subtype_Indication |
2596 N_Subunit |
2597 N_Task_Definition |
2598 N_Terminate_Alternative |
2599 N_Triggering_Alternative |
2600 N_Type_Conversion |
2601 N_Unchecked_Expression |
2602 N_Unchecked_Type_Conversion |
2603 N_Unconstrained_Array_Definition |
2604 N_Unused_At_End |
2605 N_Unused_At_Start |
2606 N_Use_Package_Clause |
2607 N_Use_Type_Clause |
2608 N_Variant |
2609 N_Variant_Part |
2610 N_Validate_Unchecked_Conversion |
2611 N_With_Clause |
2612 N_With_Type_Clause
2613 =>
2614 null;
2615
2616 end case;
2617
2618 -- Make sure that inserted actions stay in the transient scope
2619
2620 if P = Wrapped_Node then
2621 Store_Before_Actions_In_Scope (Ins_Actions);
2622 return;
2623 end if;
2624
2625 -- If we fall through above tests, keep climbing tree
2626
2627 N := P;
2628
2629 if Nkind (Parent (N)) = N_Subunit then
2630
2631 -- This is the proper body corresponding to a stub. Insertion
2632 -- must be done at the point of the stub, which is in the decla-
2633 -- tive part of the parent unit.
2634
2635 P := Corresponding_Stub (Parent (N));
2636
2637 else
2638 P := Parent (N);
2639 end if;
2640 end loop;
2641
2642 end Insert_Actions;
2643
2644 -- Version with check(s) suppressed
2645
2646 procedure Insert_Actions
2647 (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
2648 is
2649 begin
2650 if Suppress = All_Checks then
2651 declare
2652 Svg : constant Suppress_Array := Scope_Suppress;
2653 begin
2654 Scope_Suppress := (others => True);
2655 Insert_Actions (Assoc_Node, Ins_Actions);
2656 Scope_Suppress := Svg;
2657 end;
2658
2659 else
2660 declare
2661 Svg : constant Boolean := Scope_Suppress (Suppress);
2662 begin
2663 Scope_Suppress (Suppress) := True;
2664 Insert_Actions (Assoc_Node, Ins_Actions);
2665 Scope_Suppress (Suppress) := Svg;
2666 end;
2667 end if;
2668 end Insert_Actions;
2669
2670 --------------------------
2671 -- Insert_Actions_After --
2672 --------------------------
2673
2674 procedure Insert_Actions_After
2675 (Assoc_Node : Node_Id;
2676 Ins_Actions : List_Id)
2677 is
2678 begin
2679 if Scope_Is_Transient
2680 and then Assoc_Node = Node_To_Be_Wrapped
2681 then
2682 Store_After_Actions_In_Scope (Ins_Actions);
2683 else
2684 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2685 end if;
2686 end Insert_Actions_After;
2687
2688 ---------------------------------
2689 -- Insert_Library_Level_Action --
2690 ---------------------------------
2691
2692 procedure Insert_Library_Level_Action (N : Node_Id) is
2693 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2694
2695 begin
2696 New_Scope (Cunit_Entity (Main_Unit));
2697
2698 if No (Actions (Aux)) then
2699 Set_Actions (Aux, New_List (N));
2700 else
2701 Append (N, Actions (Aux));
2702 end if;
2703
2704 Analyze (N);
2705 Pop_Scope;
2706 end Insert_Library_Level_Action;
2707
2708 ----------------------------------
2709 -- Insert_Library_Level_Actions --
2710 ----------------------------------
2711
2712 procedure Insert_Library_Level_Actions (L : List_Id) is
2713 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2714
2715 begin
2716 if Is_Non_Empty_List (L) then
2717 New_Scope (Cunit_Entity (Main_Unit));
2718
2719 if No (Actions (Aux)) then
2720 Set_Actions (Aux, L);
2721 Analyze_List (L);
2722 else
2723 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2724 end if;
2725
2726 Pop_Scope;
2727 end if;
2728 end Insert_Library_Level_Actions;
2729
2730 ----------------------
2731 -- Inside_Init_Proc --
2732 ----------------------
2733
2734 function Inside_Init_Proc return Boolean is
2735 S : Entity_Id;
2736
2737 begin
2738 S := Current_Scope;
2739 while Present (S)
2740 and then S /= Standard_Standard
2741 loop
2742 if Is_Init_Proc (S) then
2743 return True;
2744 else
2745 S := Scope (S);
2746 end if;
2747 end loop;
2748
2749 return False;
2750 end Inside_Init_Proc;
2751
2752 ----------------------------
2753 -- Is_All_Null_Statements --
2754 ----------------------------
2755
2756 function Is_All_Null_Statements (L : List_Id) return Boolean is
2757 Stm : Node_Id;
2758
2759 begin
2760 Stm := First (L);
2761 while Present (Stm) loop
2762 if Nkind (Stm) /= N_Null_Statement then
2763 return False;
2764 end if;
2765
2766 Next (Stm);
2767 end loop;
2768
2769 return True;
2770 end Is_All_Null_Statements;
2771
2772 -----------------------------------------
2773 -- Is_Predefined_Dispatching_Operation --
2774 -----------------------------------------
2775
2776 function Is_Predefined_Dispatching_Operation
2777 (Subp : Entity_Id) return Boolean
2778 is
2779 TSS_Name : TSS_Name_Type;
2780 E : Entity_Id := Subp;
2781 begin
2782 pragma Assert (Is_Dispatching_Operation (Subp));
2783
2784 -- Handle overriden subprograms
2785
2786 while Present (Alias (E)) loop
2787 E := Alias (E);
2788 end loop;
2789
2790 Get_Name_String (Chars (E));
2791
2792 if Name_Len > TSS_Name_Type'Last then
2793 TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
2794 .. Name_Len));
2795 if Chars (E) = Name_uSize
2796 or else Chars (E) = Name_uAlignment
2797 or else TSS_Name = TSS_Stream_Read
2798 or else TSS_Name = TSS_Stream_Write
2799 or else TSS_Name = TSS_Stream_Input
2800 or else TSS_Name = TSS_Stream_Output
2801 or else Chars (E) = Name_Op_Eq
2802 or else Chars (E) = Name_uAssign
2803 or else TSS_Name = TSS_Deep_Adjust
2804 or else TSS_Name = TSS_Deep_Finalize
2805 or else (Ada_Version >= Ada_05
2806 and then (Chars (E) = Name_uDisp_Asynchronous_Select
2807 or else Chars (E) = Name_uDisp_Conditional_Select
2808 or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
2809 or else Chars (E) = Name_uDisp_Get_Task_Id
2810 or else Chars (E) = Name_uDisp_Timed_Select))
2811 then
2812 return True;
2813 end if;
2814 end if;
2815
2816 return False;
2817 end Is_Predefined_Dispatching_Operation;
2818
2819 ----------------------------------
2820 -- Is_Possibly_Unaligned_Object --
2821 ----------------------------------
2822
2823 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
2824 T : constant Entity_Id := Etype (N);
2825
2826 begin
2827 -- If renamed object, apply test to underlying object
2828
2829 if Is_Entity_Name (N)
2830 and then Is_Object (Entity (N))
2831 and then Present (Renamed_Object (Entity (N)))
2832 then
2833 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
2834 end if;
2835
2836 -- Tagged and controlled types and aliased types are always aligned,
2837 -- as are concurrent types.
2838
2839 if Is_Aliased (T)
2840 or else Has_Controlled_Component (T)
2841 or else Is_Concurrent_Type (T)
2842 or else Is_Tagged_Type (T)
2843 or else Is_Controlled (T)
2844 then
2845 return False;
2846 end if;
2847
2848 -- If this is an element of a packed array, may be unaligned
2849
2850 if Is_Ref_To_Bit_Packed_Array (N) then
2851 return True;
2852 end if;
2853
2854 -- Case of component reference
2855
2856 if Nkind (N) = N_Selected_Component then
2857 declare
2858 P : constant Node_Id := Prefix (N);
2859 C : constant Entity_Id := Entity (Selector_Name (N));
2860 M : Nat;
2861 S : Nat;
2862
2863 begin
2864 -- If component reference is for an array with non-static bounds,
2865 -- then it is always aligned: we can only process unaligned
2866 -- arrays with static bounds (more accurately bounds known at
2867 -- compile time).
2868
2869 if Is_Array_Type (T)
2870 and then not Compile_Time_Known_Bounds (T)
2871 then
2872 return False;
2873 end if;
2874
2875 -- If component is aliased, it is definitely properly aligned
2876
2877 if Is_Aliased (C) then
2878 return False;
2879 end if;
2880
2881 -- If component is for a type implemented as a scalar, and the
2882 -- record is packed, and the component is other than the first
2883 -- component of the record, then the component may be unaligned.
2884
2885 if Is_Packed (Etype (P))
2886 and then Represented_As_Scalar (Etype (C))
2887 and then First_Entity (Scope (C)) /= C
2888 then
2889 return True;
2890 end if;
2891
2892 -- Compute maximum possible alignment for T
2893
2894 -- If alignment is known, then that settles things
2895
2896 if Known_Alignment (T) then
2897 M := UI_To_Int (Alignment (T));
2898
2899 -- If alignment is not known, tentatively set max alignment
2900
2901 else
2902 M := Ttypes.Maximum_Alignment;
2903
2904 -- We can reduce this if the Esize is known since the default
2905 -- alignment will never be more than the smallest power of 2
2906 -- that does not exceed this Esize value.
2907
2908 if Known_Esize (T) then
2909 S := UI_To_Int (Esize (T));
2910
2911 while (M / 2) >= S loop
2912 M := M / 2;
2913 end loop;
2914 end if;
2915 end if;
2916
2917 -- If the component reference is for a record that has a specified
2918 -- alignment, and we either know it is too small, or cannot tell,
2919 -- then the component may be unaligned
2920
2921 if Known_Alignment (Etype (P))
2922 and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
2923 and then M > Alignment (Etype (P))
2924 then
2925 return True;
2926 end if;
2927
2928 -- Case of component clause present which may specify an
2929 -- unaligned position.
2930
2931 if Present (Component_Clause (C)) then
2932
2933 -- Otherwise we can do a test to make sure that the actual
2934 -- start position in the record, and the length, are both
2935 -- consistent with the required alignment. If not, we know
2936 -- that we are unaligned.
2937
2938 declare
2939 Align_In_Bits : constant Nat := M * System_Storage_Unit;
2940 begin
2941 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
2942 or else Esize (C) mod Align_In_Bits /= 0
2943 then
2944 return True;
2945 end if;
2946 end;
2947 end if;
2948
2949 -- Otherwise, for a component reference, test prefix
2950
2951 return Is_Possibly_Unaligned_Object (P);
2952 end;
2953
2954 -- If not a component reference, must be aligned
2955
2956 else
2957 return False;
2958 end if;
2959 end Is_Possibly_Unaligned_Object;
2960
2961 ---------------------------------
2962 -- Is_Possibly_Unaligned_Slice --
2963 ---------------------------------
2964
2965 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
2966 begin
2967 -- ??? GCC3 will eventually handle strings with arbitrary alignments,
2968 -- but for now the following check must be disabled.
2969
2970 -- if get_gcc_version >= 3 then
2971 -- return False;
2972 -- end if;
2973
2974 -- For renaming case, go to renamed object
2975
2976 if Is_Entity_Name (N)
2977 and then Is_Object (Entity (N))
2978 and then Present (Renamed_Object (Entity (N)))
2979 then
2980 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
2981 end if;
2982
2983 -- The reference must be a slice
2984
2985 if Nkind (N) /= N_Slice then
2986 return False;
2987 end if;
2988
2989 -- Always assume the worst for a nested record component with a
2990 -- component clause, which gigi/gcc does not appear to handle well.
2991 -- It is not clear why this special test is needed at all ???
2992
2993 if Nkind (Prefix (N)) = N_Selected_Component
2994 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
2995 and then
2996 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
2997 then
2998 return True;
2999 end if;
3000
3001 -- We only need to worry if the target has strict alignment
3002
3003 if not Target_Strict_Alignment then
3004 return False;
3005 end if;
3006
3007 -- If it is a slice, then look at the array type being sliced
3008
3009 declare
3010 Sarr : constant Node_Id := Prefix (N);
3011 -- Prefix of the slice, i.e. the array being sliced
3012
3013 Styp : constant Entity_Id := Etype (Prefix (N));
3014 -- Type of the array being sliced
3015
3016 Pref : Node_Id;
3017 Ptyp : Entity_Id;
3018
3019 begin
3020 -- The problems arise if the array object that is being sliced
3021 -- is a component of a record or array, and we cannot guarantee
3022 -- the alignment of the array within its containing object.
3023
3024 -- To investigate this, we look at successive prefixes to see
3025 -- if we have a worrisome indexed or selected component.
3026
3027 Pref := Sarr;
3028 loop
3029 -- Case of array is part of an indexed component reference
3030
3031 if Nkind (Pref) = N_Indexed_Component then
3032 Ptyp := Etype (Prefix (Pref));
3033
3034 -- The only problematic case is when the array is packed,
3035 -- in which case we really know nothing about the alignment
3036 -- of individual components.
3037
3038 if Is_Bit_Packed_Array (Ptyp) then
3039 return True;
3040 end if;
3041
3042 -- Case of array is part of a selected component reference
3043
3044 elsif Nkind (Pref) = N_Selected_Component then
3045 Ptyp := Etype (Prefix (Pref));
3046
3047 -- We are definitely in trouble if the record in question
3048 -- has an alignment, and either we know this alignment is
3049 -- inconsistent with the alignment of the slice, or we
3050 -- don't know what the alignment of the slice should be.
3051
3052 if Known_Alignment (Ptyp)
3053 and then (Unknown_Alignment (Styp)
3054 or else Alignment (Styp) > Alignment (Ptyp))
3055 then
3056 return True;
3057 end if;
3058
3059 -- We are in potential trouble if the record type is packed.
3060 -- We could special case when we know that the array is the
3061 -- first component, but that's not such a simple case ???
3062
3063 if Is_Packed (Ptyp) then
3064 return True;
3065 end if;
3066
3067 -- We are in trouble if there is a component clause, and
3068 -- either we do not know the alignment of the slice, or
3069 -- the alignment of the slice is inconsistent with the
3070 -- bit position specified by the component clause.
3071
3072 declare
3073 Field : constant Entity_Id := Entity (Selector_Name (Pref));
3074 begin
3075 if Present (Component_Clause (Field))
3076 and then
3077 (Unknown_Alignment (Styp)
3078 or else
3079 (Component_Bit_Offset (Field) mod
3080 (System_Storage_Unit * Alignment (Styp))) /= 0)
3081 then
3082 return True;
3083 end if;
3084 end;
3085
3086 -- For cases other than selected or indexed components we
3087 -- know we are OK, since no issues arise over alignment.
3088
3089 else
3090 return False;
3091 end if;
3092
3093 -- We processed an indexed component or selected component
3094 -- reference that looked safe, so keep checking prefixes.
3095
3096 Pref := Prefix (Pref);
3097 end loop;
3098 end;
3099 end Is_Possibly_Unaligned_Slice;
3100
3101 --------------------------------
3102 -- Is_Ref_To_Bit_Packed_Array --
3103 --------------------------------
3104
3105 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
3106 Result : Boolean;
3107 Expr : Node_Id;
3108
3109 begin
3110 if Is_Entity_Name (N)
3111 and then Is_Object (Entity (N))
3112 and then Present (Renamed_Object (Entity (N)))
3113 then
3114 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
3115 end if;
3116
3117 if Nkind (N) = N_Indexed_Component
3118 or else
3119 Nkind (N) = N_Selected_Component
3120 then
3121 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
3122 Result := True;
3123 else
3124 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
3125 end if;
3126
3127 if Result and then Nkind (N) = N_Indexed_Component then
3128 Expr := First (Expressions (N));
3129 while Present (Expr) loop
3130 Force_Evaluation (Expr);
3131 Next (Expr);
3132 end loop;
3133 end if;
3134
3135 return Result;
3136
3137 else
3138 return False;
3139 end if;
3140 end Is_Ref_To_Bit_Packed_Array;
3141
3142 --------------------------------
3143 -- Is_Ref_To_Bit_Packed_Slice --
3144 --------------------------------
3145
3146 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
3147 begin
3148 if Nkind (N) = N_Type_Conversion then
3149 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
3150
3151 elsif Is_Entity_Name (N)
3152 and then Is_Object (Entity (N))
3153 and then Present (Renamed_Object (Entity (N)))
3154 then
3155 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
3156
3157 elsif Nkind (N) = N_Slice
3158 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
3159 then
3160 return True;
3161
3162 elsif Nkind (N) = N_Indexed_Component
3163 or else
3164 Nkind (N) = N_Selected_Component
3165 then
3166 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
3167
3168 else
3169 return False;
3170 end if;
3171 end Is_Ref_To_Bit_Packed_Slice;
3172
3173 -----------------------
3174 -- Is_Renamed_Object --
3175 -----------------------
3176
3177 function Is_Renamed_Object (N : Node_Id) return Boolean is
3178 Pnod : constant Node_Id := Parent (N);
3179 Kind : constant Node_Kind := Nkind (Pnod);
3180
3181 begin
3182 if Kind = N_Object_Renaming_Declaration then
3183 return True;
3184
3185 elsif Kind = N_Indexed_Component
3186 or else Kind = N_Selected_Component
3187 then
3188 return Is_Renamed_Object (Pnod);
3189
3190 else
3191 return False;
3192 end if;
3193 end Is_Renamed_Object;
3194
3195 ----------------------------
3196 -- Is_Untagged_Derivation --
3197 ----------------------------
3198
3199 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
3200 begin
3201 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
3202 or else
3203 (Is_Private_Type (T) and then Present (Full_View (T))
3204 and then not Is_Tagged_Type (Full_View (T))
3205 and then Is_Derived_Type (Full_View (T))
3206 and then Etype (Full_View (T)) /= T);
3207
3208 end Is_Untagged_Derivation;
3209
3210 --------------------
3211 -- Kill_Dead_Code --
3212 --------------------
3213
3214 procedure Kill_Dead_Code (N : Node_Id) is
3215 begin
3216 if Present (N) then
3217 Remove_Warning_Messages (N);
3218
3219 -- Recurse into block statements and bodies to process declarations
3220 -- and statements
3221
3222 if Nkind (N) = N_Block_Statement
3223 or else Nkind (N) = N_Subprogram_Body
3224 or else Nkind (N) = N_Package_Body
3225 then
3226 Kill_Dead_Code (Declarations (N));
3227 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
3228
3229 if Nkind (N) = N_Subprogram_Body then
3230 Set_Is_Eliminated (Defining_Entity (N));
3231 end if;
3232
3233 elsif Nkind (N) = N_Package_Declaration then
3234 Kill_Dead_Code (Visible_Declarations (Specification (N)));
3235 Kill_Dead_Code (Private_Declarations (Specification (N)));
3236
3237 declare
3238 E : Entity_Id := First_Entity (Defining_Entity (N));
3239 begin
3240 while Present (E) loop
3241 if Ekind (E) = E_Operator then
3242 Set_Is_Eliminated (E);
3243 end if;
3244
3245 Next_Entity (E);
3246 end loop;
3247 end;
3248
3249 -- Recurse into composite statement to kill individual statements,
3250 -- in particular instantiations.
3251
3252 elsif Nkind (N) = N_If_Statement then
3253 Kill_Dead_Code (Then_Statements (N));
3254 Kill_Dead_Code (Elsif_Parts (N));
3255 Kill_Dead_Code (Else_Statements (N));
3256
3257 elsif Nkind (N) = N_Loop_Statement then
3258 Kill_Dead_Code (Statements (N));
3259
3260 elsif Nkind (N) = N_Case_Statement then
3261 declare
3262 Alt : Node_Id;
3263 begin
3264 Alt := First (Alternatives (N));
3265 while Present (Alt) loop
3266 Kill_Dead_Code (Statements (Alt));
3267 Next (Alt);
3268 end loop;
3269 end;
3270
3271 elsif Nkind (N) = N_Case_Statement_Alternative then
3272 Kill_Dead_Code (Statements (N));
3273
3274 -- Deal with dead instances caused by deleting instantiations
3275
3276 elsif Nkind (N) in N_Generic_Instantiation then
3277 Remove_Dead_Instance (N);
3278 end if;
3279
3280 Delete_Tree (N);
3281 end if;
3282 end Kill_Dead_Code;
3283
3284 -- Case where argument is a list of nodes to be killed
3285
3286 procedure Kill_Dead_Code (L : List_Id) is
3287 N : Node_Id;
3288
3289 begin
3290 if Is_Non_Empty_List (L) then
3291 loop
3292 N := Remove_Head (L);
3293 exit when No (N);
3294 Kill_Dead_Code (N);
3295 end loop;
3296 end if;
3297 end Kill_Dead_Code;
3298
3299 ------------------------
3300 -- Known_Non_Negative --
3301 ------------------------
3302
3303 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
3304 begin
3305 if Is_OK_Static_Expression (Opnd)
3306 and then Expr_Value (Opnd) >= 0
3307 then
3308 return True;
3309
3310 else
3311 declare
3312 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
3313
3314 begin
3315 return
3316 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
3317 end;
3318 end if;
3319 end Known_Non_Negative;
3320
3321 --------------------
3322 -- Known_Non_Null --
3323 --------------------
3324
3325 function Known_Non_Null (N : Node_Id) return Boolean is
3326 begin
3327 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))));
3328
3329 -- Case of entity for which Is_Known_Non_Null is True
3330
3331 if Is_Entity_Name (N) and then Is_Known_Non_Null (Entity (N)) then
3332
3333 -- If the entity is aliased or volatile, then we decide that
3334 -- we don't know it is really non-null even if the sequential
3335 -- flow indicates that it is, since such variables can be
3336 -- changed without us noticing.
3337
3338 if Is_Aliased (Entity (N))
3339 or else Treat_As_Volatile (Entity (N))
3340 then
3341 return False;
3342
3343 -- For all other cases, the flag is decisive
3344
3345 else
3346 return True;
3347 end if;
3348
3349 -- True if access attribute
3350
3351 elsif Nkind (N) = N_Attribute_Reference
3352 and then (Attribute_Name (N) = Name_Access
3353 or else
3354 Attribute_Name (N) = Name_Unchecked_Access
3355 or else
3356 Attribute_Name (N) = Name_Unrestricted_Access)
3357 then
3358 return True;
3359
3360 -- True if allocator
3361
3362 elsif Nkind (N) = N_Allocator then
3363 return True;
3364
3365 -- For a conversion, true if expression is known non-null
3366
3367 elsif Nkind (N) = N_Type_Conversion then
3368 return Known_Non_Null (Expression (N));
3369
3370 -- One more case is when Current_Value references a condition
3371 -- that ensures a non-null value.
3372
3373 elsif Is_Entity_Name (N) then
3374 declare
3375 Op : Node_Kind;
3376 Val : Node_Id;
3377
3378 begin
3379 Get_Current_Value_Condition (N, Op, Val);
3380 return Op = N_Op_Ne and then Nkind (Val) = N_Null;
3381 end;
3382
3383 -- Above are all cases where the value could be determined to be
3384 -- non-null. In all other cases, we don't know, so return False.
3385
3386 else
3387 return False;
3388 end if;
3389 end Known_Non_Null;
3390
3391 -----------------------------
3392 -- Make_CW_Equivalent_Type --
3393 -----------------------------
3394
3395 -- Create a record type used as an equivalent of any member
3396 -- of the class which takes its size from exp.
3397
3398 -- Generate the following code:
3399
3400 -- type Equiv_T is record
3401 -- _parent : T (List of discriminant constaints taken from Exp);
3402 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3403 -- end Equiv_T;
3404 --
3405 -- ??? Note that this type does not guarantee same alignment as all
3406 -- derived types
3407
3408 function Make_CW_Equivalent_Type
3409 (T : Entity_Id;
3410 E : Node_Id) return Entity_Id
3411 is
3412 Loc : constant Source_Ptr := Sloc (E);
3413 Root_Typ : constant Entity_Id := Root_Type (T);
3414 List_Def : constant List_Id := Empty_List;
3415 Equiv_Type : Entity_Id;
3416 Range_Type : Entity_Id;
3417 Str_Type : Entity_Id;
3418 Constr_Root : Entity_Id;
3419 Sizexpr : Node_Id;
3420
3421 begin
3422 if not Has_Discriminants (Root_Typ) then
3423 Constr_Root := Root_Typ;
3424 else
3425 Constr_Root :=
3426 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3427
3428 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3429
3430 Append_To (List_Def,
3431 Make_Subtype_Declaration (Loc,
3432 Defining_Identifier => Constr_Root,
3433 Subtype_Indication =>
3434 Make_Subtype_From_Expr (E, Root_Typ)));
3435 end if;
3436
3437 -- subtype rg__xx is Storage_Offset range
3438 -- (Expr'size - typ'size) / Storage_Unit
3439
3440 Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
3441
3442 Sizexpr :=
3443 Make_Op_Subtract (Loc,
3444 Left_Opnd =>
3445 Make_Attribute_Reference (Loc,
3446 Prefix =>
3447 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3448 Attribute_Name => Name_Size),
3449 Right_Opnd =>
3450 Make_Attribute_Reference (Loc,
3451 Prefix => New_Reference_To (Constr_Root, Loc),
3452 Attribute_Name => Name_Object_Size));
3453
3454 Set_Paren_Count (Sizexpr, 1);
3455
3456 Append_To (List_Def,
3457 Make_Subtype_Declaration (Loc,
3458 Defining_Identifier => Range_Type,
3459 Subtype_Indication =>
3460 Make_Subtype_Indication (Loc,
3461 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
3462 Constraint => Make_Range_Constraint (Loc,
3463 Range_Expression =>
3464 Make_Range (Loc,
3465 Low_Bound => Make_Integer_Literal (Loc, 1),
3466 High_Bound =>
3467 Make_Op_Divide (Loc,
3468 Left_Opnd => Sizexpr,
3469 Right_Opnd => Make_Integer_Literal (Loc,
3470 Intval => System_Storage_Unit)))))));
3471
3472 -- subtype str__nn is Storage_Array (rg__x);
3473
3474 Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3475 Append_To (List_Def,
3476 Make_Subtype_Declaration (Loc,
3477 Defining_Identifier => Str_Type,
3478 Subtype_Indication =>
3479 Make_Subtype_Indication (Loc,
3480 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3481 Constraint =>
3482 Make_Index_Or_Discriminant_Constraint (Loc,
3483 Constraints =>
3484 New_List (New_Reference_To (Range_Type, Loc))))));
3485
3486 -- type Equiv_T is record
3487 -- _parent : Tnn;
3488 -- E : Str_Type;
3489 -- end Equiv_T;
3490
3491 Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3492
3493 -- When the target requires front-end layout, it's necessary to allow
3494 -- the equivalent type to be frozen so that layout can occur (when the
3495 -- associated class-wide subtype is frozen, the equivalent type will
3496 -- be frozen, see freeze.adb). For other targets, Gigi wants to have
3497 -- the equivalent type marked as frozen and deals with this type itself.
3498 -- In the Gigi case this will also avoid the generation of an init
3499 -- procedure for the type.
3500
3501 if not Frontend_Layout_On_Target then
3502 Set_Is_Frozen (Equiv_Type);
3503 end if;
3504
3505 Set_Ekind (Equiv_Type, E_Record_Type);
3506 Set_Parent_Subtype (Equiv_Type, Constr_Root);
3507
3508 Append_To (List_Def,
3509 Make_Full_Type_Declaration (Loc,
3510 Defining_Identifier => Equiv_Type,
3511
3512 Type_Definition =>
3513 Make_Record_Definition (Loc,
3514 Component_List => Make_Component_List (Loc,
3515 Component_Items => New_List (
3516 Make_Component_Declaration (Loc,
3517 Defining_Identifier =>
3518 Make_Defining_Identifier (Loc, Name_uParent),
3519 Component_Definition =>
3520 Make_Component_Definition (Loc,
3521 Aliased_Present => False,
3522 Subtype_Indication =>
3523 New_Reference_To (Constr_Root, Loc))),
3524
3525 Make_Component_Declaration (Loc,
3526 Defining_Identifier =>
3527 Make_Defining_Identifier (Loc,
3528 Chars => New_Internal_Name ('C')),
3529 Component_Definition =>
3530 Make_Component_Definition (Loc,
3531 Aliased_Present => False,
3532 Subtype_Indication =>
3533 New_Reference_To (Str_Type, Loc)))),
3534
3535 Variant_Part => Empty))));
3536
3537 Insert_Actions (E, List_Def);
3538 return Equiv_Type;
3539 end Make_CW_Equivalent_Type;
3540
3541 ------------------------
3542 -- Make_Literal_Range --
3543 ------------------------
3544
3545 function Make_Literal_Range
3546 (Loc : Source_Ptr;
3547 Literal_Typ : Entity_Id) return Node_Id
3548 is
3549 Lo : constant Node_Id :=
3550 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
3551
3552 begin
3553 Set_Analyzed (Lo, False);
3554
3555 return
3556 Make_Range (Loc,
3557 Low_Bound => Lo,
3558
3559 High_Bound =>
3560 Make_Op_Subtract (Loc,
3561 Left_Opnd =>
3562 Make_Op_Add (Loc,
3563 Left_Opnd => New_Copy_Tree (Lo),
3564 Right_Opnd =>
3565 Make_Integer_Literal (Loc,
3566 String_Literal_Length (Literal_Typ))),
3567 Right_Opnd => Make_Integer_Literal (Loc, 1)));
3568 end Make_Literal_Range;
3569
3570 ----------------------------
3571 -- Make_Subtype_From_Expr --
3572 ----------------------------
3573
3574 -- 1. If Expr is an uncontrained array expression, creates
3575 -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
3576
3577 -- 2. If Expr is a unconstrained discriminated type expression, creates
3578 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3579
3580 -- 3. If Expr is class-wide, creates an implicit class wide subtype
3581
3582 function Make_Subtype_From_Expr
3583 (E : Node_Id;
3584 Unc_Typ : Entity_Id) return Node_Id
3585 is
3586 Loc : constant Source_Ptr := Sloc (E);
3587 List_Constr : constant List_Id := New_List;
3588 D : Entity_Id;
3589
3590 Full_Subtyp : Entity_Id;
3591 Priv_Subtyp : Entity_Id;
3592 Utyp : Entity_Id;
3593 Full_Exp : Node_Id;
3594
3595 begin
3596 if Is_Private_Type (Unc_Typ)
3597 and then Has_Unknown_Discriminants (Unc_Typ)
3598 then
3599 -- Prepare the subtype completion, Go to base type to
3600 -- find underlying type, because the type may be a generic
3601 -- actual or an explicit subtype.
3602
3603 Utyp := Underlying_Type (Base_Type (Unc_Typ));
3604 Full_Subtyp := Make_Defining_Identifier (Loc,
3605 New_Internal_Name ('C'));
3606 Full_Exp :=
3607 Unchecked_Convert_To
3608 (Utyp, Duplicate_Subexpr_No_Checks (E));
3609 Set_Parent (Full_Exp, Parent (E));
3610
3611 Priv_Subtyp :=
3612 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3613
3614 Insert_Action (E,
3615 Make_Subtype_Declaration (Loc,
3616 Defining_Identifier => Full_Subtyp,
3617 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
3618
3619 -- Define the dummy private subtype
3620
3621 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
3622 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
3623 Set_Scope (Priv_Subtyp, Full_Subtyp);
3624 Set_Is_Constrained (Priv_Subtyp);
3625 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
3626 Set_Is_Itype (Priv_Subtyp);
3627 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
3628
3629 if Is_Tagged_Type (Priv_Subtyp) then
3630 Set_Class_Wide_Type
3631 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
3632 Set_Primitive_Operations (Priv_Subtyp,
3633 Primitive_Operations (Unc_Typ));
3634 end if;
3635
3636 Set_Full_View (Priv_Subtyp, Full_Subtyp);
3637
3638 return New_Reference_To (Priv_Subtyp, Loc);
3639
3640 elsif Is_Array_Type (Unc_Typ) then
3641 for J in 1 .. Number_Dimensions (Unc_Typ) loop
3642 Append_To (List_Constr,
3643 Make_Range (Loc,
3644 Low_Bound =>
3645 Make_Attribute_Reference (Loc,
3646 Prefix => Duplicate_Subexpr_No_Checks (E),
3647 Attribute_Name => Name_First,
3648 Expressions => New_List (
3649 Make_Integer_Literal (Loc, J))),
3650
3651 High_Bound =>
3652 Make_Attribute_Reference (Loc,
3653 Prefix => Duplicate_Subexpr_No_Checks (E),
3654 Attribute_Name => Name_Last,
3655 Expressions => New_List (
3656 Make_Integer_Literal (Loc, J)))));
3657 end loop;
3658
3659 elsif Is_Class_Wide_Type (Unc_Typ) then
3660 declare
3661 CW_Subtype : Entity_Id;
3662 EQ_Typ : Entity_Id := Empty;
3663
3664 begin
3665 -- A class-wide equivalent type is not needed when Java_VM
3666 -- because the JVM back end handles the class-wide object
3667 -- initialization itself (and doesn't need or want the
3668 -- additional intermediate type to handle the assignment).
3669
3670 if Expander_Active and then not Java_VM then
3671 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
3672 end if;
3673
3674 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
3675 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
3676
3677 if Present (EQ_Typ) then
3678 Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
3679 end if;
3680
3681 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
3682
3683 return New_Occurrence_Of (CW_Subtype, Loc);
3684 end;
3685
3686 -- Indefinite record type with discriminants
3687
3688 else
3689 D := First_Discriminant (Unc_Typ);
3690 while Present (D) loop
3691 Append_To (List_Constr,
3692 Make_Selected_Component (Loc,
3693 Prefix => Duplicate_Subexpr_No_Checks (E),
3694 Selector_Name => New_Reference_To (D, Loc)));
3695
3696 Next_Discriminant (D);
3697 end loop;
3698 end if;
3699
3700 return
3701 Make_Subtype_Indication (Loc,
3702 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
3703 Constraint =>
3704 Make_Index_Or_Discriminant_Constraint (Loc,
3705 Constraints => List_Constr));
3706 end Make_Subtype_From_Expr;
3707
3708 -----------------------------
3709 -- May_Generate_Large_Temp --
3710 -----------------------------
3711
3712 -- At the current time, the only types that we return False for (i.e.
3713 -- where we decide we know they cannot generate large temps) are ones
3714 -- where we know the size is 256 bits or less at compile time, and we
3715 -- are still not doing a thorough job on arrays and records ???
3716
3717 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
3718 begin
3719 if not Size_Known_At_Compile_Time (Typ) then
3720 return False;
3721
3722 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
3723 return False;
3724
3725 elsif Is_Array_Type (Typ)
3726 and then Present (Packed_Array_Type (Typ))
3727 then
3728 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
3729
3730 -- We could do more here to find other small types ???
3731
3732 else
3733 return True;
3734 end if;
3735 end May_Generate_Large_Temp;
3736
3737 ----------------------------
3738 -- New_Class_Wide_Subtype --
3739 ----------------------------
3740
3741 function New_Class_Wide_Subtype
3742 (CW_Typ : Entity_Id;
3743 N : Node_Id) return Entity_Id
3744 is
3745 Res : constant Entity_Id := Create_Itype (E_Void, N);
3746 Res_Name : constant Name_Id := Chars (Res);
3747 Res_Scope : constant Entity_Id := Scope (Res);
3748
3749 begin
3750 Copy_Node (CW_Typ, Res);
3751 Set_Sloc (Res, Sloc (N));
3752 Set_Is_Itype (Res);
3753 Set_Associated_Node_For_Itype (Res, N);
3754 Set_Is_Public (Res, False); -- By default, may be changed below.
3755 Set_Public_Status (Res);
3756 Set_Chars (Res, Res_Name);
3757 Set_Scope (Res, Res_Scope);
3758 Set_Ekind (Res, E_Class_Wide_Subtype);
3759 Set_Next_Entity (Res, Empty);
3760 Set_Etype (Res, Base_Type (CW_Typ));
3761
3762 -- For targets where front-end layout is required, reset the Is_Frozen
3763 -- status of the subtype to False (it can be implicitly set to true
3764 -- from the copy of the class-wide type). For other targets, Gigi
3765 -- doesn't want the class-wide subtype to go through the freezing
3766 -- process (though it's unclear why that causes problems and it would
3767 -- be nice to allow freezing to occur normally for all targets ???).
3768
3769 if Frontend_Layout_On_Target then
3770 Set_Is_Frozen (Res, False);
3771 end if;
3772
3773 Set_Freeze_Node (Res, Empty);
3774 return (Res);
3775 end New_Class_Wide_Subtype;
3776
3777 -------------------------
3778 -- Remove_Side_Effects --
3779 -------------------------
3780
3781 procedure Remove_Side_Effects
3782 (Exp : Node_Id;
3783 Name_Req : Boolean := False;
3784 Variable_Ref : Boolean := False)
3785 is
3786 Loc : constant Source_Ptr := Sloc (Exp);
3787 Exp_Type : constant Entity_Id := Etype (Exp);
3788 Svg_Suppress : constant Suppress_Array := Scope_Suppress;
3789 Def_Id : Entity_Id;
3790 Ref_Type : Entity_Id;
3791 Res : Node_Id;
3792 Ptr_Typ_Decl : Node_Id;
3793 New_Exp : Node_Id;
3794 E : Node_Id;
3795
3796 function Side_Effect_Free (N : Node_Id) return Boolean;
3797 -- Determines if the tree N represents an expression that is known
3798 -- not to have side effects, and for which no processing is required.
3799
3800 function Side_Effect_Free (L : List_Id) return Boolean;
3801 -- Determines if all elements of the list L are side effect free
3802
3803 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
3804 -- The argument N is a construct where the Prefix is dereferenced
3805 -- if it is a an access type and the result is a variable. The call
3806 -- returns True if the construct is side effect free (not considering
3807 -- side effects in other than the prefix which are to be tested by the
3808 -- caller).
3809
3810 function Within_In_Parameter (N : Node_Id) return Boolean;
3811 -- Determines if N is a subcomponent of a composite in-parameter.
3812 -- If so, N is not side-effect free when the actual is global and
3813 -- modifiable indirectly from within a subprogram, because it may
3814 -- be passed by reference. The front-end must be conservative here
3815 -- and assume that this may happen with any array or record type.
3816 -- On the other hand, we cannot create temporaries for all expressions
3817 -- for which this condition is true, for various reasons that might
3818 -- require clearing up ??? For example, descriminant references that
3819 -- appear out of place, or spurious type errors with class-wide
3820 -- expressions. As a result, we limit the transformation to loop
3821 -- bounds, which is so far the only case that requires it.
3822
3823 -----------------------------
3824 -- Safe_Prefixed_Reference --
3825 -----------------------------
3826
3827 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
3828 begin
3829 -- If prefix is not side effect free, definitely not safe
3830
3831 if not Side_Effect_Free (Prefix (N)) then
3832 return False;
3833
3834 -- If the prefix is of an access type that is not access-to-constant,
3835 -- then this construct is a variable reference, which means it is to
3836 -- be considered to have side effects if Variable_Ref is set True
3837 -- Exception is an access to an entity that is a constant or an
3838 -- in-parameter which does not come from source, and is the result
3839 -- of a previous removal of side-effects.
3840
3841 elsif Is_Access_Type (Etype (Prefix (N)))
3842 and then not Is_Access_Constant (Etype (Prefix (N)))
3843 and then Variable_Ref
3844 then
3845 if not Is_Entity_Name (Prefix (N)) then
3846 return False;
3847 else
3848 return Ekind (Entity (Prefix (N))) = E_Constant
3849 or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
3850 end if;
3851
3852 -- The following test is the simplest way of solving a complex
3853 -- problem uncovered by BB08-010: Side effect on loop bound that
3854 -- is a subcomponent of a global variable:
3855 -- If a loop bound is a subcomponent of a global variable, a
3856 -- modification of that variable within the loop may incorrectly
3857 -- affect the execution of the loop.
3858
3859 elsif not
3860 (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
3861 or else not Within_In_Parameter (Prefix (N)))
3862 then
3863 return False;
3864
3865 -- All other cases are side effect free
3866
3867 else
3868 return True;
3869 end if;
3870 end Safe_Prefixed_Reference;
3871
3872 ----------------------
3873 -- Side_Effect_Free --
3874 ----------------------
3875
3876 function Side_Effect_Free (N : Node_Id) return Boolean is
3877 begin
3878 -- Note on checks that could raise Constraint_Error. Strictly, if
3879 -- we take advantage of 11.6, these checks do not count as side
3880 -- effects. However, we would just as soon consider that they are
3881 -- side effects, since the backend CSE does not work very well on
3882 -- expressions which can raise Constraint_Error. On the other
3883 -- hand, if we do not consider them to be side effect free, then
3884 -- we get some awkward expansions in -gnato mode, resulting in
3885 -- code insertions at a point where we do not have a clear model
3886 -- for performing the insertions. See 4908-002/comment for details.
3887
3888 -- Special handling for entity names
3889
3890 if Is_Entity_Name (N) then
3891
3892 -- If the entity is a constant, it is definitely side effect
3893 -- free. Note that the test of Is_Variable (N) below might
3894 -- be expected to catch this case, but it does not, because
3895 -- this test goes to the original tree, and we may have
3896 -- already rewritten a variable node with a constant as
3897 -- a result of an earlier Force_Evaluation call.
3898
3899 if Ekind (Entity (N)) = E_Constant
3900 or else Ekind (Entity (N)) = E_In_Parameter
3901 then
3902 return True;
3903
3904 -- Functions are not side effect free
3905
3906 elsif Ekind (Entity (N)) = E_Function then
3907 return False;
3908
3909 -- Variables are considered to be a side effect if Variable_Ref
3910 -- is set or if we have a volatile variable and Name_Req is off.
3911 -- If Name_Req is True then we can't help returning a name which
3912 -- effectively allows multiple references in any case.
3913
3914 elsif Is_Variable (N) then
3915 return not Variable_Ref
3916 and then (not Treat_As_Volatile (Entity (N))
3917 or else Name_Req);
3918
3919 -- Any other entity (e.g. a subtype name) is definitely side
3920 -- effect free.
3921
3922 else
3923 return True;
3924 end if;
3925
3926 -- A value known at compile time is always side effect free
3927
3928 elsif Compile_Time_Known_Value (N) then
3929 return True;
3930 end if;
3931
3932 -- For other than entity names and compile time known values,
3933 -- check the node kind for special processing.
3934
3935 case Nkind (N) is
3936
3937 -- An attribute reference is side effect free if its expressions
3938 -- are side effect free and its prefix is side effect free or
3939 -- is an entity reference.
3940
3941 -- Is this right? what about x'first where x is a variable???
3942
3943 when N_Attribute_Reference =>
3944 return Side_Effect_Free (Expressions (N))
3945 and then (Is_Entity_Name (Prefix (N))
3946 or else Side_Effect_Free (Prefix (N)));
3947
3948 -- A binary operator is side effect free if and both operands
3949 -- are side effect free. For this purpose binary operators
3950 -- include membership tests and short circuit forms
3951
3952 when N_Binary_Op |
3953 N_In |
3954 N_Not_In |
3955 N_And_Then |
3956 N_Or_Else =>
3957 return Side_Effect_Free (Left_Opnd (N))
3958 and then Side_Effect_Free (Right_Opnd (N));
3959
3960 -- An explicit dereference is side effect free only if it is
3961 -- a side effect free prefixed reference.
3962
3963 when N_Explicit_Dereference =>
3964 return Safe_Prefixed_Reference (N);
3965
3966 -- A call to _rep_to_pos is side effect free, since we generate
3967 -- this pure function call ourselves. Moreover it is critically
3968 -- important to make this exception, since otherwise we can
3969 -- have discriminants in array components which don't look
3970 -- side effect free in the case of an array whose index type
3971 -- is an enumeration type with an enumeration rep clause.
3972
3973 -- All other function calls are not side effect free
3974
3975 when N_Function_Call =>
3976 return Nkind (Name (N)) = N_Identifier
3977 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
3978 and then
3979 Side_Effect_Free (First (Parameter_Associations (N)));
3980
3981 -- An indexed component is side effect free if it is a side
3982 -- effect free prefixed reference and all the indexing
3983 -- expressions are side effect free.
3984
3985 when N_Indexed_Component =>
3986 return Side_Effect_Free (Expressions (N))
3987 and then Safe_Prefixed_Reference (N);
3988
3989 -- A type qualification is side effect free if the expression
3990 -- is side effect free.
3991
3992 when N_Qualified_Expression =>
3993 return Side_Effect_Free (Expression (N));
3994
3995 -- A selected component is side effect free only if it is a
3996 -- side effect free prefixed reference.
3997
3998 when N_Selected_Component =>
3999 return Safe_Prefixed_Reference (N);
4000
4001 -- A range is side effect free if the bounds are side effect free
4002
4003 when N_Range =>
4004 return Side_Effect_Free (Low_Bound (N))
4005 and then Side_Effect_Free (High_Bound (N));
4006
4007 -- A slice is side effect free if it is a side effect free
4008 -- prefixed reference and the bounds are side effect free.
4009
4010 when N_Slice =>
4011 return Side_Effect_Free (Discrete_Range (N))
4012 and then Safe_Prefixed_Reference (N);
4013
4014 -- A type conversion is side effect free if the expression
4015 -- to be converted is side effect free.
4016
4017 when N_Type_Conversion =>
4018 return Side_Effect_Free (Expression (N));
4019
4020 -- A unary operator is side effect free if the operand
4021 -- is side effect free.
4022
4023 when N_Unary_Op =>
4024 return Side_Effect_Free (Right_Opnd (N));
4025
4026 -- An unchecked type conversion is side effect free only if it
4027 -- is safe and its argument is side effect free.
4028
4029 when N_Unchecked_Type_Conversion =>
4030 return Safe_Unchecked_Type_Conversion (N)
4031 and then Side_Effect_Free (Expression (N));
4032
4033 -- An unchecked expression is side effect free if its expression
4034 -- is side effect free.
4035
4036 when N_Unchecked_Expression =>
4037 return Side_Effect_Free (Expression (N));
4038
4039 -- A literal is side effect free
4040
4041 when N_Character_Literal |
4042 N_Integer_Literal |
4043 N_Real_Literal |
4044 N_String_Literal =>
4045 return True;
4046
4047 -- We consider that anything else has side effects. This is a bit
4048 -- crude, but we are pretty close for most common cases, and we
4049 -- are certainly correct (i.e. we never return True when the
4050 -- answer should be False).
4051
4052 when others =>
4053 return False;
4054 end case;
4055 end Side_Effect_Free;
4056
4057 -- A list is side effect free if all elements of the list are
4058 -- side effect free.
4059
4060 function Side_Effect_Free (L : List_Id) return Boolean is
4061 N : Node_Id;
4062
4063 begin
4064 if L = No_List or else L = Error_List then
4065 return True;
4066
4067 else
4068 N := First (L);
4069 while Present (N) loop
4070 if not Side_Effect_Free (N) then
4071 return False;
4072 else
4073 Next (N);
4074 end if;
4075 end loop;
4076
4077 return True;
4078 end if;
4079 end Side_Effect_Free;
4080
4081 -------------------------
4082 -- Within_In_Parameter --
4083 -------------------------
4084
4085 function Within_In_Parameter (N : Node_Id) return Boolean is
4086 begin
4087 if not Comes_From_Source (N) then
4088 return False;
4089
4090 elsif Is_Entity_Name (N) then
4091 return
4092 Ekind (Entity (N)) = E_In_Parameter;
4093
4094 elsif Nkind (N) = N_Indexed_Component
4095 or else Nkind (N) = N_Selected_Component
4096 then
4097 return Within_In_Parameter (Prefix (N));
4098 else
4099
4100 return False;
4101 end if;
4102 end Within_In_Parameter;
4103
4104 -- Start of processing for Remove_Side_Effects
4105
4106 begin
4107 -- If we are side effect free already or expansion is disabled,
4108 -- there is nothing to do.
4109
4110 if Side_Effect_Free (Exp) or else not Expander_Active then
4111 return;
4112 end if;
4113
4114 -- All this must not have any checks
4115
4116 Scope_Suppress := (others => True);
4117
4118 -- If it is a scalar type and we need to capture the value, just
4119 -- make a copy. Likewise for a function call. And if we have a
4120 -- volatile variable and Nam_Req is not set (see comments above
4121 -- for Side_Effect_Free).
4122
4123 if Is_Elementary_Type (Exp_Type)
4124 and then (Variable_Ref
4125 or else Nkind (Exp) = N_Function_Call
4126 or else (not Name_Req
4127 and then Is_Entity_Name (Exp)
4128 and then Treat_As_Volatile (Entity (Exp))))
4129 then
4130
4131 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4132 Set_Etype (Def_Id, Exp_Type);
4133 Res := New_Reference_To (Def_Id, Loc);
4134
4135 E :=
4136 Make_Object_Declaration (Loc,
4137 Defining_Identifier => Def_Id,
4138 Object_Definition => New_Reference_To (Exp_Type, Loc),
4139 Constant_Present => True,
4140 Expression => Relocate_Node (Exp));
4141
4142 Set_Assignment_OK (E);
4143 Insert_Action (Exp, E);
4144
4145 -- If the expression has the form v.all then we can just capture
4146 -- the pointer, and then do an explicit dereference on the result.
4147
4148 elsif Nkind (Exp) = N_Explicit_Dereference then
4149 Def_Id :=
4150 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4151 Res :=
4152 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
4153
4154 Insert_Action (Exp,
4155 Make_Object_Declaration (Loc,
4156 Defining_Identifier => Def_Id,
4157 Object_Definition =>
4158 New_Reference_To (Etype (Prefix (Exp)), Loc),
4159 Constant_Present => True,
4160 Expression => Relocate_Node (Prefix (Exp))));
4161
4162 -- Similar processing for an unchecked conversion of an expression
4163 -- of the form v.all, where we want the same kind of treatment.
4164
4165 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4166 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
4167 then
4168 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
4169 Scope_Suppress := Svg_Suppress;
4170 return;
4171
4172 -- If this is a type conversion, leave the type conversion and remove
4173 -- the side effects in the expression. This is important in several
4174 -- circumstances: for change of representations, and also when this
4175 -- is a view conversion to a smaller object, where gigi can end up
4176 -- creating its own temporary of the wrong size.
4177
4178 -- ??? this transformation is inhibited for elementary types that are
4179 -- not involved in a change of representation because it causes
4180 -- regressions that are not fully understood yet.
4181
4182 elsif Nkind (Exp) = N_Type_Conversion
4183 and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
4184 or else Nkind (Parent (Exp)) = N_Assignment_Statement)
4185 then
4186 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
4187 Scope_Suppress := Svg_Suppress;
4188 return;
4189
4190 -- If this is an unchecked conversion that Gigi can't handle, make
4191 -- a copy or a use a renaming to capture the value.
4192
4193 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4194 and then not Safe_Unchecked_Type_Conversion (Exp)
4195 then
4196 if Controlled_Type (Etype (Exp)) then
4197
4198 -- Use a renaming to capture the expression, rather than create
4199 -- a controlled temporary.
4200
4201 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4202 Res := New_Reference_To (Def_Id, Loc);
4203
4204 Insert_Action (Exp,
4205 Make_Object_Renaming_Declaration (Loc,
4206 Defining_Identifier => Def_Id,
4207 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
4208 Name => Relocate_Node (Exp)));
4209
4210 else
4211 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4212 Set_Etype (Def_Id, Exp_Type);
4213 Res := New_Reference_To (Def_Id, Loc);
4214
4215 E :=
4216 Make_Object_Declaration (Loc,
4217 Defining_Identifier => Def_Id,
4218 Object_Definition => New_Reference_To (Exp_Type, Loc),
4219 Constant_Present => not Is_Variable (Exp),
4220 Expression => Relocate_Node (Exp));
4221
4222 Set_Assignment_OK (E);
4223 Insert_Action (Exp, E);
4224 end if;
4225
4226 -- For expressions that denote objects, we can use a renaming scheme.
4227 -- We skip using this if we have a volatile variable and we do not
4228 -- have Nam_Req set true (see comments above for Side_Effect_Free).
4229
4230 elsif Is_Object_Reference (Exp)
4231 and then Nkind (Exp) /= N_Function_Call
4232 and then (Name_Req
4233 or else not Is_Entity_Name (Exp)
4234 or else not Treat_As_Volatile (Entity (Exp)))
4235 then
4236 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4237
4238 if Nkind (Exp) = N_Selected_Component
4239 and then Nkind (Prefix (Exp)) = N_Function_Call
4240 and then Is_Array_Type (Etype (Exp))
4241 then
4242 -- Avoid generating a variable-sized temporary, by generating
4243 -- the renaming declaration just for the function call. The
4244 -- transformation could be refined to apply only when the array
4245 -- component is constrained by a discriminant???
4246
4247 Res :=
4248 Make_Selected_Component (Loc,
4249 Prefix => New_Occurrence_Of (Def_Id, Loc),
4250 Selector_Name => Selector_Name (Exp));
4251
4252 Insert_Action (Exp,
4253 Make_Object_Renaming_Declaration (Loc,
4254 Defining_Identifier => Def_Id,
4255 Subtype_Mark =>
4256 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
4257 Name => Relocate_Node (Prefix (Exp))));
4258
4259 else
4260 Res := New_Reference_To (Def_Id, Loc);
4261
4262 Insert_Action (Exp,
4263 Make_Object_Renaming_Declaration (Loc,
4264 Defining_Identifier => Def_Id,
4265 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
4266 Name => Relocate_Node (Exp)));
4267
4268 end if;
4269
4270 -- The temporary must be elaborated by gigi, and is of course
4271 -- not to be replaced in-line by the expression it renames,
4272 -- which would defeat the purpose of removing the side-effect.
4273
4274 Set_Is_Renaming_Of_Object (Def_Id, False);
4275
4276 -- Otherwise we generate a reference to the value
4277
4278 else
4279 Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4280
4281 Ptr_Typ_Decl :=
4282 Make_Full_Type_Declaration (Loc,
4283 Defining_Identifier => Ref_Type,
4284 Type_Definition =>
4285 Make_Access_To_Object_Definition (Loc,
4286 All_Present => True,
4287 Subtype_Indication =>
4288 New_Reference_To (Exp_Type, Loc)));
4289
4290 E := Exp;
4291 Insert_Action (Exp, Ptr_Typ_Decl);
4292
4293 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4294 Set_Etype (Def_Id, Exp_Type);
4295
4296 Res :=
4297 Make_Explicit_Dereference (Loc,
4298 Prefix => New_Reference_To (Def_Id, Loc));
4299
4300 if Nkind (E) = N_Explicit_Dereference then
4301 New_Exp := Relocate_Node (Prefix (E));
4302 else
4303 E := Relocate_Node (E);
4304 New_Exp := Make_Reference (Loc, E);
4305 end if;
4306
4307 if Is_Delayed_Aggregate (E) then
4308
4309 -- The expansion of nested aggregates is delayed until the
4310 -- enclosing aggregate is expanded. As aggregates are often
4311 -- qualified, the predicate applies to qualified expressions
4312 -- as well, indicating that the enclosing aggregate has not
4313 -- been expanded yet. At this point the aggregate is part of
4314 -- a stand-alone declaration, and must be fully expanded.
4315
4316 if Nkind (E) = N_Qualified_Expression then
4317 Set_Expansion_Delayed (Expression (E), False);
4318 Set_Analyzed (Expression (E), False);
4319 else
4320 Set_Expansion_Delayed (E, False);
4321 end if;
4322
4323 Set_Analyzed (E, False);
4324 end if;
4325
4326 Insert_Action (Exp,
4327 Make_Object_Declaration (Loc,
4328 Defining_Identifier => Def_Id,
4329 Object_Definition => New_Reference_To (Ref_Type, Loc),
4330 Expression => New_Exp));
4331 end if;
4332
4333 -- Preserve the Assignment_OK flag in all copies, since at least
4334 -- one copy may be used in a context where this flag must be set
4335 -- (otherwise why would the flag be set in the first place).
4336
4337 Set_Assignment_OK (Res, Assignment_OK (Exp));
4338
4339 -- Finally rewrite the original expression and we are done
4340
4341 Rewrite (Exp, Res);
4342 Analyze_And_Resolve (Exp, Exp_Type);
4343 Scope_Suppress := Svg_Suppress;
4344 end Remove_Side_Effects;
4345
4346 ---------------------------
4347 -- Represented_As_Scalar --
4348 ---------------------------
4349
4350 function Represented_As_Scalar (T : Entity_Id) return Boolean is
4351 UT : constant Entity_Id := Underlying_Type (T);
4352 begin
4353 return Is_Scalar_Type (UT)
4354 or else (Is_Bit_Packed_Array (UT)
4355 and then Is_Scalar_Type (Packed_Array_Type (UT)));
4356 end Represented_As_Scalar;
4357
4358 ------------------------------------
4359 -- Safe_Unchecked_Type_Conversion --
4360 ------------------------------------
4361
4362 -- Note: this function knows quite a bit about the exact requirements
4363 -- of Gigi with respect to unchecked type conversions, and its code
4364 -- must be coordinated with any changes in Gigi in this area.
4365
4366 -- The above requirements should be documented in Sinfo ???
4367
4368 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
4369 Otyp : Entity_Id;
4370 Ityp : Entity_Id;
4371 Oalign : Uint;
4372 Ialign : Uint;
4373 Pexp : constant Node_Id := Parent (Exp);
4374
4375 begin
4376 -- If the expression is the RHS of an assignment or object declaration
4377 -- we are always OK because there will always be a target.
4378
4379 -- Object renaming declarations, (generated for view conversions of
4380 -- actuals in inlined calls), like object declarations, provide an
4381 -- explicit type, and are safe as well.
4382
4383 if (Nkind (Pexp) = N_Assignment_Statement
4384 and then Expression (Pexp) = Exp)
4385 or else Nkind (Pexp) = N_Object_Declaration
4386 or else Nkind (Pexp) = N_Object_Renaming_Declaration
4387 then
4388 return True;
4389
4390 -- If the expression is the prefix of an N_Selected_Component
4391 -- we should also be OK because GCC knows to look inside the
4392 -- conversion except if the type is discriminated. We assume
4393 -- that we are OK anyway if the type is not set yet or if it is
4394 -- controlled since we can't afford to introduce a temporary in
4395 -- this case.
4396
4397 elsif Nkind (Pexp) = N_Selected_Component
4398 and then Prefix (Pexp) = Exp
4399 then
4400 if No (Etype (Pexp)) then
4401 return True;
4402 else
4403 return
4404 not Has_Discriminants (Etype (Pexp))
4405 or else Is_Constrained (Etype (Pexp));
4406 end if;
4407 end if;
4408
4409 -- Set the output type, this comes from Etype if it is set, otherwise
4410 -- we take it from the subtype mark, which we assume was already
4411 -- fully analyzed.
4412
4413 if Present (Etype (Exp)) then
4414 Otyp := Etype (Exp);
4415 else
4416 Otyp := Entity (Subtype_Mark (Exp));
4417 end if;
4418
4419 -- The input type always comes from the expression, and we assume
4420 -- this is indeed always analyzed, so we can simply get the Etype.
4421
4422 Ityp := Etype (Expression (Exp));
4423
4424 -- Initialize alignments to unknown so far
4425
4426 Oalign := No_Uint;
4427 Ialign := No_Uint;
4428
4429 -- Replace a concurrent type by its corresponding record type
4430 -- and each type by its underlying type and do the tests on those.
4431 -- The original type may be a private type whose completion is a
4432 -- concurrent type, so find the underlying type first.
4433
4434 if Present (Underlying_Type (Otyp)) then
4435 Otyp := Underlying_Type (Otyp);
4436 end if;
4437
4438 if Present (Underlying_Type (Ityp)) then
4439 Ityp := Underlying_Type (Ityp);
4440 end if;
4441
4442 if Is_Concurrent_Type (Otyp) then
4443 Otyp := Corresponding_Record_Type (Otyp);
4444 end if;
4445
4446 if Is_Concurrent_Type (Ityp) then
4447 Ityp := Corresponding_Record_Type (Ityp);
4448 end if;
4449
4450 -- If the base types are the same, we know there is no problem since
4451 -- this conversion will be a noop.
4452
4453 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
4454 return True;
4455
4456 -- Same if this is an upwards conversion of an untagged type, and there
4457 -- are no constraints involved (could be more general???)
4458
4459 elsif Etype (Ityp) = Otyp
4460 and then not Is_Tagged_Type (Ityp)
4461 and then not Has_Discriminants (Ityp)
4462 and then No (First_Rep_Item (Base_Type (Ityp)))
4463 then
4464 return True;
4465
4466 -- If the size of output type is known at compile time, there is
4467 -- never a problem. Note that unconstrained records are considered
4468 -- to be of known size, but we can't consider them that way here,
4469 -- because we are talking about the actual size of the object.
4470
4471 -- We also make sure that in addition to the size being known, we do
4472 -- not have a case which might generate an embarrassingly large temp
4473 -- in stack checking mode.
4474
4475 elsif Size_Known_At_Compile_Time (Otyp)
4476 and then
4477 (not Stack_Checking_Enabled
4478 or else not May_Generate_Large_Temp (Otyp))
4479 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
4480 then
4481 return True;
4482
4483 -- If either type is tagged, then we know the alignment is OK so
4484 -- Gigi will be able to use pointer punning.
4485
4486 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
4487 return True;
4488
4489 -- If either type is a limited record type, we cannot do a copy, so
4490 -- say safe since there's nothing else we can do.
4491
4492 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
4493 return True;
4494
4495 -- Conversions to and from packed array types are always ignored and
4496 -- hence are safe.
4497
4498 elsif Is_Packed_Array_Type (Otyp)
4499 or else Is_Packed_Array_Type (Ityp)
4500 then
4501 return True;
4502 end if;
4503
4504 -- The only other cases known to be safe is if the input type's
4505 -- alignment is known to be at least the maximum alignment for the
4506 -- target or if both alignments are known and the output type's
4507 -- alignment is no stricter than the input's. We can use the alignment
4508 -- of the component type of an array if a type is an unpacked
4509 -- array type.
4510
4511 if Present (Alignment_Clause (Otyp)) then
4512 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
4513
4514 elsif Is_Array_Type (Otyp)
4515 and then Present (Alignment_Clause (Component_Type (Otyp)))
4516 then
4517 Oalign := Expr_Value (Expression (Alignment_Clause
4518 (Component_Type (Otyp))));
4519 end if;
4520
4521 if Present (Alignment_Clause (Ityp)) then
4522 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
4523
4524 elsif Is_Array_Type (Ityp)
4525 and then Present (Alignment_Clause (Component_Type (Ityp)))
4526 then
4527 Ialign := Expr_Value (Expression (Alignment_Clause
4528 (Component_Type (Ityp))));
4529 end if;
4530
4531 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
4532 return True;
4533
4534 elsif Ialign /= No_Uint and then Oalign /= No_Uint
4535 and then Ialign <= Oalign
4536 then
4537 return True;
4538
4539 -- Otherwise, Gigi cannot handle this and we must make a temporary
4540
4541 else
4542 return False;
4543 end if;
4544
4545 end Safe_Unchecked_Type_Conversion;
4546
4547 --------------------------
4548 -- Set_Elaboration_Flag --
4549 --------------------------
4550
4551 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
4552 Loc : constant Source_Ptr := Sloc (N);
4553 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
4554 Asn : Node_Id;
4555
4556 begin
4557 if Present (Ent) then
4558
4559 -- Nothing to do if at the compilation unit level, because in this
4560 -- case the flag is set by the binder generated elaboration routine.
4561
4562 if Nkind (Parent (N)) = N_Compilation_Unit then
4563 null;
4564
4565 -- Here we do need to generate an assignment statement
4566
4567 else
4568 Check_Restriction (No_Elaboration_Code, N);
4569 Asn :=
4570 Make_Assignment_Statement (Loc,
4571 Name => New_Occurrence_Of (Ent, Loc),
4572 Expression => New_Occurrence_Of (Standard_True, Loc));
4573
4574 if Nkind (Parent (N)) = N_Subunit then
4575 Insert_After (Corresponding_Stub (Parent (N)), Asn);
4576 else
4577 Insert_After (N, Asn);
4578 end if;
4579
4580 Analyze (Asn);
4581
4582 -- Kill current value indication. This is necessary because
4583 -- the tests of this flag are inserted out of sequence and must
4584 -- not pick up bogus indications of the wrong constant value.
4585
4586 Set_Current_Value (Ent, Empty);
4587 end if;
4588 end if;
4589 end Set_Elaboration_Flag;
4590
4591 --------------------------
4592 -- Target_Has_Fixed_Ops --
4593 --------------------------
4594
4595 Integer_Sized_Small : Ureal;
4596 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
4597 -- function is called (we don't want to compute it more than once!)
4598
4599 Long_Integer_Sized_Small : Ureal;
4600 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
4601 -- functoin is called (we don't want to compute it more than once)
4602
4603 First_Time_For_THFO : Boolean := True;
4604 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
4605
4606 function Target_Has_Fixed_Ops
4607 (Left_Typ : Entity_Id;
4608 Right_Typ : Entity_Id;
4609 Result_Typ : Entity_Id) return Boolean
4610 is
4611 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
4612 -- Return True if the given type is a fixed-point type with a small
4613 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
4614 -- an absolute value less than 1.0. This is currently limited
4615 -- to fixed-point types that map to Integer or Long_Integer.
4616
4617 ------------------------
4618 -- Is_Fractional_Type --
4619 ------------------------
4620
4621 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
4622 begin
4623 if Esize (Typ) = Standard_Integer_Size then
4624 return Small_Value (Typ) = Integer_Sized_Small;
4625
4626 elsif Esize (Typ) = Standard_Long_Integer_Size then
4627 return Small_Value (Typ) = Long_Integer_Sized_Small;
4628
4629 else
4630 return False;
4631 end if;
4632 end Is_Fractional_Type;
4633
4634 -- Start of processing for Target_Has_Fixed_Ops
4635
4636 begin
4637 -- Return False if Fractional_Fixed_Ops_On_Target is false
4638
4639 if not Fractional_Fixed_Ops_On_Target then
4640 return False;
4641 end if;
4642
4643 -- Here the target has Fractional_Fixed_Ops, if first time, compute
4644 -- standard constants used by Is_Fractional_Type.
4645
4646 if First_Time_For_THFO then
4647 First_Time_For_THFO := False;
4648
4649 Integer_Sized_Small :=
4650 UR_From_Components
4651 (Num => Uint_1,
4652 Den => UI_From_Int (Standard_Integer_Size - 1),
4653 Rbase => 2);
4654
4655 Long_Integer_Sized_Small :=
4656 UR_From_Components
4657 (Num => Uint_1,
4658 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
4659 Rbase => 2);
4660 end if;
4661
4662 -- Return True if target supports fixed-by-fixed multiply/divide
4663 -- for fractional fixed-point types (see Is_Fractional_Type) and
4664 -- the operand and result types are equivalent fractional types.
4665
4666 return Is_Fractional_Type (Base_Type (Left_Typ))
4667 and then Is_Fractional_Type (Base_Type (Right_Typ))
4668 and then Is_Fractional_Type (Base_Type (Result_Typ))
4669 and then Esize (Left_Typ) = Esize (Right_Typ)
4670 and then Esize (Left_Typ) = Esize (Result_Typ);
4671 end Target_Has_Fixed_Ops;
4672
4673 ------------------------------------------
4674 -- Type_May_Have_Bit_Aligned_Components --
4675 ------------------------------------------
4676
4677 function Type_May_Have_Bit_Aligned_Components
4678 (Typ : Entity_Id) return Boolean
4679 is
4680 begin
4681 -- Array type, check component type
4682
4683 if Is_Array_Type (Typ) then
4684 return
4685 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
4686
4687 -- Record type, check components
4688
4689 elsif Is_Record_Type (Typ) then
4690 declare
4691 E : Entity_Id;
4692
4693 begin
4694 E := First_Entity (Typ);
4695 while Present (E) loop
4696 if Ekind (E) = E_Component
4697 or else Ekind (E) = E_Discriminant
4698 then
4699 if Component_May_Be_Bit_Aligned (E)
4700 or else
4701 Type_May_Have_Bit_Aligned_Components (Etype (E))
4702 then
4703 return True;
4704 end if;
4705 end if;
4706
4707 Next_Entity (E);
4708 end loop;
4709
4710 return False;
4711 end;
4712
4713 -- Type other than array or record is always OK
4714
4715 else
4716 return False;
4717 end if;
4718 end Type_May_Have_Bit_Aligned_Components;
4719
4720 ----------------------------
4721 -- Wrap_Cleanup_Procedure --
4722 ----------------------------
4723
4724 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
4725 Loc : constant Source_Ptr := Sloc (N);
4726 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
4727 Stmts : constant List_Id := Statements (Stseq);
4728
4729 begin
4730 if Abort_Allowed then
4731 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
4732 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4733 end if;
4734 end Wrap_Cleanup_Procedure;
4735
4736 end Exp_Util;
Mirror of the offical gcc git repository hosted at gcc.gnu.org