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