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-2013, 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 3, 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Casing; use Casing; 29with Checks; use Checks; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Elists; use Elists; 33with Errout; use Errout; 34with Exp_Aggr; use Exp_Aggr; 35with Exp_Ch6; use Exp_Ch6; 36with Exp_Ch7; use Exp_Ch7; 37with Inline; use Inline; 38with Itypes; use Itypes; 39with Lib; use Lib; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Opt; use Opt; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Sem; use Sem; 46with Sem_Aux; use Sem_Aux; 47with Sem_Ch8; use Sem_Ch8; 48with Sem_Eval; use Sem_Eval; 49with Sem_Res; use Sem_Res; 50with Sem_Type; use Sem_Type; 51with Sem_Util; use Sem_Util; 52with Snames; use Snames; 53with Stand; use Stand; 54with Stringt; use Stringt; 55with Targparm; use Targparm; 56with Tbuild; use Tbuild; 57with Ttypes; use Ttypes; 58with Urealp; use Urealp; 59with Validsw; use Validsw; 60 61package body Exp_Util is 62 63 ----------------------- 64 -- Local Subprograms -- 65 ----------------------- 66 67 function Build_Task_Array_Image 68 (Loc : Source_Ptr; 69 Id_Ref : Node_Id; 70 A_Type : Entity_Id; 71 Dyn : Boolean := False) return Node_Id; 72 -- Build function to generate the image string for a task that is an array 73 -- component, concatenating the images of each index. To avoid storage 74 -- leaks, the string is built with successive slice assignments. The flag 75 -- Dyn indicates whether this is called for the initialization procedure of 76 -- an array of tasks, or for the name of a dynamically created task that is 77 -- 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) return Node_Id; 84 -- Common processing for Task_Array_Image and Task_Record_Image. Build 85 -- function body that computes image. 86 87 procedure Build_Task_Image_Prefix 88 (Loc : Source_Ptr; 89 Len : out Entity_Id; 90 Res : out Entity_Id; 91 Pos : out Entity_Id; 92 Prefix : Entity_Id; 93 Sum : Node_Id; 94 Decls : List_Id; 95 Stats : List_Id); 96 -- Common processing for Task_Array_Image and Task_Record_Image. Create 97 -- local variables and assign prefix of name to result string. 98 99 function Build_Task_Record_Image 100 (Loc : Source_Ptr; 101 Id_Ref : Node_Id; 102 Dyn : Boolean := False) return Node_Id; 103 -- Build function to generate the image string for a task that is a record 104 -- component. Concatenate name of variable with that of selector. The flag 105 -- Dyn indicates whether this is called for the initialization procedure of 106 -- record with task components, or for a dynamically created task that is 107 -- assigned to a selected component. 108 109 procedure Evaluate_Slice_Bounds (Slice : Node_Id); 110 -- Force evaluation of bounds of a slice, which may be given by a range 111 -- or by a subtype indication with or without a constraint. 112 113 function Make_CW_Equivalent_Type 114 (T : Entity_Id; 115 E : Node_Id) return Entity_Id; 116 -- T is a class-wide type entity, E is the initial expression node that 117 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function 118 -- returns the entity of the Equivalent type and inserts on the fly the 119 -- necessary declaration such as: 120 -- 121 -- type anon is record 122 -- _parent : Root_Type (T); constrained with E discriminants (if any) 123 -- Extension : String (1 .. expr to match size of E); 124 -- end record; 125 -- 126 -- This record is compatible with any object of the class of T thanks to 127 -- the first field and has the same size as E thanks to the second. 128 129 function Make_Literal_Range 130 (Loc : Source_Ptr; 131 Literal_Typ : Entity_Id) 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 -- If the index type of the target array is not integer, we generate: 138 -- Low_Bound (Literal_Type) .. 139 -- Literal_Type'Val 140 -- (Literal_Type'Pos (Low_Bound (Literal_Type)) 141 -- + (Length (Literal_Typ) -1)) 142 143 function Make_Non_Empty_Check 144 (Loc : Source_Ptr; 145 N : Node_Id) return Node_Id; 146 -- Produce a boolean expression checking that the unidimensional array 147 -- node N is not empty. 148 149 function New_Class_Wide_Subtype 150 (CW_Typ : Entity_Id; 151 N : Node_Id) return Entity_Id; 152 -- Create an implicit subtype of CW_Typ attached to node N 153 154 function Requires_Cleanup_Actions 155 (L : List_Id; 156 Lib_Level : Boolean; 157 Nested_Constructs : Boolean) return Boolean; 158 -- Given a list L, determine whether it contains one of the following: 159 -- 160 -- 1) controlled objects 161 -- 2) library-level tagged types 162 -- 163 -- Lib_Level is True when the list comes from a construct at the library 164 -- level, and False otherwise. Nested_Constructs is True when any nested 165 -- packages declared in L must be processed, and False otherwise. 166 167 ------------------------------------- 168 -- Activate_Atomic_Synchronization -- 169 ------------------------------------- 170 171 procedure Activate_Atomic_Synchronization (N : Node_Id) is 172 Msg_Node : Node_Id; 173 174 begin 175 case Nkind (Parent (N)) is 176 177 -- Check for cases of appearing in the prefix of a construct where 178 -- we don't need atomic synchronization for this kind of usage. 179 180 when 181 -- Nothing to do if we are the prefix of an attribute, since we 182 -- do not want an atomic sync operation for things like 'Size. 183 184 N_Attribute_Reference | 185 186 -- The N_Reference node is like an attribute 187 188 N_Reference | 189 190 -- Nothing to do for a reference to a component (or components) 191 -- of a composite object. Only reads and updates of the object 192 -- as a whole require atomic synchronization (RM C.6 (15)). 193 194 N_Indexed_Component | 195 N_Selected_Component | 196 N_Slice => 197 198 -- For all the above cases, nothing to do if we are the prefix 199 200 if Prefix (Parent (N)) = N then 201 return; 202 end if; 203 204 when others => null; 205 end case; 206 207 -- Go ahead and set the flag 208 209 Set_Atomic_Sync_Required (N); 210 211 -- Generate info message if requested 212 213 if Warn_On_Atomic_Synchronization then 214 case Nkind (N) is 215 when N_Identifier => 216 Msg_Node := N; 217 218 when N_Selected_Component | N_Expanded_Name => 219 Msg_Node := Selector_Name (N); 220 221 when N_Explicit_Dereference | N_Indexed_Component => 222 Msg_Node := Empty; 223 224 when others => 225 pragma Assert (False); 226 return; 227 end case; 228 229 if Present (Msg_Node) then 230 Error_Msg_N 231 ("?N?info: atomic synchronization set for &", Msg_Node); 232 else 233 Error_Msg_N 234 ("?N?info: atomic synchronization set", N); 235 end if; 236 end if; 237 end Activate_Atomic_Synchronization; 238 239 ---------------------- 240 -- Adjust_Condition -- 241 ---------------------- 242 243 procedure Adjust_Condition (N : Node_Id) is 244 begin 245 if No (N) then 246 return; 247 end if; 248 249 declare 250 Loc : constant Source_Ptr := Sloc (N); 251 T : constant Entity_Id := Etype (N); 252 Ti : Entity_Id; 253 254 begin 255 -- Defend against a call where the argument has no type, or has a 256 -- type that is not Boolean. This can occur because of prior errors. 257 258 if No (T) or else not Is_Boolean_Type (T) then 259 return; 260 end if; 261 262 -- Apply validity checking if needed 263 264 if Validity_Checks_On and Validity_Check_Tests then 265 Ensure_Valid (N); 266 end if; 267 268 -- Immediate return if standard boolean, the most common case, 269 -- where nothing needs to be done. 270 271 if Base_Type (T) = Standard_Boolean then 272 return; 273 end if; 274 275 -- Case of zero/non-zero semantics or non-standard enumeration 276 -- representation. In each case, we rewrite the node as: 277 278 -- ityp!(N) /= False'Enum_Rep 279 280 -- where ityp is an integer type with large enough size to hold any 281 -- value of type T. 282 283 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then 284 if Esize (T) <= Esize (Standard_Integer) then 285 Ti := Standard_Integer; 286 else 287 Ti := Standard_Long_Long_Integer; 288 end if; 289 290 Rewrite (N, 291 Make_Op_Ne (Loc, 292 Left_Opnd => Unchecked_Convert_To (Ti, N), 293 Right_Opnd => 294 Make_Attribute_Reference (Loc, 295 Attribute_Name => Name_Enum_Rep, 296 Prefix => 297 New_Occurrence_Of (First_Literal (T), Loc)))); 298 Analyze_And_Resolve (N, Standard_Boolean); 299 300 else 301 Rewrite (N, Convert_To (Standard_Boolean, N)); 302 Analyze_And_Resolve (N, Standard_Boolean); 303 end if; 304 end; 305 end Adjust_Condition; 306 307 ------------------------ 308 -- Adjust_Result_Type -- 309 ------------------------ 310 311 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is 312 begin 313 -- Ignore call if current type is not Standard.Boolean 314 315 if Etype (N) /= Standard_Boolean then 316 return; 317 end if; 318 319 -- If result is already of correct type, nothing to do. Note that 320 -- this will get the most common case where everything has a type 321 -- of Standard.Boolean. 322 323 if Base_Type (T) = Standard_Boolean then 324 return; 325 326 else 327 declare 328 KP : constant Node_Kind := Nkind (Parent (N)); 329 330 begin 331 -- If result is to be used as a Condition in the syntax, no need 332 -- to convert it back, since if it was changed to Standard.Boolean 333 -- using Adjust_Condition, that is just fine for this usage. 334 335 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then 336 return; 337 338 -- If result is an operand of another logical operation, no need 339 -- to reset its type, since Standard.Boolean is just fine, and 340 -- such operations always do Adjust_Condition on their operands. 341 342 elsif KP in N_Op_Boolean 343 or else KP in N_Short_Circuit 344 or else KP = N_Op_Not 345 then 346 return; 347 348 -- Otherwise we perform a conversion from the current type, which 349 -- must be Standard.Boolean, to the desired type. 350 351 else 352 Set_Analyzed (N); 353 Rewrite (N, Convert_To (T, N)); 354 Analyze_And_Resolve (N, T); 355 end if; 356 end; 357 end if; 358 end Adjust_Result_Type; 359 360 -------------------------- 361 -- Append_Freeze_Action -- 362 -------------------------- 363 364 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is 365 Fnode : Node_Id; 366 367 begin 368 Ensure_Freeze_Node (T); 369 Fnode := Freeze_Node (T); 370 371 if No (Actions (Fnode)) then 372 Set_Actions (Fnode, New_List (N)); 373 else 374 Append (N, Actions (Fnode)); 375 end if; 376 377 end Append_Freeze_Action; 378 379 --------------------------- 380 -- Append_Freeze_Actions -- 381 --------------------------- 382 383 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is 384 Fnode : Node_Id; 385 386 begin 387 if No (L) then 388 return; 389 end if; 390 391 Ensure_Freeze_Node (T); 392 Fnode := Freeze_Node (T); 393 394 if No (Actions (Fnode)) then 395 Set_Actions (Fnode, L); 396 else 397 Append_List (L, Actions (Fnode)); 398 end if; 399 end Append_Freeze_Actions; 400 401 ------------------------------------ 402 -- Build_Allocate_Deallocate_Proc -- 403 ------------------------------------ 404 405 procedure Build_Allocate_Deallocate_Proc 406 (N : Node_Id; 407 Is_Allocate : Boolean) 408 is 409 Desig_Typ : Entity_Id; 410 Expr : Node_Id; 411 Pool_Id : Entity_Id; 412 Proc_To_Call : Node_Id := Empty; 413 Ptr_Typ : Entity_Id; 414 415 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id; 416 -- Locate TSS primitive Finalize_Address in type Typ 417 418 function Find_Object (E : Node_Id) return Node_Id; 419 -- Given an arbitrary expression of an allocator, try to find an object 420 -- reference in it, otherwise return the original expression. 421 422 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean; 423 -- Determine whether subprogram Subp denotes a custom allocate or 424 -- deallocate. 425 426 --------------------------- 427 -- Find_Finalize_Address -- 428 --------------------------- 429 430 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is 431 Utyp : Entity_Id := Typ; 432 433 begin 434 -- Handle protected class-wide or task class-wide types 435 436 if Is_Class_Wide_Type (Utyp) then 437 if Is_Concurrent_Type (Root_Type (Utyp)) then 438 Utyp := Root_Type (Utyp); 439 440 elsif Is_Private_Type (Root_Type (Utyp)) 441 and then Present (Full_View (Root_Type (Utyp))) 442 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp))) 443 then 444 Utyp := Full_View (Root_Type (Utyp)); 445 end if; 446 end if; 447 448 -- Handle private types 449 450 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then 451 Utyp := Full_View (Utyp); 452 end if; 453 454 -- Handle protected and task types 455 456 if Is_Concurrent_Type (Utyp) 457 and then Present (Corresponding_Record_Type (Utyp)) 458 then 459 Utyp := Corresponding_Record_Type (Utyp); 460 end if; 461 462 Utyp := Underlying_Type (Base_Type (Utyp)); 463 464 -- Deal with non-tagged derivation of private views. If the parent is 465 -- now known to be protected, the finalization routine is the one 466 -- defined on the corresponding record of the ancestor (corresponding 467 -- records do not automatically inherit operations, but maybe they 468 -- should???) 469 470 if Is_Untagged_Derivation (Typ) then 471 if Is_Protected_Type (Typ) then 472 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); 473 else 474 Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); 475 476 if Is_Protected_Type (Utyp) then 477 Utyp := Corresponding_Record_Type (Utyp); 478 end if; 479 end if; 480 end if; 481 482 -- If the underlying_type is a subtype, we are dealing with the 483 -- completion of a private type. We need to access the base type and 484 -- generate a conversion to it. 485 486 if Utyp /= Base_Type (Utyp) then 487 pragma Assert (Is_Private_Type (Typ)); 488 489 Utyp := Base_Type (Utyp); 490 end if; 491 492 -- When dealing with an internally built full view for a type with 493 -- unknown discriminants, use the original record type. 494 495 if Is_Underlying_Record_View (Utyp) then 496 Utyp := Etype (Utyp); 497 end if; 498 499 return TSS (Utyp, TSS_Finalize_Address); 500 end Find_Finalize_Address; 501 502 ----------------- 503 -- Find_Object -- 504 ----------------- 505 506 function Find_Object (E : Node_Id) return Node_Id is 507 Expr : Node_Id; 508 509 begin 510 pragma Assert (Is_Allocate); 511 512 Expr := E; 513 loop 514 if Nkind (Expr) = N_Explicit_Dereference then 515 Expr := Prefix (Expr); 516 517 elsif Nkind (Expr) = N_Qualified_Expression then 518 Expr := Expression (Expr); 519 520 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then 521 522 -- When interface class-wide types are involved in allocation, 523 -- the expander introduces several levels of address arithmetic 524 -- to perform dispatch table displacement. In this scenario the 525 -- object appears as: 526 527 -- Tag_Ptr (Base_Address (<object>'Address)) 528 529 -- Detect this case and utilize the whole expression as the 530 -- "object" since it now points to the proper dispatch table. 531 532 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then 533 exit; 534 535 -- Continue to strip the object 536 537 else 538 Expr := Expression (Expr); 539 end if; 540 541 else 542 exit; 543 end if; 544 end loop; 545 546 return Expr; 547 end Find_Object; 548 549 --------------------------------- 550 -- Is_Allocate_Deallocate_Proc -- 551 --------------------------------- 552 553 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is 554 begin 555 -- Look for a subprogram body with only one statement which is a 556 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled. 557 558 if Ekind (Subp) = E_Procedure 559 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body 560 then 561 declare 562 HSS : constant Node_Id := 563 Handled_Statement_Sequence (Parent (Parent (Subp))); 564 Proc : Entity_Id; 565 566 begin 567 if Present (Statements (HSS)) 568 and then Nkind (First (Statements (HSS))) = 569 N_Procedure_Call_Statement 570 then 571 Proc := Entity (Name (First (Statements (HSS)))); 572 573 return 574 Is_RTE (Proc, RE_Allocate_Any_Controlled) 575 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled); 576 end if; 577 end; 578 end if; 579 580 return False; 581 end Is_Allocate_Deallocate_Proc; 582 583 -- Start of processing for Build_Allocate_Deallocate_Proc 584 585 begin 586 -- Obtain the attributes of the allocation / deallocation 587 588 if Nkind (N) = N_Free_Statement then 589 Expr := Expression (N); 590 Ptr_Typ := Base_Type (Etype (Expr)); 591 Proc_To_Call := Procedure_To_Call (N); 592 593 else 594 if Nkind (N) = N_Object_Declaration then 595 Expr := Expression (N); 596 else 597 Expr := N; 598 end if; 599 600 -- In certain cases an allocator with a qualified expression may 601 -- be relocated and used as the initialization expression of a 602 -- temporary: 603 604 -- before: 605 -- Obj : Ptr_Typ := new Desig_Typ'(...); 606 607 -- after: 608 -- Tmp : Ptr_Typ := new Desig_Typ'(...); 609 -- Obj : Ptr_Typ := Tmp; 610 611 -- Since the allocator is always marked as analyzed to avoid infinite 612 -- expansion, it will never be processed by this routine given that 613 -- the designated type needs finalization actions. Detect this case 614 -- and complete the expansion of the allocator. 615 616 if Nkind (Expr) = N_Identifier 617 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration 618 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator 619 then 620 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True); 621 return; 622 end if; 623 624 -- The allocator may have been rewritten into something else in which 625 -- case the expansion performed by this routine does not apply. 626 627 if Nkind (Expr) /= N_Allocator then 628 return; 629 end if; 630 631 Ptr_Typ := Base_Type (Etype (Expr)); 632 Proc_To_Call := Procedure_To_Call (Expr); 633 end if; 634 635 Pool_Id := Associated_Storage_Pool (Ptr_Typ); 636 Desig_Typ := Available_View (Designated_Type (Ptr_Typ)); 637 638 -- Handle concurrent types 639 640 if Is_Concurrent_Type (Desig_Typ) 641 and then Present (Corresponding_Record_Type (Desig_Typ)) 642 then 643 Desig_Typ := Corresponding_Record_Type (Desig_Typ); 644 end if; 645 646 -- Do not process allocations / deallocations without a pool 647 648 if No (Pool_Id) then 649 return; 650 651 -- Do not process allocations on / deallocations from the secondary 652 -- stack. 653 654 elsif Is_RTE (Pool_Id, RE_SS_Pool) then 655 return; 656 657 -- Do not replicate the machinery if the allocator / free has already 658 -- been expanded and has a custom Allocate / Deallocate. 659 660 elsif Present (Proc_To_Call) 661 and then Is_Allocate_Deallocate_Proc (Proc_To_Call) 662 then 663 return; 664 end if; 665 666 if Needs_Finalization (Desig_Typ) then 667 668 -- Certain run-time configurations and targets do not provide support 669 -- for controlled types. 670 671 if Restriction_Active (No_Finalization) then 672 return; 673 674 -- Do nothing if the access type may never allocate / deallocate 675 -- objects. 676 677 elsif No_Pool_Assigned (Ptr_Typ) then 678 return; 679 680 -- Access-to-controlled types are not supported on .NET/JVM since 681 -- these targets cannot support pools and address arithmetic. 682 683 elsif VM_Target /= No_VM then 684 return; 685 end if; 686 687 -- The allocation / deallocation of a controlled object must be 688 -- chained on / detached from a finalization master. 689 690 pragma Assert (Present (Finalization_Master (Ptr_Typ))); 691 692 -- The only other kind of allocation / deallocation supported by this 693 -- routine is on / from a subpool. 694 695 elsif Nkind (Expr) = N_Allocator 696 and then No (Subpool_Handle_Name (Expr)) 697 then 698 return; 699 end if; 700 701 declare 702 Loc : constant Source_Ptr := Sloc (N); 703 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A'); 704 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L'); 705 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P'); 706 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 707 708 Actuals : List_Id; 709 Fin_Addr_Id : Entity_Id; 710 Fin_Mas_Act : Node_Id; 711 Fin_Mas_Id : Entity_Id; 712 Proc_To_Call : Entity_Id; 713 Subpool : Node_Id := Empty; 714 715 begin 716 -- Step 1: Construct all the actuals for the call to library routine 717 -- Allocate_Any_Controlled / Deallocate_Any_Controlled. 718 719 -- a) Storage pool 720 721 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc)); 722 723 if Is_Allocate then 724 725 -- b) Subpool 726 727 if Nkind (Expr) = N_Allocator then 728 Subpool := Subpool_Handle_Name (Expr); 729 end if; 730 731 -- If a subpool is present it can be an arbitrary name, so make 732 -- the actual by copying the tree. 733 734 if Present (Subpool) then 735 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc)); 736 else 737 Append_To (Actuals, Make_Null (Loc)); 738 end if; 739 740 -- c) Finalization master 741 742 if Needs_Finalization (Desig_Typ) then 743 Fin_Mas_Id := Finalization_Master (Ptr_Typ); 744 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc); 745 746 -- Handle the case where the master is actually a pointer to a 747 -- master. This case arises in build-in-place functions. 748 749 if Is_Access_Type (Etype (Fin_Mas_Id)) then 750 Append_To (Actuals, Fin_Mas_Act); 751 else 752 Append_To (Actuals, 753 Make_Attribute_Reference (Loc, 754 Prefix => Fin_Mas_Act, 755 Attribute_Name => Name_Unrestricted_Access)); 756 end if; 757 else 758 Append_To (Actuals, Make_Null (Loc)); 759 end if; 760 761 -- d) Finalize_Address 762 763 -- Primitive Finalize_Address is never generated in CodePeer mode 764 -- since it contains an Unchecked_Conversion. 765 766 if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then 767 Fin_Addr_Id := Find_Finalize_Address (Desig_Typ); 768 pragma Assert (Present (Fin_Addr_Id)); 769 770 Append_To (Actuals, 771 Make_Attribute_Reference (Loc, 772 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc), 773 Attribute_Name => Name_Unrestricted_Access)); 774 else 775 Append_To (Actuals, Make_Null (Loc)); 776 end if; 777 end if; 778 779 -- e) Address 780 -- f) Storage_Size 781 -- g) Alignment 782 783 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc)); 784 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc)); 785 786 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then 787 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); 788 789 -- For deallocation of class wide types we obtain the value of 790 -- alignment from the Type Specific Record of the deallocated object. 791 -- This is needed because the frontend expansion of class-wide types 792 -- into equivalent types confuses the backend. 793 794 else 795 -- Generate: 796 -- Obj.all'Alignment 797 798 -- ... because 'Alignment applied to class-wide types is expanded 799 -- into the code that reads the value of alignment from the TSD 800 -- (see Expand_N_Attribute_Reference) 801 802 Append_To (Actuals, 803 Unchecked_Convert_To (RTE (RE_Storage_Offset), 804 Make_Attribute_Reference (Loc, 805 Prefix => 806 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)), 807 Attribute_Name => Name_Alignment))); 808 end if; 809 810 -- h) Is_Controlled 811 812 if Needs_Finalization (Desig_Typ) then 813 declare 814 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F'); 815 Flag_Expr : Node_Id; 816 Param : Node_Id; 817 Temp : Node_Id; 818 819 begin 820 if Is_Allocate then 821 Temp := Find_Object (Expression (Expr)); 822 else 823 Temp := Expr; 824 end if; 825 826 -- Processing for allocations where the expression is a subtype 827 -- indication. 828 829 if Is_Allocate 830 and then Is_Entity_Name (Temp) 831 and then Is_Type (Entity (Temp)) 832 then 833 Flag_Expr := 834 New_Occurrence_Of 835 (Boolean_Literals 836 (Needs_Finalization (Entity (Temp))), Loc); 837 838 -- The allocation / deallocation of a class-wide object relies 839 -- on a runtime check to determine whether the object is truly 840 -- controlled or not. Depending on this check, the finalization 841 -- machinery will request or reclaim extra storage reserved for 842 -- a list header. 843 844 elsif Is_Class_Wide_Type (Desig_Typ) then 845 846 -- Detect a special case where interface class-wide types 847 -- are involved as the object appears as: 848 849 -- Tag_Ptr (Base_Address (<object>'Address)) 850 851 -- The expression already yields the proper tag, generate: 852 853 -- Temp.all 854 855 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then 856 Param := 857 Make_Explicit_Dereference (Loc, 858 Prefix => Relocate_Node (Temp)); 859 860 -- In the default case, obtain the tag of the object about 861 -- to be allocated / deallocated. Generate: 862 863 -- Temp'Tag 864 865 else 866 Param := 867 Make_Attribute_Reference (Loc, 868 Prefix => Relocate_Node (Temp), 869 Attribute_Name => Name_Tag); 870 end if; 871 872 -- Generate: 873 -- Needs_Finalization (<Param>) 874 875 Flag_Expr := 876 Make_Function_Call (Loc, 877 Name => 878 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc), 879 Parameter_Associations => New_List (Param)); 880 881 -- Processing for generic actuals 882 883 elsif Is_Generic_Actual_Type (Desig_Typ) then 884 Flag_Expr := 885 New_Occurrence_Of (Boolean_Literals 886 (Needs_Finalization (Base_Type (Desig_Typ))), Loc); 887 888 -- The object does not require any specialized checks, it is 889 -- known to be controlled. 890 891 else 892 Flag_Expr := New_Occurrence_Of (Standard_True, Loc); 893 end if; 894 895 -- Create the temporary which represents the finalization state 896 -- of the expression. Generate: 897 -- 898 -- F : constant Boolean := <Flag_Expr>; 899 900 Insert_Action (N, 901 Make_Object_Declaration (Loc, 902 Defining_Identifier => Flag_Id, 903 Constant_Present => True, 904 Object_Definition => 905 New_Occurrence_Of (Standard_Boolean, Loc), 906 Expression => Flag_Expr)); 907 908 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc)); 909 end; 910 911 -- The object is not controlled 912 913 else 914 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc)); 915 end if; 916 917 -- i) On_Subpool 918 919 if Is_Allocate then 920 Append_To (Actuals, 921 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc)); 922 end if; 923 924 -- Step 2: Build a wrapper Allocate / Deallocate which internally 925 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled. 926 927 -- Select the proper routine to call 928 929 if Is_Allocate then 930 Proc_To_Call := RTE (RE_Allocate_Any_Controlled); 931 else 932 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled); 933 end if; 934 935 -- Create a custom Allocate / Deallocate routine which has identical 936 -- profile to that of System.Storage_Pools. 937 938 Insert_Action (N, 939 Make_Subprogram_Body (Loc, 940 Specification => 941 942 -- procedure Pnn 943 944 Make_Procedure_Specification (Loc, 945 Defining_Unit_Name => Proc_Id, 946 Parameter_Specifications => New_List ( 947 948 -- P : Root_Storage_Pool 949 950 Make_Parameter_Specification (Loc, 951 Defining_Identifier => Make_Temporary (Loc, 'P'), 952 Parameter_Type => 953 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)), 954 955 -- A : [out] Address 956 957 Make_Parameter_Specification (Loc, 958 Defining_Identifier => Addr_Id, 959 Out_Present => Is_Allocate, 960 Parameter_Type => 961 New_Occurrence_Of (RTE (RE_Address), Loc)), 962 963 -- S : Storage_Count 964 965 Make_Parameter_Specification (Loc, 966 Defining_Identifier => Size_Id, 967 Parameter_Type => 968 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)), 969 970 -- L : Storage_Count 971 972 Make_Parameter_Specification (Loc, 973 Defining_Identifier => Alig_Id, 974 Parameter_Type => 975 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))), 976 977 Declarations => No_List, 978 979 Handled_Statement_Sequence => 980 Make_Handled_Sequence_Of_Statements (Loc, 981 Statements => New_List ( 982 Make_Procedure_Call_Statement (Loc, 983 Name => New_Occurrence_Of (Proc_To_Call, Loc), 984 Parameter_Associations => Actuals))))); 985 986 -- The newly generated Allocate / Deallocate becomes the default 987 -- procedure to call when the back end processes the allocation / 988 -- deallocation. 989 990 if Is_Allocate then 991 Set_Procedure_To_Call (Expr, Proc_Id); 992 else 993 Set_Procedure_To_Call (N, Proc_Id); 994 end if; 995 end; 996 end Build_Allocate_Deallocate_Proc; 997 998 ------------------------ 999 -- Build_Runtime_Call -- 1000 ------------------------ 1001 1002 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is 1003 begin 1004 -- If entity is not available, we can skip making the call (this avoids 1005 -- junk duplicated error messages in a number of cases). 1006 1007 if not RTE_Available (RE) then 1008 return Make_Null_Statement (Loc); 1009 else 1010 return 1011 Make_Procedure_Call_Statement (Loc, 1012 Name => New_Occurrence_Of (RTE (RE), Loc)); 1013 end if; 1014 end Build_Runtime_Call; 1015 1016 ---------------------------- 1017 -- Build_Task_Array_Image -- 1018 ---------------------------- 1019 1020 -- This function generates the body for a function that constructs the 1021 -- image string for a task that is an array component. The function is 1022 -- local to the init proc for the array type, and is called for each one 1023 -- of the components. The constructed image has the form of an indexed 1024 -- component, whose prefix is the outer variable of the array type. 1025 -- The n-dimensional array type has known indexes Index, Index2... 1026 1027 -- Id_Ref is an indexed component form created by the enclosing init proc. 1028 -- Its successive indexes are Val1, Val2, ... which are the loop variables 1029 -- in the loops that call the individual task init proc on each component. 1030 1031 -- The generated function has the following structure: 1032 1033 -- function F return String is 1034 -- Pref : string renames Task_Name; 1035 -- T1 : String := Index1'Image (Val1); 1036 -- ... 1037 -- Tn : String := indexn'image (Valn); 1038 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1; 1039 -- -- Len includes commas and the end parentheses. 1040 -- Res : String (1..Len); 1041 -- Pos : Integer := Pref'Length; 1042 -- 1043 -- begin 1044 -- Res (1 .. Pos) := Pref; 1045 -- Pos := Pos + 1; 1046 -- Res (Pos) := '('; 1047 -- Pos := Pos + 1; 1048 -- Res (Pos .. Pos + T1'Length - 1) := T1; 1049 -- Pos := Pos + T1'Length; 1050 -- Res (Pos) := '.'; 1051 -- Pos := Pos + 1; 1052 -- ... 1053 -- Res (Pos .. Pos + Tn'Length - 1) := Tn; 1054 -- Res (Len) := ')'; 1055 -- 1056 -- return Res; 1057 -- end F; 1058 -- 1059 -- Needless to say, multidimensional arrays of tasks are rare enough that 1060 -- the bulkiness of this code is not really a concern. 1061 1062 function Build_Task_Array_Image 1063 (Loc : Source_Ptr; 1064 Id_Ref : Node_Id; 1065 A_Type : Entity_Id; 1066 Dyn : Boolean := False) return Node_Id 1067 is 1068 Dims : constant Nat := Number_Dimensions (A_Type); 1069 -- Number of dimensions for array of tasks 1070 1071 Temps : array (1 .. Dims) of Entity_Id; 1072 -- Array of temporaries to hold string for each index 1073 1074 Indx : Node_Id; 1075 -- Index expression 1076 1077 Len : Entity_Id; 1078 -- Total length of generated name 1079 1080 Pos : Entity_Id; 1081 -- Running index for substring assignments 1082 1083 Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); 1084 -- Name of enclosing variable, prefix of resulting name 1085 1086 Res : Entity_Id; 1087 -- String to hold result 1088 1089 Val : Node_Id; 1090 -- Value of successive indexes 1091 1092 Sum : Node_Id; 1093 -- Expression to compute total size of string 1094 1095 T : Entity_Id; 1096 -- Entity for name at one index position 1097 1098 Decls : constant List_Id := New_List; 1099 Stats : constant List_Id := New_List; 1100 1101 begin 1102 -- For a dynamic task, the name comes from the target variable. For a 1103 -- static one it is a formal of the enclosing init proc. 1104 1105 if Dyn then 1106 Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); 1107 Append_To (Decls, 1108 Make_Object_Declaration (Loc, 1109 Defining_Identifier => Pref, 1110 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1111 Expression => 1112 Make_String_Literal (Loc, 1113 Strval => String_From_Name_Buffer))); 1114 1115 else 1116 Append_To (Decls, 1117 Make_Object_Renaming_Declaration (Loc, 1118 Defining_Identifier => Pref, 1119 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 1120 Name => Make_Identifier (Loc, Name_uTask_Name))); 1121 end if; 1122 1123 Indx := First_Index (A_Type); 1124 Val := First (Expressions (Id_Ref)); 1125 1126 for J in 1 .. Dims loop 1127 T := Make_Temporary (Loc, 'T'); 1128 Temps (J) := T; 1129 1130 Append_To (Decls, 1131 Make_Object_Declaration (Loc, 1132 Defining_Identifier => T, 1133 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1134 Expression => 1135 Make_Attribute_Reference (Loc, 1136 Attribute_Name => Name_Image, 1137 Prefix => New_Occurrence_Of (Etype (Indx), Loc), 1138 Expressions => New_List (New_Copy_Tree (Val))))); 1139 1140 Next_Index (Indx); 1141 Next (Val); 1142 end loop; 1143 1144 Sum := Make_Integer_Literal (Loc, Dims + 1); 1145 1146 Sum := 1147 Make_Op_Add (Loc, 1148 Left_Opnd => Sum, 1149 Right_Opnd => 1150 Make_Attribute_Reference (Loc, 1151 Attribute_Name => Name_Length, 1152 Prefix => New_Occurrence_Of (Pref, Loc), 1153 Expressions => New_List (Make_Integer_Literal (Loc, 1)))); 1154 1155 for J in 1 .. Dims loop 1156 Sum := 1157 Make_Op_Add (Loc, 1158 Left_Opnd => Sum, 1159 Right_Opnd => 1160 Make_Attribute_Reference (Loc, 1161 Attribute_Name => Name_Length, 1162 Prefix => 1163 New_Occurrence_Of (Temps (J), Loc), 1164 Expressions => New_List (Make_Integer_Literal (Loc, 1)))); 1165 end loop; 1166 1167 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats); 1168 1169 Set_Character_Literal_Name (Char_Code (Character'Pos ('('))); 1170 1171 Append_To (Stats, 1172 Make_Assignment_Statement (Loc, 1173 Name => 1174 Make_Indexed_Component (Loc, 1175 Prefix => New_Occurrence_Of (Res, Loc), 1176 Expressions => New_List (New_Occurrence_Of (Pos, Loc))), 1177 Expression => 1178 Make_Character_Literal (Loc, 1179 Chars => Name_Find, 1180 Char_Literal_Value => UI_From_Int (Character'Pos ('('))))); 1181 1182 Append_To (Stats, 1183 Make_Assignment_Statement (Loc, 1184 Name => New_Occurrence_Of (Pos, Loc), 1185 Expression => 1186 Make_Op_Add (Loc, 1187 Left_Opnd => New_Occurrence_Of (Pos, Loc), 1188 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 1189 1190 for J in 1 .. Dims loop 1191 1192 Append_To (Stats, 1193 Make_Assignment_Statement (Loc, 1194 Name => 1195 Make_Slice (Loc, 1196 Prefix => New_Occurrence_Of (Res, Loc), 1197 Discrete_Range => 1198 Make_Range (Loc, 1199 Low_Bound => New_Occurrence_Of (Pos, Loc), 1200 High_Bound => 1201 Make_Op_Subtract (Loc, 1202 Left_Opnd => 1203 Make_Op_Add (Loc, 1204 Left_Opnd => New_Occurrence_Of (Pos, Loc), 1205 Right_Opnd => 1206 Make_Attribute_Reference (Loc, 1207 Attribute_Name => Name_Length, 1208 Prefix => 1209 New_Occurrence_Of (Temps (J), Loc), 1210 Expressions => 1211 New_List (Make_Integer_Literal (Loc, 1)))), 1212 Right_Opnd => Make_Integer_Literal (Loc, 1)))), 1213 1214 Expression => New_Occurrence_Of (Temps (J), Loc))); 1215 1216 if J < Dims then 1217 Append_To (Stats, 1218 Make_Assignment_Statement (Loc, 1219 Name => New_Occurrence_Of (Pos, Loc), 1220 Expression => 1221 Make_Op_Add (Loc, 1222 Left_Opnd => New_Occurrence_Of (Pos, Loc), 1223 Right_Opnd => 1224 Make_Attribute_Reference (Loc, 1225 Attribute_Name => Name_Length, 1226 Prefix => New_Occurrence_Of (Temps (J), Loc), 1227 Expressions => 1228 New_List (Make_Integer_Literal (Loc, 1)))))); 1229 1230 Set_Character_Literal_Name (Char_Code (Character'Pos (','))); 1231 1232 Append_To (Stats, 1233 Make_Assignment_Statement (Loc, 1234 Name => Make_Indexed_Component (Loc, 1235 Prefix => New_Occurrence_Of (Res, Loc), 1236 Expressions => New_List (New_Occurrence_Of (Pos, Loc))), 1237 Expression => 1238 Make_Character_Literal (Loc, 1239 Chars => Name_Find, 1240 Char_Literal_Value => UI_From_Int (Character'Pos (','))))); 1241 1242 Append_To (Stats, 1243 Make_Assignment_Statement (Loc, 1244 Name => New_Occurrence_Of (Pos, Loc), 1245 Expression => 1246 Make_Op_Add (Loc, 1247 Left_Opnd => New_Occurrence_Of (Pos, Loc), 1248 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 1249 end if; 1250 end loop; 1251 1252 Set_Character_Literal_Name (Char_Code (Character'Pos (')'))); 1253 1254 Append_To (Stats, 1255 Make_Assignment_Statement (Loc, 1256 Name => 1257 Make_Indexed_Component (Loc, 1258 Prefix => New_Occurrence_Of (Res, Loc), 1259 Expressions => New_List (New_Occurrence_Of (Len, Loc))), 1260 Expression => 1261 Make_Character_Literal (Loc, 1262 Chars => Name_Find, 1263 Char_Literal_Value => UI_From_Int (Character'Pos (')'))))); 1264 return Build_Task_Image_Function (Loc, Decls, Stats, Res); 1265 end Build_Task_Array_Image; 1266 1267 ---------------------------- 1268 -- Build_Task_Image_Decls -- 1269 ---------------------------- 1270 1271 function Build_Task_Image_Decls 1272 (Loc : Source_Ptr; 1273 Id_Ref : Node_Id; 1274 A_Type : Entity_Id; 1275 In_Init_Proc : Boolean := False) return List_Id 1276 is 1277 Decls : constant List_Id := New_List; 1278 T_Id : Entity_Id := Empty; 1279 Decl : Node_Id; 1280 Expr : Node_Id := Empty; 1281 Fun : Node_Id := Empty; 1282 Is_Dyn : constant Boolean := 1283 Nkind (Parent (Id_Ref)) = N_Assignment_Statement 1284 and then 1285 Nkind (Expression (Parent (Id_Ref))) = N_Allocator; 1286 1287 begin 1288 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect, 1289 -- generate a dummy declaration only. 1290 1291 if Restriction_Active (No_Implicit_Heap_Allocations) 1292 or else Global_Discard_Names 1293 then 1294 T_Id := Make_Temporary (Loc, 'J'); 1295 Name_Len := 0; 1296 1297 return 1298 New_List ( 1299 Make_Object_Declaration (Loc, 1300 Defining_Identifier => T_Id, 1301 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1302 Expression => 1303 Make_String_Literal (Loc, 1304 Strval => String_From_Name_Buffer))); 1305 1306 else 1307 if Nkind (Id_Ref) = N_Identifier 1308 or else Nkind (Id_Ref) = N_Defining_Identifier 1309 then 1310 -- For a simple variable, the image of the task is built from 1311 -- the name of the variable. To avoid possible conflict with the 1312 -- anonymous type created for a single protected object, add a 1313 -- numeric suffix. 1314 1315 T_Id := 1316 Make_Defining_Identifier (Loc, 1317 New_External_Name (Chars (Id_Ref), 'T', 1)); 1318 1319 Get_Name_String (Chars (Id_Ref)); 1320 1321 Expr := 1322 Make_String_Literal (Loc, 1323 Strval => String_From_Name_Buffer); 1324 1325 elsif Nkind (Id_Ref) = N_Selected_Component then 1326 T_Id := 1327 Make_Defining_Identifier (Loc, 1328 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T')); 1329 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn); 1330 1331 elsif Nkind (Id_Ref) = N_Indexed_Component then 1332 T_Id := 1333 Make_Defining_Identifier (Loc, 1334 New_External_Name (Chars (A_Type), 'N')); 1335 1336 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn); 1337 end if; 1338 end if; 1339 1340 if Present (Fun) then 1341 Append (Fun, Decls); 1342 Expr := Make_Function_Call (Loc, 1343 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc)); 1344 1345 if not In_Init_Proc and then VM_Target = No_VM then 1346 Set_Uses_Sec_Stack (Defining_Entity (Fun)); 1347 end if; 1348 end if; 1349 1350 Decl := Make_Object_Declaration (Loc, 1351 Defining_Identifier => T_Id, 1352 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1353 Constant_Present => True, 1354 Expression => Expr); 1355 1356 Append (Decl, Decls); 1357 return Decls; 1358 end Build_Task_Image_Decls; 1359 1360 ------------------------------- 1361 -- Build_Task_Image_Function -- 1362 ------------------------------- 1363 1364 function Build_Task_Image_Function 1365 (Loc : Source_Ptr; 1366 Decls : List_Id; 1367 Stats : List_Id; 1368 Res : Entity_Id) return Node_Id 1369 is 1370 Spec : Node_Id; 1371 1372 begin 1373 Append_To (Stats, 1374 Make_Simple_Return_Statement (Loc, 1375 Expression => New_Occurrence_Of (Res, Loc))); 1376 1377 Spec := Make_Function_Specification (Loc, 1378 Defining_Unit_Name => Make_Temporary (Loc, 'F'), 1379 Result_Definition => New_Occurrence_Of (Standard_String, Loc)); 1380 1381 -- Calls to 'Image use the secondary stack, which must be cleaned up 1382 -- after the task name is built. 1383 1384 return Make_Subprogram_Body (Loc, 1385 Specification => Spec, 1386 Declarations => Decls, 1387 Handled_Statement_Sequence => 1388 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)); 1389 end Build_Task_Image_Function; 1390 1391 ----------------------------- 1392 -- Build_Task_Image_Prefix -- 1393 ----------------------------- 1394 1395 procedure Build_Task_Image_Prefix 1396 (Loc : Source_Ptr; 1397 Len : out Entity_Id; 1398 Res : out Entity_Id; 1399 Pos : out Entity_Id; 1400 Prefix : Entity_Id; 1401 Sum : Node_Id; 1402 Decls : List_Id; 1403 Stats : List_Id) 1404 is 1405 begin 1406 Len := Make_Temporary (Loc, 'L', Sum); 1407 1408 Append_To (Decls, 1409 Make_Object_Declaration (Loc, 1410 Defining_Identifier => Len, 1411 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 1412 Expression => Sum)); 1413 1414 Res := Make_Temporary (Loc, 'R'); 1415 1416 Append_To (Decls, 1417 Make_Object_Declaration (Loc, 1418 Defining_Identifier => Res, 1419 Object_Definition => 1420 Make_Subtype_Indication (Loc, 1421 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 1422 Constraint => 1423 Make_Index_Or_Discriminant_Constraint (Loc, 1424 Constraints => 1425 New_List ( 1426 Make_Range (Loc, 1427 Low_Bound => Make_Integer_Literal (Loc, 1), 1428 High_Bound => New_Occurrence_Of (Len, Loc))))))); 1429 1430 -- Indicate that the result is an internal temporary, so it does not 1431 -- receive a bogus initialization when declaration is expanded. This 1432 -- is both efficient, and prevents anomalies in the handling of 1433 -- dynamic objects on the secondary stack. 1434 1435 Set_Is_Internal (Res); 1436 Pos := Make_Temporary (Loc, 'P'); 1437 1438 Append_To (Decls, 1439 Make_Object_Declaration (Loc, 1440 Defining_Identifier => Pos, 1441 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); 1442 1443 -- Pos := Prefix'Length; 1444 1445 Append_To (Stats, 1446 Make_Assignment_Statement (Loc, 1447 Name => New_Occurrence_Of (Pos, Loc), 1448 Expression => 1449 Make_Attribute_Reference (Loc, 1450 Attribute_Name => Name_Length, 1451 Prefix => New_Occurrence_Of (Prefix, Loc), 1452 Expressions => New_List (Make_Integer_Literal (Loc, 1))))); 1453 1454 -- Res (1 .. Pos) := Prefix; 1455 1456 Append_To (Stats, 1457 Make_Assignment_Statement (Loc, 1458 Name => 1459 Make_Slice (Loc, 1460 Prefix => New_Occurrence_Of (Res, Loc), 1461 Discrete_Range => 1462 Make_Range (Loc, 1463 Low_Bound => Make_Integer_Literal (Loc, 1), 1464 High_Bound => New_Occurrence_Of (Pos, Loc))), 1465 1466 Expression => New_Occurrence_Of (Prefix, Loc))); 1467 1468 Append_To (Stats, 1469 Make_Assignment_Statement (Loc, 1470 Name => New_Occurrence_Of (Pos, Loc), 1471 Expression => 1472 Make_Op_Add (Loc, 1473 Left_Opnd => New_Occurrence_Of (Pos, Loc), 1474 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 1475 end Build_Task_Image_Prefix; 1476 1477 ----------------------------- 1478 -- Build_Task_Record_Image -- 1479 ----------------------------- 1480 1481 function Build_Task_Record_Image 1482 (Loc : Source_Ptr; 1483 Id_Ref : Node_Id; 1484 Dyn : Boolean := False) return Node_Id 1485 is 1486 Len : Entity_Id; 1487 -- Total length of generated name 1488 1489 Pos : Entity_Id; 1490 -- Index into result 1491 1492 Res : Entity_Id; 1493 -- String to hold result 1494 1495 Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); 1496 -- Name of enclosing variable, prefix of resulting name 1497 1498 Sum : Node_Id; 1499 -- Expression to compute total size of string 1500 1501 Sel : Entity_Id; 1502 -- Entity for selector name 1503 1504 Decls : constant List_Id := New_List; 1505 Stats : constant List_Id := New_List; 1506 1507 begin 1508 -- For a dynamic task, the name comes from the target variable. For a 1509 -- static one it is a formal of the enclosing init proc. 1510 1511 if Dyn then 1512 Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); 1513 Append_To (Decls, 1514 Make_Object_Declaration (Loc, 1515 Defining_Identifier => Pref, 1516 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1517 Expression => 1518 Make_String_Literal (Loc, 1519 Strval => String_From_Name_Buffer))); 1520 1521 else 1522 Append_To (Decls, 1523 Make_Object_Renaming_Declaration (Loc, 1524 Defining_Identifier => Pref, 1525 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 1526 Name => Make_Identifier (Loc, Name_uTask_Name))); 1527 end if; 1528 1529 Sel := Make_Temporary (Loc, 'S'); 1530 1531 Get_Name_String (Chars (Selector_Name (Id_Ref))); 1532 1533 Append_To (Decls, 1534 Make_Object_Declaration (Loc, 1535 Defining_Identifier => Sel, 1536 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1537 Expression => 1538 Make_String_Literal (Loc, 1539 Strval => String_From_Name_Buffer))); 1540 1541 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1)); 1542 1543 Sum := 1544 Make_Op_Add (Loc, 1545 Left_Opnd => Sum, 1546 Right_Opnd => 1547 Make_Attribute_Reference (Loc, 1548 Attribute_Name => Name_Length, 1549 Prefix => 1550 New_Occurrence_Of (Pref, Loc), 1551 Expressions => New_List (Make_Integer_Literal (Loc, 1)))); 1552 1553 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats); 1554 1555 Set_Character_Literal_Name (Char_Code (Character'Pos ('.'))); 1556 1557 -- Res (Pos) := '.'; 1558 1559 Append_To (Stats, 1560 Make_Assignment_Statement (Loc, 1561 Name => Make_Indexed_Component (Loc, 1562 Prefix => New_Occurrence_Of (Res, Loc), 1563 Expressions => New_List (New_Occurrence_Of (Pos, Loc))), 1564 Expression => 1565 Make_Character_Literal (Loc, 1566 Chars => Name_Find, 1567 Char_Literal_Value => 1568 UI_From_Int (Character'Pos ('.'))))); 1569 1570 Append_To (Stats, 1571 Make_Assignment_Statement (Loc, 1572 Name => New_Occurrence_Of (Pos, Loc), 1573 Expression => 1574 Make_Op_Add (Loc, 1575 Left_Opnd => New_Occurrence_Of (Pos, Loc), 1576 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 1577 1578 -- Res (Pos .. Len) := Selector; 1579 1580 Append_To (Stats, 1581 Make_Assignment_Statement (Loc, 1582 Name => Make_Slice (Loc, 1583 Prefix => New_Occurrence_Of (Res, Loc), 1584 Discrete_Range => 1585 Make_Range (Loc, 1586 Low_Bound => New_Occurrence_Of (Pos, Loc), 1587 High_Bound => New_Occurrence_Of (Len, Loc))), 1588 Expression => New_Occurrence_Of (Sel, Loc))); 1589 1590 return Build_Task_Image_Function (Loc, Decls, Stats, Res); 1591 end Build_Task_Record_Image; 1592 1593 ---------------------------------- 1594 -- Component_May_Be_Bit_Aligned -- 1595 ---------------------------------- 1596 1597 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is 1598 UT : Entity_Id; 1599 1600 begin 1601 -- If no component clause, then everything is fine, since the back end 1602 -- never bit-misaligns by default, even if there is a pragma Packed for 1603 -- the record. 1604 1605 if No (Comp) or else No (Component_Clause (Comp)) then 1606 return False; 1607 end if; 1608 1609 UT := Underlying_Type (Etype (Comp)); 1610 1611 -- It is only array and record types that cause trouble 1612 1613 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then 1614 return False; 1615 1616 -- If we know that we have a small (64 bits or less) record or small 1617 -- bit-packed array, then everything is fine, since the back end can 1618 -- handle these cases correctly. 1619 1620 elsif Esize (Comp) <= 64 1621 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT)) 1622 then 1623 return False; 1624 1625 -- Otherwise if the component is not byte aligned, we know we have the 1626 -- nasty unaligned case. 1627 1628 elsif Normalized_First_Bit (Comp) /= Uint_0 1629 or else Esize (Comp) mod System_Storage_Unit /= Uint_0 1630 then 1631 return True; 1632 1633 -- If we are large and byte aligned, then OK at this level 1634 1635 else 1636 return False; 1637 end if; 1638 end Component_May_Be_Bit_Aligned; 1639 1640 ----------------------------------- 1641 -- Corresponding_Runtime_Package -- 1642 ----------------------------------- 1643 1644 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is 1645 Pkg_Id : RTU_Id := RTU_Null; 1646 1647 begin 1648 pragma Assert (Is_Concurrent_Type (Typ)); 1649 1650 if Ekind (Typ) in Protected_Kind then 1651 if Has_Entries (Typ) 1652 1653 -- A protected type without entries that covers an interface and 1654 -- overrides the abstract routines with protected procedures is 1655 -- considered equivalent to a protected type with entries in the 1656 -- context of dispatching select statements. It is sufficient to 1657 -- check for the presence of an interface list in the declaration 1658 -- node to recognize this case. 1659 1660 or else Present (Interface_List (Parent (Typ))) 1661 1662 -- Protected types with interrupt handlers (when not using a 1663 -- restricted profile) are also considered equivalent to 1664 -- protected types with entries. The types which are used 1665 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection) 1666 -- are derived from Protection_Entries. 1667 1668 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile) 1669 or else Has_Interrupt_Handler (Typ) 1670 then 1671 if Abort_Allowed 1672 or else Restriction_Active (No_Entry_Queue) = False 1673 or else Restriction_Active (No_Select_Statements) = False 1674 or else Number_Entries (Typ) > 1 1675 or else (Has_Attach_Handler (Typ) 1676 and then not Restricted_Profile) 1677 then 1678 Pkg_Id := System_Tasking_Protected_Objects_Entries; 1679 else 1680 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry; 1681 end if; 1682 1683 else 1684 Pkg_Id := System_Tasking_Protected_Objects; 1685 end if; 1686 end if; 1687 1688 return Pkg_Id; 1689 end Corresponding_Runtime_Package; 1690 1691 ------------------------------- 1692 -- Convert_To_Actual_Subtype -- 1693 ------------------------------- 1694 1695 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is 1696 Act_ST : Entity_Id; 1697 1698 begin 1699 Act_ST := Get_Actual_Subtype (Exp); 1700 1701 if Act_ST = Etype (Exp) then 1702 return; 1703 else 1704 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp))); 1705 Analyze_And_Resolve (Exp, Act_ST); 1706 end if; 1707 end Convert_To_Actual_Subtype; 1708 1709 ----------------------------------- 1710 -- Current_Sem_Unit_Declarations -- 1711 ----------------------------------- 1712 1713 function Current_Sem_Unit_Declarations return List_Id is 1714 U : Node_Id := Unit (Cunit (Current_Sem_Unit)); 1715 Decls : List_Id; 1716 1717 begin 1718 -- If the current unit is a package body, locate the visible 1719 -- declarations of the package spec. 1720 1721 if Nkind (U) = N_Package_Body then 1722 U := Unit (Library_Unit (Cunit (Current_Sem_Unit))); 1723 end if; 1724 1725 if Nkind (U) = N_Package_Declaration then 1726 U := Specification (U); 1727 Decls := Visible_Declarations (U); 1728 1729 if No (Decls) then 1730 Decls := New_List; 1731 Set_Visible_Declarations (U, Decls); 1732 end if; 1733 1734 else 1735 Decls := Declarations (U); 1736 1737 if No (Decls) then 1738 Decls := New_List; 1739 Set_Declarations (U, Decls); 1740 end if; 1741 end if; 1742 1743 return Decls; 1744 end Current_Sem_Unit_Declarations; 1745 1746 ----------------------- 1747 -- Duplicate_Subexpr -- 1748 ----------------------- 1749 1750 function Duplicate_Subexpr 1751 (Exp : Node_Id; 1752 Name_Req : Boolean := False) return Node_Id 1753 is 1754 begin 1755 Remove_Side_Effects (Exp, Name_Req); 1756 return New_Copy_Tree (Exp); 1757 end Duplicate_Subexpr; 1758 1759 --------------------------------- 1760 -- Duplicate_Subexpr_No_Checks -- 1761 --------------------------------- 1762 1763 function Duplicate_Subexpr_No_Checks 1764 (Exp : Node_Id; 1765 Name_Req : Boolean := False) return Node_Id 1766 is 1767 New_Exp : Node_Id; 1768 begin 1769 Remove_Side_Effects (Exp, Name_Req); 1770 New_Exp := New_Copy_Tree (Exp); 1771 Remove_Checks (New_Exp); 1772 return New_Exp; 1773 end Duplicate_Subexpr_No_Checks; 1774 1775 ----------------------------------- 1776 -- Duplicate_Subexpr_Move_Checks -- 1777 ----------------------------------- 1778 1779 function Duplicate_Subexpr_Move_Checks 1780 (Exp : Node_Id; 1781 Name_Req : Boolean := False) return Node_Id 1782 is 1783 New_Exp : Node_Id; 1784 begin 1785 Remove_Side_Effects (Exp, Name_Req); 1786 New_Exp := New_Copy_Tree (Exp); 1787 Remove_Checks (Exp); 1788 return New_Exp; 1789 end Duplicate_Subexpr_Move_Checks; 1790 1791 -------------------- 1792 -- Ensure_Defined -- 1793 -------------------- 1794 1795 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is 1796 IR : Node_Id; 1797 1798 begin 1799 -- An itype reference must only be created if this is a local itype, so 1800 -- that gigi can elaborate it on the proper objstack. 1801 1802 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then 1803 IR := Make_Itype_Reference (Sloc (N)); 1804 Set_Itype (IR, Typ); 1805 Insert_Action (N, IR); 1806 end if; 1807 end Ensure_Defined; 1808 1809 -------------------- 1810 -- Entry_Names_OK -- 1811 -------------------- 1812 1813 function Entry_Names_OK return Boolean is 1814 begin 1815 return 1816 not Restricted_Profile 1817 and then not Global_Discard_Names 1818 and then not Restriction_Active (No_Implicit_Heap_Allocations) 1819 and then not Restriction_Active (No_Local_Allocators); 1820 end Entry_Names_OK; 1821 1822 ------------------- 1823 -- Evaluate_Name -- 1824 ------------------- 1825 1826 procedure Evaluate_Name (Nam : Node_Id) is 1827 K : constant Node_Kind := Nkind (Nam); 1828 1829 begin 1830 -- For an explicit dereference, we simply force the evaluation of the 1831 -- name expression. The dereference provides a value that is the address 1832 -- for the renamed object, and it is precisely this value that we want 1833 -- to preserve. 1834 1835 if K = N_Explicit_Dereference then 1836 Force_Evaluation (Prefix (Nam)); 1837 1838 -- For a selected component, we simply evaluate the prefix 1839 1840 elsif K = N_Selected_Component then 1841 Evaluate_Name (Prefix (Nam)); 1842 1843 -- For an indexed component, or an attribute reference, we evaluate the 1844 -- prefix, which is itself a name, recursively, and then force the 1845 -- evaluation of all the subscripts (or attribute expressions). 1846 1847 elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then 1848 Evaluate_Name (Prefix (Nam)); 1849 1850 declare 1851 E : Node_Id; 1852 1853 begin 1854 E := First (Expressions (Nam)); 1855 while Present (E) loop 1856 Force_Evaluation (E); 1857 1858 if Original_Node (E) /= E then 1859 Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); 1860 end if; 1861 1862 Next (E); 1863 end loop; 1864 end; 1865 1866 -- For a slice, we evaluate the prefix, as for the indexed component 1867 -- case and then, if there is a range present, either directly or as the 1868 -- constraint of a discrete subtype indication, we evaluate the two 1869 -- bounds of this range. 1870 1871 elsif K = N_Slice then 1872 Evaluate_Name (Prefix (Nam)); 1873 Evaluate_Slice_Bounds (Nam); 1874 1875 -- For a type conversion, the expression of the conversion must be the 1876 -- name of an object, and we simply need to evaluate this name. 1877 1878 elsif K = N_Type_Conversion then 1879 Evaluate_Name (Expression (Nam)); 1880 1881 -- For a function call, we evaluate the call 1882 1883 elsif K = N_Function_Call then 1884 Force_Evaluation (Nam); 1885 1886 -- The remaining cases are direct name, operator symbol and character 1887 -- literal. In all these cases, we do nothing, since we want to 1888 -- reevaluate each time the renamed object is used. 1889 1890 else 1891 return; 1892 end if; 1893 end Evaluate_Name; 1894 1895 --------------------------- 1896 -- Evaluate_Slice_Bounds -- 1897 --------------------------- 1898 1899 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is 1900 DR : constant Node_Id := Discrete_Range (Slice); 1901 Constr : Node_Id; 1902 Rexpr : Node_Id; 1903 1904 begin 1905 if Nkind (DR) = N_Range then 1906 Force_Evaluation (Low_Bound (DR)); 1907 Force_Evaluation (High_Bound (DR)); 1908 1909 elsif Nkind (DR) = N_Subtype_Indication then 1910 Constr := Constraint (DR); 1911 1912 if Nkind (Constr) = N_Range_Constraint then 1913 Rexpr := Range_Expression (Constr); 1914 1915 Force_Evaluation (Low_Bound (Rexpr)); 1916 Force_Evaluation (High_Bound (Rexpr)); 1917 end if; 1918 end if; 1919 end Evaluate_Slice_Bounds; 1920 1921 --------------------- 1922 -- Evolve_And_Then -- 1923 --------------------- 1924 1925 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is 1926 begin 1927 if No (Cond) then 1928 Cond := Cond1; 1929 else 1930 Cond := 1931 Make_And_Then (Sloc (Cond1), 1932 Left_Opnd => Cond, 1933 Right_Opnd => Cond1); 1934 end if; 1935 end Evolve_And_Then; 1936 1937 -------------------- 1938 -- Evolve_Or_Else -- 1939 -------------------- 1940 1941 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is 1942 begin 1943 if No (Cond) then 1944 Cond := Cond1; 1945 else 1946 Cond := 1947 Make_Or_Else (Sloc (Cond1), 1948 Left_Opnd => Cond, 1949 Right_Opnd => Cond1); 1950 end if; 1951 end Evolve_Or_Else; 1952 1953 ----------------------------------------- 1954 -- Expand_Static_Predicates_In_Choices -- 1955 ----------------------------------------- 1956 1957 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is 1958 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant)); 1959 1960 Choices : constant List_Id := Discrete_Choices (N); 1961 1962 Choice : Node_Id; 1963 Next_C : Node_Id; 1964 P : Node_Id; 1965 C : Node_Id; 1966 1967 begin 1968 Choice := First (Choices); 1969 while Present (Choice) loop 1970 Next_C := Next (Choice); 1971 1972 -- Check for name of subtype with static predicate 1973 1974 if Is_Entity_Name (Choice) 1975 and then Is_Type (Entity (Choice)) 1976 and then Has_Predicates (Entity (Choice)) 1977 then 1978 -- Loop through entries in predicate list, converting to choices 1979 -- and inserting in the list before the current choice. Note that 1980 -- if the list is empty, corresponding to a False predicate, then 1981 -- no choices are inserted. 1982 1983 P := First (Static_Predicate (Entity (Choice))); 1984 while Present (P) loop 1985 1986 -- If low bound and high bounds are equal, copy simple choice 1987 1988 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then 1989 C := New_Copy (Low_Bound (P)); 1990 1991 -- Otherwise copy a range 1992 1993 else 1994 C := New_Copy (P); 1995 end if; 1996 1997 -- Change Sloc to referencing choice (rather than the Sloc of 1998 -- the predicate declaration element itself). 1999 2000 Set_Sloc (C, Sloc (Choice)); 2001 Insert_Before (Choice, C); 2002 Next (P); 2003 end loop; 2004 2005 -- Delete the predicated entry 2006 2007 Remove (Choice); 2008 end if; 2009 2010 -- Move to next choice to check 2011 2012 Choice := Next_C; 2013 end loop; 2014 end Expand_Static_Predicates_In_Choices; 2015 2016 ------------------------------ 2017 -- Expand_Subtype_From_Expr -- 2018 ------------------------------ 2019 2020 -- This function is applicable for both static and dynamic allocation of 2021 -- objects which are constrained by an initial expression. Basically it 2022 -- transforms an unconstrained subtype indication into a constrained one. 2023 2024 -- The expression may also be transformed in certain cases in order to 2025 -- avoid multiple evaluation. In the static allocation case, the general 2026 -- scheme is: 2027 2028 -- Val : T := Expr; 2029 2030 -- is transformed into 2031 2032 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr; 2033 -- 2034 -- Here are the main cases : 2035 -- 2036 -- <if Expr is a Slice> 2037 -- Val : T ([Index_Subtype (Expr)]) := Expr; 2038 -- 2039 -- <elsif Expr is a String Literal> 2040 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr; 2041 -- 2042 -- <elsif Expr is Constrained> 2043 -- subtype T is Type_Of_Expr 2044 -- Val : T := Expr; 2045 -- 2046 -- <elsif Expr is an entity_name> 2047 -- Val : T (constraints taken from Expr) := Expr; 2048 -- 2049 -- <else> 2050 -- type Axxx is access all T; 2051 -- Rval : Axxx := Expr'ref; 2052 -- Val : T (constraints taken from Rval) := Rval.all; 2053 2054 -- ??? note: when the Expression is allocated in the secondary stack 2055 -- we could use it directly instead of copying it by declaring 2056 -- Val : T (...) renames Rval.all 2057 2058 procedure Expand_Subtype_From_Expr 2059 (N : Node_Id; 2060 Unc_Type : Entity_Id; 2061 Subtype_Indic : Node_Id; 2062 Exp : Node_Id) 2063 is 2064 Loc : constant Source_Ptr := Sloc (N); 2065 Exp_Typ : constant Entity_Id := Etype (Exp); 2066 T : Entity_Id; 2067 2068 begin 2069 -- In general we cannot build the subtype if expansion is disabled, 2070 -- because internal entities may not have been defined. However, to 2071 -- avoid some cascaded errors, we try to continue when the expression is 2072 -- an array (or string), because it is safe to compute the bounds. It is 2073 -- in fact required to do so even in a generic context, because there 2074 -- may be constants that depend on the bounds of a string literal, both 2075 -- standard string types and more generally arrays of characters. 2076 2077 -- In GNATprove mode, these extra subtypes are not needed 2078 2079 if GNATprove_Mode then 2080 return; 2081 end if; 2082 2083 if not Expander_Active 2084 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp))) 2085 then 2086 return; 2087 end if; 2088 2089 if Nkind (Exp) = N_Slice then 2090 declare 2091 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ)); 2092 2093 begin 2094 Rewrite (Subtype_Indic, 2095 Make_Subtype_Indication (Loc, 2096 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc), 2097 Constraint => 2098 Make_Index_Or_Discriminant_Constraint (Loc, 2099 Constraints => New_List 2100 (New_Occurrence_Of (Slice_Type, Loc))))); 2101 2102 -- This subtype indication may be used later for constraint checks 2103 -- we better make sure that if a variable was used as a bound of 2104 -- of the original slice, its value is frozen. 2105 2106 Evaluate_Slice_Bounds (Exp); 2107 end; 2108 2109 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then 2110 Rewrite (Subtype_Indic, 2111 Make_Subtype_Indication (Loc, 2112 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc), 2113 Constraint => 2114 Make_Index_Or_Discriminant_Constraint (Loc, 2115 Constraints => New_List ( 2116 Make_Literal_Range (Loc, 2117 Literal_Typ => Exp_Typ))))); 2118 2119 -- If the type of the expression is an internally generated type it 2120 -- may not be necessary to create a new subtype. However there are two 2121 -- exceptions: references to the current instances, and aliased array 2122 -- object declarations for which the backend needs to create a template. 2123 2124 elsif Is_Constrained (Exp_Typ) 2125 and then not Is_Class_Wide_Type (Unc_Type) 2126 and then 2127 (Nkind (N) /= N_Object_Declaration 2128 or else not Is_Entity_Name (Expression (N)) 2129 or else not Comes_From_Source (Entity (Expression (N))) 2130 or else not Is_Array_Type (Exp_Typ) 2131 or else not Aliased_Present (N)) 2132 then 2133 if Is_Itype (Exp_Typ) then 2134 2135 -- Within an initialization procedure, a selected component 2136 -- denotes a component of the enclosing record, and it appears as 2137 -- an actual in a call to its own initialization procedure. If 2138 -- this component depends on the outer discriminant, we must 2139 -- generate the proper actual subtype for it. 2140 2141 if Nkind (Exp) = N_Selected_Component 2142 and then Within_Init_Proc 2143 then 2144 declare 2145 Decl : constant Node_Id := 2146 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp); 2147 begin 2148 if Present (Decl) then 2149 Insert_Action (N, Decl); 2150 T := Defining_Identifier (Decl); 2151 else 2152 T := Exp_Typ; 2153 end if; 2154 end; 2155 2156 -- No need to generate a new subtype 2157 2158 else 2159 T := Exp_Typ; 2160 end if; 2161 2162 else 2163 T := Make_Temporary (Loc, 'T'); 2164 2165 Insert_Action (N, 2166 Make_Subtype_Declaration (Loc, 2167 Defining_Identifier => T, 2168 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc))); 2169 2170 -- This type is marked as an itype even though it has an explicit 2171 -- declaration since otherwise Is_Generic_Actual_Type can get 2172 -- set, resulting in the generation of spurious errors. (See 2173 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers) 2174 2175 Set_Is_Itype (T); 2176 Set_Associated_Node_For_Itype (T, Exp); 2177 end if; 2178 2179 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc)); 2180 2181 -- Nothing needs to be done for private types with unknown discriminants 2182 -- if the underlying type is not an unconstrained composite type or it 2183 -- is an unchecked union. 2184 2185 elsif Is_Private_Type (Unc_Type) 2186 and then Has_Unknown_Discriminants (Unc_Type) 2187 and then (not Is_Composite_Type (Underlying_Type (Unc_Type)) 2188 or else Is_Constrained (Underlying_Type (Unc_Type)) 2189 or else Is_Unchecked_Union (Underlying_Type (Unc_Type))) 2190 then 2191 null; 2192 2193 -- Case of derived type with unknown discriminants where the parent type 2194 -- also has unknown discriminants. 2195 2196 elsif Is_Record_Type (Unc_Type) 2197 and then not Is_Class_Wide_Type (Unc_Type) 2198 and then Has_Unknown_Discriminants (Unc_Type) 2199 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type)) 2200 then 2201 -- Nothing to be done if no underlying record view available 2202 2203 if No (Underlying_Record_View (Unc_Type)) then 2204 null; 2205 2206 -- Otherwise use the Underlying_Record_View to create the proper 2207 -- constrained subtype for an object of a derived type with unknown 2208 -- discriminants. 2209 2210 else 2211 Remove_Side_Effects (Exp); 2212 Rewrite (Subtype_Indic, 2213 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); 2214 end if; 2215 2216 -- Renamings of class-wide interface types require no equivalent 2217 -- constrained type declarations because we only need to reference 2218 -- the tag component associated with the interface. The same is 2219 -- presumably true for class-wide types in general, so this test 2220 -- is broadened to include all class-wide renamings, which also 2221 -- avoids cases of unbounded recursion in Remove_Side_Effects. 2222 -- (Is this really correct, or are there some cases of class-wide 2223 -- renamings that require action in this procedure???) 2224 2225 elsif Present (N) 2226 and then Nkind (N) = N_Object_Renaming_Declaration 2227 and then Is_Class_Wide_Type (Unc_Type) 2228 then 2229 null; 2230 2231 -- In Ada 95 nothing to be done if the type of the expression is limited 2232 -- because in this case the expression cannot be copied, and its use can 2233 -- only be by reference. 2234 2235 -- In Ada 2005 the context can be an object declaration whose expression 2236 -- is a function that returns in place. If the nominal subtype has 2237 -- unknown discriminants, the call still provides constraints on the 2238 -- object, and we have to create an actual subtype from it. 2239 2240 -- If the type is class-wide, the expression is dynamically tagged and 2241 -- we do not create an actual subtype either. Ditto for an interface. 2242 -- For now this applies only if the type is immutably limited, and the 2243 -- function being called is build-in-place. This will have to be revised 2244 -- when build-in-place functions are generalized to other types. 2245 2246 elsif Is_Limited_View (Exp_Typ) 2247 and then 2248 (Is_Class_Wide_Type (Exp_Typ) 2249 or else Is_Interface (Exp_Typ) 2250 or else not Has_Unknown_Discriminants (Exp_Typ) 2251 or else not Is_Composite_Type (Unc_Type)) 2252 then 2253 null; 2254 2255 -- For limited objects initialized with build in place function calls, 2256 -- nothing to be done; otherwise we prematurely introduce an N_Reference 2257 -- node in the expression initializing the object, which breaks the 2258 -- circuitry that detects and adds the additional arguments to the 2259 -- called function. 2260 2261 elsif Is_Build_In_Place_Function_Call (Exp) then 2262 null; 2263 2264 else 2265 Remove_Side_Effects (Exp); 2266 Rewrite (Subtype_Indic, 2267 Make_Subtype_From_Expr (Exp, Unc_Type)); 2268 end if; 2269 end Expand_Subtype_From_Expr; 2270 2271 ------------------------ 2272 -- Find_Interface_ADT -- 2273 ------------------------ 2274 2275 function Find_Interface_ADT 2276 (T : Entity_Id; 2277 Iface : Entity_Id) return Elmt_Id 2278 is 2279 ADT : Elmt_Id; 2280 Typ : Entity_Id := T; 2281 2282 begin 2283 pragma Assert (Is_Interface (Iface)); 2284 2285 -- Handle private types 2286 2287 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then 2288 Typ := Full_View (Typ); 2289 end if; 2290 2291 -- Handle access types 2292 2293 if Is_Access_Type (Typ) then 2294 Typ := Designated_Type (Typ); 2295 end if; 2296 2297 -- Handle task and protected types implementing interfaces 2298 2299 if Is_Concurrent_Type (Typ) then 2300 Typ := Corresponding_Record_Type (Typ); 2301 end if; 2302 2303 pragma Assert 2304 (not Is_Class_Wide_Type (Typ) 2305 and then Ekind (Typ) /= E_Incomplete_Type); 2306 2307 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then 2308 return First_Elmt (Access_Disp_Table (Typ)); 2309 2310 else 2311 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); 2312 while Present (ADT) 2313 and then Present (Related_Type (Node (ADT))) 2314 and then Related_Type (Node (ADT)) /= Iface 2315 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)), 2316 Use_Full_View => True) 2317 loop 2318 Next_Elmt (ADT); 2319 end loop; 2320 2321 pragma Assert (Present (Related_Type (Node (ADT)))); 2322 return ADT; 2323 end if; 2324 end Find_Interface_ADT; 2325 2326 ------------------------ 2327 -- Find_Interface_Tag -- 2328 ------------------------ 2329 2330 function Find_Interface_Tag 2331 (T : Entity_Id; 2332 Iface : Entity_Id) return Entity_Id 2333 is 2334 AI_Tag : Entity_Id; 2335 Found : Boolean := False; 2336 Typ : Entity_Id := T; 2337 2338 procedure Find_Tag (Typ : Entity_Id); 2339 -- Internal subprogram used to recursively climb to the ancestors 2340 2341 -------------- 2342 -- Find_Tag -- 2343 -------------- 2344 2345 procedure Find_Tag (Typ : Entity_Id) is 2346 AI_Elmt : Elmt_Id; 2347 AI : Node_Id; 2348 2349 begin 2350 -- This routine does not handle the case in which the interface is an 2351 -- ancestor of Typ. That case is handled by the enclosing subprogram. 2352 2353 pragma Assert (Typ /= Iface); 2354 2355 -- Climb to the root type handling private types 2356 2357 if Present (Full_View (Etype (Typ))) then 2358 if Full_View (Etype (Typ)) /= Typ then 2359 Find_Tag (Full_View (Etype (Typ))); 2360 end if; 2361 2362 elsif Etype (Typ) /= Typ then 2363 Find_Tag (Etype (Typ)); 2364 end if; 2365 2366 -- Traverse the list of interfaces implemented by the type 2367 2368 if not Found 2369 and then Present (Interfaces (Typ)) 2370 and then not (Is_Empty_Elmt_List (Interfaces (Typ))) 2371 then 2372 -- Skip the tag associated with the primary table 2373 2374 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); 2375 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); 2376 pragma Assert (Present (AI_Tag)); 2377 2378 AI_Elmt := First_Elmt (Interfaces (Typ)); 2379 while Present (AI_Elmt) loop 2380 AI := Node (AI_Elmt); 2381 2382 if AI = Iface 2383 or else Is_Ancestor (Iface, AI, Use_Full_View => True) 2384 then 2385 Found := True; 2386 return; 2387 end if; 2388 2389 AI_Tag := Next_Tag_Component (AI_Tag); 2390 Next_Elmt (AI_Elmt); 2391 end loop; 2392 end if; 2393 end Find_Tag; 2394 2395 -- Start of processing for Find_Interface_Tag 2396 2397 begin 2398 pragma Assert (Is_Interface (Iface)); 2399 2400 -- Handle access types 2401 2402 if Is_Access_Type (Typ) then 2403 Typ := Designated_Type (Typ); 2404 end if; 2405 2406 -- Handle class-wide types 2407 2408 if Is_Class_Wide_Type (Typ) then 2409 Typ := Root_Type (Typ); 2410 end if; 2411 2412 -- Handle private types 2413 2414 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then 2415 Typ := Full_View (Typ); 2416 end if; 2417 2418 -- Handle entities from the limited view 2419 2420 if Ekind (Typ) = E_Incomplete_Type then 2421 pragma Assert (Present (Non_Limited_View (Typ))); 2422 Typ := Non_Limited_View (Typ); 2423 end if; 2424 2425 -- Handle task and protected types implementing interfaces 2426 2427 if Is_Concurrent_Type (Typ) then 2428 Typ := Corresponding_Record_Type (Typ); 2429 end if; 2430 2431 -- If the interface is an ancestor of the type, then it shared the 2432 -- primary dispatch table. 2433 2434 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then 2435 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); 2436 return First_Tag_Component (Typ); 2437 2438 -- Otherwise we need to search for its associated tag component 2439 2440 else 2441 Find_Tag (Typ); 2442 pragma Assert (Found); 2443 return AI_Tag; 2444 end if; 2445 end Find_Interface_Tag; 2446 2447 ------------------ 2448 -- Find_Prim_Op -- 2449 ------------------ 2450 2451 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is 2452 Prim : Elmt_Id; 2453 Typ : Entity_Id := T; 2454 Op : Entity_Id; 2455 2456 begin 2457 if Is_Class_Wide_Type (Typ) then 2458 Typ := Root_Type (Typ); 2459 end if; 2460 2461 Typ := Underlying_Type (Typ); 2462 2463 -- Loop through primitive operations 2464 2465 Prim := First_Elmt (Primitive_Operations (Typ)); 2466 while Present (Prim) loop 2467 Op := Node (Prim); 2468 2469 -- We can retrieve primitive operations by name if it is an internal 2470 -- name. For equality we must check that both of its operands have 2471 -- the same type, to avoid confusion with user-defined equalities 2472 -- than may have a non-symmetric signature. 2473 2474 exit when Chars (Op) = Name 2475 and then 2476 (Name /= Name_Op_Eq 2477 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); 2478 2479 Next_Elmt (Prim); 2480 2481 -- Raise Program_Error if no primitive found 2482 2483 if No (Prim) then 2484 raise Program_Error; 2485 end if; 2486 end loop; 2487 2488 return Node (Prim); 2489 end Find_Prim_Op; 2490 2491 ------------------ 2492 -- Find_Prim_Op -- 2493 ------------------ 2494 2495 function Find_Prim_Op 2496 (T : Entity_Id; 2497 Name : TSS_Name_Type) return Entity_Id 2498 is 2499 Inher_Op : Entity_Id := Empty; 2500 Own_Op : Entity_Id := Empty; 2501 Prim_Elmt : Elmt_Id; 2502 Prim_Id : Entity_Id; 2503 Typ : Entity_Id := T; 2504 2505 begin 2506 if Is_Class_Wide_Type (Typ) then 2507 Typ := Root_Type (Typ); 2508 end if; 2509 2510 Typ := Underlying_Type (Typ); 2511 2512 -- This search is based on the assertion that the dispatching version 2513 -- of the TSS routine always precedes the real primitive. 2514 2515 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 2516 while Present (Prim_Elmt) loop 2517 Prim_Id := Node (Prim_Elmt); 2518 2519 if Is_TSS (Prim_Id, Name) then 2520 if Present (Alias (Prim_Id)) then 2521 Inher_Op := Prim_Id; 2522 else 2523 Own_Op := Prim_Id; 2524 end if; 2525 end if; 2526 2527 Next_Elmt (Prim_Elmt); 2528 end loop; 2529 2530 if Present (Own_Op) then 2531 return Own_Op; 2532 elsif Present (Inher_Op) then 2533 return Inher_Op; 2534 else 2535 raise Program_Error; 2536 end if; 2537 end Find_Prim_Op; 2538 2539 ---------------------------- 2540 -- Find_Protection_Object -- 2541 ---------------------------- 2542 2543 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is 2544 S : Entity_Id; 2545 2546 begin 2547 S := Scop; 2548 while Present (S) loop 2549 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure) 2550 and then Present (Protection_Object (S)) 2551 then 2552 return Protection_Object (S); 2553 end if; 2554 2555 S := Scope (S); 2556 end loop; 2557 2558 -- If we do not find a Protection object in the scope chain, then 2559 -- something has gone wrong, most likely the object was never created. 2560 2561 raise Program_Error; 2562 end Find_Protection_Object; 2563 2564 -------------------------- 2565 -- Find_Protection_Type -- 2566 -------------------------- 2567 2568 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is 2569 Comp : Entity_Id; 2570 Typ : Entity_Id := Conc_Typ; 2571 2572 begin 2573 if Is_Concurrent_Type (Typ) then 2574 Typ := Corresponding_Record_Type (Typ); 2575 end if; 2576 2577 -- Since restriction violations are not considered serious errors, the 2578 -- expander remains active, but may leave the corresponding record type 2579 -- malformed. In such cases, component _object is not available so do 2580 -- not look for it. 2581 2582 if not Analyzed (Typ) then 2583 return Empty; 2584 end if; 2585 2586 Comp := First_Component (Typ); 2587 while Present (Comp) loop 2588 if Chars (Comp) = Name_uObject then 2589 return Base_Type (Etype (Comp)); 2590 end if; 2591 2592 Next_Component (Comp); 2593 end loop; 2594 2595 -- The corresponding record of a protected type should always have an 2596 -- _object field. 2597 2598 raise Program_Error; 2599 end Find_Protection_Type; 2600 2601 ---------------------- 2602 -- Force_Evaluation -- 2603 ---------------------- 2604 2605 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is 2606 begin 2607 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True); 2608 end Force_Evaluation; 2609 2610 --------------------------------- 2611 -- Fully_Qualified_Name_String -- 2612 --------------------------------- 2613 2614 function Fully_Qualified_Name_String 2615 (E : Entity_Id; 2616 Append_NUL : Boolean := True) return String_Id 2617 is 2618 procedure Internal_Full_Qualified_Name (E : Entity_Id); 2619 -- Compute recursively the qualified name without NUL at the end, adding 2620 -- it to the currently started string being generated 2621 2622 ---------------------------------- 2623 -- Internal_Full_Qualified_Name -- 2624 ---------------------------------- 2625 2626 procedure Internal_Full_Qualified_Name (E : Entity_Id) is 2627 Ent : Entity_Id; 2628 2629 begin 2630 -- Deal properly with child units 2631 2632 if Nkind (E) = N_Defining_Program_Unit_Name then 2633 Ent := Defining_Identifier (E); 2634 else 2635 Ent := E; 2636 end if; 2637 2638 -- Compute qualification recursively (only "Standard" has no scope) 2639 2640 if Present (Scope (Scope (Ent))) then 2641 Internal_Full_Qualified_Name (Scope (Ent)); 2642 Store_String_Char (Get_Char_Code ('.')); 2643 end if; 2644 2645 -- Every entity should have a name except some expanded blocks 2646 -- don't bother about those. 2647 2648 if Chars (Ent) = No_Name then 2649 return; 2650 end if; 2651 2652 -- Generates the entity name in upper case 2653 2654 Get_Decoded_Name_String (Chars (Ent)); 2655 Set_All_Upper_Case; 2656 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 2657 return; 2658 end Internal_Full_Qualified_Name; 2659 2660 -- Start of processing for Full_Qualified_Name 2661 2662 begin 2663 Start_String; 2664 Internal_Full_Qualified_Name (E); 2665 2666 if Append_NUL then 2667 Store_String_Char (Get_Char_Code (ASCII.NUL)); 2668 end if; 2669 2670 return End_String; 2671 end Fully_Qualified_Name_String; 2672 2673 ------------------------ 2674 -- Generate_Poll_Call -- 2675 ------------------------ 2676 2677 procedure Generate_Poll_Call (N : Node_Id) is 2678 begin 2679 -- No poll call if polling not active 2680 2681 if not Polling_Required then 2682 return; 2683 2684 -- Otherwise generate require poll call 2685 2686 else 2687 Insert_Before_And_Analyze (N, 2688 Make_Procedure_Call_Statement (Sloc (N), 2689 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N)))); 2690 end if; 2691 end Generate_Poll_Call; 2692 2693 --------------------------------- 2694 -- Get_Current_Value_Condition -- 2695 --------------------------------- 2696 2697 -- Note: the implementation of this procedure is very closely tied to the 2698 -- implementation of Set_Current_Value_Condition. In the Get procedure, we 2699 -- interpret Current_Value fields set by the Set procedure, so the two 2700 -- procedures need to be closely coordinated. 2701 2702 procedure Get_Current_Value_Condition 2703 (Var : Node_Id; 2704 Op : out Node_Kind; 2705 Val : out Node_Id) 2706 is 2707 Loc : constant Source_Ptr := Sloc (Var); 2708 Ent : constant Entity_Id := Entity (Var); 2709 2710 procedure Process_Current_Value_Condition 2711 (N : Node_Id; 2712 S : Boolean); 2713 -- N is an expression which holds either True (S = True) or False (S = 2714 -- False) in the condition. This procedure digs out the expression and 2715 -- if it refers to Ent, sets Op and Val appropriately. 2716 2717 ------------------------------------- 2718 -- Process_Current_Value_Condition -- 2719 ------------------------------------- 2720 2721 procedure Process_Current_Value_Condition 2722 (N : Node_Id; 2723 S : Boolean) 2724 is 2725 Cond : Node_Id; 2726 Prev_Cond : Node_Id; 2727 Sens : Boolean; 2728 2729 begin 2730 Cond := N; 2731 Sens := S; 2732 2733 loop 2734 Prev_Cond := Cond; 2735 2736 -- Deal with NOT operators, inverting sense 2737 2738 while Nkind (Cond) = N_Op_Not loop 2739 Cond := Right_Opnd (Cond); 2740 Sens := not Sens; 2741 end loop; 2742 2743 -- Deal with conversions, qualifications, and expressions with 2744 -- actions. 2745 2746 while Nkind_In (Cond, 2747 N_Type_Conversion, 2748 N_Qualified_Expression, 2749 N_Expression_With_Actions) 2750 loop 2751 Cond := Expression (Cond); 2752 end loop; 2753 2754 exit when Cond = Prev_Cond; 2755 end loop; 2756 2757 -- Deal with AND THEN and AND cases 2758 2759 if Nkind_In (Cond, N_And_Then, N_Op_And) then 2760 2761 -- Don't ever try to invert a condition that is of the form of an 2762 -- AND or AND THEN (since we are not doing sufficiently general 2763 -- processing to allow this). 2764 2765 if Sens = False then 2766 Op := N_Empty; 2767 Val := Empty; 2768 return; 2769 end if; 2770 2771 -- Recursively process AND and AND THEN branches 2772 2773 Process_Current_Value_Condition (Left_Opnd (Cond), True); 2774 2775 if Op /= N_Empty then 2776 return; 2777 end if; 2778 2779 Process_Current_Value_Condition (Right_Opnd (Cond), True); 2780 return; 2781 2782 -- Case of relational operator 2783 2784 elsif Nkind (Cond) in N_Op_Compare then 2785 Op := Nkind (Cond); 2786 2787 -- Invert sense of test if inverted test 2788 2789 if Sens = False then 2790 case Op is 2791 when N_Op_Eq => Op := N_Op_Ne; 2792 when N_Op_Ne => Op := N_Op_Eq; 2793 when N_Op_Lt => Op := N_Op_Ge; 2794 when N_Op_Gt => Op := N_Op_Le; 2795 when N_Op_Le => Op := N_Op_Gt; 2796 when N_Op_Ge => Op := N_Op_Lt; 2797 when others => raise Program_Error; 2798 end case; 2799 end if; 2800 2801 -- Case of entity op value 2802 2803 if Is_Entity_Name (Left_Opnd (Cond)) 2804 and then Ent = Entity (Left_Opnd (Cond)) 2805 and then Compile_Time_Known_Value (Right_Opnd (Cond)) 2806 then 2807 Val := Right_Opnd (Cond); 2808 2809 -- Case of value op entity 2810 2811 elsif Is_Entity_Name (Right_Opnd (Cond)) 2812 and then Ent = Entity (Right_Opnd (Cond)) 2813 and then Compile_Time_Known_Value (Left_Opnd (Cond)) 2814 then 2815 Val := Left_Opnd (Cond); 2816 2817 -- We are effectively swapping operands 2818 2819 case Op is 2820 when N_Op_Eq => null; 2821 when N_Op_Ne => null; 2822 when N_Op_Lt => Op := N_Op_Gt; 2823 when N_Op_Gt => Op := N_Op_Lt; 2824 when N_Op_Le => Op := N_Op_Ge; 2825 when N_Op_Ge => Op := N_Op_Le; 2826 when others => raise Program_Error; 2827 end case; 2828 2829 else 2830 Op := N_Empty; 2831 end if; 2832 2833 return; 2834 2835 elsif Nkind_In (Cond, 2836 N_Type_Conversion, 2837 N_Qualified_Expression, 2838 N_Expression_With_Actions) 2839 then 2840 Cond := Expression (Cond); 2841 2842 -- Case of Boolean variable reference, return as though the 2843 -- reference had said var = True. 2844 2845 else 2846 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then 2847 Val := New_Occurrence_Of (Standard_True, Sloc (Cond)); 2848 2849 if Sens = False then 2850 Op := N_Op_Ne; 2851 else 2852 Op := N_Op_Eq; 2853 end if; 2854 end if; 2855 end if; 2856 end Process_Current_Value_Condition; 2857 2858 -- Start of processing for Get_Current_Value_Condition 2859 2860 begin 2861 Op := N_Empty; 2862 Val := Empty; 2863 2864 -- Immediate return, nothing doing, if this is not an object 2865 2866 if Ekind (Ent) not in Object_Kind then 2867 return; 2868 end if; 2869 2870 -- Otherwise examine current value 2871 2872 declare 2873 CV : constant Node_Id := Current_Value (Ent); 2874 Sens : Boolean; 2875 Stm : Node_Id; 2876 2877 begin 2878 -- If statement. Condition is known true in THEN section, known False 2879 -- in any ELSIF or ELSE part, and unknown outside the IF statement. 2880 2881 if Nkind (CV) = N_If_Statement then 2882 2883 -- Before start of IF statement 2884 2885 if Loc < Sloc (CV) then 2886 return; 2887 2888 -- After end of IF statement 2889 2890 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then 2891 return; 2892 end if; 2893 2894 -- At this stage we know that we are within the IF statement, but 2895 -- unfortunately, the tree does not record the SLOC of the ELSE so 2896 -- we cannot use a simple SLOC comparison to distinguish between 2897 -- the then/else statements, so we have to climb the tree. 2898 2899 declare 2900 N : Node_Id; 2901 2902 begin 2903 N := Parent (Var); 2904 while Parent (N) /= CV loop 2905 N := Parent (N); 2906 2907 -- If we fall off the top of the tree, then that's odd, but 2908 -- perhaps it could occur in some error situation, and the 2909 -- safest response is simply to assume that the outcome of 2910 -- the condition is unknown. No point in bombing during an 2911 -- attempt to optimize things. 2912 2913 if No (N) then 2914 return; 2915 end if; 2916 end loop; 2917 2918 -- Now we have N pointing to a node whose parent is the IF 2919 -- statement in question, so now we can tell if we are within 2920 -- the THEN statements. 2921 2922 if Is_List_Member (N) 2923 and then List_Containing (N) = Then_Statements (CV) 2924 then 2925 Sens := True; 2926 2927 -- If the variable reference does not come from source, we 2928 -- cannot reliably tell whether it appears in the else part. 2929 -- In particular, if it appears in generated code for a node 2930 -- that requires finalization, it may be attached to a list 2931 -- that has not been yet inserted into the code. For now, 2932 -- treat it as unknown. 2933 2934 elsif not Comes_From_Source (N) then 2935 return; 2936 2937 -- Otherwise we must be in ELSIF or ELSE part 2938 2939 else 2940 Sens := False; 2941 end if; 2942 end; 2943 2944 -- ELSIF part. Condition is known true within the referenced 2945 -- ELSIF, known False in any subsequent ELSIF or ELSE part, 2946 -- and unknown before the ELSE part or after the IF statement. 2947 2948 elsif Nkind (CV) = N_Elsif_Part then 2949 2950 -- if the Elsif_Part had condition_actions, the elsif has been 2951 -- rewritten as a nested if, and the original elsif_part is 2952 -- detached from the tree, so there is no way to obtain useful 2953 -- information on the current value of the variable. 2954 -- Can this be improved ??? 2955 2956 if No (Parent (CV)) then 2957 return; 2958 end if; 2959 2960 Stm := Parent (CV); 2961 2962 -- Before start of ELSIF part 2963 2964 if Loc < Sloc (CV) then 2965 return; 2966 2967 -- After end of IF statement 2968 2969 elsif Loc >= Sloc (Stm) + 2970 Text_Ptr (UI_To_Int (End_Span (Stm))) 2971 then 2972 return; 2973 end if; 2974 2975 -- Again we lack the SLOC of the ELSE, so we need to climb the 2976 -- tree to see if we are within the ELSIF part in question. 2977 2978 declare 2979 N : Node_Id; 2980 2981 begin 2982 N := Parent (Var); 2983 while Parent (N) /= Stm loop 2984 N := Parent (N); 2985 2986 -- If we fall off the top of the tree, then that's odd, but 2987 -- perhaps it could occur in some error situation, and the 2988 -- safest response is simply to assume that the outcome of 2989 -- the condition is unknown. No point in bombing during an 2990 -- attempt to optimize things. 2991 2992 if No (N) then 2993 return; 2994 end if; 2995 end loop; 2996 2997 -- Now we have N pointing to a node whose parent is the IF 2998 -- statement in question, so see if is the ELSIF part we want. 2999 -- the THEN statements. 3000 3001 if N = CV then 3002 Sens := True; 3003 3004 -- Otherwise we must be in subsequent ELSIF or ELSE part 3005 3006 else 3007 Sens := False; 3008 end if; 3009 end; 3010 3011 -- Iteration scheme of while loop. The condition is known to be 3012 -- true within the body of the loop. 3013 3014 elsif Nkind (CV) = N_Iteration_Scheme then 3015 declare 3016 Loop_Stmt : constant Node_Id := Parent (CV); 3017 3018 begin 3019 -- Before start of body of loop 3020 3021 if Loc < Sloc (Loop_Stmt) then 3022 return; 3023 3024 -- After end of LOOP statement 3025 3026 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then 3027 return; 3028 3029 -- We are within the body of the loop 3030 3031 else 3032 Sens := True; 3033 end if; 3034 end; 3035 3036 -- All other cases of Current_Value settings 3037 3038 else 3039 return; 3040 end if; 3041 3042 -- If we fall through here, then we have a reportable condition, Sens 3043 -- is True if the condition is true and False if it needs inverting. 3044 3045 Process_Current_Value_Condition (Condition (CV), Sens); 3046 end; 3047 end Get_Current_Value_Condition; 3048 3049 --------------------- 3050 -- Get_Stream_Size -- 3051 --------------------- 3052 3053 function Get_Stream_Size (E : Entity_Id) return Uint is 3054 begin 3055 -- If we have a Stream_Size clause for this type use it 3056 3057 if Has_Stream_Size_Clause (E) then 3058 return Static_Integer (Expression (Stream_Size_Clause (E))); 3059 3060 -- Otherwise the Stream_Size if the size of the type 3061 3062 else 3063 return Esize (E); 3064 end if; 3065 end Get_Stream_Size; 3066 3067 --------------------------- 3068 -- Has_Access_Constraint -- 3069 --------------------------- 3070 3071 function Has_Access_Constraint (E : Entity_Id) return Boolean is 3072 Disc : Entity_Id; 3073 T : constant Entity_Id := Etype (E); 3074 3075 begin 3076 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then 3077 Disc := First_Discriminant (T); 3078 while Present (Disc) loop 3079 if Is_Access_Type (Etype (Disc)) then 3080 return True; 3081 end if; 3082 3083 Next_Discriminant (Disc); 3084 end loop; 3085 3086 return False; 3087 else 3088 return False; 3089 end if; 3090 end Has_Access_Constraint; 3091 3092 ---------------------------------- 3093 -- Has_Following_Address_Clause -- 3094 ---------------------------------- 3095 3096 -- Should this function check the private part in a package ??? 3097 3098 function Has_Following_Address_Clause (D : Node_Id) return Boolean is 3099 Id : constant Entity_Id := Defining_Identifier (D); 3100 Decl : Node_Id; 3101 3102 begin 3103 Decl := Next (D); 3104 while Present (Decl) loop 3105 if Nkind (Decl) = N_At_Clause 3106 and then Chars (Identifier (Decl)) = Chars (Id) 3107 then 3108 return True; 3109 3110 elsif Nkind (Decl) = N_Attribute_Definition_Clause 3111 and then Chars (Decl) = Name_Address 3112 and then Chars (Name (Decl)) = Chars (Id) 3113 then 3114 return True; 3115 end if; 3116 3117 Next (Decl); 3118 end loop; 3119 3120 return False; 3121 end Has_Following_Address_Clause; 3122 3123 -------------------- 3124 -- Homonym_Number -- 3125 -------------------- 3126 3127 function Homonym_Number (Subp : Entity_Id) return Nat is 3128 Count : Nat; 3129 Hom : Entity_Id; 3130 3131 begin 3132 Count := 1; 3133 Hom := Homonym (Subp); 3134 while Present (Hom) loop 3135 if Scope (Hom) = Scope (Subp) then 3136 Count := Count + 1; 3137 end if; 3138 3139 Hom := Homonym (Hom); 3140 end loop; 3141 3142 return Count; 3143 end Homonym_Number; 3144 3145 ----------------------------------- 3146 -- In_Library_Level_Package_Body -- 3147 ----------------------------------- 3148 3149 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is 3150 begin 3151 -- First determine whether the entity appears at the library level, then 3152 -- look at the containing unit. 3153 3154 if Is_Library_Level_Entity (Id) then 3155 declare 3156 Container : constant Node_Id := Cunit (Get_Source_Unit (Id)); 3157 3158 begin 3159 return Nkind (Unit (Container)) = N_Package_Body; 3160 end; 3161 end if; 3162 3163 return False; 3164 end In_Library_Level_Package_Body; 3165 3166 ------------------------------ 3167 -- In_Unconditional_Context -- 3168 ------------------------------ 3169 3170 function In_Unconditional_Context (Node : Node_Id) return Boolean is 3171 P : Node_Id; 3172 3173 begin 3174 P := Node; 3175 while Present (P) loop 3176 case Nkind (P) is 3177 when N_Subprogram_Body => 3178 return True; 3179 3180 when N_If_Statement => 3181 return False; 3182 3183 when N_Loop_Statement => 3184 return False; 3185 3186 when N_Case_Statement => 3187 return False; 3188 3189 when others => 3190 P := Parent (P); 3191 end case; 3192 end loop; 3193 3194 return False; 3195 end In_Unconditional_Context; 3196 3197 ------------------- 3198 -- Insert_Action -- 3199 ------------------- 3200 3201 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is 3202 begin 3203 if Present (Ins_Action) then 3204 Insert_Actions (Assoc_Node, New_List (Ins_Action)); 3205 end if; 3206 end Insert_Action; 3207 3208 -- Version with check(s) suppressed 3209 3210 procedure Insert_Action 3211 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id) 3212 is 3213 begin 3214 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress); 3215 end Insert_Action; 3216 3217 ------------------------- 3218 -- Insert_Action_After -- 3219 ------------------------- 3220 3221 procedure Insert_Action_After 3222 (Assoc_Node : Node_Id; 3223 Ins_Action : Node_Id) 3224 is 3225 begin 3226 Insert_Actions_After (Assoc_Node, New_List (Ins_Action)); 3227 end Insert_Action_After; 3228 3229 -------------------- 3230 -- Insert_Actions -- 3231 -------------------- 3232 3233 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is 3234 N : Node_Id; 3235 P : Node_Id; 3236 3237 Wrapped_Node : Node_Id := Empty; 3238 3239 begin 3240 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then 3241 return; 3242 end if; 3243 3244 -- Ignore insert of actions from inside default expression (or other 3245 -- similar "spec expression") in the special spec-expression analyze 3246 -- mode. Any insertions at this point have no relevance, since we are 3247 -- only doing the analyze to freeze the types of any static expressions. 3248 -- See section "Handling of Default Expressions" in the spec of package 3249 -- Sem for further details. 3250 3251 if In_Spec_Expression then 3252 return; 3253 end if; 3254 3255 -- If the action derives from stuff inside a record, then the actions 3256 -- are attached to the current scope, to be inserted and analyzed on 3257 -- exit from the scope. The reason for this is that we may also be 3258 -- generating freeze actions at the same time, and they must eventually 3259 -- be elaborated in the correct order. 3260 3261 if Is_Record_Type (Current_Scope) 3262 and then not Is_Frozen (Current_Scope) 3263 then 3264 if No (Scope_Stack.Table 3265 (Scope_Stack.Last).Pending_Freeze_Actions) 3266 then 3267 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := 3268 Ins_Actions; 3269 else 3270 Append_List 3271 (Ins_Actions, 3272 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions); 3273 end if; 3274 3275 return; 3276 end if; 3277 3278 -- We now intend to climb up the tree to find the right point to 3279 -- insert the actions. We start at Assoc_Node, unless this node is a 3280 -- subexpression in which case we start with its parent. We do this for 3281 -- two reasons. First it speeds things up. Second, if Assoc_Node is 3282 -- itself one of the special nodes like N_And_Then, then we assume that 3283 -- an initial request to insert actions for such a node does not expect 3284 -- the actions to get deposited in the node for later handling when the 3285 -- node is expanded, since clearly the node is being dealt with by the 3286 -- caller. Note that in the subexpression case, N is always the child we 3287 -- came from. 3288 3289 -- N_Raise_xxx_Error is an annoying special case, it is a statement if 3290 -- it has type Standard_Void_Type, and a subexpression otherwise. 3291 -- otherwise. Procedure calls, and similarly procedure attribute 3292 -- references, are also statements. 3293 3294 if Nkind (Assoc_Node) in N_Subexpr 3295 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error 3296 or else Etype (Assoc_Node) /= Standard_Void_Type) 3297 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement 3298 and then (Nkind (Assoc_Node) /= N_Attribute_Reference 3299 or else 3300 not Is_Procedure_Attribute_Name 3301 (Attribute_Name (Assoc_Node))) 3302 then 3303 N := Assoc_Node; 3304 P := Parent (Assoc_Node); 3305 3306 -- Non-subexpression case. Note that N is initially Empty in this case 3307 -- (N is only guaranteed Non-Empty in the subexpr case). 3308 3309 else 3310 N := Empty; 3311 P := Assoc_Node; 3312 end if; 3313 3314 -- Capture root of the transient scope 3315 3316 if Scope_Is_Transient then 3317 Wrapped_Node := Node_To_Be_Wrapped; 3318 end if; 3319 3320 loop 3321 pragma Assert (Present (P)); 3322 3323 -- Make sure that inserted actions stay in the transient scope 3324 3325 if Present (Wrapped_Node) and then N = Wrapped_Node then 3326 Store_Before_Actions_In_Scope (Ins_Actions); 3327 return; 3328 end if; 3329 3330 case Nkind (P) is 3331 3332 -- Case of right operand of AND THEN or OR ELSE. Put the actions 3333 -- in the Actions field of the right operand. They will be moved 3334 -- out further when the AND THEN or OR ELSE operator is expanded. 3335 -- Nothing special needs to be done for the left operand since 3336 -- in that case the actions are executed unconditionally. 3337 3338 when N_Short_Circuit => 3339 if N = Right_Opnd (P) then 3340 3341 -- We are now going to either append the actions to the 3342 -- actions field of the short-circuit operation. We will 3343 -- also analyze the actions now. 3344 3345 -- This analysis is really too early, the proper thing would 3346 -- be to just park them there now, and only analyze them if 3347 -- we find we really need them, and to it at the proper 3348 -- final insertion point. However attempting to this proved 3349 -- tricky, so for now we just kill current values before and 3350 -- after the analyze call to make sure we avoid peculiar 3351 -- optimizations from this out of order insertion. 3352 3353 Kill_Current_Values; 3354 3355 -- If P has already been expanded, we can't park new actions 3356 -- on it, so we need to expand them immediately, introducing 3357 -- an Expression_With_Actions. N can't be an expression 3358 -- with actions, or else then the actions would have been 3359 -- inserted at an inner level. 3360 3361 if Analyzed (P) then 3362 pragma Assert (Nkind (N) /= N_Expression_With_Actions); 3363 Rewrite (N, 3364 Make_Expression_With_Actions (Sloc (N), 3365 Actions => Ins_Actions, 3366 Expression => Relocate_Node (N))); 3367 Analyze_And_Resolve (N); 3368 3369 elsif Present (Actions (P)) then 3370 Insert_List_After_And_Analyze 3371 (Last (Actions (P)), Ins_Actions); 3372 else 3373 Set_Actions (P, Ins_Actions); 3374 Analyze_List (Actions (P)); 3375 end if; 3376 3377 Kill_Current_Values; 3378 3379 return; 3380 end if; 3381 3382 -- Then or Else dependent expression of an if expression. Add 3383 -- actions to Then_Actions or Else_Actions field as appropriate. 3384 -- The actions will be moved further out when the if is expanded. 3385 3386 when N_If_Expression => 3387 declare 3388 ThenX : constant Node_Id := Next (First (Expressions (P))); 3389 ElseX : constant Node_Id := Next (ThenX); 3390 3391 begin 3392 -- If the enclosing expression is already analyzed, as 3393 -- is the case for nested elaboration checks, insert the 3394 -- conditional further out. 3395 3396 if Analyzed (P) then 3397 null; 3398 3399 -- Actions belong to the then expression, temporarily place 3400 -- them as Then_Actions of the if expression. They will be 3401 -- moved to the proper place later when the if expression 3402 -- is expanded. 3403 3404 elsif N = ThenX then 3405 if Present (Then_Actions (P)) then 3406 Insert_List_After_And_Analyze 3407 (Last (Then_Actions (P)), Ins_Actions); 3408 else 3409 Set_Then_Actions (P, Ins_Actions); 3410 Analyze_List (Then_Actions (P)); 3411 end if; 3412 3413 return; 3414 3415 -- Actions belong to the else expression, temporarily place 3416 -- them as Else_Actions of the if expression. They will be 3417 -- moved to the proper place later when the if expression 3418 -- is expanded. 3419 3420 elsif N = ElseX then 3421 if Present (Else_Actions (P)) then 3422 Insert_List_After_And_Analyze 3423 (Last (Else_Actions (P)), Ins_Actions); 3424 else 3425 Set_Else_Actions (P, Ins_Actions); 3426 Analyze_List (Else_Actions (P)); 3427 end if; 3428 3429 return; 3430 3431 -- Actions belong to the condition. In this case they are 3432 -- unconditionally executed, and so we can continue the 3433 -- search for the proper insert point. 3434 3435 else 3436 null; 3437 end if; 3438 end; 3439 3440 -- Alternative of case expression, we place the action in the 3441 -- Actions field of the case expression alternative, this will 3442 -- be handled when the case expression is expanded. 3443 3444 when N_Case_Expression_Alternative => 3445 if Present (Actions (P)) then 3446 Insert_List_After_And_Analyze 3447 (Last (Actions (P)), Ins_Actions); 3448 else 3449 Set_Actions (P, Ins_Actions); 3450 Analyze_List (Actions (P)); 3451 end if; 3452 3453 return; 3454 3455 -- Case of appearing within an Expressions_With_Actions node. When 3456 -- the new actions come from the expression of the expression with 3457 -- actions, they must be added to the existing actions. The other 3458 -- alternative is when the new actions are related to one of the 3459 -- existing actions of the expression with actions, and should 3460 -- never reach here: if actions are inserted on a statement 3461 -- within the Actions of an expression with actions, or on some 3462 -- sub-expression of such a statement, then the outermost proper 3463 -- insertion point is right before the statement, and we should 3464 -- never climb up as far as the N_Expression_With_Actions itself. 3465 3466 when N_Expression_With_Actions => 3467 if N = Expression (P) then 3468 if Is_Empty_List (Actions (P)) then 3469 Append_List_To (Actions (P), Ins_Actions); 3470 Analyze_List (Actions (P)); 3471 else 3472 Insert_List_After_And_Analyze 3473 (Last (Actions (P)), Ins_Actions); 3474 end if; 3475 3476 return; 3477 3478 else 3479 raise Program_Error; 3480 end if; 3481 3482 -- Case of appearing in the condition of a while expression or 3483 -- elsif. We insert the actions into the Condition_Actions field. 3484 -- They will be moved further out when the while loop or elsif 3485 -- is analyzed. 3486 3487 when N_Iteration_Scheme | 3488 N_Elsif_Part 3489 => 3490 if N = Condition (P) then 3491 if Present (Condition_Actions (P)) then 3492 Insert_List_After_And_Analyze 3493 (Last (Condition_Actions (P)), Ins_Actions); 3494 else 3495 Set_Condition_Actions (P, Ins_Actions); 3496 3497 -- Set the parent of the insert actions explicitly. This 3498 -- is not a syntactic field, but we need the parent field 3499 -- set, in particular so that freeze can understand that 3500 -- it is dealing with condition actions, and properly 3501 -- insert the freezing actions. 3502 3503 Set_Parent (Ins_Actions, P); 3504 Analyze_List (Condition_Actions (P)); 3505 end if; 3506 3507 return; 3508 end if; 3509 3510 -- Statements, declarations, pragmas, representation clauses 3511 3512 when 3513 -- Statements 3514 3515 N_Procedure_Call_Statement | 3516 N_Statement_Other_Than_Procedure_Call | 3517 3518 -- Pragmas 3519 3520 N_Pragma | 3521 3522 -- Representation_Clause 3523 3524 N_At_Clause | 3525 N_Attribute_Definition_Clause | 3526 N_Enumeration_Representation_Clause | 3527 N_Record_Representation_Clause | 3528 3529 -- Declarations 3530 3531 N_Abstract_Subprogram_Declaration | 3532 N_Entry_Body | 3533 N_Exception_Declaration | 3534 N_Exception_Renaming_Declaration | 3535 N_Expression_Function | 3536 N_Formal_Abstract_Subprogram_Declaration | 3537 N_Formal_Concrete_Subprogram_Declaration | 3538 N_Formal_Object_Declaration | 3539 N_Formal_Type_Declaration | 3540 N_Full_Type_Declaration | 3541 N_Function_Instantiation | 3542 N_Generic_Function_Renaming_Declaration | 3543 N_Generic_Package_Declaration | 3544 N_Generic_Package_Renaming_Declaration | 3545 N_Generic_Procedure_Renaming_Declaration | 3546 N_Generic_Subprogram_Declaration | 3547 N_Implicit_Label_Declaration | 3548 N_Incomplete_Type_Declaration | 3549 N_Number_Declaration | 3550 N_Object_Declaration | 3551 N_Object_Renaming_Declaration | 3552 N_Package_Body | 3553 N_Package_Body_Stub | 3554 N_Package_Declaration | 3555 N_Package_Instantiation | 3556 N_Package_Renaming_Declaration | 3557 N_Private_Extension_Declaration | 3558 N_Private_Type_Declaration | 3559 N_Procedure_Instantiation | 3560 N_Protected_Body | 3561 N_Protected_Body_Stub | 3562 N_Protected_Type_Declaration | 3563 N_Single_Task_Declaration | 3564 N_Subprogram_Body | 3565 N_Subprogram_Body_Stub | 3566 N_Subprogram_Declaration | 3567 N_Subprogram_Renaming_Declaration | 3568 N_Subtype_Declaration | 3569 N_Task_Body | 3570 N_Task_Body_Stub | 3571 N_Task_Type_Declaration | 3572 3573 -- Use clauses can appear in lists of declarations 3574 3575 N_Use_Package_Clause | 3576 N_Use_Type_Clause | 3577 3578 -- Freeze entity behaves like a declaration or statement 3579 3580 N_Freeze_Entity | 3581 N_Freeze_Generic_Entity 3582 => 3583 -- Do not insert here if the item is not a list member (this 3584 -- happens for example with a triggering statement, and the 3585 -- proper approach is to insert before the entire select). 3586 3587 if not Is_List_Member (P) then 3588 null; 3589 3590 -- Do not insert if parent of P is an N_Component_Association 3591 -- node (i.e. we are in the context of an N_Aggregate or 3592 -- N_Extension_Aggregate node. In this case we want to insert 3593 -- before the entire aggregate. 3594 3595 elsif Nkind (Parent (P)) = N_Component_Association then 3596 null; 3597 3598 -- Do not insert if the parent of P is either an N_Variant node 3599 -- or an N_Record_Definition node, meaning in either case that 3600 -- P is a member of a component list, and that therefore the 3601 -- actions should be inserted outside the complete record 3602 -- declaration. 3603 3604 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then 3605 null; 3606 3607 -- Do not insert freeze nodes within the loop generated for 3608 -- an aggregate, because they may be elaborated too late for 3609 -- subsequent use in the back end: within a package spec the 3610 -- loop is part of the elaboration procedure and is only 3611 -- elaborated during the second pass. 3612 3613 -- If the loop comes from source, or the entity is local to the 3614 -- loop itself it must remain within. 3615 3616 elsif Nkind (Parent (P)) = N_Loop_Statement 3617 and then not Comes_From_Source (Parent (P)) 3618 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity 3619 and then 3620 Scope (Entity (First (Ins_Actions))) /= Current_Scope 3621 then 3622 null; 3623 3624 -- Otherwise we can go ahead and do the insertion 3625 3626 elsif P = Wrapped_Node then 3627 Store_Before_Actions_In_Scope (Ins_Actions); 3628 return; 3629 3630 else 3631 Insert_List_Before_And_Analyze (P, Ins_Actions); 3632 return; 3633 end if; 3634 3635 -- A special case, N_Raise_xxx_Error can act either as a statement 3636 -- or a subexpression. We tell the difference by looking at the 3637 -- Etype. It is set to Standard_Void_Type in the statement case. 3638 3639 when 3640 N_Raise_xxx_Error => 3641 if Etype (P) = Standard_Void_Type then 3642 if P = Wrapped_Node then 3643 Store_Before_Actions_In_Scope (Ins_Actions); 3644 else 3645 Insert_List_Before_And_Analyze (P, Ins_Actions); 3646 end if; 3647 3648 return; 3649 3650 -- In the subexpression case, keep climbing 3651 3652 else 3653 null; 3654 end if; 3655 3656 -- If a component association appears within a loop created for 3657 -- an array aggregate, attach the actions to the association so 3658 -- they can be subsequently inserted within the loop. For other 3659 -- component associations insert outside of the aggregate. For 3660 -- an association that will generate a loop, its Loop_Actions 3661 -- attribute is already initialized (see exp_aggr.adb). 3662 3663 -- The list of loop_actions can in turn generate additional ones, 3664 -- that are inserted before the associated node. If the associated 3665 -- node is outside the aggregate, the new actions are collected 3666 -- at the end of the loop actions, to respect the order in which 3667 -- they are to be elaborated. 3668 3669 when 3670 N_Component_Association => 3671 if Nkind (Parent (P)) = N_Aggregate 3672 and then Present (Loop_Actions (P)) 3673 then 3674 if Is_Empty_List (Loop_Actions (P)) then 3675 Set_Loop_Actions (P, Ins_Actions); 3676 Analyze_List (Ins_Actions); 3677 3678 else 3679 declare 3680 Decl : Node_Id; 3681 3682 begin 3683 -- Check whether these actions were generated by a 3684 -- declaration that is part of the loop_ actions 3685 -- for the component_association. 3686 3687 Decl := Assoc_Node; 3688 while Present (Decl) loop 3689 exit when Parent (Decl) = P 3690 and then Is_List_Member (Decl) 3691 and then 3692 List_Containing (Decl) = Loop_Actions (P); 3693 Decl := Parent (Decl); 3694 end loop; 3695 3696 if Present (Decl) then 3697 Insert_List_Before_And_Analyze 3698 (Decl, Ins_Actions); 3699 else 3700 Insert_List_After_And_Analyze 3701 (Last (Loop_Actions (P)), Ins_Actions); 3702 end if; 3703 end; 3704 end if; 3705 3706 return; 3707 3708 else 3709 null; 3710 end if; 3711 3712 -- Another special case, an attribute denoting a procedure call 3713 3714 when 3715 N_Attribute_Reference => 3716 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then 3717 if P = Wrapped_Node then 3718 Store_Before_Actions_In_Scope (Ins_Actions); 3719 else 3720 Insert_List_Before_And_Analyze (P, Ins_Actions); 3721 end if; 3722 3723 return; 3724 3725 -- In the subexpression case, keep climbing 3726 3727 else 3728 null; 3729 end if; 3730 3731 -- A contract node should not belong to the tree 3732 3733 when N_Contract => 3734 raise Program_Error; 3735 3736 -- For all other node types, keep climbing tree 3737 3738 when 3739 N_Abortable_Part | 3740 N_Accept_Alternative | 3741 N_Access_Definition | 3742 N_Access_Function_Definition | 3743 N_Access_Procedure_Definition | 3744 N_Access_To_Object_Definition | 3745 N_Aggregate | 3746 N_Allocator | 3747 N_Aspect_Specification | 3748 N_Case_Expression | 3749 N_Case_Statement_Alternative | 3750 N_Character_Literal | 3751 N_Compilation_Unit | 3752 N_Compilation_Unit_Aux | 3753 N_Component_Clause | 3754 N_Component_Declaration | 3755 N_Component_Definition | 3756 N_Component_List | 3757 N_Constrained_Array_Definition | 3758 N_Decimal_Fixed_Point_Definition | 3759 N_Defining_Character_Literal | 3760 N_Defining_Identifier | 3761 N_Defining_Operator_Symbol | 3762 N_Defining_Program_Unit_Name | 3763 N_Delay_Alternative | 3764 N_Delta_Constraint | 3765 N_Derived_Type_Definition | 3766 N_Designator | 3767 N_Digits_Constraint | 3768 N_Discriminant_Association | 3769 N_Discriminant_Specification | 3770 N_Empty | 3771 N_Entry_Body_Formal_Part | 3772 N_Entry_Call_Alternative | 3773 N_Entry_Declaration | 3774 N_Entry_Index_Specification | 3775 N_Enumeration_Type_Definition | 3776 N_Error | 3777 N_Exception_Handler | 3778 N_Expanded_Name | 3779 N_Explicit_Dereference | 3780 N_Extension_Aggregate | 3781 N_Floating_Point_Definition | 3782 N_Formal_Decimal_Fixed_Point_Definition | 3783 N_Formal_Derived_Type_Definition | 3784 N_Formal_Discrete_Type_Definition | 3785 N_Formal_Floating_Point_Definition | 3786 N_Formal_Modular_Type_Definition | 3787 N_Formal_Ordinary_Fixed_Point_Definition | 3788 N_Formal_Package_Declaration | 3789 N_Formal_Private_Type_Definition | 3790 N_Formal_Incomplete_Type_Definition | 3791 N_Formal_Signed_Integer_Type_Definition | 3792 N_Function_Call | 3793 N_Function_Specification | 3794 N_Generic_Association | 3795 N_Handled_Sequence_Of_Statements | 3796 N_Identifier | 3797 N_In | 3798 N_Index_Or_Discriminant_Constraint | 3799 N_Indexed_Component | 3800 N_Integer_Literal | 3801 N_Iterator_Specification | 3802 N_Itype_Reference | 3803 N_Label | 3804 N_Loop_Parameter_Specification | 3805 N_Mod_Clause | 3806 N_Modular_Type_Definition | 3807 N_Not_In | 3808 N_Null | 3809 N_Op_Abs | 3810 N_Op_Add | 3811 N_Op_And | 3812 N_Op_Concat | 3813 N_Op_Divide | 3814 N_Op_Eq | 3815 N_Op_Expon | 3816 N_Op_Ge | 3817 N_Op_Gt | 3818 N_Op_Le | 3819 N_Op_Lt | 3820 N_Op_Minus | 3821 N_Op_Mod | 3822 N_Op_Multiply | 3823 N_Op_Ne | 3824 N_Op_Not | 3825 N_Op_Or | 3826 N_Op_Plus | 3827 N_Op_Rem | 3828 N_Op_Rotate_Left | 3829 N_Op_Rotate_Right | 3830 N_Op_Shift_Left | 3831 N_Op_Shift_Right | 3832 N_Op_Shift_Right_Arithmetic | 3833 N_Op_Subtract | 3834 N_Op_Xor | 3835 N_Operator_Symbol | 3836 N_Ordinary_Fixed_Point_Definition | 3837 N_Others_Choice | 3838 N_Package_Specification | 3839 N_Parameter_Association | 3840 N_Parameter_Specification | 3841 N_Pop_Constraint_Error_Label | 3842 N_Pop_Program_Error_Label | 3843 N_Pop_Storage_Error_Label | 3844 N_Pragma_Argument_Association | 3845 N_Procedure_Specification | 3846 N_Protected_Definition | 3847 N_Push_Constraint_Error_Label | 3848 N_Push_Program_Error_Label | 3849 N_Push_Storage_Error_Label | 3850 N_Qualified_Expression | 3851 N_Quantified_Expression | 3852 N_Raise_Expression | 3853 N_Range | 3854 N_Range_Constraint | 3855 N_Real_Literal | 3856 N_Real_Range_Specification | 3857 N_Record_Definition | 3858 N_Reference | 3859 N_SCIL_Dispatch_Table_Tag_Init | 3860 N_SCIL_Dispatching_Call | 3861 N_SCIL_Membership_Test | 3862 N_Selected_Component | 3863 N_Signed_Integer_Type_Definition | 3864 N_Single_Protected_Declaration | 3865 N_Slice | 3866 N_String_Literal | 3867 N_Subtype_Indication | 3868 N_Subunit | 3869 N_Task_Definition | 3870 N_Terminate_Alternative | 3871 N_Triggering_Alternative | 3872 N_Type_Conversion | 3873 N_Unchecked_Expression | 3874 N_Unchecked_Type_Conversion | 3875 N_Unconstrained_Array_Definition | 3876 N_Unused_At_End | 3877 N_Unused_At_Start | 3878 N_Variant | 3879 N_Variant_Part | 3880 N_Validate_Unchecked_Conversion | 3881 N_With_Clause 3882 => 3883 null; 3884 3885 end case; 3886 3887 -- If we fall through above tests, keep climbing tree 3888 3889 N := P; 3890 3891 if Nkind (Parent (N)) = N_Subunit then 3892 3893 -- This is the proper body corresponding to a stub. Insertion must 3894 -- be done at the point of the stub, which is in the declarative 3895 -- part of the parent unit. 3896 3897 P := Corresponding_Stub (Parent (N)); 3898 3899 else 3900 P := Parent (N); 3901 end if; 3902 end loop; 3903 end Insert_Actions; 3904 3905 -- Version with check(s) suppressed 3906 3907 procedure Insert_Actions 3908 (Assoc_Node : Node_Id; 3909 Ins_Actions : List_Id; 3910 Suppress : Check_Id) 3911 is 3912 begin 3913 if Suppress = All_Checks then 3914 declare 3915 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 3916 begin 3917 Scope_Suppress.Suppress := (others => True); 3918 Insert_Actions (Assoc_Node, Ins_Actions); 3919 Scope_Suppress.Suppress := Sva; 3920 end; 3921 3922 else 3923 declare 3924 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 3925 begin 3926 Scope_Suppress.Suppress (Suppress) := True; 3927 Insert_Actions (Assoc_Node, Ins_Actions); 3928 Scope_Suppress.Suppress (Suppress) := Svg; 3929 end; 3930 end if; 3931 end Insert_Actions; 3932 3933 -------------------------- 3934 -- Insert_Actions_After -- 3935 -------------------------- 3936 3937 procedure Insert_Actions_After 3938 (Assoc_Node : Node_Id; 3939 Ins_Actions : List_Id) 3940 is 3941 begin 3942 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then 3943 Store_After_Actions_In_Scope (Ins_Actions); 3944 else 3945 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions); 3946 end if; 3947 end Insert_Actions_After; 3948 3949 ------------------------ 3950 -- Insert_Declaration -- 3951 ------------------------ 3952 3953 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is 3954 P : Node_Id; 3955 3956 begin 3957 pragma Assert (Nkind (N) in N_Subexpr); 3958 3959 -- Climb until we find a procedure or a package 3960 3961 P := N; 3962 loop 3963 pragma Assert (Present (Parent (P))); 3964 P := Parent (P); 3965 3966 if Is_List_Member (P) then 3967 exit when Nkind_In (Parent (P), N_Package_Specification, 3968 N_Subprogram_Body); 3969 3970 -- Special handling for handled sequence of statements, we must 3971 -- insert in the statements not the exception handlers! 3972 3973 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then 3974 P := First (Statements (Parent (P))); 3975 exit; 3976 end if; 3977 end if; 3978 end loop; 3979 3980 -- Now do the insertion 3981 3982 Insert_Before (P, Decl); 3983 Analyze (Decl); 3984 end Insert_Declaration; 3985 3986 --------------------------------- 3987 -- Insert_Library_Level_Action -- 3988 --------------------------------- 3989 3990 procedure Insert_Library_Level_Action (N : Node_Id) is 3991 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); 3992 3993 begin 3994 Push_Scope (Cunit_Entity (Main_Unit)); 3995 -- ??? should this be Current_Sem_Unit instead of Main_Unit? 3996 3997 if No (Actions (Aux)) then 3998 Set_Actions (Aux, New_List (N)); 3999 else 4000 Append (N, Actions (Aux)); 4001 end if; 4002 4003 Analyze (N); 4004 Pop_Scope; 4005 end Insert_Library_Level_Action; 4006 4007 ---------------------------------- 4008 -- Insert_Library_Level_Actions -- 4009 ---------------------------------- 4010 4011 procedure Insert_Library_Level_Actions (L : List_Id) is 4012 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); 4013 4014 begin 4015 if Is_Non_Empty_List (L) then 4016 Push_Scope (Cunit_Entity (Main_Unit)); 4017 -- ??? should this be Current_Sem_Unit instead of Main_Unit? 4018 4019 if No (Actions (Aux)) then 4020 Set_Actions (Aux, L); 4021 Analyze_List (L); 4022 else 4023 Insert_List_After_And_Analyze (Last (Actions (Aux)), L); 4024 end if; 4025 4026 Pop_Scope; 4027 end if; 4028 end Insert_Library_Level_Actions; 4029 4030 ---------------------- 4031 -- Inside_Init_Proc -- 4032 ---------------------- 4033 4034 function Inside_Init_Proc return Boolean is 4035 S : Entity_Id; 4036 4037 begin 4038 S := Current_Scope; 4039 while Present (S) and then S /= Standard_Standard loop 4040 if Is_Init_Proc (S) then 4041 return True; 4042 else 4043 S := Scope (S); 4044 end if; 4045 end loop; 4046 4047 return False; 4048 end Inside_Init_Proc; 4049 4050 ---------------------------- 4051 -- Is_All_Null_Statements -- 4052 ---------------------------- 4053 4054 function Is_All_Null_Statements (L : List_Id) return Boolean is 4055 Stm : Node_Id; 4056 4057 begin 4058 Stm := First (L); 4059 while Present (Stm) loop 4060 if Nkind (Stm) /= N_Null_Statement then 4061 return False; 4062 end if; 4063 4064 Next (Stm); 4065 end loop; 4066 4067 return True; 4068 end Is_All_Null_Statements; 4069 4070 -------------------------------------------------- 4071 -- Is_Displacement_Of_Object_Or_Function_Result -- 4072 -------------------------------------------------- 4073 4074 function Is_Displacement_Of_Object_Or_Function_Result 4075 (Obj_Id : Entity_Id) return Boolean 4076 is 4077 function Is_Controlled_Function_Call (N : Node_Id) return Boolean; 4078 -- Determine if particular node denotes a controlled function call 4079 4080 function Is_Displace_Call (N : Node_Id) return Boolean; 4081 -- Determine whether a particular node is a call to Ada.Tags.Displace. 4082 -- The call might be nested within other actions such as conversions. 4083 4084 function Is_Source_Object (N : Node_Id) return Boolean; 4085 -- Determine whether a particular node denotes a source object 4086 4087 --------------------------------- 4088 -- Is_Controlled_Function_Call -- 4089 --------------------------------- 4090 4091 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is 4092 Expr : Node_Id := Original_Node (N); 4093 4094 begin 4095 if Nkind (Expr) = N_Function_Call then 4096 Expr := Name (Expr); 4097 end if; 4098 4099 -- The function call may appear in object.operation format 4100 4101 if Nkind (Expr) = N_Selected_Component then 4102 Expr := Selector_Name (Expr); 4103 end if; 4104 4105 return 4106 Nkind_In (Expr, N_Expanded_Name, N_Identifier) 4107 and then Ekind (Entity (Expr)) = E_Function 4108 and then Needs_Finalization (Etype (Entity (Expr))); 4109 end Is_Controlled_Function_Call; 4110 4111 ---------------------- 4112 -- Is_Displace_Call -- 4113 ---------------------- 4114 4115 function Is_Displace_Call (N : Node_Id) return Boolean is 4116 Call : Node_Id := N; 4117 4118 begin 4119 -- Strip various actions which may precede a call to Displace 4120 4121 loop 4122 if Nkind (Call) = N_Explicit_Dereference then 4123 Call := Prefix (Call); 4124 4125 elsif Nkind_In (Call, N_Type_Conversion, 4126 N_Unchecked_Type_Conversion) 4127 then 4128 Call := Expression (Call); 4129 4130 else 4131 exit; 4132 end if; 4133 end loop; 4134 4135 return 4136 Present (Call) 4137 and then Nkind (Call) = N_Function_Call 4138 and then Is_RTE (Entity (Name (Call)), RE_Displace); 4139 end Is_Displace_Call; 4140 4141 ---------------------- 4142 -- Is_Source_Object -- 4143 ---------------------- 4144 4145 function Is_Source_Object (N : Node_Id) return Boolean is 4146 begin 4147 return 4148 Present (N) 4149 and then Nkind (N) in N_Has_Entity 4150 and then Is_Object (Entity (N)) 4151 and then Comes_From_Source (N); 4152 end Is_Source_Object; 4153 4154 -- Local variables 4155 4156 Decl : constant Node_Id := Parent (Obj_Id); 4157 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); 4158 Orig_Decl : constant Node_Id := Original_Node (Decl); 4159 4160 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result 4161 4162 begin 4163 -- Case 1: 4164 4165 -- Obj : CW_Type := Function_Call (...); 4166 4167 -- rewritten into: 4168 4169 -- Tmp : ... := Function_Call (...)'reference; 4170 -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp)); 4171 4172 -- where the return type of the function and the class-wide type require 4173 -- dispatch table pointer displacement. 4174 4175 -- Case 2: 4176 4177 -- Obj : CW_Type := Src_Obj; 4178 4179 -- rewritten into: 4180 4181 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); 4182 4183 -- where the type of the source object and the class-wide type require 4184 -- dispatch table pointer displacement. 4185 4186 return 4187 Nkind (Decl) = N_Object_Renaming_Declaration 4188 and then Nkind (Orig_Decl) = N_Object_Declaration 4189 and then Comes_From_Source (Orig_Decl) 4190 and then Is_Class_Wide_Type (Obj_Typ) 4191 and then Is_Displace_Call (Renamed_Object (Obj_Id)) 4192 and then 4193 (Is_Controlled_Function_Call (Expression (Orig_Decl)) 4194 or else Is_Source_Object (Expression (Orig_Decl))); 4195 end Is_Displacement_Of_Object_Or_Function_Result; 4196 4197 ------------------------------ 4198 -- Is_Finalizable_Transient -- 4199 ------------------------------ 4200 4201 function Is_Finalizable_Transient 4202 (Decl : Node_Id; 4203 Rel_Node : Node_Id) return Boolean 4204 is 4205 Obj_Id : constant Entity_Id := Defining_Identifier (Decl); 4206 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); 4207 Desig : Entity_Id := Obj_Typ; 4208 4209 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean; 4210 -- Determine whether transient object Trans_Id is initialized either 4211 -- by a function call which returns an access type or simply renames 4212 -- another pointer. 4213 4214 function Initialized_By_Aliased_BIP_Func_Call 4215 (Trans_Id : Entity_Id) return Boolean; 4216 -- Determine whether transient object Trans_Id is initialized by a 4217 -- build-in-place function call where the BIPalloc parameter is of 4218 -- value 1 and BIPaccess is not null. This case creates an aliasing 4219 -- between the returned value and the value denoted by BIPaccess. 4220 4221 function Is_Aliased 4222 (Trans_Id : Entity_Id; 4223 First_Stmt : Node_Id) return Boolean; 4224 -- Determine whether transient object Trans_Id has been renamed or 4225 -- aliased through 'reference in the statement list starting from 4226 -- First_Stmt. 4227 4228 function Is_Allocated (Trans_Id : Entity_Id) return Boolean; 4229 -- Determine whether transient object Trans_Id is allocated on the heap 4230 4231 function Is_Iterated_Container 4232 (Trans_Id : Entity_Id; 4233 First_Stmt : Node_Id) return Boolean; 4234 -- Determine whether transient object Trans_Id denotes a container which 4235 -- is in the process of being iterated in the statement list starting 4236 -- from First_Stmt. 4237 4238 --------------------------- 4239 -- Initialized_By_Access -- 4240 --------------------------- 4241 4242 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is 4243 Expr : constant Node_Id := Expression (Parent (Trans_Id)); 4244 4245 begin 4246 return 4247 Present (Expr) 4248 and then Nkind (Expr) /= N_Reference 4249 and then Is_Access_Type (Etype (Expr)); 4250 end Initialized_By_Access; 4251 4252 ------------------------------------------ 4253 -- Initialized_By_Aliased_BIP_Func_Call -- 4254 ------------------------------------------ 4255 4256 function Initialized_By_Aliased_BIP_Func_Call 4257 (Trans_Id : Entity_Id) return Boolean 4258 is 4259 Call : Node_Id := Expression (Parent (Trans_Id)); 4260 4261 begin 4262 -- Build-in-place calls usually appear in 'reference format 4263 4264 if Nkind (Call) = N_Reference then 4265 Call := Prefix (Call); 4266 end if; 4267 4268 if Is_Build_In_Place_Function_Call (Call) then 4269 declare 4270 Access_Nam : Name_Id := No_Name; 4271 Access_OK : Boolean := False; 4272 Actual : Node_Id; 4273 Alloc_Nam : Name_Id := No_Name; 4274 Alloc_OK : Boolean := False; 4275 Formal : Node_Id; 4276 Func_Id : Entity_Id; 4277 Param : Node_Id; 4278 4279 begin 4280 -- Examine all parameter associations of the function call 4281 4282 Param := First (Parameter_Associations (Call)); 4283 while Present (Param) loop 4284 if Nkind (Param) = N_Parameter_Association 4285 and then Nkind (Selector_Name (Param)) = N_Identifier 4286 then 4287 Actual := Explicit_Actual_Parameter (Param); 4288 Formal := Selector_Name (Param); 4289 4290 -- Construct the names of formals BIPaccess and BIPalloc 4291 -- using the function name retrieved from an arbitrary 4292 -- formal. 4293 4294 if Access_Nam = No_Name 4295 and then Alloc_Nam = No_Name 4296 and then Present (Entity (Formal)) 4297 then 4298 Func_Id := Scope (Entity (Formal)); 4299 4300 Access_Nam := 4301 New_External_Name (Chars (Func_Id), 4302 BIP_Formal_Suffix (BIP_Object_Access)); 4303 4304 Alloc_Nam := 4305 New_External_Name (Chars (Func_Id), 4306 BIP_Formal_Suffix (BIP_Alloc_Form)); 4307 end if; 4308 4309 -- A match for BIPaccess => Temp has been found 4310 4311 if Chars (Formal) = Access_Nam 4312 and then Nkind (Actual) /= N_Null 4313 then 4314 Access_OK := True; 4315 end if; 4316 4317 -- A match for BIPalloc => 1 has been found 4318 4319 if Chars (Formal) = Alloc_Nam 4320 and then Nkind (Actual) = N_Integer_Literal 4321 and then Intval (Actual) = Uint_1 4322 then 4323 Alloc_OK := True; 4324 end if; 4325 end if; 4326 4327 Next (Param); 4328 end loop; 4329 4330 return Access_OK and Alloc_OK; 4331 end; 4332 end if; 4333 4334 return False; 4335 end Initialized_By_Aliased_BIP_Func_Call; 4336 4337 ---------------- 4338 -- Is_Aliased -- 4339 ---------------- 4340 4341 function Is_Aliased 4342 (Trans_Id : Entity_Id; 4343 First_Stmt : Node_Id) return Boolean 4344 is 4345 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id; 4346 -- Given an object renaming declaration, retrieve the entity of the 4347 -- renamed name. Return Empty if the renamed name is anything other 4348 -- than a variable or a constant. 4349 4350 ------------------------- 4351 -- Find_Renamed_Object -- 4352 ------------------------- 4353 4354 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is 4355 Ren_Obj : Node_Id := Empty; 4356 4357 function Find_Object (N : Node_Id) return Traverse_Result; 4358 -- Try to detect an object which is either a constant or a 4359 -- variable. 4360 4361 ----------------- 4362 -- Find_Object -- 4363 ----------------- 4364 4365 function Find_Object (N : Node_Id) return Traverse_Result is 4366 begin 4367 -- Stop the search once a constant or a variable has been 4368 -- detected. 4369 4370 if Nkind (N) = N_Identifier 4371 and then Present (Entity (N)) 4372 and then Ekind_In (Entity (N), E_Constant, E_Variable) 4373 then 4374 Ren_Obj := Entity (N); 4375 return Abandon; 4376 end if; 4377 4378 return OK; 4379 end Find_Object; 4380 4381 procedure Search is new Traverse_Proc (Find_Object); 4382 4383 -- Local variables 4384 4385 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl)); 4386 4387 -- Start of processing for Find_Renamed_Object 4388 4389 begin 4390 -- Actions related to dispatching calls may appear as renamings of 4391 -- tags. Do not process this type of renaming because it does not 4392 -- use the actual value of the object. 4393 4394 if not Is_RTE (Typ, RE_Tag_Ptr) then 4395 Search (Name (Ren_Decl)); 4396 end if; 4397 4398 return Ren_Obj; 4399 end Find_Renamed_Object; 4400 4401 -- Local variables 4402 4403 Expr : Node_Id; 4404 Ren_Obj : Entity_Id; 4405 Stmt : Node_Id; 4406 4407 -- Start of processing for Is_Aliased 4408 4409 begin 4410 Stmt := First_Stmt; 4411 while Present (Stmt) loop 4412 if Nkind (Stmt) = N_Object_Declaration then 4413 Expr := Expression (Stmt); 4414 4415 if Present (Expr) 4416 and then Nkind (Expr) = N_Reference 4417 and then Nkind (Prefix (Expr)) = N_Identifier 4418 and then Entity (Prefix (Expr)) = Trans_Id 4419 then 4420 return True; 4421 end if; 4422 4423 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then 4424 Ren_Obj := Find_Renamed_Object (Stmt); 4425 4426 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then 4427 return True; 4428 end if; 4429 end if; 4430 4431 Next (Stmt); 4432 end loop; 4433 4434 return False; 4435 end Is_Aliased; 4436 4437 ------------------ 4438 -- Is_Allocated -- 4439 ------------------ 4440 4441 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is 4442 Expr : constant Node_Id := Expression (Parent (Trans_Id)); 4443 begin 4444 return 4445 Is_Access_Type (Etype (Trans_Id)) 4446 and then Present (Expr) 4447 and then Nkind (Expr) = N_Allocator; 4448 end Is_Allocated; 4449 4450 --------------------------- 4451 -- Is_Iterated_Container -- 4452 --------------------------- 4453 4454 function Is_Iterated_Container 4455 (Trans_Id : Entity_Id; 4456 First_Stmt : Node_Id) return Boolean 4457 is 4458 Aspect : Node_Id; 4459 Call : Node_Id; 4460 Iter : Entity_Id; 4461 Param : Node_Id; 4462 Stmt : Node_Id; 4463 Typ : Entity_Id; 4464 4465 begin 4466 -- It is not possible to iterate over containers in non-Ada 2012 code 4467 4468 if Ada_Version < Ada_2012 then 4469 return False; 4470 end if; 4471 4472 Typ := Etype (Trans_Id); 4473 4474 -- Handle access type created for secondary stack use 4475 4476 if Is_Access_Type (Typ) then 4477 Typ := Designated_Type (Typ); 4478 end if; 4479 4480 -- Look for aspect Default_Iterator. It may be part of a type 4481 -- declaration for a container, or inherited from a base type 4482 -- or parent type. 4483 4484 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator); 4485 4486 if Present (Aspect) then 4487 Iter := Entity (Aspect); 4488 4489 -- Examine the statements following the container object and 4490 -- look for a call to the default iterate routine where the 4491 -- first parameter is the transient. Such a call appears as: 4492 4493 -- It : Access_To_CW_Iterator := 4494 -- Iterate (Tran_Id.all, ...)'reference; 4495 4496 Stmt := First_Stmt; 4497 while Present (Stmt) loop 4498 4499 -- Detect an object declaration which is initialized by a 4500 -- secondary stack function call. 4501 4502 if Nkind (Stmt) = N_Object_Declaration 4503 and then Present (Expression (Stmt)) 4504 and then Nkind (Expression (Stmt)) = N_Reference 4505 and then Nkind (Prefix (Expression (Stmt))) = 4506 N_Function_Call 4507 then 4508 Call := Prefix (Expression (Stmt)); 4509 4510 -- The call must invoke the default iterate routine of 4511 -- the container and the transient object must appear as 4512 -- the first actual parameter. Skip any calls whose names 4513 -- are not entities. 4514 4515 if Is_Entity_Name (Name (Call)) 4516 and then Entity (Name (Call)) = Iter 4517 and then Present (Parameter_Associations (Call)) 4518 then 4519 Param := First (Parameter_Associations (Call)); 4520 4521 if Nkind (Param) = N_Explicit_Dereference 4522 and then Entity (Prefix (Param)) = Trans_Id 4523 then 4524 return True; 4525 end if; 4526 end if; 4527 end if; 4528 4529 Next (Stmt); 4530 end loop; 4531 end if; 4532 4533 return False; 4534 end Is_Iterated_Container; 4535 4536 -- Start of processing for Is_Finalizable_Transient 4537 4538 begin 4539 -- Handle access types 4540 4541 if Is_Access_Type (Desig) then 4542 Desig := Available_View (Designated_Type (Desig)); 4543 end if; 4544 4545 return 4546 Ekind_In (Obj_Id, E_Constant, E_Variable) 4547 and then Needs_Finalization (Desig) 4548 and then Requires_Transient_Scope (Desig) 4549 and then Nkind (Rel_Node) /= N_Simple_Return_Statement 4550 4551 -- Do not consider renamed or 'reference-d transient objects because 4552 -- the act of renaming extends the object's lifetime. 4553 4554 and then not Is_Aliased (Obj_Id, Decl) 4555 4556 -- Do not consider transient objects allocated on the heap since 4557 -- they are attached to a finalization master. 4558 4559 and then not Is_Allocated (Obj_Id) 4560 4561 -- If the transient object is a pointer, check that it is not 4562 -- initialized by a function which returns a pointer or acts as a 4563 -- renaming of another pointer. 4564 4565 and then 4566 (not Is_Access_Type (Obj_Typ) 4567 or else not Initialized_By_Access (Obj_Id)) 4568 4569 -- Do not consider transient objects which act as indirect aliases 4570 -- of build-in-place function results. 4571 4572 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id) 4573 4574 -- Do not consider conversions of tags to class-wide types 4575 4576 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) 4577 4578 -- Do not consider containers in the context of iterator loops. Such 4579 -- transient objects must exist for as long as the loop is around, 4580 -- otherwise any operation carried out by the iterator will fail. 4581 4582 and then not Is_Iterated_Container (Obj_Id, Decl); 4583 end Is_Finalizable_Transient; 4584 4585 --------------------------------- 4586 -- Is_Fully_Repped_Tagged_Type -- 4587 --------------------------------- 4588 4589 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is 4590 U : constant Entity_Id := Underlying_Type (T); 4591 Comp : Entity_Id; 4592 4593 begin 4594 if No (U) or else not Is_Tagged_Type (U) then 4595 return False; 4596 elsif Has_Discriminants (U) then 4597 return False; 4598 elsif not Has_Specified_Layout (U) then 4599 return False; 4600 end if; 4601 4602 -- Here we have a tagged type, see if it has any unlayed out fields 4603 -- other than a possible tag and parent fields. If so, we return False. 4604 4605 Comp := First_Component (U); 4606 while Present (Comp) loop 4607 if not Is_Tag (Comp) 4608 and then Chars (Comp) /= Name_uParent 4609 and then No (Component_Clause (Comp)) 4610 then 4611 return False; 4612 else 4613 Next_Component (Comp); 4614 end if; 4615 end loop; 4616 4617 -- All components are layed out 4618 4619 return True; 4620 end Is_Fully_Repped_Tagged_Type; 4621 4622 ---------------------------------- 4623 -- Is_Library_Level_Tagged_Type -- 4624 ---------------------------------- 4625 4626 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is 4627 begin 4628 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ); 4629 end Is_Library_Level_Tagged_Type; 4630 4631 -------------------------- 4632 -- Is_Non_BIP_Func_Call -- 4633 -------------------------- 4634 4635 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is 4636 begin 4637 -- The expected call is of the format 4638 -- 4639 -- Func_Call'reference 4640 4641 return 4642 Nkind (Expr) = N_Reference 4643 and then Nkind (Prefix (Expr)) = N_Function_Call 4644 and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); 4645 end Is_Non_BIP_Func_Call; 4646 4647 ---------------------------------- 4648 -- Is_Possibly_Unaligned_Object -- 4649 ---------------------------------- 4650 4651 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is 4652 T : constant Entity_Id := Etype (N); 4653 4654 begin 4655 -- If renamed object, apply test to underlying object 4656 4657 if Is_Entity_Name (N) 4658 and then Is_Object (Entity (N)) 4659 and then Present (Renamed_Object (Entity (N))) 4660 then 4661 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N))); 4662 end if; 4663 4664 -- Tagged and controlled types and aliased types are always aligned, as 4665 -- are concurrent types. 4666 4667 if Is_Aliased (T) 4668 or else Has_Controlled_Component (T) 4669 or else Is_Concurrent_Type (T) 4670 or else Is_Tagged_Type (T) 4671 or else Is_Controlled (T) 4672 then 4673 return False; 4674 end if; 4675 4676 -- If this is an element of a packed array, may be unaligned 4677 4678 if Is_Ref_To_Bit_Packed_Array (N) then 4679 return True; 4680 end if; 4681 4682 -- Case of indexed component reference: test whether prefix is unaligned 4683 4684 if Nkind (N) = N_Indexed_Component then 4685 return Is_Possibly_Unaligned_Object (Prefix (N)); 4686 4687 -- Case of selected component reference 4688 4689 elsif Nkind (N) = N_Selected_Component then 4690 declare 4691 P : constant Node_Id := Prefix (N); 4692 C : constant Entity_Id := Entity (Selector_Name (N)); 4693 M : Nat; 4694 S : Nat; 4695 4696 begin 4697 -- If component reference is for an array with non-static bounds, 4698 -- then it is always aligned: we can only process unaligned arrays 4699 -- with static bounds (more precisely compile time known bounds). 4700 4701 if Is_Array_Type (T) 4702 and then not Compile_Time_Known_Bounds (T) 4703 then 4704 return False; 4705 end if; 4706 4707 -- If component is aliased, it is definitely properly aligned 4708 4709 if Is_Aliased (C) then 4710 return False; 4711 end if; 4712 4713 -- If component is for a type implemented as a scalar, and the 4714 -- record is packed, and the component is other than the first 4715 -- component of the record, then the component may be unaligned. 4716 4717 if Is_Packed (Etype (P)) 4718 and then Represented_As_Scalar (Etype (C)) 4719 and then First_Entity (Scope (C)) /= C 4720 then 4721 return True; 4722 end if; 4723 4724 -- Compute maximum possible alignment for T 4725 4726 -- If alignment is known, then that settles things 4727 4728 if Known_Alignment (T) then 4729 M := UI_To_Int (Alignment (T)); 4730 4731 -- If alignment is not known, tentatively set max alignment 4732 4733 else 4734 M := Ttypes.Maximum_Alignment; 4735 4736 -- We can reduce this if the Esize is known since the default 4737 -- alignment will never be more than the smallest power of 2 4738 -- that does not exceed this Esize value. 4739 4740 if Known_Esize (T) then 4741 S := UI_To_Int (Esize (T)); 4742 4743 while (M / 2) >= S loop 4744 M := M / 2; 4745 end loop; 4746 end if; 4747 end if; 4748 4749 -- The following code is historical, it used to be present but it 4750 -- is too cautious, because the front-end does not know the proper 4751 -- default alignments for the target. Also, if the alignment is 4752 -- not known, the front end can't know in any case. If a copy is 4753 -- needed, the back-end will take care of it. This whole section 4754 -- including this comment can be removed later ??? 4755 4756 -- If the component reference is for a record that has a specified 4757 -- alignment, and we either know it is too small, or cannot tell, 4758 -- then the component may be unaligned. 4759 4760 -- What is the following commented out code ??? 4761 4762 -- if Known_Alignment (Etype (P)) 4763 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment 4764 -- and then M > Alignment (Etype (P)) 4765 -- then 4766 -- return True; 4767 -- end if; 4768 4769 -- Case of component clause present which may specify an 4770 -- unaligned position. 4771 4772 if Present (Component_Clause (C)) then 4773 4774 -- Otherwise we can do a test to make sure that the actual 4775 -- start position in the record, and the length, are both 4776 -- consistent with the required alignment. If not, we know 4777 -- that we are unaligned. 4778 4779 declare 4780 Align_In_Bits : constant Nat := M * System_Storage_Unit; 4781 begin 4782 if Component_Bit_Offset (C) mod Align_In_Bits /= 0 4783 or else Esize (C) mod Align_In_Bits /= 0 4784 then 4785 return True; 4786 end if; 4787 end; 4788 end if; 4789 4790 -- Otherwise, for a component reference, test prefix 4791 4792 return Is_Possibly_Unaligned_Object (P); 4793 end; 4794 4795 -- If not a component reference, must be aligned 4796 4797 else 4798 return False; 4799 end if; 4800 end Is_Possibly_Unaligned_Object; 4801 4802 --------------------------------- 4803 -- Is_Possibly_Unaligned_Slice -- 4804 --------------------------------- 4805 4806 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is 4807 begin 4808 -- Go to renamed object 4809 4810 if Is_Entity_Name (N) 4811 and then Is_Object (Entity (N)) 4812 and then Present (Renamed_Object (Entity (N))) 4813 then 4814 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N))); 4815 end if; 4816 4817 -- The reference must be a slice 4818 4819 if Nkind (N) /= N_Slice then 4820 return False; 4821 end if; 4822 4823 -- Always assume the worst for a nested record component with a 4824 -- component clause, which gigi/gcc does not appear to handle well. 4825 -- It is not clear why this special test is needed at all ??? 4826 4827 if Nkind (Prefix (N)) = N_Selected_Component 4828 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component 4829 and then 4830 Present (Component_Clause (Entity (Selector_Name (Prefix (N))))) 4831 then 4832 return True; 4833 end if; 4834 4835 -- We only need to worry if the target has strict alignment 4836 4837 if not Target_Strict_Alignment then 4838 return False; 4839 end if; 4840 4841 -- If it is a slice, then look at the array type being sliced 4842 4843 declare 4844 Sarr : constant Node_Id := Prefix (N); 4845 -- Prefix of the slice, i.e. the array being sliced 4846 4847 Styp : constant Entity_Id := Etype (Prefix (N)); 4848 -- Type of the array being sliced 4849 4850 Pref : Node_Id; 4851 Ptyp : Entity_Id; 4852 4853 begin 4854 -- The problems arise if the array object that is being sliced 4855 -- is a component of a record or array, and we cannot guarantee 4856 -- the alignment of the array within its containing object. 4857 4858 -- To investigate this, we look at successive prefixes to see 4859 -- if we have a worrisome indexed or selected component. 4860 4861 Pref := Sarr; 4862 loop 4863 -- Case of array is part of an indexed component reference 4864 4865 if Nkind (Pref) = N_Indexed_Component then 4866 Ptyp := Etype (Prefix (Pref)); 4867 4868 -- The only problematic case is when the array is packed, in 4869 -- which case we really know nothing about the alignment of 4870 -- individual components. 4871 4872 if Is_Bit_Packed_Array (Ptyp) then 4873 return True; 4874 end if; 4875 4876 -- Case of array is part of a selected component reference 4877 4878 elsif Nkind (Pref) = N_Selected_Component then 4879 Ptyp := Etype (Prefix (Pref)); 4880 4881 -- We are definitely in trouble if the record in question 4882 -- has an alignment, and either we know this alignment is 4883 -- inconsistent with the alignment of the slice, or we don't 4884 -- know what the alignment of the slice should be. 4885 4886 if Known_Alignment (Ptyp) 4887 and then (Unknown_Alignment (Styp) 4888 or else Alignment (Styp) > Alignment (Ptyp)) 4889 then 4890 return True; 4891 end if; 4892 4893 -- We are in potential trouble if the record type is packed. 4894 -- We could special case when we know that the array is the 4895 -- first component, but that's not such a simple case ??? 4896 4897 if Is_Packed (Ptyp) then 4898 return True; 4899 end if; 4900 4901 -- We are in trouble if there is a component clause, and 4902 -- either we do not know the alignment of the slice, or 4903 -- the alignment of the slice is inconsistent with the 4904 -- bit position specified by the component clause. 4905 4906 declare 4907 Field : constant Entity_Id := Entity (Selector_Name (Pref)); 4908 begin 4909 if Present (Component_Clause (Field)) 4910 and then 4911 (Unknown_Alignment (Styp) 4912 or else 4913 (Component_Bit_Offset (Field) mod 4914 (System_Storage_Unit * Alignment (Styp))) /= 0) 4915 then 4916 return True; 4917 end if; 4918 end; 4919 4920 -- For cases other than selected or indexed components we know we 4921 -- are OK, since no issues arise over alignment. 4922 4923 else 4924 return False; 4925 end if; 4926 4927 -- We processed an indexed component or selected component 4928 -- reference that looked safe, so keep checking prefixes. 4929 4930 Pref := Prefix (Pref); 4931 end loop; 4932 end; 4933 end Is_Possibly_Unaligned_Slice; 4934 4935 ------------------------------- 4936 -- Is_Related_To_Func_Return -- 4937 ------------------------------- 4938 4939 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is 4940 Expr : constant Node_Id := Related_Expression (Id); 4941 begin 4942 return 4943 Present (Expr) 4944 and then Nkind (Expr) = N_Explicit_Dereference 4945 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement; 4946 end Is_Related_To_Func_Return; 4947 4948 -------------------------------- 4949 -- Is_Ref_To_Bit_Packed_Array -- 4950 -------------------------------- 4951 4952 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is 4953 Result : Boolean; 4954 Expr : Node_Id; 4955 4956 begin 4957 if Is_Entity_Name (N) 4958 and then Is_Object (Entity (N)) 4959 and then Present (Renamed_Object (Entity (N))) 4960 then 4961 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N))); 4962 end if; 4963 4964 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 4965 if Is_Bit_Packed_Array (Etype (Prefix (N))) then 4966 Result := True; 4967 else 4968 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N)); 4969 end if; 4970 4971 if Result and then Nkind (N) = N_Indexed_Component then 4972 Expr := First (Expressions (N)); 4973 while Present (Expr) loop 4974 Force_Evaluation (Expr); 4975 Next (Expr); 4976 end loop; 4977 end if; 4978 4979 return Result; 4980 4981 else 4982 return False; 4983 end if; 4984 end Is_Ref_To_Bit_Packed_Array; 4985 4986 -------------------------------- 4987 -- Is_Ref_To_Bit_Packed_Slice -- 4988 -------------------------------- 4989 4990 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is 4991 begin 4992 if Nkind (N) = N_Type_Conversion then 4993 return Is_Ref_To_Bit_Packed_Slice (Expression (N)); 4994 4995 elsif Is_Entity_Name (N) 4996 and then Is_Object (Entity (N)) 4997 and then Present (Renamed_Object (Entity (N))) 4998 then 4999 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N))); 5000 5001 elsif Nkind (N) = N_Slice 5002 and then Is_Bit_Packed_Array (Etype (Prefix (N))) 5003 then 5004 return True; 5005 5006 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 5007 return Is_Ref_To_Bit_Packed_Slice (Prefix (N)); 5008 5009 else 5010 return False; 5011 end if; 5012 end Is_Ref_To_Bit_Packed_Slice; 5013 5014 ----------------------- 5015 -- Is_Renamed_Object -- 5016 ----------------------- 5017 5018 function Is_Renamed_Object (N : Node_Id) return Boolean is 5019 Pnod : constant Node_Id := Parent (N); 5020 Kind : constant Node_Kind := Nkind (Pnod); 5021 begin 5022 if Kind = N_Object_Renaming_Declaration then 5023 return True; 5024 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then 5025 return Is_Renamed_Object (Pnod); 5026 else 5027 return False; 5028 end if; 5029 end Is_Renamed_Object; 5030 5031 -------------------------------------- 5032 -- Is_Secondary_Stack_BIP_Func_Call -- 5033 -------------------------------------- 5034 5035 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is 5036 Call : Node_Id := Expr; 5037 5038 begin 5039 -- Build-in-place calls usually appear in 'reference format. Note that 5040 -- the accessibility check machinery may add an extra 'reference due to 5041 -- side effect removal. 5042 5043 while Nkind (Call) = N_Reference loop 5044 Call := Prefix (Call); 5045 end loop; 5046 5047 if Nkind_In (Call, N_Qualified_Expression, 5048 N_Unchecked_Type_Conversion) 5049 then 5050 Call := Expression (Call); 5051 end if; 5052 5053 if Is_Build_In_Place_Function_Call (Call) then 5054 declare 5055 Access_Nam : Name_Id := No_Name; 5056 Actual : Node_Id; 5057 Param : Node_Id; 5058 Formal : Node_Id; 5059 5060 begin 5061 -- Examine all parameter associations of the function call 5062 5063 Param := First (Parameter_Associations (Call)); 5064 while Present (Param) loop 5065 if Nkind (Param) = N_Parameter_Association 5066 and then Nkind (Selector_Name (Param)) = N_Identifier 5067 then 5068 Formal := Selector_Name (Param); 5069 Actual := Explicit_Actual_Parameter (Param); 5070 5071 -- Construct the name of formal BIPalloc. It is much easier 5072 -- to extract the name of the function using an arbitrary 5073 -- formal's scope rather than the Name field of Call. 5074 5075 if Access_Nam = No_Name 5076 and then Present (Entity (Formal)) 5077 then 5078 Access_Nam := 5079 New_External_Name 5080 (Chars (Scope (Entity (Formal))), 5081 BIP_Formal_Suffix (BIP_Alloc_Form)); 5082 end if; 5083 5084 -- A match for BIPalloc => 2 has been found 5085 5086 if Chars (Formal) = Access_Nam 5087 and then Nkind (Actual) = N_Integer_Literal 5088 and then Intval (Actual) = Uint_2 5089 then 5090 return True; 5091 end if; 5092 end if; 5093 5094 Next (Param); 5095 end loop; 5096 end; 5097 end if; 5098 5099 return False; 5100 end Is_Secondary_Stack_BIP_Func_Call; 5101 5102 ------------------------------------- 5103 -- Is_Tag_To_Class_Wide_Conversion -- 5104 ------------------------------------- 5105 5106 function Is_Tag_To_Class_Wide_Conversion 5107 (Obj_Id : Entity_Id) return Boolean 5108 is 5109 Expr : constant Node_Id := Expression (Parent (Obj_Id)); 5110 5111 begin 5112 return 5113 Is_Class_Wide_Type (Etype (Obj_Id)) 5114 and then Present (Expr) 5115 and then Nkind (Expr) = N_Unchecked_Type_Conversion 5116 and then Etype (Expression (Expr)) = RTE (RE_Tag); 5117 end Is_Tag_To_Class_Wide_Conversion; 5118 5119 ---------------------------- 5120 -- Is_Untagged_Derivation -- 5121 ---------------------------- 5122 5123 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is 5124 begin 5125 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T)) 5126 or else 5127 (Is_Private_Type (T) and then Present (Full_View (T)) 5128 and then not Is_Tagged_Type (Full_View (T)) 5129 and then Is_Derived_Type (Full_View (T)) 5130 and then Etype (Full_View (T)) /= T); 5131 end Is_Untagged_Derivation; 5132 5133 --------------------------- 5134 -- Is_Volatile_Reference -- 5135 --------------------------- 5136 5137 function Is_Volatile_Reference (N : Node_Id) return Boolean is 5138 begin 5139 if Nkind (N) in N_Has_Etype 5140 and then Present (Etype (N)) 5141 and then Treat_As_Volatile (Etype (N)) 5142 then 5143 return True; 5144 5145 elsif Is_Entity_Name (N) then 5146 return Treat_As_Volatile (Entity (N)); 5147 5148 elsif Nkind (N) = N_Slice then 5149 return Is_Volatile_Reference (Prefix (N)); 5150 5151 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 5152 if (Is_Entity_Name (Prefix (N)) 5153 and then Has_Volatile_Components (Entity (Prefix (N)))) 5154 or else (Present (Etype (Prefix (N))) 5155 and then Has_Volatile_Components (Etype (Prefix (N)))) 5156 then 5157 return True; 5158 else 5159 return Is_Volatile_Reference (Prefix (N)); 5160 end if; 5161 5162 else 5163 return False; 5164 end if; 5165 end Is_Volatile_Reference; 5166 5167 -------------------------- 5168 -- Is_VM_By_Copy_Actual -- 5169 -------------------------- 5170 5171 function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is 5172 begin 5173 return VM_Target /= No_VM 5174 and then (Nkind (N) = N_Slice 5175 or else 5176 (Nkind (N) = N_Identifier 5177 and then Present (Renamed_Object (Entity (N))) 5178 and then Nkind (Renamed_Object (Entity (N))) = 5179 N_Slice)); 5180 end Is_VM_By_Copy_Actual; 5181 5182 -------------------- 5183 -- Kill_Dead_Code -- 5184 -------------------- 5185 5186 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is 5187 W : Boolean := Warn; 5188 -- Set False if warnings suppressed 5189 5190 begin 5191 if Present (N) then 5192 Remove_Warning_Messages (N); 5193 5194 -- Generate warning if appropriate 5195 5196 if W then 5197 5198 -- We suppress the warning if this code is under control of an 5199 -- if statement, whose condition is a simple identifier, and 5200 -- either we are in an instance, or warnings off is set for this 5201 -- identifier. The reason for killing it in the instance case is 5202 -- that it is common and reasonable for code to be deleted in 5203 -- instances for various reasons. 5204 5205 if Nkind (Parent (N)) = N_If_Statement then 5206 declare 5207 C : constant Node_Id := Condition (Parent (N)); 5208 begin 5209 if Nkind (C) = N_Identifier 5210 and then 5211 (In_Instance 5212 or else (Present (Entity (C)) 5213 and then Has_Warnings_Off (Entity (C)))) 5214 then 5215 W := False; 5216 end if; 5217 end; 5218 end if; 5219 5220 -- Generate warning if not suppressed 5221 5222 if W then 5223 Error_Msg_F 5224 ("?t?this code can never be executed and has been deleted!", 5225 N); 5226 end if; 5227 end if; 5228 5229 -- Recurse into block statements and bodies to process declarations 5230 -- and statements. 5231 5232 if Nkind (N) = N_Block_Statement 5233 or else Nkind (N) = N_Subprogram_Body 5234 or else Nkind (N) = N_Package_Body 5235 then 5236 Kill_Dead_Code (Declarations (N), False); 5237 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); 5238 5239 if Nkind (N) = N_Subprogram_Body then 5240 Set_Is_Eliminated (Defining_Entity (N)); 5241 end if; 5242 5243 elsif Nkind (N) = N_Package_Declaration then 5244 Kill_Dead_Code (Visible_Declarations (Specification (N))); 5245 Kill_Dead_Code (Private_Declarations (Specification (N))); 5246 5247 -- ??? After this point, Delete_Tree has been called on all 5248 -- declarations in Specification (N), so references to entities 5249 -- therein look suspicious. 5250 5251 declare 5252 E : Entity_Id := First_Entity (Defining_Entity (N)); 5253 begin 5254 while Present (E) loop 5255 if Ekind (E) = E_Operator then 5256 Set_Is_Eliminated (E); 5257 end if; 5258 5259 Next_Entity (E); 5260 end loop; 5261 end; 5262 5263 -- Recurse into composite statement to kill individual statements in 5264 -- particular instantiations. 5265 5266 elsif Nkind (N) = N_If_Statement then 5267 Kill_Dead_Code (Then_Statements (N)); 5268 Kill_Dead_Code (Elsif_Parts (N)); 5269 Kill_Dead_Code (Else_Statements (N)); 5270 5271 elsif Nkind (N) = N_Loop_Statement then 5272 Kill_Dead_Code (Statements (N)); 5273 5274 elsif Nkind (N) = N_Case_Statement then 5275 declare 5276 Alt : Node_Id; 5277 begin 5278 Alt := First (Alternatives (N)); 5279 while Present (Alt) loop 5280 Kill_Dead_Code (Statements (Alt)); 5281 Next (Alt); 5282 end loop; 5283 end; 5284 5285 elsif Nkind (N) = N_Case_Statement_Alternative then 5286 Kill_Dead_Code (Statements (N)); 5287 5288 -- Deal with dead instances caused by deleting instantiations 5289 5290 elsif Nkind (N) in N_Generic_Instantiation then 5291 Remove_Dead_Instance (N); 5292 end if; 5293 end if; 5294 end Kill_Dead_Code; 5295 5296 -- Case where argument is a list of nodes to be killed 5297 5298 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is 5299 N : Node_Id; 5300 W : Boolean; 5301 begin 5302 W := Warn; 5303 if Is_Non_Empty_List (L) then 5304 N := First (L); 5305 while Present (N) loop 5306 Kill_Dead_Code (N, W); 5307 W := False; 5308 Next (N); 5309 end loop; 5310 end if; 5311 end Kill_Dead_Code; 5312 5313 ------------------------ 5314 -- Known_Non_Negative -- 5315 ------------------------ 5316 5317 function Known_Non_Negative (Opnd : Node_Id) return Boolean is 5318 begin 5319 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then 5320 return True; 5321 5322 else 5323 declare 5324 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd)); 5325 begin 5326 return 5327 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0; 5328 end; 5329 end if; 5330 end Known_Non_Negative; 5331 5332 -------------------- 5333 -- Known_Non_Null -- 5334 -------------------- 5335 5336 function Known_Non_Null (N : Node_Id) return Boolean is 5337 begin 5338 -- Checks for case where N is an entity reference 5339 5340 if Is_Entity_Name (N) and then Present (Entity (N)) then 5341 declare 5342 E : constant Entity_Id := Entity (N); 5343 Op : Node_Kind; 5344 Val : Node_Id; 5345 5346 begin 5347 -- First check if we are in decisive conditional 5348 5349 Get_Current_Value_Condition (N, Op, Val); 5350 5351 if Known_Null (Val) then 5352 if Op = N_Op_Eq then 5353 return False; 5354 elsif Op = N_Op_Ne then 5355 return True; 5356 end if; 5357 end if; 5358 5359 -- If OK to do replacement, test Is_Known_Non_Null flag 5360 5361 if OK_To_Do_Constant_Replacement (E) then 5362 return Is_Known_Non_Null (E); 5363 5364 -- Otherwise if not safe to do replacement, then say so 5365 5366 else 5367 return False; 5368 end if; 5369 end; 5370 5371 -- True if access attribute 5372 5373 elsif Nkind (N) = N_Attribute_Reference 5374 and then Nam_In (Attribute_Name (N), Name_Access, 5375 Name_Unchecked_Access, 5376 Name_Unrestricted_Access) 5377 then 5378 return True; 5379 5380 -- True if allocator 5381 5382 elsif Nkind (N) = N_Allocator then 5383 return True; 5384 5385 -- For a conversion, true if expression is known non-null 5386 5387 elsif Nkind (N) = N_Type_Conversion then 5388 return Known_Non_Null (Expression (N)); 5389 5390 -- Above are all cases where the value could be determined to be 5391 -- non-null. In all other cases, we don't know, so return False. 5392 5393 else 5394 return False; 5395 end if; 5396 end Known_Non_Null; 5397 5398 ---------------- 5399 -- Known_Null -- 5400 ---------------- 5401 5402 function Known_Null (N : Node_Id) return Boolean is 5403 begin 5404 -- Checks for case where N is an entity reference 5405 5406 if Is_Entity_Name (N) and then Present (Entity (N)) then 5407 declare 5408 E : constant Entity_Id := Entity (N); 5409 Op : Node_Kind; 5410 Val : Node_Id; 5411 5412 begin 5413 -- Constant null value is for sure null 5414 5415 if Ekind (E) = E_Constant 5416 and then Known_Null (Constant_Value (E)) 5417 then 5418 return True; 5419 end if; 5420 5421 -- First check if we are in decisive conditional 5422 5423 Get_Current_Value_Condition (N, Op, Val); 5424 5425 if Known_Null (Val) then 5426 if Op = N_Op_Eq then 5427 return True; 5428 elsif Op = N_Op_Ne then 5429 return False; 5430 end if; 5431 end if; 5432 5433 -- If OK to do replacement, test Is_Known_Null flag 5434 5435 if OK_To_Do_Constant_Replacement (E) then 5436 return Is_Known_Null (E); 5437 5438 -- Otherwise if not safe to do replacement, then say so 5439 5440 else 5441 return False; 5442 end if; 5443 end; 5444 5445 -- True if explicit reference to null 5446 5447 elsif Nkind (N) = N_Null then 5448 return True; 5449 5450 -- For a conversion, true if expression is known null 5451 5452 elsif Nkind (N) = N_Type_Conversion then 5453 return Known_Null (Expression (N)); 5454 5455 -- Above are all cases where the value could be determined to be null. 5456 -- In all other cases, we don't know, so return False. 5457 5458 else 5459 return False; 5460 end if; 5461 end Known_Null; 5462 5463 ----------------------------- 5464 -- Make_CW_Equivalent_Type -- 5465 ----------------------------- 5466 5467 -- Create a record type used as an equivalent of any member of the class 5468 -- which takes its size from exp. 5469 5470 -- Generate the following code: 5471 5472 -- type Equiv_T is record 5473 -- _parent : T (List of discriminant constraints taken from Exp); 5474 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8); 5475 -- end Equiv_T; 5476 -- 5477 -- ??? Note that this type does not guarantee same alignment as all 5478 -- derived types 5479 5480 function Make_CW_Equivalent_Type 5481 (T : Entity_Id; 5482 E : Node_Id) return Entity_Id 5483 is 5484 Loc : constant Source_Ptr := Sloc (E); 5485 Root_Typ : constant Entity_Id := Root_Type (T); 5486 List_Def : constant List_Id := Empty_List; 5487 Comp_List : constant List_Id := New_List; 5488 Equiv_Type : Entity_Id; 5489 Range_Type : Entity_Id; 5490 Str_Type : Entity_Id; 5491 Constr_Root : Entity_Id; 5492 Sizexpr : Node_Id; 5493 5494 begin 5495 -- If the root type is already constrained, there are no discriminants 5496 -- in the expression. 5497 5498 if not Has_Discriminants (Root_Typ) 5499 or else Is_Constrained (Root_Typ) 5500 then 5501 Constr_Root := Root_Typ; 5502 else 5503 Constr_Root := Make_Temporary (Loc, 'R'); 5504 5505 -- subtype cstr__n is T (List of discr constraints taken from Exp) 5506 5507 Append_To (List_Def, 5508 Make_Subtype_Declaration (Loc, 5509 Defining_Identifier => Constr_Root, 5510 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ))); 5511 end if; 5512 5513 -- Generate the range subtype declaration 5514 5515 Range_Type := Make_Temporary (Loc, 'G'); 5516 5517 if not Is_Interface (Root_Typ) then 5518 5519 -- subtype rg__xx is 5520 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit 5521 5522 Sizexpr := 5523 Make_Op_Subtract (Loc, 5524 Left_Opnd => 5525 Make_Attribute_Reference (Loc, 5526 Prefix => 5527 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), 5528 Attribute_Name => Name_Size), 5529 Right_Opnd => 5530 Make_Attribute_Reference (Loc, 5531 Prefix => New_Occurrence_Of (Constr_Root, Loc), 5532 Attribute_Name => Name_Object_Size)); 5533 else 5534 -- subtype rg__xx is 5535 -- Storage_Offset range 1 .. Expr'size / Storage_Unit 5536 5537 Sizexpr := 5538 Make_Attribute_Reference (Loc, 5539 Prefix => 5540 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), 5541 Attribute_Name => Name_Size); 5542 end if; 5543 5544 Set_Paren_Count (Sizexpr, 1); 5545 5546 Append_To (List_Def, 5547 Make_Subtype_Declaration (Loc, 5548 Defining_Identifier => Range_Type, 5549 Subtype_Indication => 5550 Make_Subtype_Indication (Loc, 5551 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), 5552 Constraint => Make_Range_Constraint (Loc, 5553 Range_Expression => 5554 Make_Range (Loc, 5555 Low_Bound => Make_Integer_Literal (Loc, 1), 5556 High_Bound => 5557 Make_Op_Divide (Loc, 5558 Left_Opnd => Sizexpr, 5559 Right_Opnd => Make_Integer_Literal (Loc, 5560 Intval => System_Storage_Unit))))))); 5561 5562 -- subtype str__nn is Storage_Array (rg__x); 5563 5564 Str_Type := Make_Temporary (Loc, 'S'); 5565 Append_To (List_Def, 5566 Make_Subtype_Declaration (Loc, 5567 Defining_Identifier => Str_Type, 5568 Subtype_Indication => 5569 Make_Subtype_Indication (Loc, 5570 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 5571 Constraint => 5572 Make_Index_Or_Discriminant_Constraint (Loc, 5573 Constraints => 5574 New_List (New_Occurrence_Of (Range_Type, Loc)))))); 5575 5576 -- type Equiv_T is record 5577 -- [ _parent : Tnn; ] 5578 -- E : Str_Type; 5579 -- end Equiv_T; 5580 5581 Equiv_Type := Make_Temporary (Loc, 'T'); 5582 Set_Ekind (Equiv_Type, E_Record_Type); 5583 Set_Parent_Subtype (Equiv_Type, Constr_Root); 5584 5585 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special 5586 -- treatment for this type. In particular, even though _parent's type 5587 -- is a controlled type or contains controlled components, we do not 5588 -- want to set Has_Controlled_Component on it to avoid making it gain 5589 -- an unwanted _controller component. 5590 5591 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); 5592 5593 if not Is_Interface (Root_Typ) then 5594 Append_To (Comp_List, 5595 Make_Component_Declaration (Loc, 5596 Defining_Identifier => 5597 Make_Defining_Identifier (Loc, Name_uParent), 5598 Component_Definition => 5599 Make_Component_Definition (Loc, 5600 Aliased_Present => False, 5601 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc)))); 5602 end if; 5603 5604 Append_To (Comp_List, 5605 Make_Component_Declaration (Loc, 5606 Defining_Identifier => Make_Temporary (Loc, 'C'), 5607 Component_Definition => 5608 Make_Component_Definition (Loc, 5609 Aliased_Present => False, 5610 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc)))); 5611 5612 Append_To (List_Def, 5613 Make_Full_Type_Declaration (Loc, 5614 Defining_Identifier => Equiv_Type, 5615 Type_Definition => 5616 Make_Record_Definition (Loc, 5617 Component_List => 5618 Make_Component_List (Loc, 5619 Component_Items => Comp_List, 5620 Variant_Part => Empty)))); 5621 5622 -- Suppress all checks during the analysis of the expanded code to avoid 5623 -- the generation of spurious warnings under ZFP run-time. 5624 5625 Insert_Actions (E, List_Def, Suppress => All_Checks); 5626 return Equiv_Type; 5627 end Make_CW_Equivalent_Type; 5628 5629 ------------------------- 5630 -- Make_Invariant_Call -- 5631 ------------------------- 5632 5633 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is 5634 Loc : constant Source_Ptr := Sloc (Expr); 5635 Typ : Entity_Id; 5636 5637 begin 5638 Typ := Etype (Expr); 5639 5640 -- Subtypes may be subject to invariants coming from their respective 5641 -- base types. The subtype may be fully or partially private. 5642 5643 if Ekind_In (Typ, E_Array_Subtype, 5644 E_Private_Subtype, 5645 E_Record_Subtype, 5646 E_Record_Subtype_With_Private) 5647 then 5648 Typ := Base_Type (Typ); 5649 end if; 5650 5651 pragma Assert 5652 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ))); 5653 5654 return 5655 Make_Procedure_Call_Statement (Loc, 5656 Name => 5657 New_Occurrence_Of (Invariant_Procedure (Typ), Loc), 5658 Parameter_Associations => New_List (Relocate_Node (Expr))); 5659 end Make_Invariant_Call; 5660 5661 ------------------------ 5662 -- Make_Literal_Range -- 5663 ------------------------ 5664 5665 function Make_Literal_Range 5666 (Loc : Source_Ptr; 5667 Literal_Typ : Entity_Id) return Node_Id 5668 is 5669 Lo : constant Node_Id := 5670 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ)); 5671 Index : constant Entity_Id := Etype (Lo); 5672 5673 Hi : Node_Id; 5674 Length_Expr : constant Node_Id := 5675 Make_Op_Subtract (Loc, 5676 Left_Opnd => 5677 Make_Integer_Literal (Loc, 5678 Intval => String_Literal_Length (Literal_Typ)), 5679 Right_Opnd => 5680 Make_Integer_Literal (Loc, 1)); 5681 5682 begin 5683 Set_Analyzed (Lo, False); 5684 5685 if Is_Integer_Type (Index) then 5686 Hi := 5687 Make_Op_Add (Loc, 5688 Left_Opnd => New_Copy_Tree (Lo), 5689 Right_Opnd => Length_Expr); 5690 else 5691 Hi := 5692 Make_Attribute_Reference (Loc, 5693 Attribute_Name => Name_Val, 5694 Prefix => New_Occurrence_Of (Index, Loc), 5695 Expressions => New_List ( 5696 Make_Op_Add (Loc, 5697 Left_Opnd => 5698 Make_Attribute_Reference (Loc, 5699 Attribute_Name => Name_Pos, 5700 Prefix => New_Occurrence_Of (Index, Loc), 5701 Expressions => New_List (New_Copy_Tree (Lo))), 5702 Right_Opnd => Length_Expr))); 5703 end if; 5704 5705 return 5706 Make_Range (Loc, 5707 Low_Bound => Lo, 5708 High_Bound => Hi); 5709 end Make_Literal_Range; 5710 5711 -------------------------- 5712 -- Make_Non_Empty_Check -- 5713 -------------------------- 5714 5715 function Make_Non_Empty_Check 5716 (Loc : Source_Ptr; 5717 N : Node_Id) return Node_Id 5718 is 5719 begin 5720 return 5721 Make_Op_Ne (Loc, 5722 Left_Opnd => 5723 Make_Attribute_Reference (Loc, 5724 Attribute_Name => Name_Length, 5725 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)), 5726 Right_Opnd => 5727 Make_Integer_Literal (Loc, 0)); 5728 end Make_Non_Empty_Check; 5729 5730 ------------------------- 5731 -- Make_Predicate_Call -- 5732 ------------------------- 5733 5734 function Make_Predicate_Call 5735 (Typ : Entity_Id; 5736 Expr : Node_Id; 5737 Mem : Boolean := False) return Node_Id 5738 is 5739 Loc : constant Source_Ptr := Sloc (Expr); 5740 5741 begin 5742 pragma Assert (Present (Predicate_Function (Typ))); 5743 5744 -- Call special membership version if requested and available 5745 5746 if Mem then 5747 declare 5748 PFM : constant Entity_Id := Predicate_Function_M (Typ); 5749 begin 5750 if Present (PFM) then 5751 return 5752 Make_Function_Call (Loc, 5753 Name => New_Occurrence_Of (PFM, Loc), 5754 Parameter_Associations => New_List (Relocate_Node (Expr))); 5755 end if; 5756 end; 5757 end if; 5758 5759 -- Case of calling normal predicate function 5760 5761 return 5762 Make_Function_Call (Loc, 5763 Name => 5764 New_Occurrence_Of (Predicate_Function (Typ), Loc), 5765 Parameter_Associations => New_List (Relocate_Node (Expr))); 5766 end Make_Predicate_Call; 5767 5768 -------------------------- 5769 -- Make_Predicate_Check -- 5770 -------------------------- 5771 5772 function Make_Predicate_Check 5773 (Typ : Entity_Id; 5774 Expr : Node_Id) return Node_Id 5775 is 5776 Loc : constant Source_Ptr := Sloc (Expr); 5777 Nam : Name_Id; 5778 5779 begin 5780 -- If predicate checks are suppressed, then return a null statement. 5781 -- For this call, we check only the scope setting. If the caller wants 5782 -- to check a specific entity's setting, they must do it manually. 5783 5784 if Predicate_Checks_Suppressed (Empty) then 5785 return Make_Null_Statement (Loc); 5786 end if; 5787 5788 -- Do not generate a check within an internal subprogram (stream 5789 -- functions and the like, including including predicate functions). 5790 5791 if Within_Internal_Subprogram then 5792 return Make_Null_Statement (Loc); 5793 end if; 5794 5795 -- Compute proper name to use, we need to get this right so that the 5796 -- right set of check policies apply to the Check pragma we are making. 5797 5798 if Has_Dynamic_Predicate_Aspect (Typ) then 5799 Nam := Name_Dynamic_Predicate; 5800 elsif Has_Static_Predicate_Aspect (Typ) then 5801 Nam := Name_Static_Predicate; 5802 else 5803 Nam := Name_Predicate; 5804 end if; 5805 5806 return 5807 Make_Pragma (Loc, 5808 Pragma_Identifier => Make_Identifier (Loc, Name_Check), 5809 Pragma_Argument_Associations => New_List ( 5810 Make_Pragma_Argument_Association (Loc, 5811 Expression => Make_Identifier (Loc, Nam)), 5812 Make_Pragma_Argument_Association (Loc, 5813 Expression => Make_Predicate_Call (Typ, Expr)))); 5814 end Make_Predicate_Check; 5815 5816 ---------------------------- 5817 -- Make_Subtype_From_Expr -- 5818 ---------------------------- 5819 5820 -- 1. If Expr is an unconstrained array expression, creates 5821 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n)) 5822 5823 -- 2. If Expr is a unconstrained discriminated type expression, creates 5824 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) 5825 5826 -- 3. If Expr is class-wide, creates an implicit class wide subtype 5827 5828 function Make_Subtype_From_Expr 5829 (E : Node_Id; 5830 Unc_Typ : Entity_Id) return Node_Id 5831 is 5832 Loc : constant Source_Ptr := Sloc (E); 5833 List_Constr : constant List_Id := New_List; 5834 D : Entity_Id; 5835 5836 Full_Subtyp : Entity_Id; 5837 Priv_Subtyp : Entity_Id; 5838 Utyp : Entity_Id; 5839 Full_Exp : Node_Id; 5840 5841 begin 5842 if Is_Private_Type (Unc_Typ) 5843 and then Has_Unknown_Discriminants (Unc_Typ) 5844 then 5845 -- Prepare the subtype completion, Go to base type to 5846 -- find underlying type, because the type may be a generic 5847 -- actual or an explicit subtype. 5848 5849 Utyp := Underlying_Type (Base_Type (Unc_Typ)); 5850 Full_Subtyp := Make_Temporary (Loc, 'C'); 5851 Full_Exp := 5852 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E)); 5853 Set_Parent (Full_Exp, Parent (E)); 5854 5855 Priv_Subtyp := Make_Temporary (Loc, 'P'); 5856 5857 Insert_Action (E, 5858 Make_Subtype_Declaration (Loc, 5859 Defining_Identifier => Full_Subtyp, 5860 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp))); 5861 5862 -- Define the dummy private subtype 5863 5864 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ))); 5865 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ)); 5866 Set_Scope (Priv_Subtyp, Full_Subtyp); 5867 Set_Is_Constrained (Priv_Subtyp); 5868 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ)); 5869 Set_Is_Itype (Priv_Subtyp); 5870 Set_Associated_Node_For_Itype (Priv_Subtyp, E); 5871 5872 if Is_Tagged_Type (Priv_Subtyp) then 5873 Set_Class_Wide_Type 5874 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ)); 5875 Set_Direct_Primitive_Operations (Priv_Subtyp, 5876 Direct_Primitive_Operations (Unc_Typ)); 5877 end if; 5878 5879 Set_Full_View (Priv_Subtyp, Full_Subtyp); 5880 5881 return New_Occurrence_Of (Priv_Subtyp, Loc); 5882 5883 elsif Is_Array_Type (Unc_Typ) then 5884 for J in 1 .. Number_Dimensions (Unc_Typ) loop 5885 Append_To (List_Constr, 5886 Make_Range (Loc, 5887 Low_Bound => 5888 Make_Attribute_Reference (Loc, 5889 Prefix => Duplicate_Subexpr_No_Checks (E), 5890 Attribute_Name => Name_First, 5891 Expressions => New_List ( 5892 Make_Integer_Literal (Loc, J))), 5893 5894 High_Bound => 5895 Make_Attribute_Reference (Loc, 5896 Prefix => Duplicate_Subexpr_No_Checks (E), 5897 Attribute_Name => Name_Last, 5898 Expressions => New_List ( 5899 Make_Integer_Literal (Loc, J))))); 5900 end loop; 5901 5902 elsif Is_Class_Wide_Type (Unc_Typ) then 5903 declare 5904 CW_Subtype : Entity_Id; 5905 EQ_Typ : Entity_Id := Empty; 5906 5907 begin 5908 -- A class-wide equivalent type is not needed when VM_Target 5909 -- because the VM back-ends handle the class-wide object 5910 -- initialization itself (and doesn't need or want the 5911 -- additional intermediate type to handle the assignment). 5912 5913 if Expander_Active and then Tagged_Type_Expansion then 5914 5915 -- If this is the class_wide type of a completion that is a 5916 -- record subtype, set the type of the class_wide type to be 5917 -- the full base type, for use in the expanded code for the 5918 -- equivalent type. Should this be done earlier when the 5919 -- completion is analyzed ??? 5920 5921 if Is_Private_Type (Etype (Unc_Typ)) 5922 and then 5923 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype 5924 then 5925 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); 5926 end if; 5927 5928 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); 5929 end if; 5930 5931 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E); 5932 Set_Equivalent_Type (CW_Subtype, EQ_Typ); 5933 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ)); 5934 5935 return New_Occurrence_Of (CW_Subtype, Loc); 5936 end; 5937 5938 -- Indefinite record type with discriminants 5939 5940 else 5941 D := First_Discriminant (Unc_Typ); 5942 while Present (D) loop 5943 Append_To (List_Constr, 5944 Make_Selected_Component (Loc, 5945 Prefix => Duplicate_Subexpr_No_Checks (E), 5946 Selector_Name => New_Occurrence_Of (D, Loc))); 5947 5948 Next_Discriminant (D); 5949 end loop; 5950 end if; 5951 5952 return 5953 Make_Subtype_Indication (Loc, 5954 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc), 5955 Constraint => 5956 Make_Index_Or_Discriminant_Constraint (Loc, 5957 Constraints => List_Constr)); 5958 end Make_Subtype_From_Expr; 5959 5960 ---------------------------- 5961 -- Matching_Standard_Type -- 5962 ---------------------------- 5963 5964 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is 5965 pragma Assert (Is_Scalar_Type (Typ)); 5966 Siz : constant Uint := Esize (Typ); 5967 5968 begin 5969 -- Floating-point cases 5970 5971 if Is_Floating_Point_Type (Typ) then 5972 if Siz <= Esize (Standard_Short_Float) then 5973 return Standard_Short_Float; 5974 elsif Siz <= Esize (Standard_Float) then 5975 return Standard_Float; 5976 elsif Siz <= Esize (Standard_Long_Float) then 5977 return Standard_Long_Float; 5978 elsif Siz <= Esize (Standard_Long_Long_Float) then 5979 return Standard_Long_Long_Float; 5980 else 5981 raise Program_Error; 5982 end if; 5983 5984 -- Integer cases (includes fixed-point types) 5985 5986 -- Unsigned integer cases (includes normal enumeration types) 5987 5988 elsif Is_Unsigned_Type (Typ) then 5989 if Siz <= Esize (Standard_Short_Short_Unsigned) then 5990 return Standard_Short_Short_Unsigned; 5991 elsif Siz <= Esize (Standard_Short_Unsigned) then 5992 return Standard_Short_Unsigned; 5993 elsif Siz <= Esize (Standard_Unsigned) then 5994 return Standard_Unsigned; 5995 elsif Siz <= Esize (Standard_Long_Unsigned) then 5996 return Standard_Long_Unsigned; 5997 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then 5998 return Standard_Long_Long_Unsigned; 5999 else 6000 raise Program_Error; 6001 end if; 6002 6003 -- Signed integer cases 6004 6005 else 6006 if Siz <= Esize (Standard_Short_Short_Integer) then 6007 return Standard_Short_Short_Integer; 6008 elsif Siz <= Esize (Standard_Short_Integer) then 6009 return Standard_Short_Integer; 6010 elsif Siz <= Esize (Standard_Integer) then 6011 return Standard_Integer; 6012 elsif Siz <= Esize (Standard_Long_Integer) then 6013 return Standard_Long_Integer; 6014 elsif Siz <= Esize (Standard_Long_Long_Integer) then 6015 return Standard_Long_Long_Integer; 6016 else 6017 raise Program_Error; 6018 end if; 6019 end if; 6020 end Matching_Standard_Type; 6021 6022 ----------------------------- 6023 -- May_Generate_Large_Temp -- 6024 ----------------------------- 6025 6026 -- At the current time, the only types that we return False for (i.e. where 6027 -- we decide we know they cannot generate large temps) are ones where we 6028 -- know the size is 256 bits or less at compile time, and we are still not 6029 -- doing a thorough job on arrays and records ??? 6030 6031 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is 6032 begin 6033 if not Size_Known_At_Compile_Time (Typ) then 6034 return False; 6035 6036 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then 6037 return False; 6038 6039 elsif Is_Array_Type (Typ) and then Present (Packed_Array_Type (Typ)) then 6040 return May_Generate_Large_Temp (Packed_Array_Type (Typ)); 6041 6042 -- We could do more here to find other small types ??? 6043 6044 else 6045 return True; 6046 end if; 6047 end May_Generate_Large_Temp; 6048 6049 ------------------------ 6050 -- Needs_Finalization -- 6051 ------------------------ 6052 6053 function Needs_Finalization (T : Entity_Id) return Boolean is 6054 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; 6055 -- If type is not frozen yet, check explicitly among its components, 6056 -- because the Has_Controlled_Component flag is not necessarily set. 6057 6058 ----------------------------------- 6059 -- Has_Some_Controlled_Component -- 6060 ----------------------------------- 6061 6062 function Has_Some_Controlled_Component 6063 (Rec : Entity_Id) return Boolean 6064 is 6065 Comp : Entity_Id; 6066 6067 begin 6068 if Has_Controlled_Component (Rec) then 6069 return True; 6070 6071 elsif not Is_Frozen (Rec) then 6072 if Is_Record_Type (Rec) then 6073 Comp := First_Entity (Rec); 6074 6075 while Present (Comp) loop 6076 if not Is_Type (Comp) 6077 and then Needs_Finalization (Etype (Comp)) 6078 then 6079 return True; 6080 end if; 6081 6082 Next_Entity (Comp); 6083 end loop; 6084 6085 return False; 6086 6087 elsif Is_Array_Type (Rec) then 6088 return Needs_Finalization (Component_Type (Rec)); 6089 6090 else 6091 return Has_Controlled_Component (Rec); 6092 end if; 6093 else 6094 return False; 6095 end if; 6096 end Has_Some_Controlled_Component; 6097 6098 -- Start of processing for Needs_Finalization 6099 6100 begin 6101 -- Certain run-time configurations and targets do not provide support 6102 -- for controlled types. 6103 6104 if Restriction_Active (No_Finalization) then 6105 return False; 6106 6107 -- C, C++, CIL and Java types are not considered controlled. It is 6108 -- assumed that the non-Ada side will handle their clean up. 6109 6110 elsif Convention (T) = Convention_C 6111 or else Convention (T) = Convention_CIL 6112 or else Convention (T) = Convention_CPP 6113 or else Convention (T) = Convention_Java 6114 then 6115 return False; 6116 6117 else 6118 -- Class-wide types are treated as controlled because derivations 6119 -- from the root type can introduce controlled components. 6120 6121 return 6122 Is_Class_Wide_Type (T) 6123 or else Is_Controlled (T) 6124 or else Has_Controlled_Component (T) 6125 or else Has_Some_Controlled_Component (T) 6126 or else 6127 (Is_Concurrent_Type (T) 6128 and then Present (Corresponding_Record_Type (T)) 6129 and then Needs_Finalization (Corresponding_Record_Type (T))); 6130 end if; 6131 end Needs_Finalization; 6132 6133 ---------------------------- 6134 -- Needs_Constant_Address -- 6135 ---------------------------- 6136 6137 function Needs_Constant_Address 6138 (Decl : Node_Id; 6139 Typ : Entity_Id) return Boolean 6140 is 6141 begin 6142 6143 -- If we have no initialization of any kind, then we don't need to place 6144 -- any restrictions on the address clause, because the object will be 6145 -- elaborated after the address clause is evaluated. This happens if the 6146 -- declaration has no initial expression, or the type has no implicit 6147 -- initialization, or the object is imported. 6148 6149 -- The same holds for all initialized scalar types and all access types. 6150 -- Packed bit arrays of size up to 64 are represented using a modular 6151 -- type with an initialization (to zero) and can be processed like other 6152 -- initialized scalar types. 6153 6154 -- If the type is controlled, code to attach the object to a 6155 -- finalization chain is generated at the point of declaration, and 6156 -- therefore the elaboration of the object cannot be delayed: the 6157 -- address expression must be a constant. 6158 6159 if No (Expression (Decl)) 6160 and then not Needs_Finalization (Typ) 6161 and then 6162 (not Has_Non_Null_Base_Init_Proc (Typ) 6163 or else Is_Imported (Defining_Identifier (Decl))) 6164 then 6165 return False; 6166 6167 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) 6168 or else Is_Access_Type (Typ) 6169 or else 6170 (Is_Bit_Packed_Array (Typ) 6171 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))) 6172 then 6173 return False; 6174 6175 else 6176 6177 -- Otherwise, we require the address clause to be constant because 6178 -- the call to the initialization procedure (or the attach code) has 6179 -- to happen at the point of the declaration. 6180 6181 -- Actually the IP call has been moved to the freeze actions anyway, 6182 -- so maybe we can relax this restriction??? 6183 6184 return True; 6185 end if; 6186 end Needs_Constant_Address; 6187 6188 ---------------------------- 6189 -- New_Class_Wide_Subtype -- 6190 ---------------------------- 6191 6192 function New_Class_Wide_Subtype 6193 (CW_Typ : Entity_Id; 6194 N : Node_Id) return Entity_Id 6195 is 6196 Res : constant Entity_Id := Create_Itype (E_Void, N); 6197 Res_Name : constant Name_Id := Chars (Res); 6198 Res_Scope : constant Entity_Id := Scope (Res); 6199 6200 begin 6201 Copy_Node (CW_Typ, Res); 6202 Set_Comes_From_Source (Res, False); 6203 Set_Sloc (Res, Sloc (N)); 6204 Set_Is_Itype (Res); 6205 Set_Associated_Node_For_Itype (Res, N); 6206 Set_Is_Public (Res, False); -- By default, may be changed below. 6207 Set_Public_Status (Res); 6208 Set_Chars (Res, Res_Name); 6209 Set_Scope (Res, Res_Scope); 6210 Set_Ekind (Res, E_Class_Wide_Subtype); 6211 Set_Next_Entity (Res, Empty); 6212 Set_Etype (Res, Base_Type (CW_Typ)); 6213 Set_Is_Frozen (Res, False); 6214 Set_Freeze_Node (Res, Empty); 6215 return (Res); 6216 end New_Class_Wide_Subtype; 6217 6218 -------------------------------- 6219 -- Non_Limited_Designated_Type -- 6220 --------------------------------- 6221 6222 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is 6223 Desig : constant Entity_Id := Designated_Type (T); 6224 begin 6225 if Ekind (Desig) = E_Incomplete_Type 6226 and then Present (Non_Limited_View (Desig)) 6227 then 6228 return Non_Limited_View (Desig); 6229 else 6230 return Desig; 6231 end if; 6232 end Non_Limited_Designated_Type; 6233 6234 ----------------------------------- 6235 -- OK_To_Do_Constant_Replacement -- 6236 ----------------------------------- 6237 6238 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is 6239 ES : constant Entity_Id := Scope (E); 6240 CS : Entity_Id; 6241 6242 begin 6243 -- Do not replace statically allocated objects, because they may be 6244 -- modified outside the current scope. 6245 6246 if Is_Statically_Allocated (E) then 6247 return False; 6248 6249 -- Do not replace aliased or volatile objects, since we don't know what 6250 -- else might change the value. 6251 6252 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then 6253 return False; 6254 6255 -- Debug flag -gnatdM disconnects this optimization 6256 6257 elsif Debug_Flag_MM then 6258 return False; 6259 6260 -- Otherwise check scopes 6261 6262 else 6263 CS := Current_Scope; 6264 6265 loop 6266 -- If we are in right scope, replacement is safe 6267 6268 if CS = ES then 6269 return True; 6270 6271 -- Packages do not affect the determination of safety 6272 6273 elsif Ekind (CS) = E_Package then 6274 exit when CS = Standard_Standard; 6275 CS := Scope (CS); 6276 6277 -- Blocks do not affect the determination of safety 6278 6279 elsif Ekind (CS) = E_Block then 6280 CS := Scope (CS); 6281 6282 -- Loops do not affect the determination of safety. Note that we 6283 -- kill all current values on entry to a loop, so we are just 6284 -- talking about processing within a loop here. 6285 6286 elsif Ekind (CS) = E_Loop then 6287 CS := Scope (CS); 6288 6289 -- Otherwise, the reference is dubious, and we cannot be sure that 6290 -- it is safe to do the replacement. 6291 6292 else 6293 exit; 6294 end if; 6295 end loop; 6296 6297 return False; 6298 end if; 6299 end OK_To_Do_Constant_Replacement; 6300 6301 ------------------------------------ 6302 -- Possible_Bit_Aligned_Component -- 6303 ------------------------------------ 6304 6305 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is 6306 begin 6307 case Nkind (N) is 6308 6309 -- Case of indexed component 6310 6311 when N_Indexed_Component => 6312 declare 6313 P : constant Node_Id := Prefix (N); 6314 Ptyp : constant Entity_Id := Etype (P); 6315 6316 begin 6317 -- If we know the component size and it is less than 64, then 6318 -- we are definitely OK. The back end always does assignment of 6319 -- misaligned small objects correctly. 6320 6321 if Known_Static_Component_Size (Ptyp) 6322 and then Component_Size (Ptyp) <= 64 6323 then 6324 return False; 6325 6326 -- Otherwise, we need to test the prefix, to see if we are 6327 -- indexing from a possibly unaligned component. 6328 6329 else 6330 return Possible_Bit_Aligned_Component (P); 6331 end if; 6332 end; 6333 6334 -- Case of selected component 6335 6336 when N_Selected_Component => 6337 declare 6338 P : constant Node_Id := Prefix (N); 6339 Comp : constant Entity_Id := Entity (Selector_Name (N)); 6340 6341 begin 6342 -- If there is no component clause, then we are in the clear 6343 -- since the back end will never misalign a large component 6344 -- unless it is forced to do so. In the clear means we need 6345 -- only the recursive test on the prefix. 6346 6347 if Component_May_Be_Bit_Aligned (Comp) then 6348 return True; 6349 else 6350 return Possible_Bit_Aligned_Component (P); 6351 end if; 6352 end; 6353 6354 -- For a slice, test the prefix, if that is possibly misaligned, 6355 -- then for sure the slice is. 6356 6357 when N_Slice => 6358 return Possible_Bit_Aligned_Component (Prefix (N)); 6359 6360 -- For an unchecked conversion, check whether the expression may 6361 -- be bit-aligned. 6362 6363 when N_Unchecked_Type_Conversion => 6364 return Possible_Bit_Aligned_Component (Expression (N)); 6365 6366 -- If we have none of the above, it means that we have fallen off the 6367 -- top testing prefixes recursively, and we now have a stand alone 6368 -- object, where we don't have a problem. 6369 6370 when others => 6371 return False; 6372 6373 end case; 6374 end Possible_Bit_Aligned_Component; 6375 6376 ----------------------------------------------- 6377 -- Process_Statements_For_Controlled_Objects -- 6378 ----------------------------------------------- 6379 6380 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is 6381 Loc : constant Source_Ptr := Sloc (N); 6382 6383 function Are_Wrapped (L : List_Id) return Boolean; 6384 -- Determine whether list L contains only one statement which is a block 6385 6386 function Wrap_Statements_In_Block 6387 (L : List_Id; 6388 Scop : Entity_Id := Current_Scope) return Node_Id; 6389 -- Given a list of statements L, wrap it in a block statement and return 6390 -- the generated node. Scop is either the current scope or the scope of 6391 -- the context (if applicable). 6392 6393 ----------------- 6394 -- Are_Wrapped -- 6395 ----------------- 6396 6397 function Are_Wrapped (L : List_Id) return Boolean is 6398 Stmt : constant Node_Id := First (L); 6399 begin 6400 return 6401 Present (Stmt) 6402 and then No (Next (Stmt)) 6403 and then Nkind (Stmt) = N_Block_Statement; 6404 end Are_Wrapped; 6405 6406 ------------------------------ 6407 -- Wrap_Statements_In_Block -- 6408 ------------------------------ 6409 6410 function Wrap_Statements_In_Block 6411 (L : List_Id; 6412 Scop : Entity_Id := Current_Scope) return Node_Id 6413 is 6414 Block_Id : Entity_Id; 6415 Block_Nod : Node_Id; 6416 Iter_Loop : Entity_Id; 6417 6418 begin 6419 Block_Nod := 6420 Make_Block_Statement (Loc, 6421 Declarations => No_List, 6422 Handled_Statement_Sequence => 6423 Make_Handled_Sequence_Of_Statements (Loc, 6424 Statements => L)); 6425 6426 -- Create a label for the block in case the block needs to manage the 6427 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set. 6428 6429 Add_Block_Identifier (Block_Nod, Block_Id); 6430 6431 -- When wrapping the statements of an iterator loop, check whether 6432 -- the loop requires secondary stack management and if so, propagate 6433 -- the flag to the block. This way the secondary stack is marked and 6434 -- released at each iteration of the loop. 6435 6436 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop); 6437 6438 if Present (Iter_Loop) and then Uses_Sec_Stack (Iter_Loop) then 6439 Set_Uses_Sec_Stack (Block_Id); 6440 end if; 6441 6442 return Block_Nod; 6443 end Wrap_Statements_In_Block; 6444 6445 -- Local variables 6446 6447 Block : Node_Id; 6448 6449 -- Start of processing for Process_Statements_For_Controlled_Objects 6450 6451 begin 6452 -- Whenever a non-handled statement list is wrapped in a block, the 6453 -- block must be explicitly analyzed to redecorate all entities in the 6454 -- list and ensure that a finalizer is properly built. 6455 6456 case Nkind (N) is 6457 when N_Elsif_Part | 6458 N_If_Statement | 6459 N_Conditional_Entry_Call | 6460 N_Selective_Accept => 6461 6462 -- Check the "then statements" for elsif parts and if statements 6463 6464 if Nkind_In (N, N_Elsif_Part, N_If_Statement) 6465 and then not Is_Empty_List (Then_Statements (N)) 6466 and then not Are_Wrapped (Then_Statements (N)) 6467 and then Requires_Cleanup_Actions 6468 (Then_Statements (N), False, False) 6469 then 6470 Block := Wrap_Statements_In_Block (Then_Statements (N)); 6471 Set_Then_Statements (N, New_List (Block)); 6472 6473 Analyze (Block); 6474 end if; 6475 6476 -- Check the "else statements" for conditional entry calls, if 6477 -- statements and selective accepts. 6478 6479 if Nkind_In (N, N_Conditional_Entry_Call, 6480 N_If_Statement, 6481 N_Selective_Accept) 6482 and then not Is_Empty_List (Else_Statements (N)) 6483 and then not Are_Wrapped (Else_Statements (N)) 6484 and then Requires_Cleanup_Actions 6485 (Else_Statements (N), False, False) 6486 then 6487 Block := Wrap_Statements_In_Block (Else_Statements (N)); 6488 Set_Else_Statements (N, New_List (Block)); 6489 6490 Analyze (Block); 6491 end if; 6492 6493 when N_Abortable_Part | 6494 N_Accept_Alternative | 6495 N_Case_Statement_Alternative | 6496 N_Delay_Alternative | 6497 N_Entry_Call_Alternative | 6498 N_Exception_Handler | 6499 N_Loop_Statement | 6500 N_Triggering_Alternative => 6501 6502 if not Is_Empty_List (Statements (N)) 6503 and then not Are_Wrapped (Statements (N)) 6504 and then Requires_Cleanup_Actions (Statements (N), False, False) 6505 then 6506 if Nkind (N) = N_Loop_Statement 6507 and then Present (Identifier (N)) 6508 then 6509 Block := 6510 Wrap_Statements_In_Block 6511 (L => Statements (N), 6512 Scop => Entity (Identifier (N))); 6513 else 6514 Block := Wrap_Statements_In_Block (Statements (N)); 6515 end if; 6516 6517 Set_Statements (N, New_List (Block)); 6518 Analyze (Block); 6519 end if; 6520 6521 when others => 6522 null; 6523 end case; 6524 end Process_Statements_For_Controlled_Objects; 6525 6526 ------------------ 6527 -- Power_Of_Two -- 6528 ------------------ 6529 6530 function Power_Of_Two (N : Node_Id) return Nat is 6531 Typ : constant Entity_Id := Etype (N); 6532 pragma Assert (Is_Integer_Type (Typ)); 6533 Siz : constant Nat := UI_To_Int (Esize (Typ)); 6534 Val : Uint; 6535 6536 begin 6537 if not Compile_Time_Known_Value (N) then 6538 return 0; 6539 6540 else 6541 Val := Expr_Value (N); 6542 for J in 1 .. Siz - 1 loop 6543 if Val = Uint_2 ** J then 6544 return J; 6545 end if; 6546 end loop; 6547 6548 return 0; 6549 end if; 6550 end Power_Of_Two; 6551 6552 ---------------------- 6553 -- Remove_Init_Call -- 6554 ---------------------- 6555 6556 function Remove_Init_Call 6557 (Var : Entity_Id; 6558 Rep_Clause : Node_Id) return Node_Id 6559 is 6560 Par : constant Node_Id := Parent (Var); 6561 Typ : constant Entity_Id := Etype (Var); 6562 6563 Init_Proc : Entity_Id; 6564 -- Initialization procedure for Typ 6565 6566 function Find_Init_Call_In_List (From : Node_Id) return Node_Id; 6567 -- Look for init call for Var starting at From and scanning the 6568 -- enclosing list until Rep_Clause or the end of the list is reached. 6569 6570 ---------------------------- 6571 -- Find_Init_Call_In_List -- 6572 ---------------------------- 6573 6574 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is 6575 Init_Call : Node_Id; 6576 6577 begin 6578 Init_Call := From; 6579 while Present (Init_Call) and then Init_Call /= Rep_Clause loop 6580 if Nkind (Init_Call) = N_Procedure_Call_Statement 6581 and then Is_Entity_Name (Name (Init_Call)) 6582 and then Entity (Name (Init_Call)) = Init_Proc 6583 then 6584 return Init_Call; 6585 end if; 6586 6587 Next (Init_Call); 6588 end loop; 6589 6590 return Empty; 6591 end Find_Init_Call_In_List; 6592 6593 Init_Call : Node_Id; 6594 6595 -- Start of processing for Find_Init_Call 6596 6597 begin 6598 if Present (Initialization_Statements (Var)) then 6599 Init_Call := Initialization_Statements (Var); 6600 Set_Initialization_Statements (Var, Empty); 6601 6602 elsif not Has_Non_Null_Base_Init_Proc (Typ) then 6603 6604 -- No init proc for the type, so obviously no call to be found 6605 6606 return Empty; 6607 6608 else 6609 -- We might be able to handle other cases below by just properly 6610 -- setting Initialization_Statements at the point where the init proc 6611 -- call is generated??? 6612 6613 Init_Proc := Base_Init_Proc (Typ); 6614 6615 -- First scan the list containing the declaration of Var 6616 6617 Init_Call := Find_Init_Call_In_List (From => Next (Par)); 6618 6619 -- If not found, also look on Var's freeze actions list, if any, 6620 -- since the init call may have been moved there (case of an address 6621 -- clause applying to Var). 6622 6623 if No (Init_Call) and then Present (Freeze_Node (Var)) then 6624 Init_Call := 6625 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var)))); 6626 end if; 6627 6628 -- If the initialization call has actuals that use the secondary 6629 -- stack, the call may have been wrapped into a temporary block, in 6630 -- which case the block itself has to be removed. 6631 6632 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then 6633 declare 6634 Blk : constant Node_Id := Next (Par); 6635 begin 6636 if Present 6637 (Find_Init_Call_In_List 6638 (First (Statements (Handled_Statement_Sequence (Blk))))) 6639 then 6640 Init_Call := Blk; 6641 end if; 6642 end; 6643 end if; 6644 end if; 6645 6646 if Present (Init_Call) then 6647 Remove (Init_Call); 6648 end if; 6649 return Init_Call; 6650 end Remove_Init_Call; 6651 6652 ------------------------- 6653 -- Remove_Side_Effects -- 6654 ------------------------- 6655 6656 procedure Remove_Side_Effects 6657 (Exp : Node_Id; 6658 Name_Req : Boolean := False; 6659 Variable_Ref : Boolean := False) 6660 is 6661 Loc : constant Source_Ptr := Sloc (Exp); 6662 Exp_Type : constant Entity_Id := Etype (Exp); 6663 Svg_Suppress : constant Suppress_Record := Scope_Suppress; 6664 Def_Id : Entity_Id; 6665 E : Node_Id; 6666 New_Exp : Node_Id; 6667 Ptr_Typ_Decl : Node_Id; 6668 Ref_Type : Entity_Id; 6669 Res : Node_Id; 6670 6671 begin 6672 -- Handle cases in which there is nothing to do. In GNATprove mode, 6673 -- removal of side effects is useful for the light expansion of 6674 -- renamings. This removal should only occur when not inside a 6675 -- generic and not doing a pre-analysis. 6676 6677 if not Expander_Active 6678 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 6679 then 6680 return; 6681 end if; 6682 6683 -- Cannot generate temporaries if the invocation to remove side effects 6684 -- was issued too early and the type of the expression is not resolved 6685 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke 6686 -- Remove_Side_Effects). 6687 6688 if No (Exp_Type) 6689 or else Ekind (Exp_Type) = E_Access_Attribute_Type 6690 then 6691 return; 6692 6693 -- No action needed for side-effect free expressions 6694 6695 elsif Side_Effect_Free (Exp, Name_Req, Variable_Ref) then 6696 return; 6697 end if; 6698 6699 -- The remaining procesaing is done with all checks suppressed 6700 6701 -- Note: from now on, don't use return statements, instead do a goto 6702 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress. 6703 6704 Scope_Suppress.Suppress := (others => True); 6705 6706 -- If it is a scalar type and we need to capture the value, just make 6707 -- a copy. Likewise for a function call, an attribute reference, a 6708 -- conditional expression, an allocator, or an operator. And if we have 6709 -- a volatile reference and Name_Req is not set (see comments for 6710 -- Side_Effect_Free). 6711 6712 if Is_Elementary_Type (Exp_Type) 6713 6714 -- Note: this test is rather mysterious??? Why can't we just test ONLY 6715 -- Is_Elementary_Type and be done with it. If we try that approach, we 6716 -- get some failures (infinite recursions) from the Duplicate_Subexpr 6717 -- call at the end of Checks.Apply_Predicate_Check. To be 6718 -- investigated ??? 6719 6720 and then (Variable_Ref 6721 or else Nkind_In (Exp, N_Attribute_Reference, 6722 N_Allocator, 6723 N_Case_Expression, 6724 N_If_Expression, 6725 N_Function_Call) 6726 or else Nkind (Exp) in N_Op 6727 or else (not Name_Req 6728 and then Is_Volatile_Reference (Exp))) 6729 then 6730 Def_Id := Make_Temporary (Loc, 'R', Exp); 6731 Set_Etype (Def_Id, Exp_Type); 6732 Res := New_Occurrence_Of (Def_Id, Loc); 6733 6734 -- If the expression is a packed reference, it must be reanalyzed and 6735 -- expanded, depending on context. This is the case for actuals where 6736 -- a constraint check may capture the actual before expansion of the 6737 -- call is complete. 6738 6739 if Nkind (Exp) = N_Indexed_Component 6740 and then Is_Packed (Etype (Prefix (Exp))) 6741 then 6742 Set_Analyzed (Exp, False); 6743 Set_Analyzed (Prefix (Exp), False); 6744 end if; 6745 6746 E := 6747 Make_Object_Declaration (Loc, 6748 Defining_Identifier => Def_Id, 6749 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 6750 Constant_Present => True, 6751 Expression => Relocate_Node (Exp)); 6752 6753 Set_Assignment_OK (E); 6754 Insert_Action (Exp, E); 6755 6756 -- If the expression has the form v.all then we can just capture the 6757 -- pointer, and then do an explicit dereference on the result. 6758 6759 elsif Nkind (Exp) = N_Explicit_Dereference then 6760 Def_Id := Make_Temporary (Loc, 'R', Exp); 6761 Res := 6762 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc)); 6763 6764 Insert_Action (Exp, 6765 Make_Object_Declaration (Loc, 6766 Defining_Identifier => Def_Id, 6767 Object_Definition => 6768 New_Occurrence_Of (Etype (Prefix (Exp)), Loc), 6769 Constant_Present => True, 6770 Expression => Relocate_Node (Prefix (Exp)))); 6771 6772 -- Similar processing for an unchecked conversion of an expression of 6773 -- the form v.all, where we want the same kind of treatment. 6774 6775 elsif Nkind (Exp) = N_Unchecked_Type_Conversion 6776 and then Nkind (Expression (Exp)) = N_Explicit_Dereference 6777 then 6778 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); 6779 goto Leave; 6780 6781 -- If this is a type conversion, leave the type conversion and remove 6782 -- the side effects in the expression. This is important in several 6783 -- circumstances: for change of representations, and also when this is a 6784 -- view conversion to a smaller object, where gigi can end up creating 6785 -- its own temporary of the wrong size. 6786 6787 elsif Nkind (Exp) = N_Type_Conversion then 6788 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); 6789 goto Leave; 6790 6791 -- If this is an unchecked conversion that Gigi can't handle, make 6792 -- a copy or a use a renaming to capture the value. 6793 6794 elsif Nkind (Exp) = N_Unchecked_Type_Conversion 6795 and then not Safe_Unchecked_Type_Conversion (Exp) 6796 then 6797 if CW_Or_Has_Controlled_Part (Exp_Type) then 6798 6799 -- Use a renaming to capture the expression, rather than create 6800 -- a controlled temporary. 6801 6802 Def_Id := Make_Temporary (Loc, 'R', Exp); 6803 Res := New_Occurrence_Of (Def_Id, Loc); 6804 6805 Insert_Action (Exp, 6806 Make_Object_Renaming_Declaration (Loc, 6807 Defining_Identifier => Def_Id, 6808 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), 6809 Name => Relocate_Node (Exp))); 6810 6811 else 6812 Def_Id := Make_Temporary (Loc, 'R', Exp); 6813 Set_Etype (Def_Id, Exp_Type); 6814 Res := New_Occurrence_Of (Def_Id, Loc); 6815 6816 E := 6817 Make_Object_Declaration (Loc, 6818 Defining_Identifier => Def_Id, 6819 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 6820 Constant_Present => not Is_Variable (Exp), 6821 Expression => Relocate_Node (Exp)); 6822 6823 Set_Assignment_OK (E); 6824 Insert_Action (Exp, E); 6825 end if; 6826 6827 -- For expressions that denote objects, we can use a renaming scheme. 6828 -- This is needed for correctness in the case of a volatile object of 6829 -- a non-volatile type because the Make_Reference call of the "default" 6830 -- approach would generate an illegal access value (an access value 6831 -- cannot designate such an object - see Analyze_Reference). We skip 6832 -- using this scheme if we have an object of a volatile type and we do 6833 -- not have Name_Req set true (see comments for Side_Effect_Free). 6834 6835 -- In Ada 2012 a qualified expression is an object, but for purposes of 6836 -- removing side effects it still need to be transformed into a separate 6837 -- declaration, particularly if the expression is an aggregate. 6838 6839 elsif Is_Object_Reference (Exp) 6840 and then Nkind (Exp) /= N_Function_Call 6841 and then Nkind (Exp) /= N_Qualified_Expression 6842 and then (Name_Req or else not Treat_As_Volatile (Exp_Type)) 6843 then 6844 Def_Id := Make_Temporary (Loc, 'R', Exp); 6845 6846 if Nkind (Exp) = N_Selected_Component 6847 and then Nkind (Prefix (Exp)) = N_Function_Call 6848 and then Is_Array_Type (Exp_Type) 6849 then 6850 -- Avoid generating a variable-sized temporary, by generating 6851 -- the renaming declaration just for the function call. The 6852 -- transformation could be refined to apply only when the array 6853 -- component is constrained by a discriminant??? 6854 6855 Res := 6856 Make_Selected_Component (Loc, 6857 Prefix => New_Occurrence_Of (Def_Id, Loc), 6858 Selector_Name => Selector_Name (Exp)); 6859 6860 Insert_Action (Exp, 6861 Make_Object_Renaming_Declaration (Loc, 6862 Defining_Identifier => Def_Id, 6863 Subtype_Mark => 6864 New_Occurrence_Of (Base_Type (Etype (Prefix (Exp))), Loc), 6865 Name => Relocate_Node (Prefix (Exp)))); 6866 6867 else 6868 Res := New_Occurrence_Of (Def_Id, Loc); 6869 6870 Insert_Action (Exp, 6871 Make_Object_Renaming_Declaration (Loc, 6872 Defining_Identifier => Def_Id, 6873 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), 6874 Name => Relocate_Node (Exp))); 6875 end if; 6876 6877 -- If this is a packed reference, or a selected component with 6878 -- a non-standard representation, a reference to the temporary 6879 -- will be replaced by a copy of the original expression (see 6880 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be 6881 -- elaborated by gigi, and is of course not to be replaced in-line 6882 -- by the expression it renames, which would defeat the purpose of 6883 -- removing the side-effect. 6884 6885 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component) 6886 and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) 6887 then 6888 null; 6889 else 6890 Set_Is_Renaming_Of_Object (Def_Id, False); 6891 end if; 6892 6893 -- Otherwise we generate a reference to the value 6894 6895 else 6896 -- An expression which is in SPARK mode is considered side effect 6897 -- free if the resulting value is captured by a variable or a 6898 -- constant. 6899 6900 if GNATprove_Mode 6901 and then Nkind (Parent (Exp)) = N_Object_Declaration 6902 then 6903 goto Leave; 6904 end if; 6905 6906 -- Special processing for function calls that return a limited type. 6907 -- We need to build a declaration that will enable build-in-place 6908 -- expansion of the call. This is not done if the context is already 6909 -- an object declaration, to prevent infinite recursion. 6910 6911 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have 6912 -- to accommodate functions returning limited objects by reference. 6913 6914 if Ada_Version >= Ada_2005 6915 and then Nkind (Exp) = N_Function_Call 6916 and then Is_Limited_View (Etype (Exp)) 6917 and then Nkind (Parent (Exp)) /= N_Object_Declaration 6918 then 6919 declare 6920 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp); 6921 Decl : Node_Id; 6922 6923 begin 6924 Decl := 6925 Make_Object_Declaration (Loc, 6926 Defining_Identifier => Obj, 6927 Object_Definition => New_Occurrence_Of (Exp_Type, Loc), 6928 Expression => Relocate_Node (Exp)); 6929 6930 Insert_Action (Exp, Decl); 6931 Set_Etype (Obj, Exp_Type); 6932 Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); 6933 goto Leave; 6934 end; 6935 end if; 6936 6937 Def_Id := Make_Temporary (Loc, 'R', Exp); 6938 6939 -- The regular expansion of functions with side effects involves the 6940 -- generation of an access type to capture the return value found on 6941 -- the secondary stack. Since SPARK (and why) cannot process access 6942 -- types, use a different approach which ignores the secondary stack 6943 -- and "copies" the returned object. 6944 6945 if GNATprove_Mode then 6946 Res := New_Occurrence_Of (Def_Id, Loc); 6947 Ref_Type := Exp_Type; 6948 6949 -- Regular expansion utilizing an access type and 'reference 6950 6951 else 6952 Res := 6953 Make_Explicit_Dereference (Loc, 6954 Prefix => New_Occurrence_Of (Def_Id, Loc)); 6955 6956 -- Generate: 6957 -- type Ann is access all <Exp_Type>; 6958 6959 Ref_Type := Make_Temporary (Loc, 'A'); 6960 6961 Ptr_Typ_Decl := 6962 Make_Full_Type_Declaration (Loc, 6963 Defining_Identifier => Ref_Type, 6964 Type_Definition => 6965 Make_Access_To_Object_Definition (Loc, 6966 All_Present => True, 6967 Subtype_Indication => 6968 New_Occurrence_Of (Exp_Type, Loc))); 6969 6970 Insert_Action (Exp, Ptr_Typ_Decl); 6971 end if; 6972 6973 E := Exp; 6974 if Nkind (E) = N_Explicit_Dereference then 6975 New_Exp := Relocate_Node (Prefix (E)); 6976 6977 else 6978 E := Relocate_Node (E); 6979 6980 -- Do not generate a 'reference in SPARK mode since the access 6981 -- type is not created in the first place. 6982 6983 if GNATprove_Mode then 6984 New_Exp := E; 6985 6986 -- Otherwise generate reference, marking the value as non-null 6987 -- since we know it cannot be null and we don't want a check. 6988 6989 else 6990 New_Exp := Make_Reference (Loc, E); 6991 Set_Is_Known_Non_Null (Def_Id); 6992 end if; 6993 end if; 6994 6995 if Is_Delayed_Aggregate (E) then 6996 6997 -- The expansion of nested aggregates is delayed until the 6998 -- enclosing aggregate is expanded. As aggregates are often 6999 -- qualified, the predicate applies to qualified expressions as 7000 -- well, indicating that the enclosing aggregate has not been 7001 -- expanded yet. At this point the aggregate is part of a 7002 -- stand-alone declaration, and must be fully expanded. 7003 7004 if Nkind (E) = N_Qualified_Expression then 7005 Set_Expansion_Delayed (Expression (E), False); 7006 Set_Analyzed (Expression (E), False); 7007 else 7008 Set_Expansion_Delayed (E, False); 7009 end if; 7010 7011 Set_Analyzed (E, False); 7012 end if; 7013 7014 Insert_Action (Exp, 7015 Make_Object_Declaration (Loc, 7016 Defining_Identifier => Def_Id, 7017 Object_Definition => New_Occurrence_Of (Ref_Type, Loc), 7018 Constant_Present => True, 7019 Expression => New_Exp)); 7020 end if; 7021 7022 -- Preserve the Assignment_OK flag in all copies, since at least one 7023 -- copy may be used in a context where this flag must be set (otherwise 7024 -- why would the flag be set in the first place). 7025 7026 Set_Assignment_OK (Res, Assignment_OK (Exp)); 7027 7028 -- Finally rewrite the original expression and we are done 7029 7030 Rewrite (Exp, Res); 7031 Analyze_And_Resolve (Exp, Exp_Type); 7032 7033 <<Leave>> 7034 Scope_Suppress := Svg_Suppress; 7035 end Remove_Side_Effects; 7036 7037 --------------------------- 7038 -- Represented_As_Scalar -- 7039 --------------------------- 7040 7041 function Represented_As_Scalar (T : Entity_Id) return Boolean is 7042 UT : constant Entity_Id := Underlying_Type (T); 7043 begin 7044 return Is_Scalar_Type (UT) 7045 or else (Is_Bit_Packed_Array (UT) 7046 and then Is_Scalar_Type (Packed_Array_Type (UT))); 7047 end Represented_As_Scalar; 7048 7049 ------------------------------ 7050 -- Requires_Cleanup_Actions -- 7051 ------------------------------ 7052 7053 function Requires_Cleanup_Actions 7054 (N : Node_Id; 7055 Lib_Level : Boolean) return Boolean 7056 is 7057 At_Lib_Level : constant Boolean := 7058 Lib_Level 7059 and then Nkind_In (N, N_Package_Body, 7060 N_Package_Specification); 7061 -- N is at the library level if the top-most context is a package and 7062 -- the path taken to reach N does not inlcude non-package constructs. 7063 7064 begin 7065 case Nkind (N) is 7066 when N_Accept_Statement | 7067 N_Block_Statement | 7068 N_Entry_Body | 7069 N_Package_Body | 7070 N_Protected_Body | 7071 N_Subprogram_Body | 7072 N_Task_Body => 7073 return 7074 Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True) 7075 or else 7076 (Present (Handled_Statement_Sequence (N)) 7077 and then 7078 Requires_Cleanup_Actions 7079 (Statements (Handled_Statement_Sequence (N)), 7080 At_Lib_Level, True)); 7081 7082 when N_Package_Specification => 7083 return 7084 Requires_Cleanup_Actions 7085 (Visible_Declarations (N), At_Lib_Level, True) 7086 or else 7087 Requires_Cleanup_Actions 7088 (Private_Declarations (N), At_Lib_Level, True); 7089 7090 when others => 7091 return False; 7092 end case; 7093 end Requires_Cleanup_Actions; 7094 7095 ------------------------------ 7096 -- Requires_Cleanup_Actions -- 7097 ------------------------------ 7098 7099 function Requires_Cleanup_Actions 7100 (L : List_Id; 7101 Lib_Level : Boolean; 7102 Nested_Constructs : Boolean) return Boolean 7103 is 7104 Decl : Node_Id; 7105 Expr : Node_Id; 7106 Obj_Id : Entity_Id; 7107 Obj_Typ : Entity_Id; 7108 Pack_Id : Entity_Id; 7109 Typ : Entity_Id; 7110 7111 begin 7112 if No (L) 7113 or else Is_Empty_List (L) 7114 then 7115 return False; 7116 end if; 7117 7118 Decl := First (L); 7119 while Present (Decl) loop 7120 7121 -- Library-level tagged types 7122 7123 if Nkind (Decl) = N_Full_Type_Declaration then 7124 Typ := Defining_Identifier (Decl); 7125 7126 if Is_Tagged_Type (Typ) 7127 and then Is_Library_Level_Entity (Typ) 7128 and then Convention (Typ) = Convention_Ada 7129 and then Present (Access_Disp_Table (Typ)) 7130 and then RTE_Available (RE_Unregister_Tag) 7131 and then not No_Run_Time_Mode 7132 and then not Is_Abstract_Type (Typ) 7133 then 7134 return True; 7135 end if; 7136 7137 -- Regular object declarations 7138 7139 elsif Nkind (Decl) = N_Object_Declaration then 7140 Obj_Id := Defining_Identifier (Decl); 7141 Obj_Typ := Base_Type (Etype (Obj_Id)); 7142 Expr := Expression (Decl); 7143 7144 -- Bypass any form of processing for objects which have their 7145 -- finalization disabled. This applies only to objects at the 7146 -- library level. 7147 7148 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then 7149 null; 7150 7151 -- Transient variables are treated separately in order to minimize 7152 -- the size of the generated code. See Exp_Ch7.Process_Transient_ 7153 -- Objects. 7154 7155 elsif Is_Processed_Transient (Obj_Id) then 7156 null; 7157 7158 -- The object is of the form: 7159 -- Obj : Typ [:= Expr]; 7160 -- 7161 -- Do not process the incomplete view of a deferred constant. Do 7162 -- not consider tag-to-class-wide conversions. 7163 7164 elsif not Is_Imported (Obj_Id) 7165 and then Needs_Finalization (Obj_Typ) 7166 and then not (Ekind (Obj_Id) = E_Constant 7167 and then not Has_Completion (Obj_Id)) 7168 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) 7169 then 7170 return True; 7171 7172 -- The object is of the form: 7173 -- Obj : Access_Typ := Non_BIP_Function_Call'reference; 7174 -- 7175 -- Obj : Access_Typ := 7176 -- BIP_Function_Call (BIPalloc => 2, ...)'reference; 7177 7178 elsif Is_Access_Type (Obj_Typ) 7179 and then Needs_Finalization 7180 (Available_View (Designated_Type (Obj_Typ))) 7181 and then Present (Expr) 7182 and then 7183 (Is_Secondary_Stack_BIP_Func_Call (Expr) 7184 or else 7185 (Is_Non_BIP_Func_Call (Expr) 7186 and then not Is_Related_To_Func_Return (Obj_Id))) 7187 then 7188 return True; 7189 7190 -- Processing for "hook" objects generated for controlled 7191 -- transients declared inside an Expression_With_Actions. 7192 7193 elsif Is_Access_Type (Obj_Typ) 7194 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 7195 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 7196 N_Object_Declaration 7197 and then Is_Finalizable_Transient 7198 (Status_Flag_Or_Transient_Decl (Obj_Id), Decl) 7199 then 7200 return True; 7201 7202 -- Processing for intermediate results of if expressions where 7203 -- one of the alternatives uses a controlled function call. 7204 7205 elsif Is_Access_Type (Obj_Typ) 7206 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 7207 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 7208 N_Defining_Identifier 7209 and then Present (Expr) 7210 and then Nkind (Expr) = N_Null 7211 then 7212 return True; 7213 7214 -- Simple protected objects which use type System.Tasking. 7215 -- Protected_Objects.Protection to manage their locks should be 7216 -- treated as controlled since they require manual cleanup. 7217 7218 elsif Ekind (Obj_Id) = E_Variable 7219 and then 7220 (Is_Simple_Protected_Type (Obj_Typ) 7221 or else Has_Simple_Protected_Object (Obj_Typ)) 7222 then 7223 return True; 7224 end if; 7225 7226 -- Specific cases of object renamings 7227 7228 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 7229 Obj_Id := Defining_Identifier (Decl); 7230 Obj_Typ := Base_Type (Etype (Obj_Id)); 7231 7232 -- Bypass any form of processing for objects which have their 7233 -- finalization disabled. This applies only to objects at the 7234 -- library level. 7235 7236 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then 7237 null; 7238 7239 -- Return object of a build-in-place function. This case is 7240 -- recognized and marked by the expansion of an extended return 7241 -- statement (see Expand_N_Extended_Return_Statement). 7242 7243 elsif Needs_Finalization (Obj_Typ) 7244 and then Is_Return_Object (Obj_Id) 7245 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 7246 then 7247 return True; 7248 7249 -- Detect a case where a source object has been initialized by 7250 -- a controlled function call or another object which was later 7251 -- rewritten as a class-wide conversion of Ada.Tags.Displace. 7252 7253 -- Obj1 : CW_Type := Src_Obj; 7254 -- Obj2 : CW_Type := Function_Call (...); 7255 7256 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); 7257 -- Tmp : ... := Function_Call (...)'reference; 7258 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); 7259 7260 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then 7261 return True; 7262 end if; 7263 7264 -- Inspect the freeze node of an access-to-controlled type and look 7265 -- for a delayed finalization master. This case arises when the 7266 -- freeze actions are inserted at a later time than the expansion of 7267 -- the context. Since Build_Finalizer is never called on a single 7268 -- construct twice, the master will be ultimately left out and never 7269 -- finalized. This is also needed for freeze actions of designated 7270 -- types themselves, since in some cases the finalization master is 7271 -- associated with a designated type's freeze node rather than that 7272 -- of the access type (see handling for freeze actions in 7273 -- Build_Finalization_Master). 7274 7275 elsif Nkind (Decl) = N_Freeze_Entity 7276 and then Present (Actions (Decl)) 7277 then 7278 Typ := Entity (Decl); 7279 7280 if ((Is_Access_Type (Typ) 7281 and then not Is_Access_Subprogram_Type (Typ) 7282 and then Needs_Finalization 7283 (Available_View (Designated_Type (Typ)))) 7284 or else 7285 (Is_Type (Typ) 7286 and then Needs_Finalization (Typ))) 7287 and then Requires_Cleanup_Actions 7288 (Actions (Decl), Lib_Level, Nested_Constructs) 7289 then 7290 return True; 7291 end if; 7292 7293 -- Nested package declarations 7294 7295 elsif Nested_Constructs 7296 and then Nkind (Decl) = N_Package_Declaration 7297 then 7298 Pack_Id := Defining_Unit_Name (Specification (Decl)); 7299 7300 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then 7301 Pack_Id := Defining_Identifier (Pack_Id); 7302 end if; 7303 7304 if Ekind (Pack_Id) /= E_Generic_Package 7305 and then 7306 Requires_Cleanup_Actions (Specification (Decl), Lib_Level) 7307 then 7308 return True; 7309 end if; 7310 7311 -- Nested package bodies 7312 7313 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then 7314 Pack_Id := Corresponding_Spec (Decl); 7315 7316 if Ekind (Pack_Id) /= E_Generic_Package 7317 and then Requires_Cleanup_Actions (Decl, Lib_Level) 7318 then 7319 return True; 7320 end if; 7321 end if; 7322 7323 Next (Decl); 7324 end loop; 7325 7326 return False; 7327 end Requires_Cleanup_Actions; 7328 7329 ------------------------------------ 7330 -- Safe_Unchecked_Type_Conversion -- 7331 ------------------------------------ 7332 7333 -- Note: this function knows quite a bit about the exact requirements of 7334 -- Gigi with respect to unchecked type conversions, and its code must be 7335 -- coordinated with any changes in Gigi in this area. 7336 7337 -- The above requirements should be documented in Sinfo ??? 7338 7339 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is 7340 Otyp : Entity_Id; 7341 Ityp : Entity_Id; 7342 Oalign : Uint; 7343 Ialign : Uint; 7344 Pexp : constant Node_Id := Parent (Exp); 7345 7346 begin 7347 -- If the expression is the RHS of an assignment or object declaration 7348 -- we are always OK because there will always be a target. 7349 7350 -- Object renaming declarations, (generated for view conversions of 7351 -- actuals in inlined calls), like object declarations, provide an 7352 -- explicit type, and are safe as well. 7353 7354 if (Nkind (Pexp) = N_Assignment_Statement 7355 and then Expression (Pexp) = Exp) 7356 or else Nkind_In (Pexp, N_Object_Declaration, 7357 N_Object_Renaming_Declaration) 7358 then 7359 return True; 7360 7361 -- If the expression is the prefix of an N_Selected_Component we should 7362 -- also be OK because GCC knows to look inside the conversion except if 7363 -- the type is discriminated. We assume that we are OK anyway if the 7364 -- type is not set yet or if it is controlled since we can't afford to 7365 -- introduce a temporary in this case. 7366 7367 elsif Nkind (Pexp) = N_Selected_Component 7368 and then Prefix (Pexp) = Exp 7369 then 7370 if No (Etype (Pexp)) then 7371 return True; 7372 else 7373 return 7374 not Has_Discriminants (Etype (Pexp)) 7375 or else Is_Constrained (Etype (Pexp)); 7376 end if; 7377 end if; 7378 7379 -- Set the output type, this comes from Etype if it is set, otherwise we 7380 -- take it from the subtype mark, which we assume was already fully 7381 -- analyzed. 7382 7383 if Present (Etype (Exp)) then 7384 Otyp := Etype (Exp); 7385 else 7386 Otyp := Entity (Subtype_Mark (Exp)); 7387 end if; 7388 7389 -- The input type always comes from the expression, and we assume 7390 -- this is indeed always analyzed, so we can simply get the Etype. 7391 7392 Ityp := Etype (Expression (Exp)); 7393 7394 -- Initialize alignments to unknown so far 7395 7396 Oalign := No_Uint; 7397 Ialign := No_Uint; 7398 7399 -- Replace a concurrent type by its corresponding record type and each 7400 -- type by its underlying type and do the tests on those. The original 7401 -- type may be a private type whose completion is a concurrent type, so 7402 -- find the underlying type first. 7403 7404 if Present (Underlying_Type (Otyp)) then 7405 Otyp := Underlying_Type (Otyp); 7406 end if; 7407 7408 if Present (Underlying_Type (Ityp)) then 7409 Ityp := Underlying_Type (Ityp); 7410 end if; 7411 7412 if Is_Concurrent_Type (Otyp) then 7413 Otyp := Corresponding_Record_Type (Otyp); 7414 end if; 7415 7416 if Is_Concurrent_Type (Ityp) then 7417 Ityp := Corresponding_Record_Type (Ityp); 7418 end if; 7419 7420 -- If the base types are the same, we know there is no problem since 7421 -- this conversion will be a noop. 7422 7423 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then 7424 return True; 7425 7426 -- Same if this is an upwards conversion of an untagged type, and there 7427 -- are no constraints involved (could be more general???) 7428 7429 elsif Etype (Ityp) = Otyp 7430 and then not Is_Tagged_Type (Ityp) 7431 and then not Has_Discriminants (Ityp) 7432 and then No (First_Rep_Item (Base_Type (Ityp))) 7433 then 7434 return True; 7435 7436 -- If the expression has an access type (object or subprogram) we assume 7437 -- that the conversion is safe, because the size of the target is safe, 7438 -- even if it is a record (which might be treated as having unknown size 7439 -- at this point). 7440 7441 elsif Is_Access_Type (Ityp) then 7442 return True; 7443 7444 -- If the size of output type is known at compile time, there is never 7445 -- a problem. Note that unconstrained records are considered to be of 7446 -- known size, but we can't consider them that way here, because we are 7447 -- talking about the actual size of the object. 7448 7449 -- We also make sure that in addition to the size being known, we do not 7450 -- have a case which might generate an embarrassingly large temp in 7451 -- stack checking mode. 7452 7453 elsif Size_Known_At_Compile_Time (Otyp) 7454 and then 7455 (not Stack_Checking_Enabled 7456 or else not May_Generate_Large_Temp (Otyp)) 7457 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp)) 7458 then 7459 return True; 7460 7461 -- If either type is tagged, then we know the alignment is OK so 7462 -- Gigi will be able to use pointer punning. 7463 7464 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then 7465 return True; 7466 7467 -- If either type is a limited record type, we cannot do a copy, so say 7468 -- safe since there's nothing else we can do. 7469 7470 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then 7471 return True; 7472 7473 -- Conversions to and from packed array types are always ignored and 7474 -- hence are safe. 7475 7476 elsif Is_Packed_Array_Type (Otyp) 7477 or else Is_Packed_Array_Type (Ityp) 7478 then 7479 return True; 7480 end if; 7481 7482 -- The only other cases known to be safe is if the input type's 7483 -- alignment is known to be at least the maximum alignment for the 7484 -- target or if both alignments are known and the output type's 7485 -- alignment is no stricter than the input's. We can use the component 7486 -- type alignement for an array if a type is an unpacked array type. 7487 7488 if Present (Alignment_Clause (Otyp)) then 7489 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp))); 7490 7491 elsif Is_Array_Type (Otyp) 7492 and then Present (Alignment_Clause (Component_Type (Otyp))) 7493 then 7494 Oalign := Expr_Value (Expression (Alignment_Clause 7495 (Component_Type (Otyp)))); 7496 end if; 7497 7498 if Present (Alignment_Clause (Ityp)) then 7499 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp))); 7500 7501 elsif Is_Array_Type (Ityp) 7502 and then Present (Alignment_Clause (Component_Type (Ityp))) 7503 then 7504 Ialign := Expr_Value (Expression (Alignment_Clause 7505 (Component_Type (Ityp)))); 7506 end if; 7507 7508 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then 7509 return True; 7510 7511 elsif Ialign /= No_Uint and then Oalign /= No_Uint 7512 and then Ialign <= Oalign 7513 then 7514 return True; 7515 7516 -- Otherwise, Gigi cannot handle this and we must make a temporary 7517 7518 else 7519 return False; 7520 end if; 7521 end Safe_Unchecked_Type_Conversion; 7522 7523 --------------------------------- 7524 -- Set_Current_Value_Condition -- 7525 --------------------------------- 7526 7527 -- Note: the implementation of this procedure is very closely tied to the 7528 -- implementation of Get_Current_Value_Condition. Here we set required 7529 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret 7530 -- them, so they must have a consistent view. 7531 7532 procedure Set_Current_Value_Condition (Cnode : Node_Id) is 7533 7534 procedure Set_Entity_Current_Value (N : Node_Id); 7535 -- If N is an entity reference, where the entity is of an appropriate 7536 -- kind, then set the current value of this entity to Cnode, unless 7537 -- there is already a definite value set there. 7538 7539 procedure Set_Expression_Current_Value (N : Node_Id); 7540 -- If N is of an appropriate form, sets an appropriate entry in current 7541 -- value fields of relevant entities. Multiple entities can be affected 7542 -- in the case of an AND or AND THEN. 7543 7544 ------------------------------ 7545 -- Set_Entity_Current_Value -- 7546 ------------------------------ 7547 7548 procedure Set_Entity_Current_Value (N : Node_Id) is 7549 begin 7550 if Is_Entity_Name (N) then 7551 declare 7552 Ent : constant Entity_Id := Entity (N); 7553 7554 begin 7555 -- Don't capture if not safe to do so 7556 7557 if not Safe_To_Capture_Value (N, Ent, Cond => True) then 7558 return; 7559 end if; 7560 7561 -- Here we have a case where the Current_Value field may need 7562 -- to be set. We set it if it is not already set to a compile 7563 -- time expression value. 7564 7565 -- Note that this represents a decision that one condition 7566 -- blots out another previous one. That's certainly right if 7567 -- they occur at the same level. If the second one is nested, 7568 -- then the decision is neither right nor wrong (it would be 7569 -- equally OK to leave the outer one in place, or take the new 7570 -- inner one. Really we should record both, but our data 7571 -- structures are not that elaborate. 7572 7573 if Nkind (Current_Value (Ent)) not in N_Subexpr then 7574 Set_Current_Value (Ent, Cnode); 7575 end if; 7576 end; 7577 end if; 7578 end Set_Entity_Current_Value; 7579 7580 ---------------------------------- 7581 -- Set_Expression_Current_Value -- 7582 ---------------------------------- 7583 7584 procedure Set_Expression_Current_Value (N : Node_Id) is 7585 Cond : Node_Id; 7586 7587 begin 7588 Cond := N; 7589 7590 -- Loop to deal with (ignore for now) any NOT operators present. The 7591 -- presence of NOT operators will be handled properly when we call 7592 -- Get_Current_Value_Condition. 7593 7594 while Nkind (Cond) = N_Op_Not loop 7595 Cond := Right_Opnd (Cond); 7596 end loop; 7597 7598 -- For an AND or AND THEN, recursively process operands 7599 7600 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then 7601 Set_Expression_Current_Value (Left_Opnd (Cond)); 7602 Set_Expression_Current_Value (Right_Opnd (Cond)); 7603 return; 7604 end if; 7605 7606 -- Check possible relational operator 7607 7608 if Nkind (Cond) in N_Op_Compare then 7609 if Compile_Time_Known_Value (Right_Opnd (Cond)) then 7610 Set_Entity_Current_Value (Left_Opnd (Cond)); 7611 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then 7612 Set_Entity_Current_Value (Right_Opnd (Cond)); 7613 end if; 7614 7615 elsif Nkind_In (Cond, 7616 N_Type_Conversion, 7617 N_Qualified_Expression, 7618 N_Expression_With_Actions) 7619 then 7620 Set_Expression_Current_Value (Expression (Cond)); 7621 7622 -- Check possible boolean variable reference 7623 7624 else 7625 Set_Entity_Current_Value (Cond); 7626 end if; 7627 end Set_Expression_Current_Value; 7628 7629 -- Start of processing for Set_Current_Value_Condition 7630 7631 begin 7632 Set_Expression_Current_Value (Condition (Cnode)); 7633 end Set_Current_Value_Condition; 7634 7635 -------------------------- 7636 -- Set_Elaboration_Flag -- 7637 -------------------------- 7638 7639 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is 7640 Loc : constant Source_Ptr := Sloc (N); 7641 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id); 7642 Asn : Node_Id; 7643 7644 begin 7645 if Present (Ent) then 7646 7647 -- Nothing to do if at the compilation unit level, because in this 7648 -- case the flag is set by the binder generated elaboration routine. 7649 7650 if Nkind (Parent (N)) = N_Compilation_Unit then 7651 null; 7652 7653 -- Here we do need to generate an assignment statement 7654 7655 else 7656 Check_Restriction (No_Elaboration_Code, N); 7657 Asn := 7658 Make_Assignment_Statement (Loc, 7659 Name => New_Occurrence_Of (Ent, Loc), 7660 Expression => Make_Integer_Literal (Loc, Uint_1)); 7661 7662 if Nkind (Parent (N)) = N_Subunit then 7663 Insert_After (Corresponding_Stub (Parent (N)), Asn); 7664 else 7665 Insert_After (N, Asn); 7666 end if; 7667 7668 Analyze (Asn); 7669 7670 -- Kill current value indication. This is necessary because the 7671 -- tests of this flag are inserted out of sequence and must not 7672 -- pick up bogus indications of the wrong constant value. 7673 7674 Set_Current_Value (Ent, Empty); 7675 end if; 7676 end if; 7677 end Set_Elaboration_Flag; 7678 7679 ---------------------------- 7680 -- Set_Renamed_Subprogram -- 7681 ---------------------------- 7682 7683 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is 7684 begin 7685 -- If input node is an identifier, we can just reset it 7686 7687 if Nkind (N) = N_Identifier then 7688 Set_Chars (N, Chars (E)); 7689 Set_Entity (N, E); 7690 7691 -- Otherwise we have to do a rewrite, preserving Comes_From_Source 7692 7693 else 7694 declare 7695 CS : constant Boolean := Comes_From_Source (N); 7696 begin 7697 Rewrite (N, Make_Identifier (Sloc (N), Chars (E))); 7698 Set_Entity (N, E); 7699 Set_Comes_From_Source (N, CS); 7700 Set_Analyzed (N, True); 7701 end; 7702 end if; 7703 end Set_Renamed_Subprogram; 7704 7705 ---------------------- 7706 -- Side_Effect_Free -- 7707 ---------------------- 7708 7709 function Side_Effect_Free 7710 (N : Node_Id; 7711 Name_Req : Boolean := False; 7712 Variable_Ref : Boolean := False) return Boolean 7713 is 7714 Typ : constant Entity_Id := Etype (N); 7715 -- Result type of the expression 7716 7717 function Safe_Prefixed_Reference (N : Node_Id) return Boolean; 7718 -- The argument N is a construct where the Prefix is dereferenced if it 7719 -- is an access type and the result is a variable. The call returns True 7720 -- if the construct is side effect free (not considering side effects in 7721 -- other than the prefix which are to be tested by the caller). 7722 7723 function Within_In_Parameter (N : Node_Id) return Boolean; 7724 -- Determines if N is a subcomponent of a composite in-parameter. If so, 7725 -- N is not side-effect free when the actual is global and modifiable 7726 -- indirectly from within a subprogram, because it may be passed by 7727 -- reference. The front-end must be conservative here and assume that 7728 -- this may happen with any array or record type. On the other hand, we 7729 -- cannot create temporaries for all expressions for which this 7730 -- condition is true, for various reasons that might require clearing up 7731 -- ??? For example, discriminant references that appear out of place, or 7732 -- spurious type errors with class-wide expressions. As a result, we 7733 -- limit the transformation to loop bounds, which is so far the only 7734 -- case that requires it. 7735 7736 ----------------------------- 7737 -- Safe_Prefixed_Reference -- 7738 ----------------------------- 7739 7740 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is 7741 begin 7742 -- If prefix is not side effect free, definitely not safe 7743 7744 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then 7745 return False; 7746 7747 -- If the prefix is of an access type that is not access-to-constant, 7748 -- then this construct is a variable reference, which means it is to 7749 -- be considered to have side effects if Variable_Ref is set True. 7750 7751 elsif Is_Access_Type (Etype (Prefix (N))) 7752 and then not Is_Access_Constant (Etype (Prefix (N))) 7753 and then Variable_Ref 7754 then 7755 -- Exception is a prefix that is the result of a previous removal 7756 -- of side-effects. 7757 7758 return Is_Entity_Name (Prefix (N)) 7759 and then not Comes_From_Source (Prefix (N)) 7760 and then Ekind (Entity (Prefix (N))) = E_Constant 7761 and then Is_Internal_Name (Chars (Entity (Prefix (N)))); 7762 7763 -- If the prefix is an explicit dereference then this construct is a 7764 -- variable reference, which means it is to be considered to have 7765 -- side effects if Variable_Ref is True. 7766 7767 -- We do NOT exclude dereferences of access-to-constant types because 7768 -- we handle them as constant view of variables. 7769 7770 elsif Nkind (Prefix (N)) = N_Explicit_Dereference 7771 and then Variable_Ref 7772 then 7773 return False; 7774 7775 -- Note: The following test is the simplest way of solving a complex 7776 -- problem uncovered by the following test (Side effect on loop bound 7777 -- that is a subcomponent of a global variable: 7778 7779 -- with Text_Io; use Text_Io; 7780 -- procedure Tloop is 7781 -- type X is 7782 -- record 7783 -- V : Natural := 4; 7784 -- S : String (1..5) := (others => 'a'); 7785 -- end record; 7786 -- X1 : X; 7787 7788 -- procedure Modi; 7789 7790 -- generic 7791 -- with procedure Action; 7792 -- procedure Loop_G (Arg : X; Msg : String) 7793 7794 -- procedure Loop_G (Arg : X; Msg : String) is 7795 -- begin 7796 -- Put_Line ("begin loop_g " & Msg & " will loop till: " 7797 -- & Natural'Image (Arg.V)); 7798 -- for Index in 1 .. Arg.V loop 7799 -- Text_Io.Put_Line 7800 -- (Natural'Image (Index) & " " & Arg.S (Index)); 7801 -- if Index > 2 then 7802 -- Modi; 7803 -- end if; 7804 -- end loop; 7805 -- Put_Line ("end loop_g " & Msg); 7806 -- end; 7807 7808 -- procedure Loop1 is new Loop_G (Modi); 7809 -- procedure Modi is 7810 -- begin 7811 -- X1.V := 1; 7812 -- Loop1 (X1, "from modi"); 7813 -- end; 7814 -- 7815 -- begin 7816 -- Loop1 (X1, "initial"); 7817 -- end; 7818 7819 -- The output of the above program should be: 7820 7821 -- begin loop_g initial will loop till: 4 7822 -- 1 a 7823 -- 2 a 7824 -- 3 a 7825 -- begin loop_g from modi will loop till: 1 7826 -- 1 a 7827 -- end loop_g from modi 7828 -- 4 a 7829 -- begin loop_g from modi will loop till: 1 7830 -- 1 a 7831 -- end loop_g from modi 7832 -- end loop_g initial 7833 7834 -- If a loop bound is a subcomponent of a global variable, a 7835 -- modification of that variable within the loop may incorrectly 7836 -- affect the execution of the loop. 7837 7838 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification 7839 and then Within_In_Parameter (Prefix (N)) 7840 and then Variable_Ref 7841 then 7842 return False; 7843 7844 -- All other cases are side effect free 7845 7846 else 7847 return True; 7848 end if; 7849 end Safe_Prefixed_Reference; 7850 7851 ------------------------- 7852 -- Within_In_Parameter -- 7853 ------------------------- 7854 7855 function Within_In_Parameter (N : Node_Id) return Boolean is 7856 begin 7857 if not Comes_From_Source (N) then 7858 return False; 7859 7860 elsif Is_Entity_Name (N) then 7861 return Ekind (Entity (N)) = E_In_Parameter; 7862 7863 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 7864 return Within_In_Parameter (Prefix (N)); 7865 7866 else 7867 return False; 7868 end if; 7869 end Within_In_Parameter; 7870 7871 -- Start of processing for Side_Effect_Free 7872 7873 begin 7874 -- Note on checks that could raise Constraint_Error. Strictly, if we 7875 -- take advantage of 11.6, these checks do not count as side effects. 7876 -- However, we would prefer to consider that they are side effects, 7877 -- since the backend CSE does not work very well on expressions which 7878 -- can raise Constraint_Error. On the other hand if we don't consider 7879 -- them to be side effect free, then we get some awkward expansions 7880 -- in -gnato mode, resulting in code insertions at a point where we 7881 -- do not have a clear model for performing the insertions. 7882 7883 -- Special handling for entity names 7884 7885 if Is_Entity_Name (N) then 7886 7887 -- Variables are considered to be a side effect if Variable_Ref 7888 -- is set or if we have a volatile reference and Name_Req is off. 7889 -- If Name_Req is True then we can't help returning a name which 7890 -- effectively allows multiple references in any case. 7891 7892 if Is_Variable (N, Use_Original_Node => False) then 7893 return not Variable_Ref 7894 and then (not Is_Volatile_Reference (N) or else Name_Req); 7895 7896 -- Any other entity (e.g. a subtype name) is definitely side 7897 -- effect free. 7898 7899 else 7900 return True; 7901 end if; 7902 7903 -- A value known at compile time is always side effect free 7904 7905 elsif Compile_Time_Known_Value (N) then 7906 return True; 7907 7908 -- A variable renaming is not side-effect free, because the renaming 7909 -- will function like a macro in the front-end in some cases, and an 7910 -- assignment can modify the component designated by N, so we need to 7911 -- create a temporary for it. 7912 7913 -- The guard testing for Entity being present is needed at least in 7914 -- the case of rewritten predicate expressions, and may well also be 7915 -- appropriate elsewhere. Obviously we can't go testing the entity 7916 -- field if it does not exist, so it's reasonable to say that this is 7917 -- not the renaming case if it does not exist. 7918 7919 elsif Is_Entity_Name (Original_Node (N)) 7920 and then Present (Entity (Original_Node (N))) 7921 and then Is_Renaming_Of_Object (Entity (Original_Node (N))) 7922 and then Ekind (Entity (Original_Node (N))) /= E_Constant 7923 then 7924 declare 7925 RO : constant Node_Id := 7926 Renamed_Object (Entity (Original_Node (N))); 7927 7928 begin 7929 -- If the renamed object is an indexed component, or an 7930 -- explicit dereference, then the designated object could 7931 -- be modified by an assignment. 7932 7933 if Nkind_In (RO, N_Indexed_Component, 7934 N_Explicit_Dereference) 7935 then 7936 return False; 7937 7938 -- A selected component must have a safe prefix 7939 7940 elsif Nkind (RO) = N_Selected_Component then 7941 return Safe_Prefixed_Reference (RO); 7942 7943 -- In all other cases, designated object cannot be changed so 7944 -- we are side effect free. 7945 7946 else 7947 return True; 7948 end if; 7949 end; 7950 7951 -- Remove_Side_Effects generates an object renaming declaration to 7952 -- capture the expression of a class-wide expression. In VM targets 7953 -- the frontend performs no expansion for dispatching calls to 7954 -- class- wide types since they are handled by the VM. Hence, we must 7955 -- locate here if this node corresponds to a previous invocation of 7956 -- Remove_Side_Effects to avoid a never ending loop in the frontend. 7957 7958 elsif VM_Target /= No_VM 7959 and then not Comes_From_Source (N) 7960 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration 7961 and then Is_Class_Wide_Type (Typ) 7962 then 7963 return True; 7964 end if; 7965 7966 -- For other than entity names and compile time known values, 7967 -- check the node kind for special processing. 7968 7969 case Nkind (N) is 7970 7971 -- An attribute reference is side effect free if its expressions 7972 -- are side effect free and its prefix is side effect free or 7973 -- is an entity reference. 7974 7975 -- Is this right? what about x'first where x is a variable??? 7976 7977 when N_Attribute_Reference => 7978 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) 7979 and then Attribute_Name (N) /= Name_Input 7980 and then (Is_Entity_Name (Prefix (N)) 7981 or else Side_Effect_Free 7982 (Prefix (N), Name_Req, Variable_Ref)); 7983 7984 -- A binary operator is side effect free if and both operands are 7985 -- side effect free. For this purpose binary operators include 7986 -- membership tests and short circuit forms. 7987 7988 when N_Binary_Op | N_Membership_Test | N_Short_Circuit => 7989 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref) 7990 and then 7991 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref); 7992 7993 -- An explicit dereference is side effect free only if it is 7994 -- a side effect free prefixed reference. 7995 7996 when N_Explicit_Dereference => 7997 return Safe_Prefixed_Reference (N); 7998 7999 -- An expression with action is side effect free if its expression 8000 -- is side effect free and it has no actions. 8001 8002 when N_Expression_With_Actions => 8003 return Is_Empty_List (Actions (N)) 8004 and then 8005 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); 8006 8007 -- A call to _rep_to_pos is side effect free, since we generate 8008 -- this pure function call ourselves. Moreover it is critically 8009 -- important to make this exception, since otherwise we can have 8010 -- discriminants in array components which don't look side effect 8011 -- free in the case of an array whose index type is an enumeration 8012 -- type with an enumeration rep clause. 8013 8014 -- All other function calls are not side effect free 8015 8016 when N_Function_Call => 8017 return Nkind (Name (N)) = N_Identifier 8018 and then Is_TSS (Name (N), TSS_Rep_To_Pos) 8019 and then 8020 Side_Effect_Free 8021 (First (Parameter_Associations (N)), Name_Req, Variable_Ref); 8022 8023 -- An IF expression is side effect free if it's of a scalar type, and 8024 -- all its components are all side effect free (conditions and then 8025 -- actions and else actions). We restrict to scalar types, since it 8026 -- is annoying to deal with things like (if A then B else C)'First 8027 -- where the type involved is a string type. 8028 8029 when N_If_Expression => 8030 return Is_Scalar_Type (Typ) 8031 and then 8032 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref); 8033 8034 -- An indexed component is side effect free if it is a side 8035 -- effect free prefixed reference and all the indexing 8036 -- expressions are side effect free. 8037 8038 when N_Indexed_Component => 8039 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) 8040 and then Safe_Prefixed_Reference (N); 8041 8042 -- A type qualification is side effect free if the expression 8043 -- is side effect free. 8044 8045 when N_Qualified_Expression => 8046 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); 8047 8048 -- A selected component is side effect free only if it is a side 8049 -- effect free prefixed reference. If it designates a component 8050 -- with a rep. clause it must be treated has having a potential 8051 -- side effect, because it may be modified through a renaming, and 8052 -- a subsequent use of the renaming as a macro will yield the 8053 -- wrong value. This complex interaction between renaming and 8054 -- removing side effects is a reminder that the latter has become 8055 -- a headache to maintain, and that it should be removed in favor 8056 -- of the gcc mechanism to capture values ??? 8057 8058 when N_Selected_Component => 8059 if Nkind (Parent (N)) = N_Explicit_Dereference 8060 and then Has_Non_Standard_Rep (Designated_Type (Typ)) 8061 then 8062 return False; 8063 else 8064 return Safe_Prefixed_Reference (N); 8065 end if; 8066 8067 -- A range is side effect free if the bounds are side effect free 8068 8069 when N_Range => 8070 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref) 8071 and then 8072 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref); 8073 8074 -- A slice is side effect free if it is a side effect free 8075 -- prefixed reference and the bounds are side effect free. 8076 8077 when N_Slice => 8078 return Side_Effect_Free 8079 (Discrete_Range (N), Name_Req, Variable_Ref) 8080 and then Safe_Prefixed_Reference (N); 8081 8082 -- A type conversion is side effect free if the expression to be 8083 -- converted is side effect free. 8084 8085 when N_Type_Conversion => 8086 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); 8087 8088 -- A unary operator is side effect free if the operand 8089 -- is side effect free. 8090 8091 when N_Unary_Op => 8092 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref); 8093 8094 -- An unchecked type conversion is side effect free only if it 8095 -- is safe and its argument is side effect free. 8096 8097 when N_Unchecked_Type_Conversion => 8098 return Safe_Unchecked_Type_Conversion (N) 8099 and then 8100 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); 8101 8102 -- An unchecked expression is side effect free if its expression 8103 -- is side effect free. 8104 8105 when N_Unchecked_Expression => 8106 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); 8107 8108 -- A literal is side effect free 8109 8110 when N_Character_Literal | 8111 N_Integer_Literal | 8112 N_Real_Literal | 8113 N_String_Literal => 8114 return True; 8115 8116 -- We consider that anything else has side effects. This is a bit 8117 -- crude, but we are pretty close for most common cases, and we 8118 -- are certainly correct (i.e. we never return True when the 8119 -- answer should be False). 8120 8121 when others => 8122 return False; 8123 end case; 8124 end Side_Effect_Free; 8125 8126 -- A list is side effect free if all elements of the list are side 8127 -- effect free. 8128 8129 function Side_Effect_Free 8130 (L : List_Id; 8131 Name_Req : Boolean := False; 8132 Variable_Ref : Boolean := False) return Boolean 8133 is 8134 N : Node_Id; 8135 8136 begin 8137 if L = No_List or else L = Error_List then 8138 return True; 8139 8140 else 8141 N := First (L); 8142 while Present (N) loop 8143 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then 8144 return False; 8145 else 8146 Next (N); 8147 end if; 8148 end loop; 8149 8150 return True; 8151 end if; 8152 end Side_Effect_Free; 8153 8154 ---------------------------------- 8155 -- Silly_Boolean_Array_Not_Test -- 8156 ---------------------------------- 8157 8158 -- This procedure implements an odd and silly test. We explicitly check 8159 -- for the case where the 'First of the component type is equal to the 8160 -- 'Last of this component type, and if this is the case, we make sure 8161 -- that constraint error is raised. The reason is that the NOT is bound 8162 -- to cause CE in this case, and we will not otherwise catch it. 8163 8164 -- No such check is required for AND and OR, since for both these cases 8165 -- False op False = False, and True op True = True. For the XOR case, 8166 -- see Silly_Boolean_Array_Xor_Test. 8167 8168 -- Believe it or not, this was reported as a bug. Note that nearly always, 8169 -- the test will evaluate statically to False, so the code will be 8170 -- statically removed, and no extra overhead caused. 8171 8172 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is 8173 Loc : constant Source_Ptr := Sloc (N); 8174 CT : constant Entity_Id := Component_Type (T); 8175 8176 begin 8177 -- The check we install is 8178 8179 -- constraint_error when 8180 -- component_type'first = component_type'last 8181 -- and then array_type'Length /= 0) 8182 8183 -- We need the last guard because we don't want to raise CE for empty 8184 -- arrays since no out of range values result. (Empty arrays with a 8185 -- component type of True .. True -- very useful -- even the ACATS 8186 -- does not test that marginal case). 8187 8188 Insert_Action (N, 8189 Make_Raise_Constraint_Error (Loc, 8190 Condition => 8191 Make_And_Then (Loc, 8192 Left_Opnd => 8193 Make_Op_Eq (Loc, 8194 Left_Opnd => 8195 Make_Attribute_Reference (Loc, 8196 Prefix => New_Occurrence_Of (CT, Loc), 8197 Attribute_Name => Name_First), 8198 8199 Right_Opnd => 8200 Make_Attribute_Reference (Loc, 8201 Prefix => New_Occurrence_Of (CT, Loc), 8202 Attribute_Name => Name_Last)), 8203 8204 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))), 8205 Reason => CE_Range_Check_Failed)); 8206 end Silly_Boolean_Array_Not_Test; 8207 8208 ---------------------------------- 8209 -- Silly_Boolean_Array_Xor_Test -- 8210 ---------------------------------- 8211 8212 -- This procedure implements an odd and silly test. We explicitly check 8213 -- for the XOR case where the component type is True .. True, since this 8214 -- will raise constraint error. A special check is required since CE 8215 -- will not be generated otherwise (cf Expand_Packed_Not). 8216 8217 -- No such check is required for AND and OR, since for both these cases 8218 -- False op False = False, and True op True = True, and no check is 8219 -- required for the case of False .. False, since False xor False = False. 8220 -- See also Silly_Boolean_Array_Not_Test 8221 8222 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is 8223 Loc : constant Source_Ptr := Sloc (N); 8224 CT : constant Entity_Id := Component_Type (T); 8225 8226 begin 8227 -- The check we install is 8228 8229 -- constraint_error when 8230 -- Boolean (component_type'First) 8231 -- and then Boolean (component_type'Last) 8232 -- and then array_type'Length /= 0) 8233 8234 -- We need the last guard because we don't want to raise CE for empty 8235 -- arrays since no out of range values result (Empty arrays with a 8236 -- component type of True .. True -- very useful -- even the ACATS 8237 -- does not test that marginal case). 8238 8239 Insert_Action (N, 8240 Make_Raise_Constraint_Error (Loc, 8241 Condition => 8242 Make_And_Then (Loc, 8243 Left_Opnd => 8244 Make_And_Then (Loc, 8245 Left_Opnd => 8246 Convert_To (Standard_Boolean, 8247 Make_Attribute_Reference (Loc, 8248 Prefix => New_Occurrence_Of (CT, Loc), 8249 Attribute_Name => Name_First)), 8250 8251 Right_Opnd => 8252 Convert_To (Standard_Boolean, 8253 Make_Attribute_Reference (Loc, 8254 Prefix => New_Occurrence_Of (CT, Loc), 8255 Attribute_Name => Name_Last))), 8256 8257 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))), 8258 Reason => CE_Range_Check_Failed)); 8259 end Silly_Boolean_Array_Xor_Test; 8260 8261 -------------------------- 8262 -- Target_Has_Fixed_Ops -- 8263 -------------------------- 8264 8265 Integer_Sized_Small : Ureal; 8266 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is 8267 -- called (we don't want to compute it more than once). 8268 8269 Long_Integer_Sized_Small : Ureal; 8270 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function 8271 -- is called (we don't want to compute it more than once) 8272 8273 First_Time_For_THFO : Boolean := True; 8274 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) 8275 8276 function Target_Has_Fixed_Ops 8277 (Left_Typ : Entity_Id; 8278 Right_Typ : Entity_Id; 8279 Result_Typ : Entity_Id) return Boolean 8280 is 8281 function Is_Fractional_Type (Typ : Entity_Id) return Boolean; 8282 -- Return True if the given type is a fixed-point type with a small 8283 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have 8284 -- an absolute value less than 1.0. This is currently limited to 8285 -- fixed-point types that map to Integer or Long_Integer. 8286 8287 ------------------------ 8288 -- Is_Fractional_Type -- 8289 ------------------------ 8290 8291 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is 8292 begin 8293 if Esize (Typ) = Standard_Integer_Size then 8294 return Small_Value (Typ) = Integer_Sized_Small; 8295 8296 elsif Esize (Typ) = Standard_Long_Integer_Size then 8297 return Small_Value (Typ) = Long_Integer_Sized_Small; 8298 8299 else 8300 return False; 8301 end if; 8302 end Is_Fractional_Type; 8303 8304 -- Start of processing for Target_Has_Fixed_Ops 8305 8306 begin 8307 -- Return False if Fractional_Fixed_Ops_On_Target is false 8308 8309 if not Fractional_Fixed_Ops_On_Target then 8310 return False; 8311 end if; 8312 8313 -- Here the target has Fractional_Fixed_Ops, if first time, compute 8314 -- standard constants used by Is_Fractional_Type. 8315 8316 if First_Time_For_THFO then 8317 First_Time_For_THFO := False; 8318 8319 Integer_Sized_Small := 8320 UR_From_Components 8321 (Num => Uint_1, 8322 Den => UI_From_Int (Standard_Integer_Size - 1), 8323 Rbase => 2); 8324 8325 Long_Integer_Sized_Small := 8326 UR_From_Components 8327 (Num => Uint_1, 8328 Den => UI_From_Int (Standard_Long_Integer_Size - 1), 8329 Rbase => 2); 8330 end if; 8331 8332 -- Return True if target supports fixed-by-fixed multiply/divide for 8333 -- fractional fixed-point types (see Is_Fractional_Type) and the operand 8334 -- and result types are equivalent fractional types. 8335 8336 return Is_Fractional_Type (Base_Type (Left_Typ)) 8337 and then Is_Fractional_Type (Base_Type (Right_Typ)) 8338 and then Is_Fractional_Type (Base_Type (Result_Typ)) 8339 and then Esize (Left_Typ) = Esize (Right_Typ) 8340 and then Esize (Left_Typ) = Esize (Result_Typ); 8341 end Target_Has_Fixed_Ops; 8342 8343 ------------------------------------------ 8344 -- Type_May_Have_Bit_Aligned_Components -- 8345 ------------------------------------------ 8346 8347 function Type_May_Have_Bit_Aligned_Components 8348 (Typ : Entity_Id) return Boolean 8349 is 8350 begin 8351 -- Array type, check component type 8352 8353 if Is_Array_Type (Typ) then 8354 return 8355 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)); 8356 8357 -- Record type, check components 8358 8359 elsif Is_Record_Type (Typ) then 8360 declare 8361 E : Entity_Id; 8362 8363 begin 8364 E := First_Component_Or_Discriminant (Typ); 8365 while Present (E) loop 8366 if Component_May_Be_Bit_Aligned (E) 8367 or else Type_May_Have_Bit_Aligned_Components (Etype (E)) 8368 then 8369 return True; 8370 end if; 8371 8372 Next_Component_Or_Discriminant (E); 8373 end loop; 8374 8375 return False; 8376 end; 8377 8378 -- Type other than array or record is always OK 8379 8380 else 8381 return False; 8382 end if; 8383 end Type_May_Have_Bit_Aligned_Components; 8384 8385 ---------------------------------- 8386 -- Within_Case_Or_If_Expression -- 8387 ---------------------------------- 8388 8389 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is 8390 Par : Node_Id; 8391 8392 begin 8393 -- Locate an enclosing case or if expression. Note that these constructs 8394 -- can be expanded into Expression_With_Actions, hence the test of the 8395 -- original node. 8396 8397 Par := Parent (N); 8398 while Present (Par) loop 8399 if Nkind_In (Original_Node (Par), N_Case_Expression, 8400 N_If_Expression) 8401 then 8402 return True; 8403 8404 -- Prevent the search from going too far 8405 8406 elsif Is_Body_Or_Package_Declaration (Par) then 8407 return False; 8408 end if; 8409 8410 Par := Parent (Par); 8411 end loop; 8412 8413 return False; 8414 end Within_Case_Or_If_Expression; 8415 8416 -------------------------------- 8417 -- Within_Internal_Subprogram -- 8418 -------------------------------- 8419 8420 function Within_Internal_Subprogram return Boolean is 8421 S : Entity_Id; 8422 8423 begin 8424 S := Current_Scope; 8425 while Present (S) and then not Is_Subprogram (S) loop 8426 S := Scope (S); 8427 end loop; 8428 8429 return Present (S) 8430 and then Get_TSS_Name (S) /= TSS_Null 8431 and then not Is_Predicate_Function (S); 8432 end Within_Internal_Subprogram; 8433 8434 ---------------------------- 8435 -- Wrap_Cleanup_Procedure -- 8436 ---------------------------- 8437 8438 procedure Wrap_Cleanup_Procedure (N : Node_Id) is 8439 Loc : constant Source_Ptr := Sloc (N); 8440 Stseq : constant Node_Id := Handled_Statement_Sequence (N); 8441 Stmts : constant List_Id := Statements (Stseq); 8442 8443 begin 8444 if Abort_Allowed then 8445 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 8446 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 8447 end if; 8448 end Wrap_Cleanup_Procedure; 8449 8450end Exp_Util; 8451