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