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