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