]> gcc.gnu.org Git - gcc.git/blame - gcc/ada/exp_util.adb
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[multiple changes]
[gcc.git] / gcc / ada / exp_util.adb
CommitLineData
70482933
RK		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ U T I L --
6-- --
7-- B o d y --
8-- --
3e2399ba 9-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
70482933
RK		 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- --
b5c84c3c 13-- ware Foundation; either version 3, or (at your option) any later ver- --
70482933
RK		 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 --
b5c84c3c
RD		 18-- Public License distributed with GNAT; see file COPYING3. If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license. --
70482933
RK		 20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 22-- Extensive contributions were provided by Ada Core Technologies Inc. --
70482933
RK		 23-- --
24------------------------------------------------------------------------------
25
26with Atree; use Atree;
27with Checks; use Checks;
59e54267 28with Debug; use Debug;
70482933
RK		 29with Einfo; use Einfo;
30with Elists; use Elists;
31with Errout; use Errout;
f44fe430 32with Exp_Aggr; use Exp_Aggr;
86cde7b1 33with Exp_Ch6; use Exp_Ch6;
70482933 34with Exp_Ch7; use Exp_Ch7;
70482933
RK		 35with Inline; use Inline;
36with Itypes; use Itypes;
37with Lib; use Lib;
70482933
RK		 38with Nlists; use Nlists;
39with Nmake; use Nmake;
40with Opt; use Opt;
41with Restrict; use Restrict;
6e937c1c 42with Rident; use Rident;
70482933 43with Sem; use Sem;
a4100e55 44with Sem_Aux; use Sem_Aux;
70482933
RK		 45with Sem_Ch8; use Sem_Ch8;
46with Sem_Eval; use Sem_Eval;
47with Sem_Res; use Sem_Res;
758c442c 48with Sem_Type; use Sem_Type;
70482933 49with Sem_Util; use Sem_Util;
fbf5a39b 50with Snames; use Snames;
70482933
RK		 51with Stand; use Stand;
52with Stringt; use Stringt;
07fc65c4 53with Targparm; use Targparm;
70482933
RK		 54with Tbuild; use Tbuild;
55with Ttypes; use Ttypes;
56with Uintp; use Uintp;
07fc65c4 57with Urealp; use Urealp;
70482933
RK		 58with Validsw; use Validsw;
59
60package 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;
7bc1c7df 69 A_Type : Entity_Id;
bebbff91 70 Dyn : Boolean := False) return Node_Id;
70482933
RK		 71 -- Build function to generate the image string for a task that is an
72 -- array component, concatenating the images of each index. To avoid
73 -- storage leaks, the string is built with successive slice assignments.
7bc1c7df
ES		 74 -- The flag Dyn indicates whether this is called for the initialization
75 -- procedure of an array of tasks, or for the name of a dynamically
76 -- created task that is assigned to an indexed component.
70482933
RK		 77
78 function Build_Task_Image_Function
79 (Loc : Source_Ptr;
80 Decls : List_Id;
81 Stats : List_Id;
bebbff91 82 Res : Entity_Id) return Node_Id;
70482933
RK		 83 -- Common processing for Task_Array_Image and Task_Record_Image.
84 -- Build function body that computes image.
85
86 procedure Build_Task_Image_Prefix
87 (Loc : Source_Ptr;
88 Len : out Entity_Id;
89 Res : out Entity_Id;
90 Pos : out Entity_Id;
91 Prefix : Entity_Id;
92 Sum : Node_Id;
86cde7b1
RD		 93 Decls : List_Id;
94 Stats : List_Id);
70482933
RK		 95 -- Common processing for Task_Array_Image and Task_Record_Image.
96 -- Create local variables and assign prefix of name to result string.
97
98 function Build_Task_Record_Image
99 (Loc : Source_Ptr;
100 Id_Ref : Node_Id;
bebbff91 101 Dyn : Boolean := False) return Node_Id;
70482933
RK		 102 -- Build function to generate the image string for a task that is a
103 -- record component. Concatenate name of variable with that of selector.
7bc1c7df
ES		 104 -- The flag Dyn indicates whether this is called for the initialization
105 -- procedure of record with task components, or for a dynamically
106 -- created task that is assigned to a selected component.
70482933
RK		 107
108 function Make_CW_Equivalent_Type
bebbff91
AC		 109 (T : Entity_Id;
110 E : Node_Id) return Entity_Id;
70482933
RK		 111 -- T is a class-wide type entity, E is the initial expression node that
112 -- constrains T in case such as: " X: T := E" or "new T'(E)"
113 -- This function returns the entity of the Equivalent type and inserts
114 -- on the fly the necessary declaration such as:
fbf5a39b 115 --
70482933
RK		 116 -- type anon is record
117 -- _parent : Root_Type (T); constrained with E discriminants (if any)
118 -- Extension : String (1 .. expr to match size of E);
119 -- end record;
120 --
121 -- This record is compatible with any object of the class of T thanks
122 -- to the first field and has the same size as E thanks to the second.
123
124 function Make_Literal_Range
125 (Loc : Source_Ptr;
bebbff91 126 Literal_Typ : Entity_Id) return Node_Id;
70482933 127 -- Produce a Range node whose bounds are:
f91b40db 128 -- Low_Bound (Literal_Type) ..
86cde7b1 129 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
70482933 130 -- this is used for expanding declarations like X : String := "sdfgdfg";
86cde7b1
RD		 131 --
132 -- If the index type of the target array is not integer, we generate:
133 -- Low_Bound (Literal_Type) ..
134 -- Literal_Type'Val
135 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
136 -- + (Length (Literal_Typ) -1))
70482933 137
b3b9865d
AC		 138 function Make_Non_Empty_Check
139 (Loc : Source_Ptr;
140 N : Node_Id) return Node_Id;
141 -- Produce a boolean expression checking that the unidimensional array
142 -- node N is not empty.
143
70482933
RK		 144 function New_Class_Wide_Subtype
145 (CW_Typ : Entity_Id;
bebbff91
AC		 146 N : Node_Id) return Entity_Id;
147 -- Create an implicit subtype of CW_Typ attached to node N
70482933
RK		 148
149 ----------------------
150 -- Adjust_Condition --
151 ----------------------
152
153 procedure Adjust_Condition (N : Node_Id) is
154 begin
155 if No (N) then
156 return;
157 end if;
158
159 declare
160 Loc : constant Source_Ptr := Sloc (N);
161 T : constant Entity_Id := Etype (N);
162 Ti : Entity_Id;
163
164 begin
165 -- For now, we simply ignore a call where the argument has no
166 -- type (probably case of unanalyzed condition), or has a type
167 -- that is not Boolean. This is because this is a pretty marginal
168 -- piece of functionality, and violations of these rules are
169 -- likely to be truly marginal (how much code uses Fortran Logical
170 -- as the barrier to a protected entry?) and we do not want to
171 -- blow up existing programs. We can change this to an assertion
172 -- after 3.12a is released ???
173
174 if No (T) or else not Is_Boolean_Type (T) then
175 return;
176 end if;
177
178 -- Apply validity checking if needed
179
180 if Validity_Checks_On and Validity_Check_Tests then
181 Ensure_Valid (N);
182 end if;
183
184 -- Immediate return if standard boolean, the most common case,
185 -- where nothing needs to be done.
186
187 if Base_Type (T) = Standard_Boolean then
188 return;
189 end if;
190
191 -- Case of zero/non-zero semantics or non-standard enumeration
192 -- representation. In each case, we rewrite the node as:
193
194 -- ityp!(N) /= False'Enum_Rep
195
196 -- where ityp is an integer type with large enough size to hold
197 -- any value of type T.
198
199 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
200 if Esize (T) <= Esize (Standard_Integer) then
201 Ti := Standard_Integer;
202 else
203 Ti := Standard_Long_Long_Integer;
204 end if;
205
206 Rewrite (N,
207 Make_Op_Ne (Loc,
208 Left_Opnd => Unchecked_Convert_To (Ti, N),
209 Right_Opnd =>
210 Make_Attribute_Reference (Loc,
211 Attribute_Name => Name_Enum_Rep,
212 Prefix =>
213 New_Occurrence_Of (First_Literal (T), Loc))));
214 Analyze_And_Resolve (N, Standard_Boolean);
215
216 else
217 Rewrite (N, Convert_To (Standard_Boolean, N));
218 Analyze_And_Resolve (N, Standard_Boolean);
219 end if;
220 end;
221 end Adjust_Condition;
222
223 ------------------------
224 -- Adjust_Result_Type --
225 ------------------------
226
227 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
228 begin
229 -- Ignore call if current type is not Standard.Boolean
230
231 if Etype (N) /= Standard_Boolean then
232 return;
233 end if;
234
235 -- If result is already of correct type, nothing to do. Note that
236 -- this will get the most common case where everything has a type
237 -- of Standard.Boolean.
238
239 if Base_Type (T) = Standard_Boolean then
240 return;
241
242 else
243 declare
244 KP : constant Node_Kind := Nkind (Parent (N));
245
246 begin
247 -- If result is to be used as a Condition in the syntax, no need
248 -- to convert it back, since if it was changed to Standard.Boolean
249 -- using Adjust_Condition, that is just fine for this usage.
250
251 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
252 return;
253
254 -- If result is an operand of another logical operation, no need
255 -- to reset its type, since Standard.Boolean is just fine, and
256 -- such operations always do Adjust_Condition on their operands.
257
ac7120ce
RD		 258 elsif KP in N_Op_Boolean
259 or else KP in N_Short_Circuit
70482933
RK		 260 or else KP = N_Op_Not
261 then
262 return;
263
264 -- Otherwise we perform a conversion from the current type,
265 -- which must be Standard.Boolean, to the desired type.
266
267 else
268 Set_Analyzed (N);
269 Rewrite (N, Convert_To (T, N));
270 Analyze_And_Resolve (N, T);
271 end if;
272 end;
273 end if;
274 end Adjust_Result_Type;
275
276 --------------------------
277 -- Append_Freeze_Action --
278 --------------------------
279
280 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
05350ac6 281 Fnode : Node_Id;
70482933
RK		 282
283 begin
284 Ensure_Freeze_Node (T);
285 Fnode := Freeze_Node (T);
286
59e54267 287 if No (Actions (Fnode)) then
70482933
RK		 288 Set_Actions (Fnode, New_List);
289 end if;
290
291 Append (N, Actions (Fnode));
292 end Append_Freeze_Action;
293
294 ---------------------------
295 -- Append_Freeze_Actions --
296 ---------------------------
297
298 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
299 Fnode : constant Node_Id := Freeze_Node (T);
300
301 begin
302 if No (L) then
303 return;
304
305 else
306 if No (Actions (Fnode)) then
307 Set_Actions (Fnode, L);
70482933
RK		 308 else
309 Append_List (L, Actions (Fnode));
310 end if;
70482933
RK		 311 end if;
312 end Append_Freeze_Actions;
313
314 ------------------------
315 -- Build_Runtime_Call --
316 ------------------------
317
318 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
319 begin
fbf5a39b
AC		 320 -- If entity is not available, we can skip making the call (this avoids
321 -- junk duplicated error messages in a number of cases).
322
323 if not RTE_Available (RE) then
324 return Make_Null_Statement (Loc);
325 else
326 return
327 Make_Procedure_Call_Statement (Loc,
328 Name => New_Reference_To (RTE (RE), Loc));
329 end if;
70482933
RK		 330 end Build_Runtime_Call;
331
15ce9ca2
AC		 332 ----------------------------
333 -- Build_Task_Array_Image --
334 ----------------------------
70482933
RK		 335
336 -- This function generates the body for a function that constructs the
337 -- image string for a task that is an array component. The function is
fbf5a39b 338 -- local to the init proc for the array type, and is called for each one
70482933
RK		 339 -- of the components. The constructed image has the form of an indexed
340 -- component, whose prefix is the outer variable of the array type.
341 -- The n-dimensional array type has known indices Index, Index2...
fbf5a39b 342 -- Id_Ref is an indexed component form created by the enclosing init proc.
65df5b71 343 -- Its successive indices are Val1, Val2, ... which are the loop variables
fbf5a39b 344 -- in the loops that call the individual task init proc on each component.
70482933
RK		 345
346 -- The generated function has the following structure:
347
fbf5a39b
AC		 348 -- function F return String is
349 -- Pref : string renames Task_Name;
350 -- T1 : String := Index1'Image (Val1);
70482933 351 -- ...
fbf5a39b
AC		 352 -- Tn : String := indexn'image (Valn);
353 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
70482933 354 -- -- Len includes commas and the end parentheses.
fbf5a39b
AC		 355 -- Res : String (1..Len);
356 -- Pos : Integer := Pref'Length;
70482933
RK		 357 --
358 -- begin
7bc1c7df 359 -- Res (1 .. Pos) := Pref;
70482933
RK		 360 -- Pos := Pos + 1;
361 -- Res (Pos) := '(';
362 -- Pos := Pos + 1;
363 -- Res (Pos .. Pos + T1'Length - 1) := T1;
364 -- Pos := Pos + T1'Length;
365 -- Res (Pos) := '.';
366 -- Pos := Pos + 1;
367 -- ...
368 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
369 -- Res (Len) := ')';
370 --
fbf5a39b 371 -- return Res;
70482933
RK		 372 -- end F;
373 --
374 -- Needless to say, multidimensional arrays of tasks are rare enough
375 -- that the bulkiness of this code is not really a concern.
376
377 function Build_Task_Array_Image
378 (Loc : Source_Ptr;
379 Id_Ref : Node_Id;
7bc1c7df 380 A_Type : Entity_Id;
bebbff91 381 Dyn : Boolean := False) return Node_Id
70482933
RK		 382 is
383 Dims : constant Nat := Number_Dimensions (A_Type);
bebbff91 384 -- Number of dimensions for array of tasks
70482933
RK		 385
386 Temps : array (1 .. Dims) of Entity_Id;
bebbff91 387 -- Array of temporaries to hold string for each index
70482933
RK		 388
389 Indx : Node_Id;
390 -- Index expression
391
392 Len : Entity_Id;
393 -- Total length of generated name
394
395 Pos : Entity_Id;
396 -- Running index for substring assignments
397
092ef350 398 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
70482933
RK		 399 -- Name of enclosing variable, prefix of resulting name
400
401 Res : Entity_Id;
402 -- String to hold result
403
404 Val : Node_Id;
405 -- Value of successive indices
406
407 Sum : Node_Id;
408 -- Expression to compute total size of string
409
410 T : Entity_Id;
411 -- Entity for name at one index position
412
86cde7b1
RD		 413 Decls : constant List_Id := New_List;
414 Stats : constant List_Id := New_List;
70482933
RK		 415
416 begin
7bc1c7df 417 -- For a dynamic task, the name comes from the target variable.
fbf5a39b 418 -- For a static one it is a formal of the enclosing init proc.
7bc1c7df
ES		 419
420 if Dyn then
421 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
fbf5a39b
AC		 422 Append_To (Decls,
423 Make_Object_Declaration (Loc,
424 Defining_Identifier => Pref,
425 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
426 Expression =>
bebbff91
AC		 427 Make_String_Literal (Loc,
428 Strval => String_From_Name_Buffer)));
fbf5a39b 429
7bc1c7df 430 else
fbf5a39b
AC		 431 Append_To (Decls,
432 Make_Object_Renaming_Declaration (Loc,
433 Defining_Identifier => Pref,
434 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
435 Name => Make_Identifier (Loc, Name_uTask_Name)));
7bc1c7df 436 end if;
70482933 437
70482933
RK		 438 Indx := First_Index (A_Type);
439 Val := First (Expressions (Id_Ref));
440
441 for J in 1 .. Dims loop
092ef350 442 T := Make_Temporary (Loc, 'T');
70482933
RK		 443 Temps (J) := T;
444
445 Append_To (Decls,
446 Make_Object_Declaration (Loc,
447 Defining_Identifier => T,
448 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
449 Expression =>
450 Make_Attribute_Reference (Loc,
451 Attribute_Name => Name_Image,
092ef350
RD		 452 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
453 Expressions => New_List (New_Copy_Tree (Val)))));
70482933
RK		 454
455 Next_Index (Indx);
456 Next (Val);
457 end loop;
458
459 Sum := Make_Integer_Literal (Loc, Dims + 1);
460
461 Sum :=
462 Make_Op_Add (Loc,
463 Left_Opnd => Sum,
464 Right_Opnd =>
465 Make_Attribute_Reference (Loc,
466 Attribute_Name => Name_Length,
467 Prefix =>
7bc1c7df 468 New_Occurrence_Of (Pref, Loc),
70482933
RK		 469 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
470
471 for J in 1 .. Dims loop
472 Sum :=
473 Make_Op_Add (Loc,
474 Left_Opnd => Sum,
475 Right_Opnd =>
476 Make_Attribute_Reference (Loc,
477 Attribute_Name => Name_Length,
478 Prefix =>
479 New_Occurrence_Of (Temps (J), Loc),
480 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
481 end loop;
482
7bc1c7df 483 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
70482933
RK		 484
485 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
486
487 Append_To (Stats,
488 Make_Assignment_Statement (Loc,
489 Name => Make_Indexed_Component (Loc,
490 Prefix => New_Occurrence_Of (Res, Loc),
491 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
492 Expression =>
493 Make_Character_Literal (Loc,
494 Chars => Name_Find,
495 Char_Literal_Value =>
82c80734 496 UI_From_Int (Character'Pos ('(')))));
70482933
RK		 497
498 Append_To (Stats,
499 Make_Assignment_Statement (Loc,
500 Name => New_Occurrence_Of (Pos, Loc),
501 Expression =>
502 Make_Op_Add (Loc,
503 Left_Opnd => New_Occurrence_Of (Pos, Loc),
504 Right_Opnd => Make_Integer_Literal (Loc, 1))));
505
506 for J in 1 .. Dims loop
507
508 Append_To (Stats,
509 Make_Assignment_Statement (Loc,
510 Name => Make_Slice (Loc,
511 Prefix => New_Occurrence_Of (Res, Loc),
512 Discrete_Range =>
513 Make_Range (Loc,
514 Low_Bound => New_Occurrence_Of (Pos, Loc),
515 High_Bound => Make_Op_Subtract (Loc,
516 Left_Opnd =>
517 Make_Op_Add (Loc,
518 Left_Opnd => New_Occurrence_Of (Pos, Loc),
519 Right_Opnd =>
520 Make_Attribute_Reference (Loc,
521 Attribute_Name => Name_Length,
522 Prefix =>
523 New_Occurrence_Of (Temps (J), Loc),
524 Expressions =>
525 New_List (Make_Integer_Literal (Loc, 1)))),
526 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
527
528 Expression => New_Occurrence_Of (Temps (J), Loc)));
529
530 if J < Dims then
531 Append_To (Stats,
532 Make_Assignment_Statement (Loc,
533 Name => New_Occurrence_Of (Pos, Loc),
534 Expression =>
535 Make_Op_Add (Loc,
536 Left_Opnd => New_Occurrence_Of (Pos, Loc),
537 Right_Opnd =>
538 Make_Attribute_Reference (Loc,
539 Attribute_Name => Name_Length,
540 Prefix => New_Occurrence_Of (Temps (J), Loc),
541 Expressions =>
542 New_List (Make_Integer_Literal (Loc, 1))))));
543
544 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
545
546 Append_To (Stats,
547 Make_Assignment_Statement (Loc,
548 Name => Make_Indexed_Component (Loc,
549 Prefix => New_Occurrence_Of (Res, Loc),
550 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
551 Expression =>
552 Make_Character_Literal (Loc,
553 Chars => Name_Find,
554 Char_Literal_Value =>
82c80734 555 UI_From_Int (Character'Pos (',')))));
70482933
RK		 556
557 Append_To (Stats,
558 Make_Assignment_Statement (Loc,
559 Name => New_Occurrence_Of (Pos, Loc),
560 Expression =>
561 Make_Op_Add (Loc,
562 Left_Opnd => New_Occurrence_Of (Pos, Loc),
563 Right_Opnd => Make_Integer_Literal (Loc, 1))));
564 end if;
565 end loop;
566
567 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
568
569 Append_To (Stats,
570 Make_Assignment_Statement (Loc,
571 Name => Make_Indexed_Component (Loc,
572 Prefix => New_Occurrence_Of (Res, Loc),
573 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
574 Expression =>
575 Make_Character_Literal (Loc,
576 Chars => Name_Find,
577 Char_Literal_Value =>
82c80734 578 UI_From_Int (Character'Pos (')')))));
70482933
RK		 579 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
580 end Build_Task_Array_Image;
581
582 ----------------------------
583 -- Build_Task_Image_Decls --
584 ----------------------------
585
586 function Build_Task_Image_Decls
05350ac6
BD		 587 (Loc : Source_Ptr;
588 Id_Ref : Node_Id;
589 A_Type : Entity_Id;
590 In_Init_Proc : Boolean := False) return List_Id
70482933 591 is
fbf5a39b 592 Decls : constant List_Id := New_List;
7bc1c7df
ES		 593 T_Id : Entity_Id := Empty;
594 Decl : Node_Id;
7bc1c7df
ES		 595 Expr : Node_Id := Empty;
596 Fun : Node_Id := Empty;
597 Is_Dyn : constant Boolean :=
fbf5a39b
AC		 598 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
599 and then
600 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
70482933
RK		 601
602 begin
fbf5a39b
AC		 603 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
604 -- generate a dummy declaration only.
70482933 605
6e937c1c 606 if Restriction_Active (No_Implicit_Heap_Allocations)
fbf5a39b
AC		 607 or else Global_Discard_Names
608 then
092ef350 609 T_Id := Make_Temporary (Loc, 'J');
fbf5a39b 610 Name_Len := 0;
70482933
RK		 611
612 return
613 New_List (
614 Make_Object_Declaration (Loc,
615 Defining_Identifier => T_Id,
fbf5a39b
AC		 616 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
617 Expression =>
bebbff91
AC		 618 Make_String_Literal (Loc,
619 Strval => String_From_Name_Buffer)));
70482933
RK		 620
621 else
622 if Nkind (Id_Ref) = N_Identifier
623 or else Nkind (Id_Ref) = N_Defining_Identifier
624 then
523456db
AC		 625 -- For a simple variable, the image of the task is built from
626 -- the name of the variable. To avoid possible conflict with
627 -- the anonymous type created for a single protected object,
628 -- add a numeric suffix.
70482933
RK		 629
630 T_Id :=
631 Make_Defining_Identifier (Loc,
523456db 632 New_External_Name (Chars (Id_Ref), 'T', 1));
70482933
RK		 633
634 Get_Name_String (Chars (Id_Ref));
635
bebbff91
AC		 636 Expr :=
637 Make_String_Literal (Loc,
638 Strval => String_From_Name_Buffer);
70482933
RK		 639
640 elsif Nkind (Id_Ref) = N_Selected_Component then
641 T_Id :=
642 Make_Defining_Identifier (Loc,
fbf5a39b 643 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
07fc65c4 644 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
70482933
RK		 645
646 elsif Nkind (Id_Ref) = N_Indexed_Component then
647 T_Id :=
648 Make_Defining_Identifier (Loc,
fbf5a39b 649 New_External_Name (Chars (A_Type), 'N'));
70482933 650
7bc1c7df 651 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
70482933
RK		 652 end if;
653 end if;
654
655 if Present (Fun) then
656 Append (Fun, Decls);
fbf5a39b
AC		 657 Expr := Make_Function_Call (Loc,
658 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
05350ac6 659
0712790c 660 if not In_Init_Proc and then VM_Target = No_VM then
05350ac6
BD		 661 Set_Uses_Sec_Stack (Defining_Entity (Fun));
662 end if;
70482933
RK		 663 end if;
664
665 Decl := Make_Object_Declaration (Loc,
666 Defining_Identifier => T_Id,
fbf5a39b
AC		 667 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
668 Constant_Present => True,
669 Expression => Expr);
70482933
RK		 670
671 Append (Decl, Decls);
672 return Decls;
673 end Build_Task_Image_Decls;
674
675 -------------------------------
676 -- Build_Task_Image_Function --
677 -------------------------------
678
679 function Build_Task_Image_Function
680 (Loc : Source_Ptr;
681 Decls : List_Id;
682 Stats : List_Id;
bebbff91 683 Res : Entity_Id) return Node_Id
70482933
RK		 684 is
685 Spec : Node_Id;
686
687 begin
688 Append_To (Stats,
86cde7b1 689 Make_Simple_Return_Statement (Loc,
fbf5a39b
AC		 690 Expression => New_Occurrence_Of (Res, Loc)));
691
692 Spec := Make_Function_Specification (Loc,
092ef350
RD		 693 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
694 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
fbf5a39b
AC		 695
696 -- Calls to 'Image use the secondary stack, which must be cleaned
697 -- up after the task name is built.
698
70482933
RK		 699 return Make_Subprogram_Body (Loc,
700 Specification => Spec,
701 Declarations => Decls,
702 Handled_Statement_Sequence =>
fbf5a39b 703 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
70482933
RK		 704 end Build_Task_Image_Function;
705
706 -----------------------------
707 -- Build_Task_Image_Prefix --
708 -----------------------------
709
710 procedure Build_Task_Image_Prefix
711 (Loc : Source_Ptr;
712 Len : out Entity_Id;
713 Res : out Entity_Id;
714 Pos : out Entity_Id;
715 Prefix : Entity_Id;
716 Sum : Node_Id;
86cde7b1
RD		 717 Decls : List_Id;
718 Stats : List_Id)
70482933
RK		 719 is
720 begin
092ef350 721 Len := Make_Temporary (Loc, 'L', Sum);
70482933
RK		 722
723 Append_To (Decls,
724 Make_Object_Declaration (Loc,
725 Defining_Identifier => Len,
092ef350
RD		 726 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
727 Expression => Sum));
70482933 728
092ef350 729 Res := Make_Temporary (Loc, 'R');
70482933
RK		 730
731 Append_To (Decls,
732 Make_Object_Declaration (Loc,
733 Defining_Identifier => Res,
734 Object_Definition =>
735 Make_Subtype_Indication (Loc,
736 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
737 Constraint =>
738 Make_Index_Or_Discriminant_Constraint (Loc,
739 Constraints =>
740 New_List (
741 Make_Range (Loc,
742 Low_Bound => Make_Integer_Literal (Loc, 1),
743 High_Bound => New_Occurrence_Of (Len, Loc)))))));
744
092ef350 745 Pos := Make_Temporary (Loc, 'P');
70482933
RK		 746
747 Append_To (Decls,
748 Make_Object_Declaration (Loc,
749 Defining_Identifier => Pos,
092ef350 750 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
70482933
RK		 751
752 -- Pos := Prefix'Length;
753
754 Append_To (Stats,
755 Make_Assignment_Statement (Loc,
756 Name => New_Occurrence_Of (Pos, Loc),
757 Expression =>
758 Make_Attribute_Reference (Loc,
759 Attribute_Name => Name_Length,
092ef350
RD		 760 Prefix => New_Occurrence_Of (Prefix, Loc),
761 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
70482933
RK		 762
763 -- Res (1 .. Pos) := Prefix;
764
765 Append_To (Stats,
092ef350
RD		 766 Make_Assignment_Statement (Loc,
767 Name =>
768 Make_Slice (Loc,
769 Prefix => New_Occurrence_Of (Res, Loc),
70482933
RK		 770 Discrete_Range =>
771 Make_Range (Loc,
092ef350 772 Low_Bound => Make_Integer_Literal (Loc, 1),
70482933
RK		 773 High_Bound => New_Occurrence_Of (Pos, Loc))),
774
092ef350 775 Expression => New_Occurrence_Of (Prefix, Loc)));
70482933
RK		 776
777 Append_To (Stats,
778 Make_Assignment_Statement (Loc,
092ef350 779 Name => New_Occurrence_Of (Pos, Loc),
70482933
RK		 780 Expression =>
781 Make_Op_Add (Loc,
092ef350 782 Left_Opnd => New_Occurrence_Of (Pos, Loc),
70482933
RK		 783 Right_Opnd => Make_Integer_Literal (Loc, 1))));
784 end Build_Task_Image_Prefix;
785
786 -----------------------------
787 -- Build_Task_Record_Image --
788 -----------------------------
789
790 function Build_Task_Record_Image
791 (Loc : Source_Ptr;
792 Id_Ref : Node_Id;
bebbff91 793 Dyn : Boolean := False) return Node_Id
70482933
RK		 794 is
795 Len : Entity_Id;
796 -- Total length of generated name
797
798 Pos : Entity_Id;
799 -- Index into result
800
801 Res : Entity_Id;
802 -- String to hold result
803
092ef350 804 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
70482933
RK		 805 -- Name of enclosing variable, prefix of resulting name
806
807 Sum : Node_Id;
bebbff91 808 -- Expression to compute total size of string
70482933
RK		 809
810 Sel : Entity_Id;
811 -- Entity for selector name
812
86cde7b1
RD		 813 Decls : constant List_Id := New_List;
814 Stats : constant List_Id := New_List;
70482933
RK		 815
816 begin
7bc1c7df 817 -- For a dynamic task, the name comes from the target variable.
fbf5a39b 818 -- For a static one it is a formal of the enclosing init proc.
7bc1c7df
ES		 819
820 if Dyn then
821 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
fbf5a39b
AC		 822 Append_To (Decls,
823 Make_Object_Declaration (Loc,
824 Defining_Identifier => Pref,
825 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
826 Expression =>
bebbff91
AC		 827 Make_String_Literal (Loc,
828 Strval => String_From_Name_Buffer)));
fbf5a39b 829
7bc1c7df 830 else
fbf5a39b
AC		 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)));
7bc1c7df 836 end if;
70482933 837
092ef350 838 Sel := Make_Temporary (Loc, 'S');
70482933
RK		 839
840 Get_Name_String (Chars (Selector_Name (Id_Ref)));
841
842 Append_To (Decls,
843 Make_Object_Declaration (Loc,
844 Defining_Identifier => Sel,
092ef350
RD		 845 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
846 Expression =>
bebbff91
AC		 847 Make_String_Literal (Loc,
848 Strval => String_From_Name_Buffer)));
70482933
RK		 849
850 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
851
852 Sum :=
853 Make_Op_Add (Loc,
854 Left_Opnd => Sum,
855 Right_Opnd =>
856 Make_Attribute_Reference (Loc,
857 Attribute_Name => Name_Length,
858 Prefix =>
7bc1c7df 859 New_Occurrence_Of (Pref, Loc),
70482933
RK		 860 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
861
7bc1c7df 862 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
70482933
RK		 863
864 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
865
866 -- Res (Pos) := '.';
867
868 Append_To (Stats,
869 Make_Assignment_Statement (Loc,
870 Name => Make_Indexed_Component (Loc,
871 Prefix => New_Occurrence_Of (Res, Loc),
872 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
873 Expression =>
874 Make_Character_Literal (Loc,
875 Chars => Name_Find,
876 Char_Literal_Value =>
82c80734 877 UI_From_Int (Character'Pos ('.')))));
70482933
RK		 878
879 Append_To (Stats,
880 Make_Assignment_Statement (Loc,
881 Name => New_Occurrence_Of (Pos, Loc),
882 Expression =>
883 Make_Op_Add (Loc,
884 Left_Opnd => New_Occurrence_Of (Pos, Loc),
885 Right_Opnd => Make_Integer_Literal (Loc, 1))));
886
887 -- Res (Pos .. Len) := Selector;
888
889 Append_To (Stats,
890 Make_Assignment_Statement (Loc,
891 Name => Make_Slice (Loc,
892 Prefix => New_Occurrence_Of (Res, Loc),
893 Discrete_Range =>
894 Make_Range (Loc,
895 Low_Bound => New_Occurrence_Of (Pos, Loc),
896 High_Bound => New_Occurrence_Of (Len, Loc))),
897 Expression => New_Occurrence_Of (Sel, Loc)));
898
899 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
900 end Build_Task_Record_Image;
901
91b1417d
AC		 902 ----------------------------------
903 -- Component_May_Be_Bit_Aligned --
904 ----------------------------------
905
906 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
c97c0163 907 UT : Entity_Id;
6fb4cdde 908
91b1417d 909 begin
dc7c0c4d
AC		 910 -- If no component clause, then everything is fine, since the back end
911 -- never bit-misaligns by default, even if there is a pragma Packed for
912 -- the record.
91b1417d 913
c97c0163 914 if No (Comp) or else No (Component_Clause (Comp)) then
91b1417d
AC		 915 return False;
916 end if;
917
c97c0163
AC		 918 UT := Underlying_Type (Etype (Comp));
919
91b1417d
AC		 920 -- It is only array and record types that cause trouble
921
9cd33a66
AC		 922 if not Is_Record_Type (UT)
923 and then not Is_Array_Type (UT)
91b1417d
AC		 924 then
925 return False;
926
6fb4cdde
AC		 927 -- If we know that we have a small (64 bits or less) record or small
928 -- bit-packed array, then everything is fine, since the back end can
929 -- handle these cases correctly.
91b1417d
AC		 930
931 elsif Esize (Comp) <= 64
9cd33a66
AC		 932 and then (Is_Record_Type (UT)
933 or else Is_Bit_Packed_Array (UT))
91b1417d
AC		 934 then
935 return False;
936
dc7c0c4d
AC		 937 -- Otherwise if the component is not byte aligned, we know we have the
938 -- nasty unaligned case.
91b1417d
AC		 939
940 elsif Normalized_First_Bit (Comp) /= Uint_0
941 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
942 then
943 return True;
944
945 -- If we are large and byte aligned, then OK at this level
946
947 else
948 return False;
949 end if;
950 end Component_May_Be_Bit_Aligned;
951
1923d2d6
JM		 952 -----------------------------------
953 -- Corresponding_Runtime_Package --
954 -----------------------------------
955
956 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
957 Pkg_Id : RTU_Id := RTU_Null;
958
959 begin
960 pragma Assert (Is_Concurrent_Type (Typ));
961
962 if Ekind (Typ) in Protected_Kind then
963 if Has_Entries (Typ)
964 or else Has_Interrupt_Handler (Typ)
965 or else (Has_Attach_Handler (Typ)
65df5b71
HK		 966 and then not Restricted_Profile)
967
968 -- A protected type without entries that covers an interface and
969 -- overrides the abstract routines with protected procedures is
970 -- considered equivalent to a protected type with entries in the
f3d0f304 971 -- context of dispatching select statements. It is sufficient to
65df5b71
HK		 972 -- check for the presence of an interface list in the declaration
973 -- node to recognize this case.
974
975 or else Present (Interface_List (Parent (Typ)))
1923d2d6
JM		 976 then
977 if Abort_Allowed
978 or else Restriction_Active (No_Entry_Queue) = False
979 or else Number_Entries (Typ) > 1
980 or else (Has_Attach_Handler (Typ)
981 and then not Restricted_Profile)
982 then
983 Pkg_Id := System_Tasking_Protected_Objects_Entries;
984 else
985 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
986 end if;
987
988 else
989 Pkg_Id := System_Tasking_Protected_Objects;
990 end if;
991 end if;
992
993 return Pkg_Id;
994 end Corresponding_Runtime_Package;
995
70482933
RK		 996 -------------------------------
997 -- Convert_To_Actual_Subtype --
998 -------------------------------
999
1000 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1001 Act_ST : Entity_Id;
1002
1003 begin
1004 Act_ST := Get_Actual_Subtype (Exp);
1005
1006 if Act_ST = Etype (Exp) then
1007 return;
1008
1009 else
1010 Rewrite (Exp,
1011 Convert_To (Act_ST, Relocate_Node (Exp)));
1012 Analyze_And_Resolve (Exp, Act_ST);
1013 end if;
1014 end Convert_To_Actual_Subtype;
1015
1016 -----------------------------------
1017 -- Current_Sem_Unit_Declarations --
1018 -----------------------------------
1019
1020 function Current_Sem_Unit_Declarations return List_Id is
1021 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
1022 Decls : List_Id;
1023
1024 begin
1025 -- If the current unit is a package body, locate the visible
1026 -- declarations of the package spec.
1027
1028 if Nkind (U) = N_Package_Body then
1029 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1030 end if;
1031
1032 if Nkind (U) = N_Package_Declaration then
1033 U := Specification (U);
1034 Decls := Visible_Declarations (U);
1035
1036 if No (Decls) then
1037 Decls := New_List;
1038 Set_Visible_Declarations (U, Decls);
1039 end if;
1040
1041 else
1042 Decls := Declarations (U);
1043
1044 if No (Decls) then
1045 Decls := New_List;
1046 Set_Declarations (U, Decls);
1047 end if;
1048 end if;
1049
1050 return Decls;
1051 end Current_Sem_Unit_Declarations;
1052
1053 -----------------------
1054 -- Duplicate_Subexpr --
1055 -----------------------
1056
1057 function Duplicate_Subexpr
1058 (Exp : Node_Id;
bebbff91 1059 Name_Req : Boolean := False) return Node_Id
70482933
RK		 1060 is
1061 begin
1062 Remove_Side_Effects (Exp, Name_Req);
1063 return New_Copy_Tree (Exp);
1064 end Duplicate_Subexpr;
1065
8cbb664e
MG		 1066 ---------------------------------
1067 -- Duplicate_Subexpr_No_Checks --
1068 ---------------------------------
1069
1070 function Duplicate_Subexpr_No_Checks
1071 (Exp : Node_Id;
bebbff91 1072 Name_Req : Boolean := False) return Node_Id
8cbb664e
MG		 1073 is
1074 New_Exp : Node_Id;
1075
1076 begin
1077 Remove_Side_Effects (Exp, Name_Req);
1078 New_Exp := New_Copy_Tree (Exp);
1079 Remove_Checks (New_Exp);
1080 return New_Exp;
1081 end Duplicate_Subexpr_No_Checks;
1082
1083 -----------------------------------
1084 -- Duplicate_Subexpr_Move_Checks --
1085 -----------------------------------
1086
1087 function Duplicate_Subexpr_Move_Checks
1088 (Exp : Node_Id;
bebbff91 1089 Name_Req : Boolean := False) return Node_Id
8cbb664e
MG		 1090 is
1091 New_Exp : Node_Id;
1092
1093 begin
1094 Remove_Side_Effects (Exp, Name_Req);
1095 New_Exp := New_Copy_Tree (Exp);
1096 Remove_Checks (Exp);
1097 return New_Exp;
1098 end Duplicate_Subexpr_Move_Checks;
1099
70482933
RK		 1100 --------------------
1101 -- Ensure_Defined --
1102 --------------------
1103
1104 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1105 IR : Node_Id;
70482933
RK		 1106
1107 begin
86cde7b1
RD		 1108 -- An itype reference must only be created if this is a local
1109 -- itype, so that gigi can elaborate it on the proper objstack.
1110
1111 if Is_Itype (Typ)
19590d70 1112 and then Scope (Typ) = Current_Scope
86cde7b1 1113 then
70482933
RK		 1114 IR := Make_Itype_Reference (Sloc (N));
1115 Set_Itype (IR, Typ);
86cde7b1 1116 Insert_Action (N, IR);
70482933
RK		 1117 end if;
1118 end Ensure_Defined;
1119
c42e6724
HK		 1120 --------------------
1121 -- Entry_Names_OK --
1122 --------------------
1123
1124 function Entry_Names_OK return Boolean is
1125 begin
1126 return
1127 not Restricted_Profile
1128 and then not Global_Discard_Names
1129 and then not Restriction_Active (No_Implicit_Heap_Allocations)
1130 and then not Restriction_Active (No_Local_Allocators);
1131 end Entry_Names_OK;
1132
70482933
RK		 1133 ---------------------
1134 -- Evolve_And_Then --
1135 ---------------------
1136
1137 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1138 begin
1139 if No (Cond) then
1140 Cond := Cond1;
1141 else
1142 Cond :=
1143 Make_And_Then (Sloc (Cond1),
1144 Left_Opnd => Cond,
1145 Right_Opnd => Cond1);
1146 end if;
1147 end Evolve_And_Then;
1148
1149 --------------------
1150 -- Evolve_Or_Else --
1151 --------------------
1152
1153 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1154 begin
1155 if No (Cond) then
1156 Cond := Cond1;
1157 else
1158 Cond :=
1159 Make_Or_Else (Sloc (Cond1),
1160 Left_Opnd => Cond,
1161 Right_Opnd => Cond1);
1162 end if;
1163 end Evolve_Or_Else;
1164
1165 ------------------------------
1166 -- Expand_Subtype_From_Expr --
1167 ------------------------------
1168
1169 -- This function is applicable for both static and dynamic allocation of
1170 -- objects which are constrained by an initial expression. Basically it
1171 -- transforms an unconstrained subtype indication into a constrained one.
1172 -- The expression may also be transformed in certain cases in order to
05350ac6
BD		 1173 -- avoid multiple evaluation. In the static allocation case, the general
1174 -- scheme is:
70482933
RK		 1175
1176 -- Val : T := Expr;
1177
1178 -- is transformed into
1179
1180 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1181 --
1182 -- Here are the main cases :
1183 --
1184 -- <if Expr is a Slice>
1185 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1186 --
1187 -- <elsif Expr is a String Literal>
1188 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1189 --
1190 -- <elsif Expr is Constrained>
1191 -- subtype T is Type_Of_Expr
1192 -- Val : T := Expr;
1193 --
1194 -- <elsif Expr is an entity_name>
638e383e 1195 -- Val : T (constraints taken from Expr) := Expr;
70482933
RK		 1196 --
1197 -- <else>
1198 -- type Axxx is access all T;
1199 -- Rval : Axxx := Expr'ref;
638e383e 1200 -- Val : T (constraints taken from Rval) := Rval.all;
70482933
RK		 1201
1202 -- ??? note: when the Expression is allocated in the secondary stack
1203 -- we could use it directly instead of copying it by declaring
1204 -- Val : T (...) renames Rval.all
1205
1206 procedure Expand_Subtype_From_Expr
1207 (N : Node_Id;
1208 Unc_Type : Entity_Id;
1209 Subtype_Indic : Node_Id;
1210 Exp : Node_Id)
1211 is
1212 Loc : constant Source_Ptr := Sloc (N);
1213 Exp_Typ : constant Entity_Id := Etype (Exp);
1214 T : Entity_Id;
1215
1216 begin
1217 -- In general we cannot build the subtype if expansion is disabled,
1218 -- because internal entities may not have been defined. However, to
1219 -- avoid some cascaded errors, we try to continue when the expression
1220 -- is an array (or string), because it is safe to compute the bounds.
1221 -- It is in fact required to do so even in a generic context, because
1222 -- there may be constants that depend on bounds of string literal.
1223
1224 if not Expander_Active
1225 and then (No (Etype (Exp))
1226 or else Base_Type (Etype (Exp)) /= Standard_String)
1227 then
1228 return;
1229 end if;
1230
1231 if Nkind (Exp) = N_Slice then
1232 declare
1233 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1234
1235 begin
1236 Rewrite (Subtype_Indic,
1237 Make_Subtype_Indication (Loc,
1238 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1239 Constraint =>
1240 Make_Index_Or_Discriminant_Constraint (Loc,
1241 Constraints => New_List
1242 (New_Reference_To (Slice_Type, Loc)))));
1243
e14c931f 1244 -- This subtype indication may be used later for constraint checks
70482933
RK		 1245 -- we better make sure that if a variable was used as a bound of
1246 -- of the original slice, its value is frozen.
1247
1248 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1249 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1250 end;
1251
1252 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1253 Rewrite (Subtype_Indic,
1254 Make_Subtype_Indication (Loc,
1255 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1256 Constraint =>
1257 Make_Index_Or_Discriminant_Constraint (Loc,
1258 Constraints => New_List (
1259 Make_Literal_Range (Loc,
f91b40db 1260 Literal_Typ => Exp_Typ)))));
70482933
RK		 1261
1262 elsif Is_Constrained (Exp_Typ)
1263 and then not Is_Class_Wide_Type (Unc_Type)
1264 then
1265 if Is_Itype (Exp_Typ) then
1266
758c442c
GD		 1267 -- Within an initialization procedure, a selected component
1268 -- denotes a component of the enclosing record, and it appears
1269 -- as an actual in a call to its own initialization procedure.
1270 -- If this component depends on the outer discriminant, we must
1271 -- generate the proper actual subtype for it.
70482933 1272
758c442c
GD		 1273 if Nkind (Exp) = N_Selected_Component
1274 and then Within_Init_Proc
1275 then
1276 declare
1277 Decl : constant Node_Id :=
1278 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
1279 begin
1280 if Present (Decl) then
1281 Insert_Action (N, Decl);
1282 T := Defining_Identifier (Decl);
1283 else
1284 T := Exp_Typ;
1285 end if;
1286 end;
1287
1288 -- No need to generate a new one (new what???)
1289
1290 else
1291 T := Exp_Typ;
1292 end if;
70482933
RK		 1293
1294 else
092ef350 1295 T := Make_Temporary (Loc, 'T');
70482933
RK		 1296
1297 Insert_Action (N,
1298 Make_Subtype_Declaration (Loc,
1299 Defining_Identifier => T,
1300 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
1301
1302 -- This type is marked as an itype even though it has an
1303 -- explicit declaration because otherwise it can be marked
1304 -- with Is_Generic_Actual_Type and generate spurious errors.
1305 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1306
1307 Set_Is_Itype (T);
1308 Set_Associated_Node_For_Itype (T, Exp);
1309 end if;
1310
1311 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1312
0a69df7c 1313 -- Nothing needs to be done for private types with unknown discriminants
3f5bb1b8
AC		 1314 -- if the underlying type is not an unconstrained composite type or it
1315 -- is an unchecked union.
70482933
RK		 1316
1317 elsif Is_Private_Type (Unc_Type)
1318 and then Has_Unknown_Discriminants (Unc_Type)
1319 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
0a69df7c
AC		 1320 or else Is_Constrained (Underlying_Type (Unc_Type))
1321 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
70482933
RK		 1322 then
1323 null;
1324
58a9d876
AC		 1325 -- Case of derived type with unknown discriminants where the parent type
1326 -- also has unknown discriminants.
f4d379b8
HK		 1327
1328 elsif Is_Record_Type (Unc_Type)
1329 and then not Is_Class_Wide_Type (Unc_Type)
1330 and then Has_Unknown_Discriminants (Unc_Type)
1331 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
1332 then
58a9d876
AC		 1333 -- Nothing to be done if no underlying record view available
1334
1335 if No (Underlying_Record_View (Unc_Type)) then
1336 null;
1337
1338 -- Otherwise use the Underlying_Record_View to create the proper
1339 -- constrained subtype for an object of a derived type with unknown
1340 -- discriminants.
1341
1342 else
1343 Remove_Side_Effects (Exp);
1344 Rewrite (Subtype_Indic,
1345 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
1346 end if;
f4d379b8 1347
0e41a941
AC		 1348 -- Renamings of class-wide interface types require no equivalent
1349 -- constrained type declarations because we only need to reference
1350 -- the tag component associated with the interface.
1351
1352 elsif Present (N)
1353 and then Nkind (N) = N_Object_Renaming_Declaration
1354 and then Is_Interface (Unc_Type)
1355 then
1356 pragma Assert (Is_Class_Wide_Type (Unc_Type));
1357 null;
1358
01957849 1359 -- In Ada95, nothing to be done if the type of the expression is
0712790c
ES		 1360 -- limited, because in this case the expression cannot be copied,
1361 -- and its use can only be by reference.
10b93b2e 1362
0712790c
ES		 1363 -- In Ada2005, the context can be an object declaration whose expression
1364 -- is a function that returns in place. If the nominal subtype has
1365 -- unknown discriminants, the call still provides constraints on the
1366 -- object, and we have to create an actual subtype from it.
1367
1368 -- If the type is class-wide, the expression is dynamically tagged and
1369 -- we do not create an actual subtype either. Ditto for an interface.
1370
1371 elsif Is_Limited_Type (Exp_Typ)
1372 and then
1373 (Is_Class_Wide_Type (Exp_Typ)
1374 or else Is_Interface (Exp_Typ)
1375 or else not Has_Unknown_Discriminants (Exp_Typ)
1376 or else not Is_Composite_Type (Unc_Type))
1377 then
1378 null;
1379
86cde7b1
RD		 1380 -- For limited objects initialized with build in place function calls,
1381 -- nothing to be done; otherwise we prematurely introduce an N_Reference
1382 -- node in the expression initializing the object, which breaks the
1383 -- circuitry that detects and adds the additional arguments to the
1384 -- called function.
1385
1386 elsif Is_Build_In_Place_Function_Call (Exp) then
1387 null;
1388
70482933
RK		 1389 else
1390 Remove_Side_Effects (Exp);
1391 Rewrite (Subtype_Indic,
1392 Make_Subtype_From_Expr (Exp, Unc_Type));
1393 end if;
1394 end Expand_Subtype_From_Expr;
1395
f3b57ab0
AC		 1396 --------------------
1397 -- Find_Init_Call --
1398 --------------------
1399
1400 function Find_Init_Call
1401 (Var : Entity_Id;
1402 Rep_Clause : Node_Id) return Node_Id
1403 is
1404 Typ : constant Entity_Id := Etype (Var);
1405
1406 Init_Proc : Entity_Id;
1407 -- Initialization procedure for Typ
1408
1409 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
1410 -- Look for init call for Var starting at From and scanning the
1411 -- enclosing list until Rep_Clause or the end of the list is reached.
1412
1413 ----------------------------
1414 -- Find_Init_Call_In_List --
1415 ----------------------------
1416
1417 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
1418 Init_Call : Node_Id;
1419 begin
1420 Init_Call := From;
1421
1422 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
1423 if Nkind (Init_Call) = N_Procedure_Call_Statement
1424 and then Is_Entity_Name (Name (Init_Call))
1425 and then Entity (Name (Init_Call)) = Init_Proc
1426 then
1427 return Init_Call;
1428 end if;
1429 Next (Init_Call);
1430 end loop;
1431
1432 return Empty;
1433 end Find_Init_Call_In_List;
1434
1435 Init_Call : Node_Id;
1436
1437 -- Start of processing for Find_Init_Call
1438
1439 begin
1440 if not Has_Non_Null_Base_Init_Proc (Typ) then
1441 -- No init proc for the type, so obviously no call to be found
1442
1443 return Empty;
1444 end if;
1445
1446 Init_Proc := Base_Init_Proc (Typ);
1447
1448 -- First scan the list containing the declaration of Var
1449
1450 Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
1451
1452 -- If not found, also look on Var's freeze actions list, if any, since
1453 -- the init call may have been moved there (case of an address clause
1454 -- applying to Var).
1455
1456 if No (Init_Call) and then Present (Freeze_Node (Var)) then
1457 Init_Call := Find_Init_Call_In_List
1458 (First (Actions (Freeze_Node (Var))));
1459 end if;
1460
1461 return Init_Call;
1462 end Find_Init_Call;
1463
758c442c 1464 ------------------------
f4d379b8 1465 -- Find_Interface_ADT --
758c442c
GD		 1466 ------------------------
1467
3ca505dc
JM		 1468 function Find_Interface_ADT
1469 (T : Entity_Id;
ac4d6407 1470 Iface : Entity_Id) return Elmt_Id
3ca505dc 1471 is
ce2b6ba5
JM		 1472 ADT : Elmt_Id;
1473 Typ : Entity_Id := T;
3ca505dc
JM		 1474
1475 begin
dee4682a
JM		 1476 pragma Assert (Is_Interface (Iface));
1477
3ca505dc
JM		 1478 -- Handle private types
1479
1480 if Has_Private_Declaration (Typ)
1481 and then Present (Full_View (Typ))
1482 then
1483 Typ := Full_View (Typ);
1484 end if;
1485
1486 -- Handle access types
1487
1488 if Is_Access_Type (Typ) then
841dd0f5 1489 Typ := Designated_Type (Typ);
3ca505dc
JM		 1490 end if;
1491
1492 -- Handle task and protected types implementing interfaces
1493
dee4682a 1494 if Is_Concurrent_Type (Typ) then
3ca505dc
JM		 1495 Typ := Corresponding_Record_Type (Typ);
1496 end if;
1497
dee4682a
JM		 1498 pragma Assert
1499 (not Is_Class_Wide_Type (Typ)
1500 and then Ekind (Typ) /= E_Incomplete_Type);
1501
ce2b6ba5
JM		 1502 if Is_Ancestor (Iface, Typ) then
1503 return First_Elmt (Access_Disp_Table (Typ));
1504
1505 else
1506 ADT :=
1507 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
1508 while Present (ADT)
1509 and then Present (Related_Type (Node (ADT)))
1510 and then Related_Type (Node (ADT)) /= Iface
1511 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
1512 loop
1513 Next_Elmt (ADT);
1514 end loop;
1515
1516 pragma Assert (Present (Related_Type (Node (ADT))));
1517 return ADT;
1518 end if;
3ca505dc
JM		 1519 end Find_Interface_ADT;
1520
1521 ------------------------
1522 -- Find_Interface_Tag --
1523 ------------------------
1524
1525 function Find_Interface_Tag
dee4682a
JM		 1526 (T : Entity_Id;
1527 Iface : Entity_Id) return Entity_Id
758c442c 1528 is
3ca505dc 1529 AI_Tag : Entity_Id;
dee4682a 1530 Found : Boolean := False;
3ca505dc 1531 Typ : Entity_Id := T;
758c442c 1532
59e54267 1533 procedure Find_Tag (Typ : Entity_Id);
3ca505dc 1534 -- Internal subprogram used to recursively climb to the ancestors
758c442c 1535
ea985d95
RD		 1536 --------------
1537 -- Find_Tag --
1538 --------------
758c442c 1539
59e54267 1540 procedure Find_Tag (Typ : Entity_Id) is
758c442c
GD		 1541 AI_Elmt : Elmt_Id;
1542 AI : Node_Id;
1543
1544 begin
0e41a941
AC		 1545 -- This routine does not handle the case in which the interface is an
1546 -- ancestor of Typ. That case is handled by the enclosing subprogram.
758c442c 1547
0e41a941 1548 pragma Assert (Typ /= Iface);
758c442c 1549
f4d379b8
HK		 1550 -- Climb to the root type handling private types
1551
ce2b6ba5 1552 if Present (Full_View (Etype (Typ))) then
f4d379b8
HK		 1553 if Full_View (Etype (Typ)) /= Typ then
1554 Find_Tag (Full_View (Etype (Typ)));
1555 end if;
758c442c 1556
f4d379b8 1557 elsif Etype (Typ) /= Typ then
3ca505dc 1558 Find_Tag (Etype (Typ));
758c442c
GD		 1559 end if;
1560
1561 -- Traverse the list of interfaces implemented by the type
1562
1563 if not Found
ce2b6ba5
JM		 1564 and then Present (Interfaces (Typ))
1565 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
758c442c 1566 then
10b93b2e 1567 -- Skip the tag associated with the primary table
758c442c 1568
ce2b6ba5
JM		 1569 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1570 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1571 pragma Assert (Present (AI_Tag));
758c442c 1572
ce2b6ba5 1573 AI_Elmt := First_Elmt (Interfaces (Typ));
758c442c
GD		 1574 while Present (AI_Elmt) loop
1575 AI := Node (AI_Elmt);
1576
1577 if AI = Iface or else Is_Ancestor (Iface, AI) then
1578 Found := True;
1579 return;
1580 end if;
1581
1582 AI_Tag := Next_Tag_Component (AI_Tag);
1583 Next_Elmt (AI_Elmt);
758c442c
GD		 1584 end loop;
1585 end if;
3ca505dc
JM		 1586 end Find_Tag;
1587
1588 -- Start of processing for Find_Interface_Tag
758c442c
GD		 1589
1590 begin
f4d379b8
HK		 1591 pragma Assert (Is_Interface (Iface));
1592
3ca505dc 1593 -- Handle access types
758c442c 1594
3ca505dc 1595 if Is_Access_Type (Typ) then
841dd0f5 1596 Typ := Designated_Type (Typ);
3ca505dc 1597 end if;
758c442c 1598
c6ad817f 1599 -- Handle class-wide types
758c442c 1600
c6ad817f
JM		 1601 if Is_Class_Wide_Type (Typ) then
1602 Typ := Root_Type (Typ);
3ca505dc
JM		 1603 end if;
1604
c6ad817f
JM		 1605 -- Handle private types
1606
1607 if Has_Private_Declaration (Typ)
1608 and then Present (Full_View (Typ))
1609 then
1610 Typ := Full_View (Typ);
10b93b2e
HK		 1611 end if;
1612
1613 -- Handle entities from the limited view
1614
1615 if Ekind (Typ) = E_Incomplete_Type then
1616 pragma Assert (Present (Non_Limited_View (Typ)));
1617 Typ := Non_Limited_View (Typ);
1618 end if;
1619
c6ad817f
JM		 1620 -- Handle task and protected types implementing interfaces
1621
1622 if Is_Concurrent_Type (Typ) then
1623 Typ := Corresponding_Record_Type (Typ);
1624 end if;
1625
0e41a941
AC		 1626 -- If the interface is an ancestor of the type, then it shared the
1627 -- primary dispatch table.
1628
1629 if Is_Ancestor (Iface, Typ) then
1630 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1631 return First_Tag_Component (Typ);
1632
1633 -- Otherwise we need to search for its associated tag component
1634
1635 else
1636 Find_Tag (Typ);
1637 pragma Assert (Found);
1638 return AI_Tag;
1639 end if;
ce2b6ba5 1640 end Find_Interface_Tag;
ea985d95 1641
70482933
RK		 1642 ------------------
1643 -- Find_Prim_Op --
1644 ------------------
1645
1646 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1647 Prim : Elmt_Id;
1648 Typ : Entity_Id := T;
59e54267 1649 Op : Entity_Id;
70482933
RK		 1650
1651 begin
1652 if Is_Class_Wide_Type (Typ) then
1653 Typ := Root_Type (Typ);
1654 end if;
1655
1656 Typ := Underlying_Type (Typ);
1657
59e54267
ES		 1658 -- Loop through primitive operations
1659
70482933 1660 Prim := First_Elmt (Primitive_Operations (Typ));
59e54267
ES		 1661 while Present (Prim) loop
1662 Op := Node (Prim);
1663
1664 -- We can retrieve primitive operations by name if it is an internal
1665 -- name. For equality we must check that both of its operands have
1666 -- the same type, to avoid confusion with user-defined equalities
1667 -- than may have a non-symmetric signature.
1668
1669 exit when Chars (Op) = Name
1670 and then
1671 (Name /= Name_Op_Eq
ea7f928b 1672 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
59e54267 1673
70482933 1674 Next_Elmt (Prim);
6a4d72a6 1675
7813a510
RD		 1676 -- Raise Program_Error if no primitive found
1677
6a4d72a6
ES		 1678 if No (Prim) then
1679 raise Program_Error;
1680 end if;
70482933
RK		 1681 end loop;
1682
1683 return Node (Prim);
1684 end Find_Prim_Op;
1685
dee4682a
JM		 1686 ------------------
1687 -- Find_Prim_Op --
1688 ------------------
1689
fbf5a39b
AC		 1690 function Find_Prim_Op
1691 (T : Entity_Id;
1692 Name : TSS_Name_Type) return Entity_Id
1693 is
1694 Prim : Elmt_Id;
1695 Typ : Entity_Id := T;
1696
1697 begin
1698 if Is_Class_Wide_Type (Typ) then
1699 Typ := Root_Type (Typ);
1700 end if;
1701
1702 Typ := Underlying_Type (Typ);
1703
1704 Prim := First_Elmt (Primitive_Operations (Typ));
1705 while not Is_TSS (Node (Prim), Name) loop
1706 Next_Elmt (Prim);
6a4d72a6 1707
7813a510
RD		 1708 -- Raise program error if no primitive found
1709
6a4d72a6
ES		 1710 if No (Prim) then
1711 raise Program_Error;
1712 end if;
fbf5a39b
AC		 1713 end loop;
1714
1715 return Node (Prim);
1716 end Find_Prim_Op;
1717
65df5b71
HK		 1718 ----------------------------
1719 -- Find_Protection_Object --
1720 ----------------------------
1721
1722 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
1723 S : Entity_Id;
1724
1725 begin
1726 S := Scop;
1727 while Present (S) loop
1728 if (Ekind (S) = E_Entry
1729 or else Ekind (S) = E_Entry_Family
1730 or else Ekind (S) = E_Function
1731 or else Ekind (S) = E_Procedure)
1732 and then Present (Protection_Object (S))
1733 then
1734 return Protection_Object (S);
1735 end if;
1736
1737 S := Scope (S);
1738 end loop;
1739
1740 -- If we do not find a Protection object in the scope chain, then
1741 -- something has gone wrong, most likely the object was never created.
1742
1743 raise Program_Error;
1744 end Find_Protection_Object;
1745
70482933
RK		 1746 ----------------------
1747 -- Force_Evaluation --
1748 ----------------------
1749
1750 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1751 begin
d9e0a587 1752 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
70482933
RK		 1753 end Force_Evaluation;
1754
1755 ------------------------
1756 -- Generate_Poll_Call --
1757 ------------------------
1758
1759 procedure Generate_Poll_Call (N : Node_Id) is
1760 begin
1761 -- No poll call if polling not active
1762
1763 if not Polling_Required then
1764 return;
1765
1766 -- Otherwise generate require poll call
1767
1768 else
1769 Insert_Before_And_Analyze (N,
1770 Make_Procedure_Call_Statement (Sloc (N),
1771 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1772 end if;
1773 end Generate_Poll_Call;
1774
fbf5a39b
AC		 1775 ---------------------------------
1776 -- Get_Current_Value_Condition --
1777 ---------------------------------
1778
05350ac6
BD		 1779 -- Note: the implementation of this procedure is very closely tied to the
1780 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
1781 -- interpret Current_Value fields set by the Set procedure, so the two
1782 -- procedures need to be closely coordinated.
1783
fbf5a39b
AC		 1784 procedure Get_Current_Value_Condition
1785 (Var : Node_Id;
1786 Op : out Node_Kind;
1787 Val : out Node_Id)
1788 is
59e54267
ES		 1789 Loc : constant Source_Ptr := Sloc (Var);
1790 Ent : constant Entity_Id := Entity (Var);
fbf5a39b 1791
05350ac6
BD		 1792 procedure Process_Current_Value_Condition
1793 (N : Node_Id;
1794 S : Boolean);
1795 -- N is an expression which holds either True (S = True) or False (S =
1796 -- False) in the condition. This procedure digs out the expression and
1797 -- if it refers to Ent, sets Op and Val appropriately.
1798
1799 -------------------------------------
1800 -- Process_Current_Value_Condition --
1801 -------------------------------------
1802
1803 procedure Process_Current_Value_Condition
1804 (N : Node_Id;
1805 S : Boolean)
1806 is
1807 Cond : Node_Id;
1808 Sens : Boolean;
1809
1810 begin
1811 Cond := N;
1812 Sens := S;
1813
1814 -- Deal with NOT operators, inverting sense
1815
1816 while Nkind (Cond) = N_Op_Not loop
1817 Cond := Right_Opnd (Cond);
1818 Sens := not Sens;
1819 end loop;
1820
1821 -- Deal with AND THEN and AND cases
1822
1823 if Nkind (Cond) = N_And_Then
1824 or else Nkind (Cond) = N_Op_And
1825 then
1826 -- Don't ever try to invert a condition that is of the form
1827 -- of an AND or AND THEN (since we are not doing sufficiently
1828 -- general processing to allow this).
1829
1830 if Sens = False then
1831 Op := N_Empty;
1832 Val := Empty;
1833 return;
1834 end if;
1835
1836 -- Recursively process AND and AND THEN branches
1837
1838 Process_Current_Value_Condition (Left_Opnd (Cond), True);
1839
1840 if Op /= N_Empty then
1841 return;
1842 end if;
1843
1844 Process_Current_Value_Condition (Right_Opnd (Cond), True);
1845 return;
1846
1847 -- Case of relational operator
1848
1849 elsif Nkind (Cond) in N_Op_Compare then
1850 Op := Nkind (Cond);
1851
1852 -- Invert sense of test if inverted test
1853
1854 if Sens = False then
1855 case Op is
1856 when N_Op_Eq => Op := N_Op_Ne;
1857 when N_Op_Ne => Op := N_Op_Eq;
1858 when N_Op_Lt => Op := N_Op_Ge;
1859 when N_Op_Gt => Op := N_Op_Le;
1860 when N_Op_Le => Op := N_Op_Gt;
1861 when N_Op_Ge => Op := N_Op_Lt;
1862 when others => raise Program_Error;
1863 end case;
1864 end if;
1865
1866 -- Case of entity op value
1867
1868 if Is_Entity_Name (Left_Opnd (Cond))
1869 and then Ent = Entity (Left_Opnd (Cond))
1870 and then Compile_Time_Known_Value (Right_Opnd (Cond))
1871 then
1872 Val := Right_Opnd (Cond);
1873
1874 -- Case of value op entity
1875
1876 elsif Is_Entity_Name (Right_Opnd (Cond))
1877 and then Ent = Entity (Right_Opnd (Cond))
1878 and then Compile_Time_Known_Value (Left_Opnd (Cond))
1879 then
1880 Val := Left_Opnd (Cond);
1881
1882 -- We are effectively swapping operands
1883
1884 case Op is
1885 when N_Op_Eq => null;
1886 when N_Op_Ne => null;
1887 when N_Op_Lt => Op := N_Op_Gt;
1888 when N_Op_Gt => Op := N_Op_Lt;
1889 when N_Op_Le => Op := N_Op_Ge;
1890 when N_Op_Ge => Op := N_Op_Le;
1891 when others => raise Program_Error;
1892 end case;
1893
1894 else
1895 Op := N_Empty;
1896 end if;
1897
1898 return;
1899
1900 -- Case of Boolean variable reference, return as though the
1901 -- reference had said var = True.
1902
1903 else
1904 if Is_Entity_Name (Cond)
1905 and then Ent = Entity (Cond)
1906 then
1907 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
1908
1909 if Sens = False then
1910 Op := N_Op_Ne;
1911 else
1912 Op := N_Op_Eq;
1913 end if;
1914 end if;
1915 end if;
1916 end Process_Current_Value_Condition;
1917
1918 -- Start of processing for Get_Current_Value_Condition
1919
fbf5a39b
AC		 1920 begin
1921 Op := N_Empty;
1922 Val := Empty;
1923
59e54267 1924 -- Immediate return, nothing doing, if this is not an object
fbf5a39b 1925
59e54267
ES		 1926 if Ekind (Ent) not in Object_Kind then
1927 return;
1928 end if;
fbf5a39b 1929
59e54267 1930 -- Otherwise examine current value
fbf5a39b 1931
59e54267
ES		 1932 declare
1933 CV : constant Node_Id := Current_Value (Ent);
1934 Sens : Boolean;
1935 Stm : Node_Id;
fbf5a39b 1936
59e54267
ES		 1937 begin
1938 -- If statement. Condition is known true in THEN section, known False
1939 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
fbf5a39b 1940
59e54267 1941 if Nkind (CV) = N_If_Statement then
fbf5a39b 1942
59e54267 1943 -- Before start of IF statement
fbf5a39b 1944
59e54267
ES		 1945 if Loc < Sloc (CV) then
1946 return;
fbf5a39b 1947
59e54267 1948 -- After end of IF statement
fbf5a39b 1949
59e54267
ES		 1950 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1951 return;
1952 end if;
fbf5a39b 1953
59e54267
ES		 1954 -- At this stage we know that we are within the IF statement, but
1955 -- unfortunately, the tree does not record the SLOC of the ELSE so
1956 -- we cannot use a simple SLOC comparison to distinguish between
1957 -- the then/else statements, so we have to climb the tree.
fbf5a39b 1958
59e54267
ES		 1959 declare
1960 N : Node_Id;
fbf5a39b 1961
59e54267
ES		 1962 begin
1963 N := Parent (Var);
1964 while Parent (N) /= CV loop
1965 N := Parent (N);
fbf5a39b 1966
59e54267
ES		 1967 -- If we fall off the top of the tree, then that's odd, but
1968 -- perhaps it could occur in some error situation, and the
1969 -- safest response is simply to assume that the outcome of
1970 -- the condition is unknown. No point in bombing during an
1971 -- attempt to optimize things.
fbf5a39b 1972
59e54267
ES		 1973 if No (N) then
1974 return;
1975 end if;
1976 end loop;
fbf5a39b 1977
59e54267
ES		 1978 -- Now we have N pointing to a node whose parent is the IF
1979 -- statement in question, so now we can tell if we are within
1980 -- the THEN statements.
fbf5a39b 1981
59e54267
ES		 1982 if Is_List_Member (N)
1983 and then List_Containing (N) = Then_Statements (CV)
1984 then
1985 Sens := True;
fbf5a39b 1986
05350ac6
BD		 1987 -- If the variable reference does not come from source, we
1988 -- cannot reliably tell whether it appears in the else part.
16b05213 1989 -- In particular, if it appears in generated code for a node
05350ac6
BD		 1990 -- that requires finalization, it may be attached to a list
1991 -- that has not been yet inserted into the code. For now,
1992 -- treat it as unknown.
1993
1994 elsif not Comes_From_Source (N) then
1995 return;
1996
1997 -- Otherwise we must be in ELSIF or ELSE part
fbf5a39b 1998
59e54267
ES		 1999 else
2000 Sens := False;
2001 end if;
2002 end;
fbf5a39b 2003
59e54267
ES		 2004 -- ELSIF part. Condition is known true within the referenced
2005 -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
2006 -- unknown before the ELSE part or after the IF statement.
fbf5a39b 2007
59e54267 2008 elsif Nkind (CV) = N_Elsif_Part then
196379c6
ES		 2009
2010 -- if the Elsif_Part had condition_actions, the elsif has been
2011 -- rewritten as a nested if, and the original elsif_part is
2012 -- detached from the tree, so there is no way to obtain useful
2013 -- information on the current value of the variable.
2014 -- Can this be improved ???
2015
2016 if No (Parent (CV)) then
2017 return;
2018 end if;
2019
59e54267 2020 Stm := Parent (CV);
fbf5a39b 2021
59e54267 2022 -- Before start of ELSIF part
fbf5a39b 2023
59e54267
ES		 2024 if Loc < Sloc (CV) then
2025 return;
fbf5a39b 2026
59e54267 2027 -- After end of IF statement
fbf5a39b 2028
59e54267
ES		 2029 elsif Loc >= Sloc (Stm) +
2030 Text_Ptr (UI_To_Int (End_Span (Stm)))
2031 then
2032 return;
2033 end if;
fbf5a39b 2034
59e54267
ES		 2035 -- Again we lack the SLOC of the ELSE, so we need to climb the
2036 -- tree to see if we are within the ELSIF part in question.
fbf5a39b 2037
59e54267
ES		 2038 declare
2039 N : Node_Id;
fbf5a39b 2040
59e54267
ES		 2041 begin
2042 N := Parent (Var);
2043 while Parent (N) /= Stm loop
2044 N := Parent (N);
fbf5a39b 2045
59e54267
ES		 2046 -- If we fall off the top of the tree, then that's odd, but
2047 -- perhaps it could occur in some error situation, and the
2048 -- safest response is simply to assume that the outcome of
2049 -- the condition is unknown. No point in bombing during an
2050 -- attempt to optimize things.
fbf5a39b 2051
59e54267
ES		 2052 if No (N) then
2053 return;
2054 end if;
2055 end loop;
fbf5a39b 2056
59e54267
ES		 2057 -- Now we have N pointing to a node whose parent is the IF
2058 -- statement in question, so see if is the ELSIF part we want.
2059 -- the THEN statements.
fbf5a39b 2060
59e54267
ES		 2061 if N = CV then
2062 Sens := True;
fbf5a39b 2063
e14c931f 2064 -- Otherwise we must be in subsequent ELSIF or ELSE part
fbf5a39b 2065
59e54267
ES		 2066 else
2067 Sens := False;
2068 end if;
2069 end;
fbf5a39b 2070
05350ac6
BD		 2071 -- Iteration scheme of while loop. The condition is known to be
2072 -- true within the body of the loop.
59e54267 2073
05350ac6
BD		 2074 elsif Nkind (CV) = N_Iteration_Scheme then
2075 declare
2076 Loop_Stmt : constant Node_Id := Parent (CV);
fbf5a39b 2077
05350ac6
BD		 2078 begin
2079 -- Before start of body of loop
fbf5a39b 2080
05350ac6
BD		 2081 if Loc < Sloc (Loop_Stmt) then
2082 return;
fbf5a39b 2083
05350ac6 2084 -- After end of LOOP statement
59e54267 2085
05350ac6
BD		 2086 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2087 return;
59e54267 2088
05350ac6 2089 -- We are within the body of the loop
59e54267 2090
05350ac6
BD		 2091 else
2092 Sens := True;
2093 end if;
2094 end;
fbf5a39b 2095
05350ac6 2096 -- All other cases of Current_Value settings
fbf5a39b 2097
05350ac6
BD		 2098 else
2099 return;
59e54267 2100 end if;
05350ac6
BD		 2101
2102 -- If we fall through here, then we have a reportable condition, Sens
2103 -- is True if the condition is true and False if it needs inverting.
2104
2105 Process_Current_Value_Condition (Condition (CV), Sens);
59e54267 2106 end;
fbf5a39b
AC		 2107 end Get_Current_Value_Condition;
2108
0712790c
ES		 2109 ---------------------------------
2110 -- Has_Controlled_Coextensions --
2111 ---------------------------------
2112
2113 function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
2114 D_Typ : Entity_Id;
2115 Discr : Entity_Id;
2116
2117 begin
2118 -- Only consider record types
2119
b29def53 2120 if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then
0712790c
ES		 2121 return False;
2122 end if;
2123
2124 if Has_Discriminants (Typ) then
2125 Discr := First_Discriminant (Typ);
2126 while Present (Discr) loop
2127 D_Typ := Etype (Discr);
2128
2129 if Ekind (D_Typ) = E_Anonymous_Access_Type
2130 and then
841dd0f5 2131 (Is_Controlled (Designated_Type (D_Typ))
0712790c 2132 or else
841dd0f5 2133 Is_Concurrent_Type (Designated_Type (D_Typ)))
0712790c
ES		 2134 then
2135 return True;
2136 end if;
2137
2138 Next_Discriminant (Discr);
2139 end loop;
2140 end if;
2141
2142 return False;
2143 end Has_Controlled_Coextensions;
2144
a5d83d61
AC		 2145 ------------------------
2146 -- Has_Address_Clause --
2147 ------------------------
2148
2149 -- Should this function check the private part in a package ???
2150
2151 function Has_Following_Address_Clause (D : Node_Id) return Boolean is
2152 Id : constant Entity_Id := Defining_Identifier (D);
2153 Decl : Node_Id;
2154
2155 begin
2156 Decl := Next (D);
2157 while Present (Decl) loop
2158 if Nkind (Decl) = N_At_Clause
2159 and then Chars (Identifier (Decl)) = Chars (Id)
2160 then
2161 return True;
2162
2163 elsif Nkind (Decl) = N_Attribute_Definition_Clause
2164 and then Chars (Decl) = Name_Address
2165 and then Chars (Name (Decl)) = Chars (Id)
2166 then
2167 return True;
2168 end if;
2169
2170 Next (Decl);
2171 end loop;
2172
2173 return False;
2174 end Has_Following_Address_Clause;
2175
70482933
RK		 2176 --------------------
2177 -- Homonym_Number --
2178 --------------------
2179
2180 function Homonym_Number (Subp : Entity_Id) return Nat is
2181 Count : Nat;
2182 Hom : Entity_Id;
2183
2184 begin
2185 Count := 1;
2186 Hom := Homonym (Subp);
2187 while Present (Hom) loop
2188 if Scope (Hom) = Scope (Subp) then
2189 Count := Count + 1;
2190 end if;
2191
2192 Hom := Homonym (Hom);
2193 end loop;
2194
2195 return Count;
2196 end Homonym_Number;
2197
2198 ------------------------------
2199 -- In_Unconditional_Context --
2200 ------------------------------
2201
2202 function In_Unconditional_Context (Node : Node_Id) return Boolean is
2203 P : Node_Id;
2204
2205 begin
2206 P := Node;
2207 while Present (P) loop
2208 case Nkind (P) is
2209 when N_Subprogram_Body =>
2210 return True;
2211
2212 when N_If_Statement =>
2213 return False;
2214
2215 when N_Loop_Statement =>
2216 return False;
2217
2218 when N_Case_Statement =>
2219 return False;
2220
2221 when others =>
2222 P := Parent (P);
2223 end case;
2224 end loop;
2225
2226 return False;
2227 end In_Unconditional_Context;
2228
2229 -------------------
2230 -- Insert_Action --
2231 -------------------
2232
2233 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
2234 begin
2235 if Present (Ins_Action) then
2236 Insert_Actions (Assoc_Node, New_List (Ins_Action));
2237 end if;
2238 end Insert_Action;
2239
2240 -- Version with check(s) suppressed
2241
2242 procedure Insert_Action
2243 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
2244 is
2245 begin
2246 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
2247 end Insert_Action;
2248
2249 --------------------
2250 -- Insert_Actions --
2251 --------------------
2252
2253 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
2254 N : Node_Id;
2255 P : Node_Id;
2256
2257 Wrapped_Node : Node_Id := Empty;
2258
2259 begin
2260 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
2261 return;
2262 end if;
2263
65df5b71
HK		 2264 -- Ignore insert of actions from inside default expression (or other
2265 -- similar "spec expression") in the special spec-expression analyze
2266 -- mode. Any insertions at this point have no relevance, since we are
2267 -- only doing the analyze to freeze the types of any static expressions.
2268 -- See section "Handling of Default Expressions" in the spec of package
2269 -- Sem for further details.
70482933 2270
65df5b71 2271 if In_Spec_Expression then
70482933
RK		 2272 return;
2273 end if;
2274
2275 -- If the action derives from stuff inside a record, then the actions
2276 -- are attached to the current scope, to be inserted and analyzed on
2277 -- exit from the scope. The reason for this is that we may also
2278 -- be generating freeze actions at the same time, and they must
2279 -- eventually be elaborated in the correct order.
2280
2281 if Is_Record_Type (Current_Scope)
2282 and then not Is_Frozen (Current_Scope)
2283 then
2284 if No (Scope_Stack.Table
2285 (Scope_Stack.Last).Pending_Freeze_Actions)
2286 then
2287 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
2288 Ins_Actions;
2289 else
2290 Append_List
2291 (Ins_Actions,
2292 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
2293 end if;
2294
2295 return;
2296 end if;
2297
2298 -- We now intend to climb up the tree to find the right point to
2299 -- insert the actions. We start at Assoc_Node, unless this node is
2300 -- a subexpression in which case we start with its parent. We do this
2301 -- for two reasons. First it speeds things up. Second, if Assoc_Node
2302 -- is itself one of the special nodes like N_And_Then, then we assume
2303 -- that an initial request to insert actions for such a node does not
2304 -- expect the actions to get deposited in the node for later handling
2305 -- when the node is expanded, since clearly the node is being dealt
2306 -- with by the caller. Note that in the subexpression case, N is
2307 -- always the child we came from.
2308
2309 -- N_Raise_xxx_Error is an annoying special case, it is a statement
2310 -- if it has type Standard_Void_Type, and a subexpression otherwise.
2311 -- otherwise. Procedure attribute references are also statements.
2312
2313 if Nkind (Assoc_Node) in N_Subexpr
2314 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
2315 or else Etype (Assoc_Node) /= Standard_Void_Type)
2316 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
2317 or else
2318 not Is_Procedure_Attribute_Name
2319 (Attribute_Name (Assoc_Node)))
2320 then
fbf5a39b 2321 P := Assoc_Node; -- ??? does not agree with above!
70482933
RK		 2322 N := Parent (Assoc_Node);
2323
2324 -- Non-subexpression case. Note that N is initially Empty in this
2325 -- case (N is only guaranteed Non-Empty in the subexpr case).
2326
2327 else
2328 P := Assoc_Node;
2329 N := Empty;
2330 end if;
2331
2332 -- Capture root of the transient scope
2333
2334 if Scope_Is_Transient then
05350ac6 2335 Wrapped_Node := Node_To_Be_Wrapped;
70482933
RK		 2336 end if;
2337
2338 loop
2339 pragma Assert (Present (P));
2340
2341 case Nkind (P) is
2342
2343 -- Case of right operand of AND THEN or OR ELSE. Put the actions
2344 -- in the Actions field of the right operand. They will be moved
2345 -- out further when the AND THEN or OR ELSE operator is expanded.
2346 -- Nothing special needs to be done for the left operand since
2347 -- in that case the actions are executed unconditionally.
2348
ac7120ce 2349 when N_Short_Circuit =>
70482933 2350 if N = Right_Opnd (P) then
ac4d6407
RD		 2351
2352 -- We are now going to either append the actions to the
2353 -- actions field of the short-circuit operation. We will
2354 -- also analyze the actions now.
2355
2356 -- This analysis is really too early, the proper thing would
2357 -- be to just park them there now, and only analyze them if
2358 -- we find we really need them, and to it at the proper
2359 -- final insertion point. However attempting to this proved
2360 -- tricky, so for now we just kill current values before and
2361 -- after the analyze call to make sure we avoid peculiar
2362 -- optimizations from this out of order insertion.
2363
2364 Kill_Current_Values;
2365
70482933
RK		 2366 if Present (Actions (P)) then
2367 Insert_List_After_And_Analyze
ac4d6407 2368 (Last (Actions (P)), Ins_Actions);
70482933
RK		 2369 else
2370 Set_Actions (P, Ins_Actions);
2371 Analyze_List (Actions (P));
2372 end if;
2373
ac4d6407
RD		 2374 Kill_Current_Values;
2375
70482933
RK		 2376 return;
2377 end if;
2378
2379 -- Then or Else operand of conditional expression. Add actions to
2380 -- Then_Actions or Else_Actions field as appropriate. The actions
2381 -- will be moved further out when the conditional is expanded.
2382
2383 when N_Conditional_Expression =>
2384 declare
2385 ThenX : constant Node_Id := Next (First (Expressions (P)));
2386 ElseX : constant Node_Id := Next (ThenX);
2387
2388 begin
2389 -- Actions belong to the then expression, temporarily
2390 -- place them as Then_Actions of the conditional expr.
2391 -- They will be moved to the proper place later when
2392 -- the conditional expression is expanded.
2393
2394 if N = ThenX then
2395 if Present (Then_Actions (P)) then
2396 Insert_List_After_And_Analyze
2397 (Last (Then_Actions (P)), Ins_Actions);
2398 else
2399 Set_Then_Actions (P, Ins_Actions);
2400 Analyze_List (Then_Actions (P));
2401 end if;
2402
2403 return;
2404
2405 -- Actions belong to the else expression, temporarily
2406 -- place them as Else_Actions of the conditional expr.
2407 -- They will be moved to the proper place later when
2408 -- the conditional expression is expanded.
2409
2410 elsif N = ElseX then
2411 if Present (Else_Actions (P)) then
2412 Insert_List_After_And_Analyze
2413 (Last (Else_Actions (P)), Ins_Actions);
2414 else
2415 Set_Else_Actions (P, Ins_Actions);
2416 Analyze_List (Else_Actions (P));
2417 end if;
2418
2419 return;
2420
2421 -- Actions belong to the condition. In this case they are
2422 -- unconditionally executed, and so we can continue the
2423 -- search for the proper insert point.
2424
2425 else
2426 null;
2427 end if;
2428 end;
2429
19d846a0
RD		 2430 -- Alternative of case expression, we place the action in
2431 -- the Actions field of the case expression alternative, this
2432 -- will be handled when the case expression is expanded.
2433
2434 when N_Case_Expression_Alternative =>
2435 if Present (Actions (P)) then
2436 Insert_List_After_And_Analyze
2437 (Last (Actions (P)), Ins_Actions);
2438 else
2439 Set_Actions (P, Ins_Actions);
2440 Analyze_List (Then_Actions (P));
2441 end if;
2442
2443 return;
2444
955871d3
AC		 2445 -- Case of appearing within an Expressions_With_Actions node. We
2446 -- prepend the actions to the list of actions already there.
2447
2448 when N_Expression_With_Actions =>
2449 Prepend_List (Ins_Actions, Actions (P));
2450 return;
2451
70482933
RK		 2452 -- Case of appearing in the condition of a while expression or
2453 -- elsif. We insert the actions into the Condition_Actions field.
2454 -- They will be moved further out when the while loop or elsif
2455 -- is analyzed.
2456
2457 when N_Iteration_Scheme |
2458 N_Elsif_Part
2459 =>
2460 if N = Condition (P) then
2461 if Present (Condition_Actions (P)) then
2462 Insert_List_After_And_Analyze
2463 (Last (Condition_Actions (P)), Ins_Actions);
2464 else
2465 Set_Condition_Actions (P, Ins_Actions);
2466
2467 -- Set the parent of the insert actions explicitly.
2468 -- This is not a syntactic field, but we need the
2469 -- parent field set, in particular so that freeze
2470 -- can understand that it is dealing with condition
2471 -- actions, and properly insert the freezing actions.
2472
2473 Set_Parent (Ins_Actions, P);
2474 Analyze_List (Condition_Actions (P));
2475 end if;
2476
2477 return;
2478 end if;
2479
bebbff91 2480 -- Statements, declarations, pragmas, representation clauses
70482933
RK		 2481
2482 when
2483 -- Statements
2484
2485 N_Procedure_Call_Statement |
2486 N_Statement_Other_Than_Procedure_Call |
2487
2488 -- Pragmas
2489
2490 N_Pragma |
2491
2492 -- Representation_Clause
2493
2494 N_At_Clause |
2495 N_Attribute_Definition_Clause |
2496 N_Enumeration_Representation_Clause |
2497 N_Record_Representation_Clause |
2498
2499 -- Declarations
2500
2501 N_Abstract_Subprogram_Declaration |
2502 N_Entry_Body |
2503 N_Exception_Declaration |
2504 N_Exception_Renaming_Declaration |
82c80734
RD		 2505 N_Formal_Abstract_Subprogram_Declaration |
2506 N_Formal_Concrete_Subprogram_Declaration |
70482933 2507 N_Formal_Object_Declaration |
70482933
RK		 2508 N_Formal_Type_Declaration |
2509 N_Full_Type_Declaration |
2510 N_Function_Instantiation |
2511 N_Generic_Function_Renaming_Declaration |
2512 N_Generic_Package_Declaration |
2513 N_Generic_Package_Renaming_Declaration |
2514 N_Generic_Procedure_Renaming_Declaration |
2515 N_Generic_Subprogram_Declaration |
2516 N_Implicit_Label_Declaration |
2517 N_Incomplete_Type_Declaration |
2518 N_Number_Declaration |
2519 N_Object_Declaration |
2520 N_Object_Renaming_Declaration |
2521 N_Package_Body |
2522 N_Package_Body_Stub |
2523 N_Package_Declaration |
2524 N_Package_Instantiation |
2525 N_Package_Renaming_Declaration |
2526 N_Private_Extension_Declaration |
2527 N_Private_Type_Declaration |
2528 N_Procedure_Instantiation |
19590d70 2529 N_Protected_Body |
70482933
RK		 2530 N_Protected_Body_Stub |
2531 N_Protected_Type_Declaration |
2532 N_Single_Task_Declaration |
2533 N_Subprogram_Body |
2534 N_Subprogram_Body_Stub |
2535 N_Subprogram_Declaration |
2536 N_Subprogram_Renaming_Declaration |
2537 N_Subtype_Declaration |
2538 N_Task_Body |
2539 N_Task_Body_Stub |
2540 N_Task_Type_Declaration |
2541
2542 -- Freeze entity behaves like a declaration or statement
2543
2544 N_Freeze_Entity
2545 =>
2546 -- Do not insert here if the item is not a list member (this
2547 -- happens for example with a triggering statement, and the
2548 -- proper approach is to insert before the entire select).
2549
2550 if not Is_List_Member (P) then
2551 null;
2552
2553 -- Do not insert if parent of P is an N_Component_Association
05350ac6
BD		 2554 -- node (i.e. we are in the context of an N_Aggregate or
2555 -- N_Extension_Aggregate node. In this case we want to insert
2556 -- before the entire aggregate.
70482933
RK		 2557
2558 elsif Nkind (Parent (P)) = N_Component_Association then
2559 null;
2560
2561 -- Do not insert if the parent of P is either an N_Variant
2562 -- node or an N_Record_Definition node, meaning in either
2563 -- case that P is a member of a component list, and that
2564 -- therefore the actions should be inserted outside the
2565 -- complete record declaration.
2566
2567 elsif Nkind (Parent (P)) = N_Variant
2568 or else Nkind (Parent (P)) = N_Record_Definition
2569 then
2570 null;
2571
2572 -- Do not insert freeze nodes within the loop generated for
2573 -- an aggregate, because they may be elaborated too late for
2574 -- subsequent use in the back end: within a package spec the
2575 -- loop is part of the elaboration procedure and is only
2576 -- elaborated during the second pass.
2577 -- If the loop comes from source, or the entity is local to
2578 -- the loop itself it must remain within.
2579
2580 elsif Nkind (Parent (P)) = N_Loop_Statement
2581 and then not Comes_From_Source (Parent (P))
2582 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
2583 and then
2584 Scope (Entity (First (Ins_Actions))) /= Current_Scope
2585 then
2586 null;
2587
2588 -- Otherwise we can go ahead and do the insertion
2589
05350ac6 2590 elsif P = Wrapped_Node then
70482933
RK		 2591 Store_Before_Actions_In_Scope (Ins_Actions);
2592 return;
2593
2594 else
2595 Insert_List_Before_And_Analyze (P, Ins_Actions);
2596 return;
2597 end if;
2598
2599 -- A special case, N_Raise_xxx_Error can act either as a
2600 -- statement or a subexpression. We tell the difference
2601 -- by looking at the Etype. It is set to Standard_Void_Type
2602 -- in the statement case.
2603
2604 when
2605 N_Raise_xxx_Error =>
2606 if Etype (P) = Standard_Void_Type then
2607 if P = Wrapped_Node then
2608 Store_Before_Actions_In_Scope (Ins_Actions);
2609 else
2610 Insert_List_Before_And_Analyze (P, Ins_Actions);
2611 end if;
2612
2613 return;
2614
2615 -- In the subexpression case, keep climbing
2616
2617 else
2618 null;
2619 end if;
2620
2621 -- If a component association appears within a loop created for
2622 -- an array aggregate, attach the actions to the association so
2623 -- they can be subsequently inserted within the loop. For other
fbf5a39b
AC		 2624 -- component associations insert outside of the aggregate. For
2625 -- an association that will generate a loop, its Loop_Actions
2626 -- attribute is already initialized (see exp_aggr.adb).
70482933
RK		 2627
2628 -- The list of loop_actions can in turn generate additional ones,
2629 -- that are inserted before the associated node. If the associated
2630 -- node is outside the aggregate, the new actions are collected
2631 -- at the end of the loop actions, to respect the order in which
2632 -- they are to be elaborated.
2633
2634 when
2635 N_Component_Association =>
2636 if Nkind (Parent (P)) = N_Aggregate
fbf5a39b 2637 and then Present (Loop_Actions (P))
70482933 2638 then
fbf5a39b 2639 if Is_Empty_List (Loop_Actions (P)) then
70482933
RK		 2640 Set_Loop_Actions (P, Ins_Actions);
2641 Analyze_List (Ins_Actions);
2642
2643 else
2644 declare
bebbff91 2645 Decl : Node_Id;
70482933
RK		 2646
2647 begin
2648 -- Check whether these actions were generated
2649 -- by a declaration that is part of the loop_
2650 -- actions for the component_association.
2651
bebbff91 2652 Decl := Assoc_Node;
70482933
RK		 2653 while Present (Decl) loop
2654 exit when Parent (Decl) = P
2655 and then Is_List_Member (Decl)
2656 and then
2657 List_Containing (Decl) = Loop_Actions (P);
2658 Decl := Parent (Decl);
2659 end loop;
2660
2661 if Present (Decl) then
2662 Insert_List_Before_And_Analyze
2663 (Decl, Ins_Actions);
2664 else
2665 Insert_List_After_And_Analyze
2666 (Last (Loop_Actions (P)), Ins_Actions);
2667 end if;
2668 end;
2669 end if;
2670
2671 return;
2672
2673 else
2674 null;
2675 end if;
2676
2677 -- Another special case, an attribute denoting a procedure call
2678
2679 when
2680 N_Attribute_Reference =>
2681 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
2682 if P = Wrapped_Node then
2683 Store_Before_Actions_In_Scope (Ins_Actions);
2684 else
2685 Insert_List_Before_And_Analyze (P, Ins_Actions);
2686 end if;
2687
2688 return;
2689
2690 -- In the subexpression case, keep climbing
2691
2692 else
2693 null;
2694 end if;
2695
2696 -- For all other node types, keep climbing tree
2697
2698 when
2699 N_Abortable_Part |
2700 N_Accept_Alternative |
2701 N_Access_Definition |
2702 N_Access_Function_Definition |
2703 N_Access_Procedure_Definition |
2704 N_Access_To_Object_Definition |
2705 N_Aggregate |
2706 N_Allocator |
19d846a0 2707 N_Case_Expression |
70482933
RK		 2708 N_Case_Statement_Alternative |
2709 N_Character_Literal |
2710 N_Compilation_Unit |
2711 N_Compilation_Unit_Aux |
2712 N_Component_Clause |
2713 N_Component_Declaration |
a397db96 2714 N_Component_Definition |
70482933
RK		 2715 N_Component_List |
2716 N_Constrained_Array_Definition |
2717 N_Decimal_Fixed_Point_Definition |
2718 N_Defining_Character_Literal |
2719 N_Defining_Identifier |
2720 N_Defining_Operator_Symbol |
2721 N_Defining_Program_Unit_Name |
2722 N_Delay_Alternative |
2723 N_Delta_Constraint |
2724 N_Derived_Type_Definition |
2725 N_Designator |
2726 N_Digits_Constraint |
2727 N_Discriminant_Association |
2728 N_Discriminant_Specification |
2729 N_Empty |
2730 N_Entry_Body_Formal_Part |
2731 N_Entry_Call_Alternative |
2732 N_Entry_Declaration |
2733 N_Entry_Index_Specification |
2734 N_Enumeration_Type_Definition |
2735 N_Error |
2736 N_Exception_Handler |
2737 N_Expanded_Name |
2738 N_Explicit_Dereference |
2739 N_Extension_Aggregate |
2740 N_Floating_Point_Definition |
2741 N_Formal_Decimal_Fixed_Point_Definition |
2742 N_Formal_Derived_Type_Definition |
2743 N_Formal_Discrete_Type_Definition |
2744 N_Formal_Floating_Point_Definition |
2745 N_Formal_Modular_Type_Definition |
2746 N_Formal_Ordinary_Fixed_Point_Definition |
2747 N_Formal_Package_Declaration |
2748 N_Formal_Private_Type_Definition |
2749 N_Formal_Signed_Integer_Type_Definition |
2750 N_Function_Call |
2751 N_Function_Specification |
2752 N_Generic_Association |
2753 N_Handled_Sequence_Of_Statements |
2754 N_Identifier |
2755 N_In |
2756 N_Index_Or_Discriminant_Constraint |
2757 N_Indexed_Component |
2758 N_Integer_Literal |
2759 N_Itype_Reference |
2760 N_Label |
2761 N_Loop_Parameter_Specification |
2762 N_Mod_Clause |
2763 N_Modular_Type_Definition |
2764 N_Not_In |
2765 N_Null |
2766 N_Op_Abs |
2767 N_Op_Add |
2768 N_Op_And |
2769 N_Op_Concat |
2770 N_Op_Divide |
2771 N_Op_Eq |
2772 N_Op_Expon |
2773 N_Op_Ge |
2774 N_Op_Gt |
2775 N_Op_Le |
2776 N_Op_Lt |
2777 N_Op_Minus |
2778 N_Op_Mod |
2779 N_Op_Multiply |
2780 N_Op_Ne |
2781 N_Op_Not |
2782 N_Op_Or |
2783 N_Op_Plus |
2784 N_Op_Rem |
2785 N_Op_Rotate_Left |
2786 N_Op_Rotate_Right |
2787 N_Op_Shift_Left |
2788 N_Op_Shift_Right |
2789 N_Op_Shift_Right_Arithmetic |
2790 N_Op_Subtract |
2791 N_Op_Xor |
2792 N_Operator_Symbol |
2793 N_Ordinary_Fixed_Point_Definition |
2794 N_Others_Choice |
2795 N_Package_Specification |
2796 N_Parameter_Association |
2797 N_Parameter_Specification |
dee4682a
JM		 2798 N_Pop_Constraint_Error_Label |
2799 N_Pop_Program_Error_Label |
2800 N_Pop_Storage_Error_Label |
70482933
RK		 2801 N_Pragma_Argument_Association |
2802 N_Procedure_Specification |
70482933 2803 N_Protected_Definition |
dee4682a
JM		 2804 N_Push_Constraint_Error_Label |
2805 N_Push_Program_Error_Label |
2806 N_Push_Storage_Error_Label |
70482933
RK		 2807 N_Qualified_Expression |
2808 N_Range |
2809 N_Range_Constraint |
2810 N_Real_Literal |
2811 N_Real_Range_Specification |
2812 N_Record_Definition |
2813 N_Reference |
327503f1
JM		 2814 N_SCIL_Dispatch_Table_Tag_Init |
2815 N_SCIL_Dispatching_Call |
82878151 2816 N_SCIL_Membership_Test |
70482933
RK		 2817 N_Selected_Component |
2818 N_Signed_Integer_Type_Definition |
2819 N_Single_Protected_Declaration |
2820 N_Slice |
2821 N_String_Literal |
2822 N_Subprogram_Info |
2823 N_Subtype_Indication |
2824 N_Subunit |
2825 N_Task_Definition |
2826 N_Terminate_Alternative |
2827 N_Triggering_Alternative |
2828 N_Type_Conversion |
2829 N_Unchecked_Expression |
2830 N_Unchecked_Type_Conversion |
2831 N_Unconstrained_Array_Definition |
2832 N_Unused_At_End |
2833 N_Unused_At_Start |
2834 N_Use_Package_Clause |
2835 N_Use_Type_Clause |
2836 N_Variant |
2837 N_Variant_Part |
2838 N_Validate_Unchecked_Conversion |
0712790c 2839 N_With_Clause
70482933
RK		 2840 =>
2841 null;
2842
2843 end case;
2844
2845 -- Make sure that inserted actions stay in the transient scope
2846
2847 if P = Wrapped_Node then
2848 Store_Before_Actions_In_Scope (Ins_Actions);
2849 return;
2850 end if;
2851
2852 -- If we fall through above tests, keep climbing tree
2853
2854 N := P;
2855
2856 if Nkind (Parent (N)) = N_Subunit then
2857
2858 -- This is the proper body corresponding to a stub. Insertion
2859 -- must be done at the point of the stub, which is in the decla-
e14c931f 2860 -- rative part of the parent unit.
70482933
RK		 2861
2862 P := Corresponding_Stub (Parent (N));
2863
2864 else
2865 P := Parent (N);
2866 end if;
2867 end loop;
70482933
RK		 2868 end Insert_Actions;
2869
2870 -- Version with check(s) suppressed
2871
2872 procedure Insert_Actions
0712790c
ES		 2873 (Assoc_Node : Node_Id;
2874 Ins_Actions : List_Id;
2875 Suppress : Check_Id)
70482933
RK		 2876 is
2877 begin
2878 if Suppress = All_Checks then
2879 declare
fbf5a39b 2880 Svg : constant Suppress_Array := Scope_Suppress;
70482933
RK		 2881 begin
2882 Scope_Suppress := (others => True);
2883 Insert_Actions (Assoc_Node, Ins_Actions);
2884 Scope_Suppress := Svg;
2885 end;
2886
2887 else
2888 declare
fbf5a39b 2889 Svg : constant Boolean := Scope_Suppress (Suppress);
70482933 2890 begin
fbf5a39b 2891 Scope_Suppress (Suppress) := True;
70482933 2892 Insert_Actions (Assoc_Node, Ins_Actions);
fbf5a39b 2893 Scope_Suppress (Suppress) := Svg;
70482933
RK		 2894 end;
2895 end if;
2896 end Insert_Actions;
2897
2898 --------------------------
2899 -- Insert_Actions_After --
2900 --------------------------
2901
2902 procedure Insert_Actions_After
2903 (Assoc_Node : Node_Id;
2904 Ins_Actions : List_Id)
2905 is
2906 begin
2907 if Scope_Is_Transient
2908 and then Assoc_Node = Node_To_Be_Wrapped
2909 then
2910 Store_After_Actions_In_Scope (Ins_Actions);
2911 else
2912 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2913 end if;
2914 end Insert_Actions_After;
2915
2916 ---------------------------------
2917 -- Insert_Library_Level_Action --
2918 ---------------------------------
2919
2920 procedure Insert_Library_Level_Action (N : Node_Id) is
2921 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2922
2923 begin
0712790c
ES		 2924 Push_Scope (Cunit_Entity (Main_Unit));
2925 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
70482933
RK		 2926
2927 if No (Actions (Aux)) then
2928 Set_Actions (Aux, New_List (N));
2929 else
2930 Append (N, Actions (Aux));
2931 end if;
2932
2933 Analyze (N);
2934 Pop_Scope;
2935 end Insert_Library_Level_Action;
2936
2937 ----------------------------------
2938 -- Insert_Library_Level_Actions --
2939 ----------------------------------
2940
2941 procedure Insert_Library_Level_Actions (L : List_Id) is
2942 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2943
2944 begin
2945 if Is_Non_Empty_List (L) then
0712790c
ES		 2946 Push_Scope (Cunit_Entity (Main_Unit));
2947 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
70482933
RK		 2948
2949 if No (Actions (Aux)) then
2950 Set_Actions (Aux, L);
2951 Analyze_List (L);
2952 else
2953 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2954 end if;
2955
2956 Pop_Scope;
2957 end if;
2958 end Insert_Library_Level_Actions;
2959
2960 ----------------------
2961 -- Inside_Init_Proc --
2962 ----------------------
2963
2964 function Inside_Init_Proc return Boolean is
2965 S : Entity_Id;
2966
2967 begin
2968 S := Current_Scope;
fbf5a39b
AC		 2969 while Present (S)
2970 and then S /= Standard_Standard
2971 loop
2972 if Is_Init_Proc (S) then
70482933
RK		 2973 return True;
2974 else
2975 S := Scope (S);
2976 end if;
2977 end loop;
2978
2979 return False;
2980 end Inside_Init_Proc;
2981
fbf5a39b
AC		 2982 ----------------------------
2983 -- Is_All_Null_Statements --
2984 ----------------------------
2985
2986 function Is_All_Null_Statements (L : List_Id) return Boolean is
2987 Stm : Node_Id;
2988
2989 begin
2990 Stm := First (L);
2991 while Present (Stm) loop
2992 if Nkind (Stm) /= N_Null_Statement then
2993 return False;
2994 end if;
2995
2996 Next (Stm);
2997 end loop;
2998
2999 return True;
3000 end Is_All_Null_Statements;
3001
6fb4cdde
AC		 3002 ---------------------------------
3003 -- Is_Fully_Repped_Tagged_Type --
3004 ---------------------------------
3005
3006 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
3007 U : constant Entity_Id := Underlying_Type (T);
3008 Comp : Entity_Id;
3009
3010 begin
3011 if No (U) or else not Is_Tagged_Type (U) then
3012 return False;
3013 elsif Has_Discriminants (U) then
3014 return False;
3015 elsif not Has_Specified_Layout (U) then
3016 return False;
3017 end if;
3018
3019 -- Here we have a tagged type, see if it has any unlayed out fields
3020 -- other than a possible tag and parent fields. If so, we return False.
3021
3022 Comp := First_Component (U);
3023 while Present (Comp) loop
3024 if not Is_Tag (Comp)
3025 and then Chars (Comp) /= Name_uParent
3026 and then No (Component_Clause (Comp))
3027 then
3028 return False;
3029 else
3030 Next_Component (Comp);
3031 end if;
3032 end loop;
3033
3034 -- All components are layed out
3035
3036 return True;
3037 end Is_Fully_Repped_Tagged_Type;
3038
86cde7b1
RD		 3039 ----------------------------------
3040 -- Is_Library_Level_Tagged_Type --
3041 ----------------------------------
3042
3043 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
3044 begin
3045 return Is_Tagged_Type (Typ)
3046 and then Is_Library_Level_Entity (Typ);
3047 end Is_Library_Level_Tagged_Type;
3048
fbf5a39b
AC		 3049 ----------------------------------
3050 -- Is_Possibly_Unaligned_Object --
3051 ----------------------------------
3052
f44fe430
RD		 3053 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
3054 T : constant Entity_Id := Etype (N);
3055
fbf5a39b 3056 begin
f44fe430 3057 -- If renamed object, apply test to underlying object
fbf5a39b 3058
f44fe430
RD		 3059 if Is_Entity_Name (N)
3060 and then Is_Object (Entity (N))
3061 and then Present (Renamed_Object (Entity (N)))
3062 then
3063 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
fbf5a39b
AC		 3064 end if;
3065
f44fe430
RD		 3066 -- Tagged and controlled types and aliased types are always aligned,
3067 -- as are concurrent types.
fbf5a39b 3068
f44fe430
RD		 3069 if Is_Aliased (T)
3070 or else Has_Controlled_Component (T)
3071 or else Is_Concurrent_Type (T)
3072 or else Is_Tagged_Type (T)
3073 or else Is_Controlled (T)
fbf5a39b 3074 then
f44fe430 3075 return False;
fbf5a39b
AC		 3076 end if;
3077
3078 -- If this is an element of a packed array, may be unaligned
3079
f44fe430 3080 if Is_Ref_To_Bit_Packed_Array (N) then
fbf5a39b
AC		 3081 return True;
3082 end if;
3083
3084 -- Case of component reference
3085
f44fe430
RD		 3086 if Nkind (N) = N_Selected_Component then
3087 declare
3088 P : constant Node_Id := Prefix (N);
3089 C : constant Entity_Id := Entity (Selector_Name (N));
3090 M : Nat;
3091 S : Nat;
fbf5a39b 3092
f44fe430
RD		 3093 begin
3094 -- If component reference is for an array with non-static bounds,
758c442c
GD		 3095 -- then it is always aligned: we can only process unaligned
3096 -- arrays with static bounds (more accurately bounds known at
3097 -- compile time).
fbf5a39b 3098
f44fe430
RD		 3099 if Is_Array_Type (T)
3100 and then not Compile_Time_Known_Bounds (T)
3101 then
3102 return False;
3103 end if;
fbf5a39b 3104
f44fe430 3105 -- If component is aliased, it is definitely properly aligned
fbf5a39b 3106
f44fe430
RD		 3107 if Is_Aliased (C) then
3108 return False;
3109 end if;
3110
3111 -- If component is for a type implemented as a scalar, and the
3112 -- record is packed, and the component is other than the first
3113 -- component of the record, then the component may be unaligned.
3114
3115 if Is_Packed (Etype (P))
8adcacef
RD		 3116 and then Represented_As_Scalar (Etype (C))
3117 and then First_Entity (Scope (C)) /= C
f44fe430
RD		 3118 then
3119 return True;
3120 end if;
3121
3122 -- Compute maximum possible alignment for T
3123
3124 -- If alignment is known, then that settles things
3125
3126 if Known_Alignment (T) then
3127 M := UI_To_Int (Alignment (T));
3128
3129 -- If alignment is not known, tentatively set max alignment
3130
3131 else
3132 M := Ttypes.Maximum_Alignment;
3133
3134 -- We can reduce this if the Esize is known since the default
3135 -- alignment will never be more than the smallest power of 2
3136 -- that does not exceed this Esize value.
3137
3138 if Known_Esize (T) then
3139 S := UI_To_Int (Esize (T));
3140
3141 while (M / 2) >= S loop
3142 M := M / 2;
3143 end loop;
3144 end if;
3145 end if;
3146
87dc09cb
AC		 3147 -- The following code is historical, it used to be present but it
3148 -- is too cautious, because the front-end does not know the proper
3149 -- default alignments for the target. Also, if the alignment is
3150 -- not known, the front end can't know in any case! If a copy is
3151 -- needed, the back-end will take care of it. This whole section
3152 -- including this comment can be removed later ???
3153
f44fe430
RD		 3154 -- If the component reference is for a record that has a specified
3155 -- alignment, and we either know it is too small, or cannot tell,
87dc09cb
AC		 3156 -- then the component may be unaligned.
3157
3158 -- if Known_Alignment (Etype (P))
3159 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
3160 -- and then M > Alignment (Etype (P))
3161 -- then
3162 -- return True;
3163 -- end if;
f44fe430
RD		 3164
3165 -- Case of component clause present which may specify an
3166 -- unaligned position.
3167
3168 if Present (Component_Clause (C)) then
3169
3170 -- Otherwise we can do a test to make sure that the actual
3171 -- start position in the record, and the length, are both
3172 -- consistent with the required alignment. If not, we know
3173 -- that we are unaligned.
3174
3175 declare
3176 Align_In_Bits : constant Nat := M * System_Storage_Unit;
3177 begin
3178 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
3179 or else Esize (C) mod Align_In_Bits /= 0
3180 then
3181 return True;
3182 end if;
3183 end;
3184 end if;
3185
3186 -- Otherwise, for a component reference, test prefix
3187
3188 return Is_Possibly_Unaligned_Object (P);
3189 end;
fbf5a39b
AC		 3190
3191 -- If not a component reference, must be aligned
3192
3193 else
3194 return False;
3195 end if;
3196 end Is_Possibly_Unaligned_Object;
3197
3198 ---------------------------------
3199 -- Is_Possibly_Unaligned_Slice --
3200 ---------------------------------
3201
f44fe430 3202 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
fbf5a39b 3203 begin
0712790c 3204 -- Go to renamed object
246d2ceb 3205
f44fe430
RD		 3206 if Is_Entity_Name (N)
3207 and then Is_Object (Entity (N))
3208 and then Present (Renamed_Object (Entity (N)))
fbf5a39b 3209 then
f44fe430 3210 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
fbf5a39b
AC		 3211 end if;
3212
246d2ceb 3213 -- The reference must be a slice
fbf5a39b 3214
f44fe430 3215 if Nkind (N) /= N_Slice then
246d2ceb 3216 return False;
fbf5a39b
AC		 3217 end if;
3218
246d2ceb
AC		 3219 -- Always assume the worst for a nested record component with a
3220 -- component clause, which gigi/gcc does not appear to handle well.
3221 -- It is not clear why this special test is needed at all ???
fbf5a39b 3222
f44fe430
RD		 3223 if Nkind (Prefix (N)) = N_Selected_Component
3224 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
246d2ceb 3225 and then
f44fe430 3226 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
246d2ceb
AC		 3227 then
3228 return True;
3229 end if;
3230
3231 -- We only need to worry if the target has strict alignment
3232
3233 if not Target_Strict_Alignment then
fbf5a39b
AC		 3234 return False;
3235 end if;
3236
3237 -- If it is a slice, then look at the array type being sliced
3238
3239 declare
f44fe430 3240 Sarr : constant Node_Id := Prefix (N);
246d2ceb
AC		 3241 -- Prefix of the slice, i.e. the array being sliced
3242
f44fe430 3243 Styp : constant Entity_Id := Etype (Prefix (N));
246d2ceb
AC		 3244 -- Type of the array being sliced
3245
3246 Pref : Node_Id;
3247 Ptyp : Entity_Id;
fbf5a39b
AC		 3248
3249 begin
246d2ceb
AC		 3250 -- The problems arise if the array object that is being sliced
3251 -- is a component of a record or array, and we cannot guarantee
3252 -- the alignment of the array within its containing object.
fbf5a39b 3253
246d2ceb
AC		 3254 -- To investigate this, we look at successive prefixes to see
3255 -- if we have a worrisome indexed or selected component.
fbf5a39b 3256
246d2ceb
AC		 3257 Pref := Sarr;
3258 loop
3259 -- Case of array is part of an indexed component reference
fbf5a39b 3260
246d2ceb
AC		 3261 if Nkind (Pref) = N_Indexed_Component then
3262 Ptyp := Etype (Prefix (Pref));
3263
3264 -- The only problematic case is when the array is packed,
3265 -- in which case we really know nothing about the alignment
3266 -- of individual components.
3267
3268 if Is_Bit_Packed_Array (Ptyp) then
3269 return True;
3270 end if;
3271
3272 -- Case of array is part of a selected component reference
3273
3274 elsif Nkind (Pref) = N_Selected_Component then
3275 Ptyp := Etype (Prefix (Pref));
3276
3277 -- We are definitely in trouble if the record in question
3278 -- has an alignment, and either we know this alignment is
3279 -- inconsistent with the alignment of the slice, or we
3280 -- don't know what the alignment of the slice should be.
3281
3282 if Known_Alignment (Ptyp)
3283 and then (Unknown_Alignment (Styp)
3284 or else Alignment (Styp) > Alignment (Ptyp))
3285 then
3286 return True;
3287 end if;
3288
3289 -- We are in potential trouble if the record type is packed.
3290 -- We could special case when we know that the array is the
3291 -- first component, but that's not such a simple case ???
3292
3293 if Is_Packed (Ptyp) then
3294 return True;
3295 end if;
3296
3297 -- We are in trouble if there is a component clause, and
3298 -- either we do not know the alignment of the slice, or
3299 -- the alignment of the slice is inconsistent with the
3300 -- bit position specified by the component clause.
3301
3302 declare
3303 Field : constant Entity_Id := Entity (Selector_Name (Pref));
3304 begin
3305 if Present (Component_Clause (Field))
3306 and then
3307 (Unknown_Alignment (Styp)
3308 or else
3309 (Component_Bit_Offset (Field) mod
3310 (System_Storage_Unit * Alignment (Styp))) /= 0)
3311 then
3312 return True;
3313 end if;
3314 end;
3315
3316 -- For cases other than selected or indexed components we
3317 -- know we are OK, since no issues arise over alignment.
3318
3319 else
3320 return False;
3321 end if;
3322
3323 -- We processed an indexed component or selected component
3324 -- reference that looked safe, so keep checking prefixes.
3325
3326 Pref := Prefix (Pref);
3327 end loop;
fbf5a39b
AC		 3328 end;
3329 end Is_Possibly_Unaligned_Slice;
3330
70482933
RK		 3331 --------------------------------
3332 -- Is_Ref_To_Bit_Packed_Array --
3333 --------------------------------
3334
f44fe430 3335 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
70482933
RK		 3336 Result : Boolean;
3337 Expr : Node_Id;
3338
3339 begin
f44fe430
RD		 3340 if Is_Entity_Name (N)
3341 and then Is_Object (Entity (N))
3342 and then Present (Renamed_Object (Entity (N)))
fbf5a39b 3343 then
f44fe430 3344 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
fbf5a39b
AC		 3345 end if;
3346
f44fe430 3347 if Nkind (N) = N_Indexed_Component
70482933 3348 or else
f44fe430 3349 Nkind (N) = N_Selected_Component
70482933 3350 then
f44fe430 3351 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
70482933
RK		 3352 Result := True;
3353 else
f44fe430 3354 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
70482933
RK		 3355 end if;
3356
f44fe430
RD		 3357 if Result and then Nkind (N) = N_Indexed_Component then
3358 Expr := First (Expressions (N));
70482933
RK		 3359 while Present (Expr) loop
3360 Force_Evaluation (Expr);
3361 Next (Expr);
3362 end loop;
3363 end if;
3364
3365 return Result;
3366
3367 else
3368 return False;
3369 end if;
3370 end Is_Ref_To_Bit_Packed_Array;
3371
3372 --------------------------------
fbf5a39b 3373 -- Is_Ref_To_Bit_Packed_Slice --
70482933
RK		 3374 --------------------------------
3375
f44fe430 3376 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
70482933 3377 begin
ea985d95
RD		 3378 if Nkind (N) = N_Type_Conversion then
3379 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
3380
3381 elsif Is_Entity_Name (N)
f44fe430
RD		 3382 and then Is_Object (Entity (N))
3383 and then Present (Renamed_Object (Entity (N)))
fbf5a39b 3384 then
f44fe430 3385 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
fbf5a39b 3386
ea985d95 3387 elsif Nkind (N) = N_Slice
f44fe430 3388 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
70482933
RK		 3389 then
3390 return True;
3391
f44fe430 3392 elsif Nkind (N) = N_Indexed_Component
70482933 3393 or else
f44fe430 3394 Nkind (N) = N_Selected_Component
70482933 3395 then
f44fe430 3396 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
70482933
RK		 3397
3398 else
3399 return False;
3400 end if;
3401 end Is_Ref_To_Bit_Packed_Slice;
3402
3403 -----------------------
3404 -- Is_Renamed_Object --
3405 -----------------------
3406
3407 function Is_Renamed_Object (N : Node_Id) return Boolean is
3408 Pnod : constant Node_Id := Parent (N);
3409 Kind : constant Node_Kind := Nkind (Pnod);
70482933
RK		 3410 begin
3411 if Kind = N_Object_Renaming_Declaration then
3412 return True;
6fb4cdde 3413 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
70482933 3414 return Is_Renamed_Object (Pnod);
70482933
RK		 3415 else
3416 return False;
3417 end if;
3418 end Is_Renamed_Object;
3419
3420 ----------------------------
3421 -- Is_Untagged_Derivation --
3422 ----------------------------
3423
3424 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
3425 begin
3426 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
3427 or else
3428 (Is_Private_Type (T) and then Present (Full_View (T))
3429 and then not Is_Tagged_Type (Full_View (T))
3430 and then Is_Derived_Type (Full_View (T))
3431 and then Etype (Full_View (T)) /= T);
70482933
RK		 3432 end Is_Untagged_Derivation;
3433
65df5b71
HK		 3434 ---------------------------
3435 -- Is_Volatile_Reference --
3436 ---------------------------
3437
3438 function Is_Volatile_Reference (N : Node_Id) return Boolean is
3439 begin
3440 if Nkind (N) in N_Has_Etype
3441 and then Present (Etype (N))
3442 and then Treat_As_Volatile (Etype (N))
3443 then
3444 return True;
3445
3446 elsif Is_Entity_Name (N) then
3447 return Treat_As_Volatile (Entity (N));
3448
3449 elsif Nkind (N) = N_Slice then
3450 return Is_Volatile_Reference (Prefix (N));
3451
3452 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
3453 if (Is_Entity_Name (Prefix (N))
3454 and then Has_Volatile_Components (Entity (Prefix (N))))
3455 or else (Present (Etype (Prefix (N)))
3456 and then Has_Volatile_Components (Etype (Prefix (N))))
3457 then
3458 return True;
3459 else
3460 return Is_Volatile_Reference (Prefix (N));
3461 end if;
3462
3463 else
3464 return False;
3465 end if;
3466 end Is_Volatile_Reference;
3467
70482933
RK		 3468 --------------------
3469 -- Kill_Dead_Code --
3470 --------------------
3471
05350ac6 3472 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
3acdda2d
AC		 3473 W : Boolean := Warn;
3474 -- Set False if warnings suppressed
3475
70482933
RK		 3476 begin
3477 if Present (N) then
70482933
RK		 3478 Remove_Warning_Messages (N);
3479
3acdda2d
AC		 3480 -- Generate warning if appropriate
3481
3482 if W then
3483
3484 -- We suppress the warning if this code is under control of an
3485 -- if statement, whose condition is a simple identifier, and
3486 -- either we are in an instance, or warnings off is set for this
3487 -- identifier. The reason for killing it in the instance case is
3488 -- that it is common and reasonable for code to be deleted in
3489 -- instances for various reasons.
3490
3491 if Nkind (Parent (N)) = N_If_Statement then
3492 declare
3493 C : constant Node_Id := Condition (Parent (N));
3494 begin
3495 if Nkind (C) = N_Identifier
3496 and then
3497 (In_Instance
3498 or else (Present (Entity (C))
3499 and then Has_Warnings_Off (Entity (C))))
3500 then
3501 W := False;
3502 end if;
3503 end;
3504 end if;
3505
3506 -- Generate warning if not suppressed
3507
3508 if W then
ed2233dc 3509 Error_Msg_F
3acdda2d
AC		 3510 ("?this code can never be executed and has been deleted!", N);
3511 end if;
05350ac6
BD		 3512 end if;
3513
07fc65c4 3514 -- Recurse into block statements and bodies to process declarations
3acdda2d 3515 -- and statements.
70482933 3516
07fc65c4
GB		 3517 if Nkind (N) = N_Block_Statement
3518 or else Nkind (N) = N_Subprogram_Body
3519 or else Nkind (N) = N_Package_Body
3520 then
569f538b
TQ		 3521 Kill_Dead_Code (Declarations (N), False);
3522 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
70482933 3523
07fc65c4
GB		 3524 if Nkind (N) = N_Subprogram_Body then
3525 Set_Is_Eliminated (Defining_Entity (N));
3526 end if;
3527
f44fe430
RD		 3528 elsif Nkind (N) = N_Package_Declaration then
3529 Kill_Dead_Code (Visible_Declarations (Specification (N)));
3530 Kill_Dead_Code (Private_Declarations (Specification (N)));
3531
569f538b
TQ		 3532 -- ??? After this point, Delete_Tree has been called on all
3533 -- declarations in Specification (N), so references to
3534 -- entities therein look suspicious.
3535
f44fe430
RD		 3536 declare
3537 E : Entity_Id := First_Entity (Defining_Entity (N));
3538 begin
3539 while Present (E) loop
3540 if Ekind (E) = E_Operator then
3541 Set_Is_Eliminated (E);
3542 end if;
3543
3544 Next_Entity (E);
3545 end loop;
3546 end;
3547
70482933
RK		 3548 -- Recurse into composite statement to kill individual statements,
3549 -- in particular instantiations.
3550
3551 elsif Nkind (N) = N_If_Statement then
3552 Kill_Dead_Code (Then_Statements (N));
3553 Kill_Dead_Code (Elsif_Parts (N));
3554 Kill_Dead_Code (Else_Statements (N));
3555
3556 elsif Nkind (N) = N_Loop_Statement then
3557 Kill_Dead_Code (Statements (N));
3558
3559 elsif Nkind (N) = N_Case_Statement then
3560 declare
bebbff91 3561 Alt : Node_Id;
70482933 3562 begin
bebbff91 3563 Alt := First (Alternatives (N));
70482933
RK		 3564 while Present (Alt) loop
3565 Kill_Dead_Code (Statements (Alt));
3566 Next (Alt);
3567 end loop;
3568 end;
3569
fbf5a39b
AC		 3570 elsif Nkind (N) = N_Case_Statement_Alternative then
3571 Kill_Dead_Code (Statements (N));
3572
70482933
RK		 3573 -- Deal with dead instances caused by deleting instantiations
3574
3575 elsif Nkind (N) in N_Generic_Instantiation then
3576 Remove_Dead_Instance (N);
3577 end if;
70482933
RK		 3578 end if;
3579 end Kill_Dead_Code;
3580
3581 -- Case where argument is a list of nodes to be killed
3582
05350ac6 3583 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
70482933 3584 N : Node_Id;
05350ac6 3585 W : Boolean;
70482933 3586 begin
05350ac6 3587 W := Warn;
70482933 3588 if Is_Non_Empty_List (L) then
ac4d6407
RD		 3589 N := First (L);
3590 while Present (N) loop
05350ac6
BD		 3591 Kill_Dead_Code (N, W);
3592 W := False;
ac4d6407 3593 Next (N);
70482933
RK		 3594 end loop;
3595 end if;
3596 end Kill_Dead_Code;
3597
3598 ------------------------
3599 -- Known_Non_Negative --
3600 ------------------------
3601
3602 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
3603 begin
3604 if Is_OK_Static_Expression (Opnd)
3605 and then Expr_Value (Opnd) >= 0
3606 then
3607 return True;
3608
3609 else
3610 declare
3611 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
3612
3613 begin
3614 return
3615 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
3616 end;
3617 end if;
3618 end Known_Non_Negative;
3619
fbf5a39b
AC		 3620 --------------------
3621 -- Known_Non_Null --
3622 --------------------
07fc65c4 3623
fbf5a39b
AC		 3624 function Known_Non_Null (N : Node_Id) return Boolean is
3625 begin
59e54267 3626 -- Checks for case where N is an entity reference
07fc65c4 3627
59e54267
ES		 3628 if Is_Entity_Name (N) and then Present (Entity (N)) then
3629 declare
3630 E : constant Entity_Id := Entity (N);
3631 Op : Node_Kind;
3632 Val : Node_Id;
07fc65c4 3633
59e54267
ES		 3634 begin
3635 -- First check if we are in decisive conditional
07fc65c4 3636
59e54267 3637 Get_Current_Value_Condition (N, Op, Val);
07fc65c4 3638
86cde7b1 3639 if Known_Null (Val) then
59e54267
ES		 3640 if Op = N_Op_Eq then
3641 return False;
3642 elsif Op = N_Op_Ne then
3643 return True;
3644 end if;
3645 end if;
07fc65c4 3646
59e54267 3647 -- If OK to do replacement, test Is_Known_Non_Null flag
07fc65c4 3648
59e54267
ES		 3649 if OK_To_Do_Constant_Replacement (E) then
3650 return Is_Known_Non_Null (E);
3651
3652 -- Otherwise if not safe to do replacement, then say so
3653
3654 else
3655 return False;
3656 end if;
3657 end;
07fc65c4 3658
fbf5a39b 3659 -- True if access attribute
07fc65c4 3660
fbf5a39b
AC		 3661 elsif Nkind (N) = N_Attribute_Reference
3662 and then (Attribute_Name (N) = Name_Access
3663 or else
3664 Attribute_Name (N) = Name_Unchecked_Access
3665 or else
3666 Attribute_Name (N) = Name_Unrestricted_Access)
3667 then
3668 return True;
07fc65c4 3669
fbf5a39b 3670 -- True if allocator
07fc65c4 3671
fbf5a39b
AC		 3672 elsif Nkind (N) = N_Allocator then
3673 return True;
07fc65c4 3674
fbf5a39b 3675 -- For a conversion, true if expression is known non-null
07fc65c4 3676
fbf5a39b
AC		 3677 elsif Nkind (N) = N_Type_Conversion then
3678 return Known_Non_Null (Expression (N));
07fc65c4 3679
59e54267
ES		 3680 -- Above are all cases where the value could be determined to be
3681 -- non-null. In all other cases, we don't know, so return False.
07fc65c4 3682
59e54267
ES		 3683 else
3684 return False;
3685 end if;
3686 end Known_Non_Null;
3687
3688 ----------------
3689 -- Known_Null --
3690 ----------------
3691
3692 function Known_Null (N : Node_Id) return Boolean is
3693 begin
3694 -- Checks for case where N is an entity reference
3695
3696 if Is_Entity_Name (N) and then Present (Entity (N)) then
fbf5a39b 3697 declare
59e54267 3698 E : constant Entity_Id := Entity (N);
fbf5a39b
AC		 3699 Op : Node_Kind;
3700 Val : Node_Id;
07fc65c4 3701
fbf5a39b 3702 begin
86cde7b1
RD		 3703 -- Constant null value is for sure null
3704
3705 if Ekind (E) = E_Constant
3706 and then Known_Null (Constant_Value (E))
3707 then
3708 return True;
3709 end if;
3710
59e54267
ES		 3711 -- First check if we are in decisive conditional
3712
fbf5a39b 3713 Get_Current_Value_Condition (N, Op, Val);
59e54267 3714
86cde7b1 3715 if Known_Null (Val) then
59e54267
ES		 3716 if Op = N_Op_Eq then
3717 return True;
3718 elsif Op = N_Op_Ne then
3719 return False;
3720 end if;
3721 end if;
3722
3723 -- If OK to do replacement, test Is_Known_Null flag
3724
3725 if OK_To_Do_Constant_Replacement (E) then
3726 return Is_Known_Null (E);
3727
3728 -- Otherwise if not safe to do replacement, then say so
3729
3730 else
3731 return False;
3732 end if;
fbf5a39b
AC		 3733 end;
3734
59e54267
ES		 3735 -- True if explicit reference to null
3736
3737 elsif Nkind (N) = N_Null then
3738 return True;
3739
3740 -- For a conversion, true if expression is known null
3741
3742 elsif Nkind (N) = N_Type_Conversion then
3743 return Known_Null (Expression (N));
3744
3745 -- Above are all cases where the value could be determined to be null.
3746 -- In all other cases, we don't know, so return False.
fbf5a39b
AC		 3747
3748 else
3749 return False;
3750 end if;
59e54267 3751 end Known_Null;
07fc65c4 3752
70482933
RK		 3753 -----------------------------
3754 -- Make_CW_Equivalent_Type --
3755 -----------------------------
3756
6fb4cdde
AC		 3757 -- Create a record type used as an equivalent of any member of the class
3758 -- which takes its size from exp.
70482933
RK		 3759
3760 -- Generate the following code:
3761
3762 -- type Equiv_T is record
e14c931f 3763 -- _parent : T (List of discriminant constraints taken from Exp);
fbf5a39b 3764 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
70482933 3765 -- end Equiv_T;
fbf5a39b
AC		 3766 --
3767 -- ??? Note that this type does not guarantee same alignment as all
3768 -- derived types
70482933
RK		 3769
3770 function Make_CW_Equivalent_Type
bebbff91
AC		 3771 (T : Entity_Id;
3772 E : Node_Id) return Entity_Id
70482933
RK		 3773 is
3774 Loc : constant Source_Ptr := Sloc (E);
3775 Root_Typ : constant Entity_Id := Root_Type (T);
fbf5a39b 3776 List_Def : constant List_Id := Empty_List;
0712790c 3777 Comp_List : constant List_Id := New_List;
70482933
RK		 3778 Equiv_Type : Entity_Id;
3779 Range_Type : Entity_Id;
3780 Str_Type : Entity_Id;
70482933
RK		 3781 Constr_Root : Entity_Id;
3782 Sizexpr : Node_Id;
3783
3784 begin
3e2399ba
AC		 3785 -- If the root type is already constrained, there are no discriminants
3786 -- in the expression.
3787
3788 if not Has_Discriminants (Root_Typ)
3789 or else Is_Constrained (Root_Typ)
3790 then
70482933
RK		 3791 Constr_Root := Root_Typ;
3792 else
092ef350 3793 Constr_Root := Make_Temporary (Loc, 'R');
70482933
RK		 3794
3795 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3796
3797 Append_To (List_Def,
3798 Make_Subtype_Declaration (Loc,
3799 Defining_Identifier => Constr_Root,
092ef350 3800 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
70482933
RK		 3801 end if;
3802
0712790c 3803 -- Generate the range subtype declaration
70482933 3804
092ef350 3805 Range_Type := Make_Temporary (Loc, 'G');
70482933 3806
0712790c 3807 if not Is_Interface (Root_Typ) then
6fb4cdde 3808
0712790c
ES		 3809 -- subtype rg__xx is
3810 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3811
3812 Sizexpr :=
3813 Make_Op_Subtract (Loc,
3814 Left_Opnd =>
3815 Make_Attribute_Reference (Loc,
3816 Prefix =>
3817 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3818 Attribute_Name => Name_Size),
3819 Right_Opnd =>
3820 Make_Attribute_Reference (Loc,
3821 Prefix => New_Reference_To (Constr_Root, Loc),
3822 Attribute_Name => Name_Object_Size));
3823 else
3824 -- subtype rg__xx is
3825 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
3826
3827 Sizexpr :=
3828 Make_Attribute_Reference (Loc,
3829 Prefix =>
3830 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3831 Attribute_Name => Name_Size);
3832 end if;
70482933
RK		 3833
3834 Set_Paren_Count (Sizexpr, 1);
3835
3836 Append_To (List_Def,
3837 Make_Subtype_Declaration (Loc,
3838 Defining_Identifier => Range_Type,
3839 Subtype_Indication =>
3840 Make_Subtype_Indication (Loc,
3841 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
3842 Constraint => Make_Range_Constraint (Loc,
3843 Range_Expression =>
3844 Make_Range (Loc,
3845 Low_Bound => Make_Integer_Literal (Loc, 1),
3846 High_Bound =>
3847 Make_Op_Divide (Loc,
3848 Left_Opnd => Sizexpr,
3849 Right_Opnd => Make_Integer_Literal (Loc,
3850 Intval => System_Storage_Unit)))))));
3851
3852 -- subtype str__nn is Storage_Array (rg__x);
3853
092ef350 3854 Str_Type := Make_Temporary (Loc, 'S');
70482933
RK		 3855 Append_To (List_Def,
3856 Make_Subtype_Declaration (Loc,
3857 Defining_Identifier => Str_Type,
3858 Subtype_Indication =>
3859 Make_Subtype_Indication (Loc,
3860 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3861 Constraint =>
3862 Make_Index_Or_Discriminant_Constraint (Loc,
3863 Constraints =>
3864 New_List (New_Reference_To (Range_Type, Loc))))));
3865
3866 -- type Equiv_T is record
0712790c 3867 -- [ _parent : Tnn; ]
70482933
RK		 3868 -- E : Str_Type;
3869 -- end Equiv_T;
3870
092ef350 3871 Equiv_Type := Make_Temporary (Loc, 'T');
70482933
RK		 3872 Set_Ekind (Equiv_Type, E_Record_Type);
3873 Set_Parent_Subtype (Equiv_Type, Constr_Root);
3874
80fa4617
EB		 3875 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
3876 -- treatment for this type. In particular, even though _parent's type
3877 -- is a controlled type or contains controlled components, we do not
3878 -- want to set Has_Controlled_Component on it to avoid making it gain
3879 -- an unwanted _controller component.
3880
3881 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
3882
0712790c
ES		 3883 if not Is_Interface (Root_Typ) then
3884 Append_To (Comp_List,
3885 Make_Component_Declaration (Loc,
3886 Defining_Identifier =>
3887 Make_Defining_Identifier (Loc, Name_uParent),
3888 Component_Definition =>
3889 Make_Component_Definition (Loc,
3890 Aliased_Present => False,
3891 Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
3892 end if;
3893
3894 Append_To (Comp_List,
3895 Make_Component_Declaration (Loc,
092ef350 3896 Defining_Identifier => Make_Temporary (Loc, 'C'),
0712790c
ES		 3897 Component_Definition =>
3898 Make_Component_Definition (Loc,
3899 Aliased_Present => False,
3900 Subtype_Indication => New_Reference_To (Str_Type, Loc))));
3901
70482933
RK		 3902 Append_To (List_Def,
3903 Make_Full_Type_Declaration (Loc,
3904 Defining_Identifier => Equiv_Type,
70482933
RK		 3905 Type_Definition =>
3906 Make_Record_Definition (Loc,
0712790c
ES		 3907 Component_List =>
3908 Make_Component_List (Loc,
3909 Component_Items => Comp_List,
3910 Variant_Part => Empty))));
3911
3912 -- Suppress all checks during the analysis of the expanded code
3913 -- to avoid the generation of spurious warnings under ZFP run-time.
3914
3915 Insert_Actions (E, List_Def, Suppress => All_Checks);
70482933
RK		 3916 return Equiv_Type;
3917 end Make_CW_Equivalent_Type;
3918
3919 ------------------------
3920 -- Make_Literal_Range --
3921 ------------------------
3922
3923 function Make_Literal_Range
3924 (Loc : Source_Ptr;
bebbff91 3925 Literal_Typ : Entity_Id) return Node_Id
70482933 3926 is
86cde7b1
RD		 3927 Lo : constant Node_Id :=
3928 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
3929 Index : constant Entity_Id := Etype (Lo);
3930
3931 Hi : Node_Id;
3932 Length_Expr : constant Node_Id :=
3933 Make_Op_Subtract (Loc,
3934 Left_Opnd =>
3935 Make_Integer_Literal (Loc,
3936 Intval => String_Literal_Length (Literal_Typ)),
3937 Right_Opnd =>
3938 Make_Integer_Literal (Loc, 1));
f91b40db 3939
70482933 3940 begin
f91b40db
GB		 3941 Set_Analyzed (Lo, False);
3942
86cde7b1
RD		 3943 if Is_Integer_Type (Index) then
3944 Hi :=
3945 Make_Op_Add (Loc,
3946 Left_Opnd => New_Copy_Tree (Lo),
3947 Right_Opnd => Length_Expr);
3948 else
3949 Hi :=
3950 Make_Attribute_Reference (Loc,
3951 Attribute_Name => Name_Val,
3952 Prefix => New_Occurrence_Of (Index, Loc),
3953 Expressions => New_List (
3954 Make_Op_Add (Loc,
3955 Left_Opnd =>
3956 Make_Attribute_Reference (Loc,
3957 Attribute_Name => Name_Pos,
3958 Prefix => New_Occurrence_Of (Index, Loc),
3959 Expressions => New_List (New_Copy_Tree (Lo))),
3960 Right_Opnd => Length_Expr)));
3961 end if;
3962
70482933
RK		 3963 return
3964 Make_Range (Loc,
86cde7b1
RD		 3965 Low_Bound => Lo,
3966 High_Bound => Hi);
70482933
RK		 3967 end Make_Literal_Range;
3968
b3b9865d
AC		 3969 --------------------------
3970 -- Make_Non_Empty_Check --
3971 --------------------------
3972
3973 function Make_Non_Empty_Check
3974 (Loc : Source_Ptr;
3975 N : Node_Id) return Node_Id
3976 is
3977 begin
3978 return
3979 Make_Op_Ne (Loc,
3980 Left_Opnd =>
3981 Make_Attribute_Reference (Loc,
3982 Attribute_Name => Name_Length,
3983 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
3984 Right_Opnd =>
3985 Make_Integer_Literal (Loc, 0));
3986 end Make_Non_Empty_Check;
3987
70482933
RK		 3988 ----------------------------
3989 -- Make_Subtype_From_Expr --
3990 ----------------------------
3991
e14c931f
RW		 3992 -- 1. If Expr is an unconstrained array expression, creates
3993 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
70482933
RK		 3994
3995 -- 2. If Expr is a unconstrained discriminated type expression, creates
3996 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3997
3998 -- 3. If Expr is class-wide, creates an implicit class wide subtype
3999
4000 function Make_Subtype_From_Expr
4001 (E : Node_Id;
bebbff91 4002 Unc_Typ : Entity_Id) return Node_Id
70482933
RK		 4003 is
4004 Loc : constant Source_Ptr := Sloc (E);
fbf5a39b 4005 List_Constr : constant List_Id := New_List;
70482933
RK		 4006 D : Entity_Id;
4007
4008 Full_Subtyp : Entity_Id;
4009 Priv_Subtyp : Entity_Id;
4010 Utyp : Entity_Id;
4011 Full_Exp : Node_Id;
4012
4013 begin
4014 if Is_Private_Type (Unc_Typ)
4015 and then Has_Unknown_Discriminants (Unc_Typ)
4016 then
fbf5a39b 4017 -- Prepare the subtype completion, Go to base type to
ea985d95
RD		 4018 -- find underlying type, because the type may be a generic
4019 -- actual or an explicit subtype.
70482933 4020
fbf5a39b 4021 Utyp := Underlying_Type (Base_Type (Unc_Typ));
092ef350 4022 Full_Subtyp := Make_Temporary (Loc, 'C');
8cbb664e 4023 Full_Exp :=
092ef350 4024 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
70482933
RK		 4025 Set_Parent (Full_Exp, Parent (E));
4026
092ef350 4027 Priv_Subtyp := Make_Temporary (Loc, 'P');
70482933
RK		 4028
4029 Insert_Action (E,
4030 Make_Subtype_Declaration (Loc,
4031 Defining_Identifier => Full_Subtyp,
4032 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
4033
4034 -- Define the dummy private subtype
4035
4036 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
ea985d95 4037 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
70482933
RK		 4038 Set_Scope (Priv_Subtyp, Full_Subtyp);
4039 Set_Is_Constrained (Priv_Subtyp);
4040 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
4041 Set_Is_Itype (Priv_Subtyp);
4042 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
4043
4044 if Is_Tagged_Type (Priv_Subtyp) then
4045 Set_Class_Wide_Type
4046 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
4047 Set_Primitive_Operations (Priv_Subtyp,
4048 Primitive_Operations (Unc_Typ));
4049 end if;
4050
4051 Set_Full_View (Priv_Subtyp, Full_Subtyp);
4052
4053 return New_Reference_To (Priv_Subtyp, Loc);
4054
4055 elsif Is_Array_Type (Unc_Typ) then
4056 for J in 1 .. Number_Dimensions (Unc_Typ) loop
4057 Append_To (List_Constr,
4058 Make_Range (Loc,
4059 Low_Bound =>
4060 Make_Attribute_Reference (Loc,
8cbb664e 4061 Prefix => Duplicate_Subexpr_No_Checks (E),
70482933
RK		 4062 Attribute_Name => Name_First,
4063 Expressions => New_List (
4064 Make_Integer_Literal (Loc, J))),
8cbb664e 4065
70482933
RK		 4066 High_Bound =>
4067 Make_Attribute_Reference (Loc,
8cbb664e 4068 Prefix => Duplicate_Subexpr_No_Checks (E),
70482933
RK		 4069 Attribute_Name => Name_Last,
4070 Expressions => New_List (
4071 Make_Integer_Literal (Loc, J)))));
4072 end loop;
4073
4074 elsif Is_Class_Wide_Type (Unc_Typ) then
4075 declare
4076 CW_Subtype : Entity_Id;
4077 EQ_Typ : Entity_Id := Empty;
4078
4079 begin
0712790c
ES		 4080 -- A class-wide equivalent type is not needed when VM_Target
4081 -- because the VM back-ends handle the class-wide object
44d6a706 4082 -- initialization itself (and doesn't need or want the
70482933
RK		 4083 -- additional intermediate type to handle the assignment).
4084
1f110335 4085 if Expander_Active and then Tagged_Type_Expansion then
22cb89b5
AC		 4086
4087 -- If this is the class_wide type of a completion that is
4088 -- a record subtype, set the type of the class_wide type
4089 -- to be the full base type, for use in the expanded code
4090 -- for the equivalent type. Should this be done earlier when
4091 -- the completion is analyzed ???
4092
4093 if Is_Private_Type (Etype (Unc_Typ))
4094 and then
4095 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
4096 then
4097 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
4098 end if;
4099
70482933
RK		 4100 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
4101 end if;
4102
4103 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
4104 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
4105 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
4106
4107 return New_Occurrence_Of (CW_Subtype, Loc);
4108 end;
4109
ea985d95 4110 -- Indefinite record type with discriminants
fbf5a39b 4111
70482933
RK		 4112 else
4113 D := First_Discriminant (Unc_Typ);
fbf5a39b 4114 while Present (D) loop
70482933
RK		 4115 Append_To (List_Constr,
4116 Make_Selected_Component (Loc,
8cbb664e 4117 Prefix => Duplicate_Subexpr_No_Checks (E),
70482933
RK		 4118 Selector_Name => New_Reference_To (D, Loc)));
4119
4120 Next_Discriminant (D);
4121 end loop;
4122 end if;
4123
4124 return
4125 Make_Subtype_Indication (Loc,
4126 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
4127 Constraint =>
4128 Make_Index_Or_Discriminant_Constraint (Loc,
4129 Constraints => List_Constr));
4130 end Make_Subtype_From_Expr;
4131
4132 -----------------------------
4133 -- May_Generate_Large_Temp --
4134 -----------------------------
4135
4136 -- At the current time, the only types that we return False for (i.e.
4137 -- where we decide we know they cannot generate large temps) are ones
8adcacef 4138 -- where we know the size is 256 bits or less at compile time, and we
70482933
RK		 4139 -- are still not doing a thorough job on arrays and records ???
4140
4141 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
4142 begin
7324bf49 4143 if not Size_Known_At_Compile_Time (Typ) then
70482933
RK		 4144 return False;
4145
4146 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
4147 return False;
4148
4149 elsif Is_Array_Type (Typ)
4150 and then Present (Packed_Array_Type (Typ))
4151 then
4152 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
4153
4154 -- We could do more here to find other small types ???
4155
4156 else
4157 return True;
4158 end if;
4159 end May_Generate_Large_Temp;
4160
70482933
RK		 4161 ----------------------------
4162 -- New_Class_Wide_Subtype --
4163 ----------------------------
4164
4165 function New_Class_Wide_Subtype
4166 (CW_Typ : Entity_Id;
bebbff91 4167 N : Node_Id) return Entity_Id
70482933 4168 is
fbf5a39b
AC		 4169 Res : constant Entity_Id := Create_Itype (E_Void, N);
4170 Res_Name : constant Name_Id := Chars (Res);
4171 Res_Scope : constant Entity_Id := Scope (Res);
70482933
RK		 4172
4173 begin
4174 Copy_Node (CW_Typ, Res);
05350ac6 4175 Set_Comes_From_Source (Res, False);
70482933
RK		 4176 Set_Sloc (Res, Sloc (N));
4177 Set_Is_Itype (Res);
4178 Set_Associated_Node_For_Itype (Res, N);
4179 Set_Is_Public (Res, False); -- By default, may be changed below.
4180 Set_Public_Status (Res);
4181 Set_Chars (Res, Res_Name);
4182 Set_Scope (Res, Res_Scope);
4183 Set_Ekind (Res, E_Class_Wide_Subtype);
4184 Set_Next_Entity (Res, Empty);
4185 Set_Etype (Res, Base_Type (CW_Typ));
cbae498b 4186 Set_Is_Frozen (Res, False);
70482933
RK		 4187 Set_Freeze_Node (Res, Empty);
4188 return (Res);
4189 end New_Class_Wide_Subtype;
4190
0712790c
ES		 4191 --------------------------------
4192 -- Non_Limited_Designated_Type --
4193 ---------------------------------
4194
4195 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
4196 Desig : constant Entity_Id := Designated_Type (T);
4197 begin
4198 if Ekind (Desig) = E_Incomplete_Type
4199 and then Present (Non_Limited_View (Desig))
4200 then
4201 return Non_Limited_View (Desig);
4202 else
4203 return Desig;
4204 end if;
4205 end Non_Limited_Designated_Type;
4206
59e54267
ES		 4207 -----------------------------------
4208 -- OK_To_Do_Constant_Replacement --
4209 -----------------------------------
4210
4211 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
4212 ES : constant Entity_Id := Scope (E);
4213 CS : Entity_Id;
4214
4215 begin
4216 -- Do not replace statically allocated objects, because they may be
4217 -- modified outside the current scope.
4218
4219 if Is_Statically_Allocated (E) then
4220 return False;
4221
4222 -- Do not replace aliased or volatile objects, since we don't know what
4223 -- else might change the value.
4224
4225 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
4226 return False;
4227
4228 -- Debug flag -gnatdM disconnects this optimization
4229
4230 elsif Debug_Flag_MM then
4231 return False;
4232
4233 -- Otherwise check scopes
4234
4235 else
59e54267
ES		 4236 CS := Current_Scope;
4237
4238 loop
4239 -- If we are in right scope, replacement is safe
4240
4241 if CS = ES then
4242 return True;
4243
4244 -- Packages do not affect the determination of safety
4245
4246 elsif Ekind (CS) = E_Package then
59e54267 4247 exit when CS = Standard_Standard;
05350ac6 4248 CS := Scope (CS);
59e54267
ES		 4249
4250 -- Blocks do not affect the determination of safety
4251
4252 elsif Ekind (CS) = E_Block then
4253 CS := Scope (CS);
4254
05350ac6
BD		 4255 -- Loops do not affect the determination of safety. Note that we
4256 -- kill all current values on entry to a loop, so we are just
4257 -- talking about processing within a loop here.
4258
4259 elsif Ekind (CS) = E_Loop then
4260 CS := Scope (CS);
4261
59e54267
ES		 4262 -- Otherwise, the reference is dubious, and we cannot be sure that
4263 -- it is safe to do the replacement.
4264
4265 else
4266 exit;
4267 end if;
4268 end loop;
4269
4270 return False;
4271 end if;
4272 end OK_To_Do_Constant_Replacement;
4273
0712790c
ES		 4274 ------------------------------------
4275 -- Possible_Bit_Aligned_Component --
4276 ------------------------------------
4277
4278 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
4279 begin
4280 case Nkind (N) is
4281
4282 -- Case of indexed component
4283
4284 when N_Indexed_Component =>
4285 declare
4286 P : constant Node_Id := Prefix (N);
4287 Ptyp : constant Entity_Id := Etype (P);
4288
4289 begin
4290 -- If we know the component size and it is less than 64, then
dc7c0c4d
AC		 4291 -- we are definitely OK. The back end always does assignment of
4292 -- misaligned small objects correctly.
0712790c
ES		 4293
4294 if Known_Static_Component_Size (Ptyp)
4295 and then Component_Size (Ptyp) <= 64
4296 then
4297 return False;
4298
4299 -- Otherwise, we need to test the prefix, to see if we are
4300 -- indexing from a possibly unaligned component.
4301
4302 else
4303 return Possible_Bit_Aligned_Component (P);
4304 end if;
4305 end;
4306
4307 -- Case of selected component
4308
4309 when N_Selected_Component =>
4310 declare
4311 P : constant Node_Id := Prefix (N);
4312 Comp : constant Entity_Id := Entity (Selector_Name (N));
4313
4314 begin
4315 -- If there is no component clause, then we are in the clear
4316 -- since the back end will never misalign a large component
4317 -- unless it is forced to do so. In the clear means we need
4318 -- only the recursive test on the prefix.
4319
4320 if Component_May_Be_Bit_Aligned (Comp) then
4321 return True;
4322 else
4323 return Possible_Bit_Aligned_Component (P);
4324 end if;
4325 end;
4326
65df5b71
HK		 4327 -- For a slice, test the prefix, if that is possibly misaligned,
4328 -- then for sure the slice is!
4329
4330 when N_Slice =>
4331 return Possible_Bit_Aligned_Component (Prefix (N));
4332
4333 -- If we have none of the above, it means that we have fallen off the
4334 -- top testing prefixes recursively, and we now have a stand alone
4335 -- object, where we don't have a problem.
0712790c
ES		 4336
4337 when others =>
4338 return False;
4339
4340 end case;
4341 end Possible_Bit_Aligned_Component;
4342
70482933
RK		 4343 -------------------------
4344 -- Remove_Side_Effects --
4345 -------------------------
4346
4347 procedure Remove_Side_Effects
4348 (Exp : Node_Id;
4349 Name_Req : Boolean := False;
4350 Variable_Ref : Boolean := False)
4351 is
59e54267 4352 Loc : constant Source_Ptr := Sloc (Exp);
fbf5a39b
AC		 4353 Exp_Type : constant Entity_Id := Etype (Exp);
4354 Svg_Suppress : constant Suppress_Array := Scope_Suppress;
70482933
RK		 4355 Def_Id : Entity_Id;
4356 Ref_Type : Entity_Id;
4357 Res : Node_Id;
4358 Ptr_Typ_Decl : Node_Id;
4359 New_Exp : Node_Id;
4360 E : Node_Id;
4361
4362 function Side_Effect_Free (N : Node_Id) return Boolean;
59e54267
ES		 4363 -- Determines if the tree N represents an expression that is known not
4364 -- to have side effects, and for which no processing is required.
70482933
RK		 4365
4366 function Side_Effect_Free (L : List_Id) return Boolean;
4367 -- Determines if all elements of the list L are side effect free
4368
fbf5a39b 4369 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
59e54267
ES		 4370 -- The argument N is a construct where the Prefix is dereferenced if it
4371 -- is an access type and the result is a variable. The call returns True
4372 -- if the construct is side effect free (not considering side effects in
4373 -- other than the prefix which are to be tested by the caller).
fbf5a39b
AC		 4374
4375 function Within_In_Parameter (N : Node_Id) return Boolean;
59e54267
ES		 4376 -- Determines if N is a subcomponent of a composite in-parameter. If so,
4377 -- N is not side-effect free when the actual is global and modifiable
4378 -- indirectly from within a subprogram, because it may be passed by
4379 -- reference. The front-end must be conservative here and assume that
4380 -- this may happen with any array or record type. On the other hand, we
4381 -- cannot create temporaries for all expressions for which this
4382 -- condition is true, for various reasons that might require clearing up
e14c931f 4383 -- ??? For example, discriminant references that appear out of place, or
59e54267
ES		 4384 -- spurious type errors with class-wide expressions. As a result, we
4385 -- limit the transformation to loop bounds, which is so far the only
4386 -- case that requires it.
fbf5a39b
AC		 4387
4388 -----------------------------
4389 -- Safe_Prefixed_Reference --
4390 -----------------------------
4391
4392 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
4393 begin
4394 -- If prefix is not side effect free, definitely not safe
70482933 4395
fbf5a39b
AC		 4396 if not Side_Effect_Free (Prefix (N)) then
4397 return False;
70482933 4398
fbf5a39b
AC		 4399 -- If the prefix is of an access type that is not access-to-constant,
4400 -- then this construct is a variable reference, which means it is to
4401 -- be considered to have side effects if Variable_Ref is set True
4402 -- Exception is an access to an entity that is a constant or an
4403 -- in-parameter which does not come from source, and is the result
4404 -- of a previous removal of side-effects.
4405
4406 elsif Is_Access_Type (Etype (Prefix (N)))
70482933 4407 and then not Is_Access_Constant (Etype (Prefix (N)))
fbf5a39b
AC		 4408 and then Variable_Ref
4409 then
4410 if not Is_Entity_Name (Prefix (N)) then
4411 return False;
4412 else
4413 return Ekind (Entity (Prefix (N))) = E_Constant
4414 or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
4415 end if;
4416
4417 -- The following test is the simplest way of solving a complex
4418 -- problem uncovered by BB08-010: Side effect on loop bound that
4419 -- is a subcomponent of a global variable:
4420 -- If a loop bound is a subcomponent of a global variable, a
4421 -- modification of that variable within the loop may incorrectly
4422 -- affect the execution of the loop.
4423
4424 elsif not
4425 (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
4426 or else not Within_In_Parameter (Prefix (N)))
4427 then
4428 return False;
4429
4430 -- All other cases are side effect free
4431
4432 else
4433 return True;
4434 end if;
4435 end Safe_Prefixed_Reference;
70482933
RK		 4436
4437 ----------------------
4438 -- Side_Effect_Free --
4439 ----------------------
4440
4441 function Side_Effect_Free (N : Node_Id) return Boolean is
70482933
RK		 4442 begin
4443 -- Note on checks that could raise Constraint_Error. Strictly, if
4444 -- we take advantage of 11.6, these checks do not count as side
4445 -- effects. However, we would just as soon consider that they are
4446 -- side effects, since the backend CSE does not work very well on
4447 -- expressions which can raise Constraint_Error. On the other
4448 -- hand, if we do not consider them to be side effect free, then
4449 -- we get some awkward expansions in -gnato mode, resulting in
4450 -- code insertions at a point where we do not have a clear model
65df5b71 4451 -- for performing the insertions.
70482933 4452
fbf5a39b 4453 -- Special handling for entity names
70482933 4454
fbf5a39b 4455 if Is_Entity_Name (N) then
70482933 4456
70482933
RK		 4457 -- If the entity is a constant, it is definitely side effect
4458 -- free. Note that the test of Is_Variable (N) below might
4459 -- be expected to catch this case, but it does not, because
4460 -- this test goes to the original tree, and we may have
4461 -- already rewritten a variable node with a constant as
4462 -- a result of an earlier Force_Evaluation call.
4463
b29def53 4464 if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then
70482933
RK		 4465 return True;
4466
fbf5a39b
AC		 4467 -- Functions are not side effect free
4468
4469 elsif Ekind (Entity (N)) = E_Function then
4470 return False;
4471
4472 -- Variables are considered to be a side effect if Variable_Ref
65df5b71 4473 -- is set or if we have a volatile reference and Name_Req is off.
fbf5a39b
AC		 4474 -- If Name_Req is True then we can't help returning a name which
4475 -- effectively allows multiple references in any case.
70482933 4476
fbf5a39b
AC		 4477 elsif Is_Variable (N) then
4478 return not Variable_Ref
65df5b71 4479 and then (not Is_Volatile_Reference (N) or else Name_Req);
fbf5a39b
AC		 4480
4481 -- Any other entity (e.g. a subtype name) is definitely side
4482 -- effect free.
70482933
RK		 4483
4484 else
4485 return True;
4486 end if;
4487
4488 -- A value known at compile time is always side effect free
4489
4490 elsif Compile_Time_Known_Value (N) then
4491 return True;
0712790c 4492
e14c931f 4493 -- A variable renaming is not side-effect free, because the
0712790c 4494 -- renaming will function like a macro in the front-end in
e14c931f 4495 -- some cases, and an assignment can modify the component
0712790c
ES		 4496 -- designated by N, so we need to create a temporary for it.
4497
4498 elsif Is_Entity_Name (Original_Node (N))
4499 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
4500 and then Ekind (Entity (Original_Node (N))) /= E_Constant
4501 then
4502 return False;
fbf5a39b 4503 end if;
70482933 4504
fbf5a39b
AC		 4505 -- For other than entity names and compile time known values,
4506 -- check the node kind for special processing.
70482933 4507
fbf5a39b
AC		 4508 case Nkind (N) is
4509
4510 -- An attribute reference is side effect free if its expressions
4511 -- are side effect free and its prefix is side effect free or
4512 -- is an entity reference.
4513
4514 -- Is this right? what about x'first where x is a variable???
4515
4516 when N_Attribute_Reference =>
4517 return Side_Effect_Free (Expressions (N))
59e54267 4518 and then Attribute_Name (N) /= Name_Input
fbf5a39b
AC		 4519 and then (Is_Entity_Name (Prefix (N))
4520 or else Side_Effect_Free (Prefix (N)));
4521
4522 -- A binary operator is side effect free if and both operands
4523 -- are side effect free. For this purpose binary operators
4524 -- include membership tests and short circuit forms
4525
ac7120ce 4526 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
fbf5a39b 4527 return Side_Effect_Free (Left_Opnd (N))
ac7120ce
RD		 4528 and then
4529 Side_Effect_Free (Right_Opnd (N));
fbf5a39b
AC		 4530
4531 -- An explicit dereference is side effect free only if it is
4532 -- a side effect free prefixed reference.
4533
4534 when N_Explicit_Dereference =>
4535 return Safe_Prefixed_Reference (N);
4536
4537 -- A call to _rep_to_pos is side effect free, since we generate
4538 -- this pure function call ourselves. Moreover it is critically
4539 -- important to make this exception, since otherwise we can
4540 -- have discriminants in array components which don't look
4541 -- side effect free in the case of an array whose index type
4542 -- is an enumeration type with an enumeration rep clause.
4543
4544 -- All other function calls are not side effect free
4545
4546 when N_Function_Call =>
4547 return Nkind (Name (N)) = N_Identifier
4548 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
4549 and then
4550 Side_Effect_Free (First (Parameter_Associations (N)));
70482933 4551
fbf5a39b
AC		 4552 -- An indexed component is side effect free if it is a side
4553 -- effect free prefixed reference and all the indexing
4554 -- expressions are side effect free.
70482933 4555
fbf5a39b
AC		 4556 when N_Indexed_Component =>
4557 return Side_Effect_Free (Expressions (N))
4558 and then Safe_Prefixed_Reference (N);
70482933 4559
fbf5a39b
AC		 4560 -- A type qualification is side effect free if the expression
4561 -- is side effect free.
70482933 4562
fbf5a39b 4563 when N_Qualified_Expression =>
70482933 4564 return Side_Effect_Free (Expression (N));
70482933 4565
fbf5a39b 4566 -- A selected component is side effect free only if it is a
86cde7b1
RD		 4567 -- side effect free prefixed reference. If it designates a
4568 -- component with a rep. clause it must be treated has having
4569 -- a potential side effect, because it may be modified through
4570 -- a renaming, and a subsequent use of the renaming as a macro
4571 -- will yield the wrong value. This complex interaction between
4572 -- renaming and removing side effects is a reminder that the
4573 -- latter has become a headache to maintain, and that it should
4574 -- be removed in favor of the gcc mechanism to capture values ???
70482933 4575
fbf5a39b 4576 when N_Selected_Component =>
86cde7b1
RD		 4577 if Nkind (Parent (N)) = N_Explicit_Dereference
4578 and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
4579 then
4580 return False;
4581 else
4582 return Safe_Prefixed_Reference (N);
4583 end if;
70482933 4584
fbf5a39b 4585 -- A range is side effect free if the bounds are side effect free
70482933 4586
fbf5a39b
AC		 4587 when N_Range =>
4588 return Side_Effect_Free (Low_Bound (N))
4589 and then Side_Effect_Free (High_Bound (N));
70482933 4590
fbf5a39b
AC		 4591 -- A slice is side effect free if it is a side effect free
4592 -- prefixed reference and the bounds are side effect free.
70482933 4593
fbf5a39b
AC		 4594 when N_Slice =>
4595 return Side_Effect_Free (Discrete_Range (N))
4596 and then Safe_Prefixed_Reference (N);
70482933 4597
86cde7b1
RD		 4598 -- A type conversion is side effect free if the expression to be
4599 -- converted is side effect free.
70482933 4600
fbf5a39b
AC		 4601 when N_Type_Conversion =>
4602 return Side_Effect_Free (Expression (N));
4603
4604 -- A unary operator is side effect free if the operand
4605 -- is side effect free.
4606
4607 when N_Unary_Op =>
4608 return Side_Effect_Free (Right_Opnd (N));
4609
4610 -- An unchecked type conversion is side effect free only if it
4611 -- is safe and its argument is side effect free.
4612
4613 when N_Unchecked_Type_Conversion =>
4614 return Safe_Unchecked_Type_Conversion (N)
4615 and then Side_Effect_Free (Expression (N));
4616
4617 -- An unchecked expression is side effect free if its expression
4618 -- is side effect free.
4619
4620 when N_Unchecked_Expression =>
4621 return Side_Effect_Free (Expression (N));
4622
5c1c8a03
AC		 4623 -- A literal is side effect free
4624
4625 when N_Character_Literal |
4626 N_Integer_Literal |
4627 N_Real_Literal |
6e059adb 4628 N_String_Literal =>
5c1c8a03
AC		 4629 return True;
4630
fbf5a39b
AC		 4631 -- We consider that anything else has side effects. This is a bit
4632 -- crude, but we are pretty close for most common cases, and we
4633 -- are certainly correct (i.e. we never return True when the
4634 -- answer should be False).
4635
4636 when others =>
4637 return False;
4638 end case;
70482933
RK		 4639 end Side_Effect_Free;
4640
fbf5a39b
AC		 4641 -- A list is side effect free if all elements of the list are
4642 -- side effect free.
4643
70482933
RK		 4644 function Side_Effect_Free (L : List_Id) return Boolean is
4645 N : Node_Id;
4646
4647 begin
4648 if L = No_List or else L = Error_List then
4649 return True;
4650
4651 else
4652 N := First (L);
70482933
RK		 4653 while Present (N) loop
4654 if not Side_Effect_Free (N) then
4655 return False;
4656 else
4657 Next (N);
4658 end if;
4659 end loop;
4660
4661 return True;
4662 end if;
4663 end Side_Effect_Free;
4664
fbf5a39b
AC		 4665 -------------------------
4666 -- Within_In_Parameter --
4667 -------------------------
4668
4669 function Within_In_Parameter (N : Node_Id) return Boolean is
4670 begin
4671 if not Comes_From_Source (N) then
4672 return False;
4673
4674 elsif Is_Entity_Name (N) then
86cde7b1 4675 return Ekind (Entity (N)) = E_In_Parameter;
fbf5a39b
AC		 4676
4677 elsif Nkind (N) = N_Indexed_Component
4678 or else Nkind (N) = N_Selected_Component
4679 then
4680 return Within_In_Parameter (Prefix (N));
4681 else
4682
4683 return False;
4684 end if;
4685 end Within_In_Parameter;
4686
70482933
RK		 4687 -- Start of processing for Remove_Side_Effects
4688
4689 begin
4690 -- If we are side effect free already or expansion is disabled,
4691 -- there is nothing to do.
4692
4693 if Side_Effect_Free (Exp) or else not Expander_Active then
4694 return;
4695 end if;
4696
fbf5a39b 4697 -- All this must not have any checks
70482933
RK		 4698
4699 Scope_Suppress := (others => True);
4700
86cde7b1 4701 -- If it is a scalar type and we need to capture the value, just make
6a497607 4702 -- a copy. Likewise for a function call, an attribute reference, an
48b351d9 4703 -- allocator, or an operator. And if we have a volatile reference and
6a497607 4704 -- Name_Req is not set (see comments above for Side_Effect_Free).
d9e0a587
EB		 4705
4706 if Is_Elementary_Type (Exp_Type)
4707 and then (Variable_Ref
4708 or else Nkind (Exp) = N_Function_Call
65df5b71 4709 or else Nkind (Exp) = N_Attribute_Reference
6a497607 4710 or else Nkind (Exp) = N_Allocator
86cde7b1 4711 or else Nkind (Exp) in N_Op
65df5b71 4712 or else (not Name_Req and then Is_Volatile_Reference (Exp)))
d9e0a587 4713 then
faf387e1 4714 Def_Id := Make_Temporary (Loc, 'R', Exp);
d9e0a587
EB		 4715 Set_Etype (Def_Id, Exp_Type);
4716 Res := New_Reference_To (Def_Id, Loc);
4717
4718 E :=
4719 Make_Object_Declaration (Loc,
4720 Defining_Identifier => Def_Id,
4721 Object_Definition => New_Reference_To (Exp_Type, Loc),
4722 Constant_Present => True,
4723 Expression => Relocate_Node (Exp));
4724
4725 Set_Assignment_OK (E);
4726 Insert_Action (Exp, E);
4727
70482933
RK		 4728 -- If the expression has the form v.all then we can just capture
4729 -- the pointer, and then do an explicit dereference on the result.
4730
d9e0a587 4731 elsif Nkind (Exp) = N_Explicit_Dereference then
faf387e1 4732 Def_Id := Make_Temporary (Loc, 'R', Exp);
70482933
RK		 4733 Res :=
4734 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
4735
4736 Insert_Action (Exp,
4737 Make_Object_Declaration (Loc,
4738 Defining_Identifier => Def_Id,
4739 Object_Definition =>
4740 New_Reference_To (Etype (Prefix (Exp)), Loc),
4741 Constant_Present => True,
4742 Expression => Relocate_Node (Prefix (Exp))));
4743
fbf5a39b
AC		 4744 -- Similar processing for an unchecked conversion of an expression
4745 -- of the form v.all, where we want the same kind of treatment.
4746
4747 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4748 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
4749 then
8adcacef 4750 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
fbf5a39b
AC		 4751 Scope_Suppress := Svg_Suppress;
4752 return;
4753
70482933
RK		 4754 -- If this is a type conversion, leave the type conversion and remove
4755 -- the side effects in the expression. This is important in several
65df5b71
HK		 4756 -- circumstances: for change of representations, and also when this is
4757 -- a view conversion to a smaller object, where gigi can end up creating
4758 -- its own temporary of the wrong size.
c9a4817d 4759
59e54267 4760 elsif Nkind (Exp) = N_Type_Conversion then
8adcacef 4761 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
70482933
RK		 4762 Scope_Suppress := Svg_Suppress;
4763 return;
4764
d9e0a587
EB		 4765 -- If this is an unchecked conversion that Gigi can't handle, make
4766 -- a copy or a use a renaming to capture the value.
4767
4768 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4769 and then not Safe_Unchecked_Type_Conversion (Exp)
4770 then
048e5cef 4771 if CW_Or_Has_Controlled_Part (Exp_Type) then
d9e0a587
EB		 4772
4773 -- Use a renaming to capture the expression, rather than create
4774 -- a controlled temporary.
4775
faf387e1 4776 Def_Id := Make_Temporary (Loc, 'R', Exp);
d9e0a587
EB		 4777 Res := New_Reference_To (Def_Id, Loc);
4778
4779 Insert_Action (Exp,
4780 Make_Object_Renaming_Declaration (Loc,
4781 Defining_Identifier => Def_Id,
4782 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
4783 Name => Relocate_Node (Exp)));
4784
4785 else
faf387e1 4786 Def_Id := Make_Temporary (Loc, 'R', Exp);
d9e0a587
EB		 4787 Set_Etype (Def_Id, Exp_Type);
4788 Res := New_Reference_To (Def_Id, Loc);
4789
4790 E :=
4791 Make_Object_Declaration (Loc,
4792 Defining_Identifier => Def_Id,
4793 Object_Definition => New_Reference_To (Exp_Type, Loc),
4794 Constant_Present => not Is_Variable (Exp),
4795 Expression => Relocate_Node (Exp));
4796
4797 Set_Assignment_OK (E);
4798 Insert_Action (Exp, E);
4799 end if;
4800
70482933 4801 -- For expressions that denote objects, we can use a renaming scheme.
676e8420
AC		 4802 -- This is needed for correctness in the case of a volatile object
4803 -- of a non-volatile type because the Make_Reference call of the
4804 -- "default" approach would generate an illegal access value (an access
4805 -- value cannot designate such an object - see Analyze_Reference).
4806 -- We skip using this scheme if we have an object of a volatile type
4807 -- and we do not have Name_Req set true (see comments above for
4808 -- Side_Effect_Free).
fbf5a39b 4809
70482933
RK		 4810 elsif Is_Object_Reference (Exp)
4811 and then Nkind (Exp) /= N_Function_Call
676e8420 4812 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
70482933 4813 then
faf387e1 4814 Def_Id := Make_Temporary (Loc, 'R', Exp);
70482933
RK		 4815
4816 if Nkind (Exp) = N_Selected_Component
4817 and then Nkind (Prefix (Exp)) = N_Function_Call
59e54267 4818 and then Is_Array_Type (Exp_Type)
70482933
RK		 4819 then
4820 -- Avoid generating a variable-sized temporary, by generating
4821 -- the renaming declaration just for the function call. The
4822 -- transformation could be refined to apply only when the array
4823 -- component is constrained by a discriminant???
4824
4825 Res :=
4826 Make_Selected_Component (Loc,
4827 Prefix => New_Occurrence_Of (Def_Id, Loc),
4828 Selector_Name => Selector_Name (Exp));
4829
4830 Insert_Action (Exp,
4831 Make_Object_Renaming_Declaration (Loc,
4832 Defining_Identifier => Def_Id,
4833 Subtype_Mark =>
4834 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
4835 Name => Relocate_Node (Prefix (Exp))));
fbf5a39b 4836
70482933
RK		 4837 else
4838 Res := New_Reference_To (Def_Id, Loc);
4839
4840 Insert_Action (Exp,
4841 Make_Object_Renaming_Declaration (Loc,
4842 Defining_Identifier => Def_Id,
4843 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
4844 Name => Relocate_Node (Exp)));
4845 end if;
4846
59e54267
ES		 4847 -- If this is a packed reference, or a selected component with a
4848 -- non-standard representation, a reference to the temporary will
4849 -- be replaced by a copy of the original expression (see
65df5b71 4850 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
59e54267
ES		 4851 -- elaborated by gigi, and is of course not to be replaced in-line
4852 -- by the expression it renames, which would defeat the purpose of
4853 -- removing the side-effect.
4854
4855 if (Nkind (Exp) = N_Selected_Component
4856 or else Nkind (Exp) = N_Indexed_Component)
4857 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
4858 then
4859 null;
4860 else
4861 Set_Is_Renaming_Of_Object (Def_Id, False);
4862 end if;
70482933
RK		 4863
4864 -- Otherwise we generate a reference to the value
4865
4866 else
01957849
AC		 4867 -- Special processing for function calls that return a limited type.
4868 -- We need to build a declaration that will enable build-in-place
4869 -- expansion of the call. This is not done if the context is already
4870 -- an object declaration, to prevent infinite recursion.
65df5b71
HK		 4871
4872 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
4873 -- to accommodate functions returning limited objects by reference.
4874
4875 if Nkind (Exp) = N_Function_Call
01957849
AC		 4876 and then Is_Inherently_Limited_Type (Etype (Exp))
4877 and then Nkind (Parent (Exp)) /= N_Object_Declaration
65df5b71
HK		 4878 and then Ada_Version >= Ada_05
4879 then
4880 declare
faf387e1 4881 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
65df5b71
HK		 4882 Decl : Node_Id;
4883
4884 begin
4885 Decl :=
4886 Make_Object_Declaration (Loc,
4887 Defining_Identifier => Obj,
4888 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
4889 Expression => Relocate_Node (Exp));
327503f1 4890
65df5b71
HK		 4891 Insert_Action (Exp, Decl);
4892 Set_Etype (Obj, Exp_Type);
4893 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
4894 return;
4895 end;
4896 end if;
4897
092ef350 4898 Ref_Type := Make_Temporary (Loc, 'A');
70482933
RK		 4899
4900 Ptr_Typ_Decl :=
4901 Make_Full_Type_Declaration (Loc,
4902 Defining_Identifier => Ref_Type,
4903 Type_Definition =>
4904 Make_Access_To_Object_Definition (Loc,
4905 All_Present => True,
4906 Subtype_Indication =>
4907 New_Reference_To (Exp_Type, Loc)));
4908
4909 E := Exp;
4910 Insert_Action (Exp, Ptr_Typ_Decl);
4911
faf387e1 4912 Def_Id := Make_Temporary (Loc, 'R', Exp);
70482933
RK		 4913 Set_Etype (Def_Id, Exp_Type);
4914
4915 Res :=
4916 Make_Explicit_Dereference (Loc,
4917 Prefix => New_Reference_To (Def_Id, Loc));
4918
4919 if Nkind (E) = N_Explicit_Dereference then
4920 New_Exp := Relocate_Node (Prefix (E));
4921 else
4922 E := Relocate_Node (E);
4923 New_Exp := Make_Reference (Loc, E);
4924 end if;
4925
f44fe430
RD		 4926 if Is_Delayed_Aggregate (E) then
4927
4928 -- The expansion of nested aggregates is delayed until the
4929 -- enclosing aggregate is expanded. As aggregates are often
4930 -- qualified, the predicate applies to qualified expressions
4931 -- as well, indicating that the enclosing aggregate has not
4932 -- been expanded yet. At this point the aggregate is part of
4933 -- a stand-alone declaration, and must be fully expanded.
4934
4935 if Nkind (E) = N_Qualified_Expression then
4936 Set_Expansion_Delayed (Expression (E), False);
4937 Set_Analyzed (Expression (E), False);
4938 else
4939 Set_Expansion_Delayed (E, False);
4940 end if;
4941
70482933
RK		 4942 Set_Analyzed (E, False);
4943 end if;
4944
4945 Insert_Action (Exp,
4946 Make_Object_Declaration (Loc,
4947 Defining_Identifier => Def_Id,
4948 Object_Definition => New_Reference_To (Ref_Type, Loc),
4949 Expression => New_Exp));
4950 end if;
4951
4952 -- Preserve the Assignment_OK flag in all copies, since at least
4953 -- one copy may be used in a context where this flag must be set
4954 -- (otherwise why would the flag be set in the first place).
4955
4956 Set_Assignment_OK (Res, Assignment_OK (Exp));
4957
4958 -- Finally rewrite the original expression and we are done
4959
4960 Rewrite (Exp, Res);
4961 Analyze_And_Resolve (Exp, Exp_Type);
4962 Scope_Suppress := Svg_Suppress;
4963 end Remove_Side_Effects;
4964
f44fe430
RD		 4965 ---------------------------
4966 -- Represented_As_Scalar --
4967 ---------------------------
4968
4969 function Represented_As_Scalar (T : Entity_Id) return Boolean is
4970 UT : constant Entity_Id := Underlying_Type (T);
4971 begin
4972 return Is_Scalar_Type (UT)
4973 or else (Is_Bit_Packed_Array (UT)
4974 and then Is_Scalar_Type (Packed_Array_Type (UT)));
4975 end Represented_As_Scalar;
4976
70482933
RK		 4977 ------------------------------------
4978 -- Safe_Unchecked_Type_Conversion --
4979 ------------------------------------
4980
4981 -- Note: this function knows quite a bit about the exact requirements
4982 -- of Gigi with respect to unchecked type conversions, and its code
4983 -- must be coordinated with any changes in Gigi in this area.
4984
4985 -- The above requirements should be documented in Sinfo ???
4986
4987 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
4988 Otyp : Entity_Id;
4989 Ityp : Entity_Id;
4990 Oalign : Uint;
4991 Ialign : Uint;
4992 Pexp : constant Node_Id := Parent (Exp);
4993
4994 begin
4995 -- If the expression is the RHS of an assignment or object declaration
4996 -- we are always OK because there will always be a target.
4997
4998 -- Object renaming declarations, (generated for view conversions of
4999 -- actuals in inlined calls), like object declarations, provide an
5000 -- explicit type, and are safe as well.
5001
5002 if (Nkind (Pexp) = N_Assignment_Statement
5003 and then Expression (Pexp) = Exp)
5004 or else Nkind (Pexp) = N_Object_Declaration
5005 or else Nkind (Pexp) = N_Object_Renaming_Declaration
5006 then
5007 return True;
5008
5009 -- If the expression is the prefix of an N_Selected_Component
5010 -- we should also be OK because GCC knows to look inside the
5011 -- conversion except if the type is discriminated. We assume
5012 -- that we are OK anyway if the type is not set yet or if it is
5013 -- controlled since we can't afford to introduce a temporary in
5014 -- this case.
5015
5016 elsif Nkind (Pexp) = N_Selected_Component
5017 and then Prefix (Pexp) = Exp
5018 then
5019 if No (Etype (Pexp)) then
5020 return True;
5021 else
5022 return
5023 not Has_Discriminants (Etype (Pexp))
5024 or else Is_Constrained (Etype (Pexp));
5025 end if;
5026 end if;
5027
5028 -- Set the output type, this comes from Etype if it is set, otherwise
5029 -- we take it from the subtype mark, which we assume was already
5030 -- fully analyzed.
5031
5032 if Present (Etype (Exp)) then
5033 Otyp := Etype (Exp);
5034 else
5035 Otyp := Entity (Subtype_Mark (Exp));
5036 end if;
5037
5038 -- The input type always comes from the expression, and we assume
5039 -- this is indeed always analyzed, so we can simply get the Etype.
5040
5041 Ityp := Etype (Expression (Exp));
5042
5043 -- Initialize alignments to unknown so far
5044
5045 Oalign := No_Uint;
5046 Ialign := No_Uint;
5047
5048 -- Replace a concurrent type by its corresponding record type
5049 -- and each type by its underlying type and do the tests on those.
5050 -- The original type may be a private type whose completion is a
5051 -- concurrent type, so find the underlying type first.
5052
5053 if Present (Underlying_Type (Otyp)) then
5054 Otyp := Underlying_Type (Otyp);
5055 end if;
5056
5057 if Present (Underlying_Type (Ityp)) then
5058 Ityp := Underlying_Type (Ityp);
5059 end if;
5060
5061 if Is_Concurrent_Type (Otyp) then
5062 Otyp := Corresponding_Record_Type (Otyp);
5063 end if;
5064
5065 if Is_Concurrent_Type (Ityp) then
5066 Ityp := Corresponding_Record_Type (Ityp);
5067 end if;
5068
5069 -- If the base types are the same, we know there is no problem since
5070 -- this conversion will be a noop.
5071
5072 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
5073 return True;
5074
6cdb2c6e
AC		 5075 -- Same if this is an upwards conversion of an untagged type, and there
5076 -- are no constraints involved (could be more general???)
5077
5078 elsif Etype (Ityp) = Otyp
5079 and then not Is_Tagged_Type (Ityp)
5080 and then not Has_Discriminants (Ityp)
5081 and then No (First_Rep_Item (Base_Type (Ityp)))
5082 then
5083 return True;
5084
4da17013
AC		 5085 -- If the expression has an access type (object or subprogram) we
5086 -- assume that the conversion is safe, because the size of the target
ef7c5692 5087 -- is safe, even if it is a record (which might be treated as having
4da17013
AC		 5088 -- unknown size at this point).
5089
5090 elsif Is_Access_Type (Ityp) then
5091 return True;
5092
70482933
RK		 5093 -- If the size of output type is known at compile time, there is
5094 -- never a problem. Note that unconstrained records are considered
5095 -- to be of known size, but we can't consider them that way here,
5096 -- because we are talking about the actual size of the object.
5097
5098 -- We also make sure that in addition to the size being known, we do
5099 -- not have a case which might generate an embarrassingly large temp
5100 -- in stack checking mode.
5101
5102 elsif Size_Known_At_Compile_Time (Otyp)
7324bf49
AC		 5103 and then
5104 (not Stack_Checking_Enabled
5105 or else not May_Generate_Large_Temp (Otyp))
70482933
RK		 5106 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
5107 then
5108 return True;
5109
5110 -- If either type is tagged, then we know the alignment is OK so
5111 -- Gigi will be able to use pointer punning.
5112
5113 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
5114 return True;
5115
5116 -- If either type is a limited record type, we cannot do a copy, so
5117 -- say safe since there's nothing else we can do.
5118
5119 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
5120 return True;
5121
5122 -- Conversions to and from packed array types are always ignored and
5123 -- hence are safe.
5124
5125 elsif Is_Packed_Array_Type (Otyp)
5126 or else Is_Packed_Array_Type (Ityp)
5127 then
5128 return True;
5129 end if;
5130
5131 -- The only other cases known to be safe is if the input type's
5132 -- alignment is known to be at least the maximum alignment for the
5133 -- target or if both alignments are known and the output type's
5134 -- alignment is no stricter than the input's. We can use the alignment
5135 -- of the component type of an array if a type is an unpacked
5136 -- array type.
5137
5138 if Present (Alignment_Clause (Otyp)) then
5139 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
5140
5141 elsif Is_Array_Type (Otyp)
5142 and then Present (Alignment_Clause (Component_Type (Otyp)))
5143 then
5144 Oalign := Expr_Value (Expression (Alignment_Clause
5145 (Component_Type (Otyp))));
5146 end if;
5147
5148 if Present (Alignment_Clause (Ityp)) then
5149 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
5150
5151 elsif Is_Array_Type (Ityp)
5152 and then Present (Alignment_Clause (Component_Type (Ityp)))
5153 then
5154 Ialign := Expr_Value (Expression (Alignment_Clause
5155 (Component_Type (Ityp))));
5156 end if;
5157
5158 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
5159 return True;
5160
5161 elsif Ialign /= No_Uint and then Oalign /= No_Uint
5162 and then Ialign <= Oalign
5163 then
5164 return True;
5165
bebbff91 5166 -- Otherwise, Gigi cannot handle this and we must make a temporary
70482933
RK		 5167
5168 else
5169 return False;
5170 end if;
70482933
RK		 5171 end Safe_Unchecked_Type_Conversion;
5172
05350ac6
BD		 5173 ---------------------------------
5174 -- Set_Current_Value_Condition --
5175 ---------------------------------
5176
5177 -- Note: the implementation of this procedure is very closely tied to the
5178 -- implementation of Get_Current_Value_Condition. Here we set required
5179 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
5180 -- them, so they must have a consistent view.
5181
5182 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
5183
5184 procedure Set_Entity_Current_Value (N : Node_Id);
5185 -- If N is an entity reference, where the entity is of an appropriate
5186 -- kind, then set the current value of this entity to Cnode, unless
5187 -- there is already a definite value set there.
5188
5189 procedure Set_Expression_Current_Value (N : Node_Id);
5190 -- If N is of an appropriate form, sets an appropriate entry in current
5191 -- value fields of relevant entities. Multiple entities can be affected
5192 -- in the case of an AND or AND THEN.
5193
5194 ------------------------------
5195 -- Set_Entity_Current_Value --
5196 ------------------------------
5197
5198 procedure Set_Entity_Current_Value (N : Node_Id) is
5199 begin
5200 if Is_Entity_Name (N) then
5201 declare
5202 Ent : constant Entity_Id := Entity (N);
5203
5204 begin
5205 -- Don't capture if not safe to do so
5206
5207 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
5208 return;
5209 end if;
5210
5211 -- Here we have a case where the Current_Value field may
5212 -- need to be set. We set it if it is not already set to a
5213 -- compile time expression value.
5214
5215 -- Note that this represents a decision that one condition
5216 -- blots out another previous one. That's certainly right
5217 -- if they occur at the same level. If the second one is
5218 -- nested, then the decision is neither right nor wrong (it
5219 -- would be equally OK to leave the outer one in place, or
5220 -- take the new inner one. Really we should record both, but
5221 -- our data structures are not that elaborate.
5222
5223 if Nkind (Current_Value (Ent)) not in N_Subexpr then
5224 Set_Current_Value (Ent, Cnode);
5225 end if;
5226 end;
5227 end if;
5228 end Set_Entity_Current_Value;
5229
5230 ----------------------------------
5231 -- Set_Expression_Current_Value --
5232 ----------------------------------
5233
5234 procedure Set_Expression_Current_Value (N : Node_Id) is
5235 Cond : Node_Id;
5236
5237 begin
5238 Cond := N;
5239
5240 -- Loop to deal with (ignore for now) any NOT operators present. The
5241 -- presence of NOT operators will be handled properly when we call
5242 -- Get_Current_Value_Condition.
5243
5244 while Nkind (Cond) = N_Op_Not loop
5245 Cond := Right_Opnd (Cond);
5246 end loop;
5247
5248 -- For an AND or AND THEN, recursively process operands
5249
5250 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
5251 Set_Expression_Current_Value (Left_Opnd (Cond));
5252 Set_Expression_Current_Value (Right_Opnd (Cond));
5253 return;
5254 end if;
5255
5256 -- Check possible relational operator
5257
5258 if Nkind (Cond) in N_Op_Compare then
5259 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
5260 Set_Entity_Current_Value (Left_Opnd (Cond));
5261 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
5262 Set_Entity_Current_Value (Right_Opnd (Cond));
5263 end if;
5264
5265 -- Check possible boolean variable reference
5266
5267 else
5268 Set_Entity_Current_Value (Cond);
5269 end if;
5270 end Set_Expression_Current_Value;
5271
5272 -- Start of processing for Set_Current_Value_Condition
5273
5274 begin
5275 Set_Expression_Current_Value (Condition (Cnode));
5276 end Set_Current_Value_Condition;
5277
70482933
RK		 5278 --------------------------
5279 -- Set_Elaboration_Flag --
5280 --------------------------
5281
5282 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
5283 Loc : constant Source_Ptr := Sloc (N);
fbf5a39b 5284 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
70482933
RK		 5285 Asn : Node_Id;
5286
5287 begin
fbf5a39b 5288 if Present (Ent) then
70482933
RK		 5289
5290 -- Nothing to do if at the compilation unit level, because in this
5291 -- case the flag is set by the binder generated elaboration routine.
5292
5293 if Nkind (Parent (N)) = N_Compilation_Unit then
5294 null;
5295
5296 -- Here we do need to generate an assignment statement
5297
5298 else
5299 Check_Restriction (No_Elaboration_Code, N);
5300 Asn :=
5301 Make_Assignment_Statement (Loc,
fbf5a39b 5302 Name => New_Occurrence_Of (Ent, Loc),
70482933
RK		 5303 Expression => New_Occurrence_Of (Standard_True, Loc));
5304
5305 if Nkind (Parent (N)) = N_Subunit then
5306 Insert_After (Corresponding_Stub (Parent (N)), Asn);
5307 else
5308 Insert_After (N, Asn);
5309 end if;
5310
5311 Analyze (Asn);
fbf5a39b 5312
65df5b71
HK		 5313 -- Kill current value indication. This is necessary because the
5314 -- tests of this flag are inserted out of sequence and must not
5315 -- pick up bogus indications of the wrong constant value.
fbf5a39b
AC		 5316
5317 Set_Current_Value (Ent, Empty);
70482933
RK		 5318 end if;
5319 end if;
5320 end Set_Elaboration_Flag;
5321
59e54267
ES		 5322 ----------------------------
5323 -- Set_Renamed_Subprogram --
5324 ----------------------------
5325
5326 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
5327 begin
5328 -- If input node is an identifier, we can just reset it
5329
5330 if Nkind (N) = N_Identifier then
5331 Set_Chars (N, Chars (E));
5332 Set_Entity (N, E);
5333
5334 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
5335
5336 else
5337 declare
5338 CS : constant Boolean := Comes_From_Source (N);
5339 begin
5340 Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
5341 Set_Entity (N, E);
5342 Set_Comes_From_Source (N, CS);
5343 Set_Analyzed (N, True);
5344 end;
5345 end if;
5346 end Set_Renamed_Subprogram;
5347
65df5b71
HK		 5348 ----------------------------------
5349 -- Silly_Boolean_Array_Not_Test --
5350 ----------------------------------
5351
5352 -- This procedure implements an odd and silly test. We explicitly check
5353 -- for the case where the 'First of the component type is equal to the
5354 -- 'Last of this component type, and if this is the case, we make sure
5355 -- that constraint error is raised. The reason is that the NOT is bound
5356 -- to cause CE in this case, and we will not otherwise catch it.
5357
b3b9865d
AC		 5358 -- No such check is required for AND and OR, since for both these cases
5359 -- False op False = False, and True op True = True. For the XOR case,
5360 -- see Silly_Boolean_Array_Xor_Test.
5361
65df5b71
HK		 5362 -- Believe it or not, this was reported as a bug. Note that nearly
5363 -- always, the test will evaluate statically to False, so the code will
5364 -- be statically removed, and no extra overhead caused.
5365
5366 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
5367 Loc : constant Source_Ptr := Sloc (N);
5368 CT : constant Entity_Id := Component_Type (T);
5369
5370 begin
b3b9865d
AC		 5371 -- The check we install is
5372
5373 -- constraint_error when
5374 -- component_type'first = component_type'last
5375 -- and then array_type'Length /= 0)
5376
5377 -- We need the last guard because we don't want to raise CE for empty
5378 -- arrays since no out of range values result. (Empty arrays with a
5379 -- component type of True .. True -- very useful -- even the ACATS
5380 -- does not test that marginal case!)
5381
65df5b71
HK		 5382 Insert_Action (N,
5383 Make_Raise_Constraint_Error (Loc,
5384 Condition =>
b3b9865d 5385 Make_And_Then (Loc,
65df5b71 5386 Left_Opnd =>
b3b9865d
AC		 5387 Make_Op_Eq (Loc,
5388 Left_Opnd =>
5389 Make_Attribute_Reference (Loc,
5390 Prefix => New_Occurrence_Of (CT, Loc),
5391 Attribute_Name => Name_First),
5392
5393 Right_Opnd =>
5394 Make_Attribute_Reference (Loc,
5395 Prefix => New_Occurrence_Of (CT, Loc),
5396 Attribute_Name => Name_Last)),
5397
5398 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
65df5b71
HK		 5399 Reason => CE_Range_Check_Failed));
5400 end Silly_Boolean_Array_Not_Test;
5401
5402 ----------------------------------
5403 -- Silly_Boolean_Array_Xor_Test --
5404 ----------------------------------
5405
5406 -- This procedure implements an odd and silly test. We explicitly check
5407 -- for the XOR case where the component type is True .. True, since this
5408 -- will raise constraint error. A special check is required since CE
f17889b3 5409 -- will not be generated otherwise (cf Expand_Packed_Not).
65df5b71
HK		 5410
5411 -- No such check is required for AND and OR, since for both these cases
b3b9865d
AC		 5412 -- False op False = False, and True op True = True, and no check is
5413 -- required for the case of False .. False, since False xor False = False.
5414 -- See also Silly_Boolean_Array_Not_Test
65df5b71
HK		 5415
5416 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
5417 Loc : constant Source_Ptr := Sloc (N);
5418 CT : constant Entity_Id := Component_Type (T);
65df5b71
HK		 5419
5420 begin
f17889b3
RD		 5421 -- The check we install is
5422
5423 -- constraint_error when
5424 -- Boolean (component_type'First)
5425 -- and then Boolean (component_type'Last)
5426 -- and then array_type'Length /= 0)
5427
5428 -- We need the last guard because we don't want to raise CE for empty
5429 -- arrays since no out of range values result (Empty arrays with a
5430 -- component type of True .. True -- very useful -- even the ACATS
5431 -- does not test that marginal case!).
5432
65df5b71
HK		 5433 Insert_Action (N,
5434 Make_Raise_Constraint_Error (Loc,
5435 Condition =>
f17889b3 5436 Make_And_Then (Loc,
65df5b71 5437 Left_Opnd =>
f17889b3 5438 Make_And_Then (Loc,
65df5b71 5439 Left_Opnd =>
f17889b3
RD		 5440 Convert_To (Standard_Boolean,
5441 Make_Attribute_Reference (Loc,
5442 Prefix => New_Occurrence_Of (CT, Loc),
5443 Attribute_Name => Name_First)),
65df5b71
HK		 5444
5445 Right_Opnd =>
f17889b3
RD		 5446 Convert_To (Standard_Boolean,
5447 Make_Attribute_Reference (Loc,
5448 Prefix => New_Occurrence_Of (CT, Loc),
5449 Attribute_Name => Name_Last))),
65df5b71 5450
b3b9865d 5451 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
65df5b71
HK		 5452 Reason => CE_Range_Check_Failed));
5453 end Silly_Boolean_Array_Xor_Test;
5454
fbf5a39b
AC		 5455 --------------------------
5456 -- Target_Has_Fixed_Ops --
5457 --------------------------
5458
5459 Integer_Sized_Small : Ureal;
5460 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
5461 -- function is called (we don't want to compute it more than once!)
5462
5463 Long_Integer_Sized_Small : Ureal;
5464 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
e14c931f 5465 -- function is called (we don't want to compute it more than once)
fbf5a39b
AC		 5466
5467 First_Time_For_THFO : Boolean := True;
5468 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5469
5470 function Target_Has_Fixed_Ops
5471 (Left_Typ : Entity_Id;
5472 Right_Typ : Entity_Id;
bebbff91 5473 Result_Typ : Entity_Id) return Boolean
fbf5a39b
AC		 5474 is
5475 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
5476 -- Return True if the given type is a fixed-point type with a small
5477 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5478 -- an absolute value less than 1.0. This is currently limited
5479 -- to fixed-point types that map to Integer or Long_Integer.
5480
5481 ------------------------
5482 -- Is_Fractional_Type --
5483 ------------------------
5484
5485 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
5486 begin
5487 if Esize (Typ) = Standard_Integer_Size then
5488 return Small_Value (Typ) = Integer_Sized_Small;
5489
5490 elsif Esize (Typ) = Standard_Long_Integer_Size then
5491 return Small_Value (Typ) = Long_Integer_Sized_Small;
5492
5493 else
5494 return False;
5495 end if;
5496 end Is_Fractional_Type;
5497
5498 -- Start of processing for Target_Has_Fixed_Ops
5499
5500 begin
5501 -- Return False if Fractional_Fixed_Ops_On_Target is false
5502
5503 if not Fractional_Fixed_Ops_On_Target then
5504 return False;
5505 end if;
5506
5507 -- Here the target has Fractional_Fixed_Ops, if first time, compute
5508 -- standard constants used by Is_Fractional_Type.
5509
5510 if First_Time_For_THFO then
5511 First_Time_For_THFO := False;
5512
5513 Integer_Sized_Small :=
5514 UR_From_Components
5515 (Num => Uint_1,
5516 Den => UI_From_Int (Standard_Integer_Size - 1),
5517 Rbase => 2);
5518
5519 Long_Integer_Sized_Small :=
5520 UR_From_Components
5521 (Num => Uint_1,
5522 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
5523 Rbase => 2);
5524 end if;
5525
5526 -- Return True if target supports fixed-by-fixed multiply/divide
5527 -- for fractional fixed-point types (see Is_Fractional_Type) and
5528 -- the operand and result types are equivalent fractional types.
5529
5530 return Is_Fractional_Type (Base_Type (Left_Typ))
5531 and then Is_Fractional_Type (Base_Type (Right_Typ))
5532 and then Is_Fractional_Type (Base_Type (Result_Typ))
5533 and then Esize (Left_Typ) = Esize (Right_Typ)
5534 and then Esize (Left_Typ) = Esize (Result_Typ);
5535 end Target_Has_Fixed_Ops;
5536
91b1417d
AC		 5537 ------------------------------------------
5538 -- Type_May_Have_Bit_Aligned_Components --
5539 ------------------------------------------
5540
5541 function Type_May_Have_Bit_Aligned_Components
5542 (Typ : Entity_Id) return Boolean
5543 is
5544 begin
5545 -- Array type, check component type
5546
5547 if Is_Array_Type (Typ) then
5548 return
5549 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
5550
5551 -- Record type, check components
5552
5553 elsif Is_Record_Type (Typ) then
5554 declare
5555 E : Entity_Id;
5556
5557 begin
dee4682a 5558 E := First_Component_Or_Discriminant (Typ);
91b1417d 5559 while Present (E) loop
dee4682a
JM		 5560 if Component_May_Be_Bit_Aligned (E)
5561 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
91b1417d 5562 then
dee4682a 5563 return True;
91b1417d
AC		 5564 end if;
5565
dee4682a 5566 Next_Component_Or_Discriminant (E);
91b1417d
AC		 5567 end loop;
5568
5569 return False;
5570 end;
5571
5572 -- Type other than array or record is always OK
5573
5574 else
5575 return False;
5576 end if;
5577 end Type_May_Have_Bit_Aligned_Components;
5578
70482933
RK		 5579 ----------------------------
5580 -- Wrap_Cleanup_Procedure --
5581 ----------------------------
5582
5583 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
5584 Loc : constant Source_Ptr := Sloc (N);
5585 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
5586 Stmts : constant List_Id := Statements (Stseq);
5587
5588 begin
5589 if Abort_Allowed then
5590 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
5591 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
5592 end if;
5593 end Wrap_Cleanup_Procedure;
5594
5595end Exp_Util;
GNU Compiler Collection
This page took 4.405921 seconds and 5 git commands to generate.