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