1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2014, 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 Elists; use Elists; 32with Errout; use Errout; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Disp; use Exp_Disp; 35with Exp_Util; use Exp_Util; 36with Fname; use Fname; 37with Freeze; use Freeze; 38with Lib; use Lib; 39with Lib.Xref; use Lib.Xref; 40with Namet.Sp; use Namet.Sp; 41with Nlists; use Nlists; 42with Nmake; use Nmake; 43with Output; use Output; 44with Opt; use Opt; 45with Restrict; use Restrict; 46with Rident; use Rident; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Aux; use Sem_Aux; 50with Sem_Attr; use Sem_Attr; 51with Sem_Ch8; use Sem_Ch8; 52with Sem_Disp; use Sem_Disp; 53with Sem_Eval; use Sem_Eval; 54with Sem_Prag; use Sem_Prag; 55with Sem_Res; use Sem_Res; 56with Sem_Type; use Sem_Type; 57with Sinfo; use Sinfo; 58with Sinput; use Sinput; 59with Stand; use Stand; 60with Style; 61with Stringt; use Stringt; 62with Targparm; use Targparm; 63with Tbuild; use Tbuild; 64with Ttypes; use Ttypes; 65with Uname; use Uname; 66 67with GNAT.HTable; use GNAT.HTable; 68 69package body Sem_Util is 70 71 ---------------------------------------- 72 -- Global_Variables for New_Copy_Tree -- 73 ---------------------------------------- 74 75 -- These global variables are used by New_Copy_Tree. See description 76 -- of the body of this subprogram for details. Global variables can be 77 -- safely used by New_Copy_Tree, since there is no case of a recursive 78 -- call from the processing inside New_Copy_Tree. 79 80 NCT_Hash_Threshold : constant := 20; 81 -- If there are more than this number of pairs of entries in the 82 -- map, then Hash_Tables_Used will be set, and the hash tables will 83 -- be initialized and used for the searches. 84 85 NCT_Hash_Tables_Used : Boolean := False; 86 -- Set to True if hash tables are in use 87 88 NCT_Table_Entries : Nat := 0; 89 -- Count entries in table to see if threshold is reached 90 91 NCT_Hash_Table_Setup : Boolean := False; 92 -- Set to True if hash table contains data. We set this True if we 93 -- setup the hash table with data, and leave it set permanently 94 -- from then on, this is a signal that second and subsequent users 95 -- of the hash table must clear the old entries before reuse. 96 97 subtype NCT_Header_Num is Int range 0 .. 511; 98 -- Defines range of headers in hash tables (512 headers) 99 100 ----------------------- 101 -- Local Subprograms -- 102 ----------------------- 103 104 function Build_Component_Subtype 105 (C : List_Id; 106 Loc : Source_Ptr; 107 T : Entity_Id) return Node_Id; 108 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 109 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 110 -- Loc is the source location, T is the original subtype. 111 112 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 113 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 114 -- with discriminants whose default values are static, examine only the 115 -- components in the selected variant to determine whether all of them 116 -- have a default. 117 118 function Has_Enabled_Property 119 (Item_Id : Entity_Id; 120 Property : Name_Id) return Boolean; 121 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 122 -- Determine whether an abstract state or a variable denoted by entity 123 -- Item_Id has enabled property Property. 124 125 function Has_Null_Extension (T : Entity_Id) return Boolean; 126 -- T is a derived tagged type. Check whether the type extension is null. 127 -- If the parent type is fully initialized, T can be treated as such. 128 129 ------------------------------ 130 -- Abstract_Interface_List -- 131 ------------------------------ 132 133 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 134 Nod : Node_Id; 135 136 begin 137 if Is_Concurrent_Type (Typ) then 138 139 -- If we are dealing with a synchronized subtype, go to the base 140 -- type, whose declaration has the interface list. 141 142 -- Shouldn't this be Declaration_Node??? 143 144 Nod := Parent (Base_Type (Typ)); 145 146 if Nkind (Nod) = N_Full_Type_Declaration then 147 return Empty_List; 148 end if; 149 150 elsif Ekind (Typ) = E_Record_Type_With_Private then 151 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 152 Nod := Type_Definition (Parent (Typ)); 153 154 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 155 if Present (Full_View (Typ)) 156 and then Nkind (Parent (Full_View (Typ))) 157 = N_Full_Type_Declaration 158 then 159 Nod := Type_Definition (Parent (Full_View (Typ))); 160 161 -- If the full-view is not available we cannot do anything else 162 -- here (the source has errors). 163 164 else 165 return Empty_List; 166 end if; 167 168 -- Support for generic formals with interfaces is still missing ??? 169 170 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 171 return Empty_List; 172 173 else 174 pragma Assert 175 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 176 Nod := Parent (Typ); 177 end if; 178 179 elsif Ekind (Typ) = E_Record_Subtype then 180 Nod := Type_Definition (Parent (Etype (Typ))); 181 182 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 183 184 -- Recurse, because parent may still be a private extension. Also 185 -- note that the full view of the subtype or the full view of its 186 -- base type may (both) be unavailable. 187 188 return Abstract_Interface_List (Etype (Typ)); 189 190 else pragma Assert ((Ekind (Typ)) = E_Record_Type); 191 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 192 Nod := Formal_Type_Definition (Parent (Typ)); 193 else 194 Nod := Type_Definition (Parent (Typ)); 195 end if; 196 end if; 197 198 return Interface_List (Nod); 199 end Abstract_Interface_List; 200 201 -------------------------------- 202 -- Add_Access_Type_To_Process -- 203 -------------------------------- 204 205 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 206 L : Elist_Id; 207 208 begin 209 Ensure_Freeze_Node (E); 210 L := Access_Types_To_Process (Freeze_Node (E)); 211 212 if No (L) then 213 L := New_Elmt_List; 214 Set_Access_Types_To_Process (Freeze_Node (E), L); 215 end if; 216 217 Append_Elmt (A, L); 218 end Add_Access_Type_To_Process; 219 220 -------------------------- 221 -- Add_Block_Identifier -- 222 -------------------------- 223 224 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 225 Loc : constant Source_Ptr := Sloc (N); 226 227 begin 228 pragma Assert (Nkind (N) = N_Block_Statement); 229 230 -- The block already has a label, return its entity 231 232 if Present (Identifier (N)) then 233 Id := Entity (Identifier (N)); 234 235 -- Create a new block label and set its attributes 236 237 else 238 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 239 Set_Etype (Id, Standard_Void_Type); 240 Set_Parent (Id, N); 241 242 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 243 Set_Block_Node (Id, Identifier (N)); 244 end if; 245 end Add_Block_Identifier; 246 247 ----------------------- 248 -- Add_Contract_Item -- 249 ----------------------- 250 251 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is 252 Items : constant Node_Id := Contract (Id); 253 Nam : Name_Id; 254 N : Node_Id; 255 256 begin 257 -- The related context must have a contract and the item to be added 258 -- must be a pragma. 259 260 pragma Assert (Present (Items)); 261 pragma Assert (Nkind (Prag) = N_Pragma); 262 263 Nam := Original_Aspect_Name (Prag); 264 265 -- Contract items related to [generic] packages or instantiations. The 266 -- applicable pragmas are: 267 -- Abstract_States 268 -- Initial_Condition 269 -- Initializes 270 -- Part_Of (instantiation only) 271 272 if Ekind_In (Id, E_Generic_Package, E_Package) then 273 if Nam_In (Nam, Name_Abstract_State, 274 Name_Initial_Condition, 275 Name_Initializes) 276 then 277 Set_Next_Pragma (Prag, Classifications (Items)); 278 Set_Classifications (Items, Prag); 279 280 -- Indicator Part_Of must be associated with a package instantiation 281 282 elsif Nam = Name_Part_Of and then Is_Generic_Instance (Id) then 283 Set_Next_Pragma (Prag, Classifications (Items)); 284 Set_Classifications (Items, Prag); 285 286 -- The pragma is not a proper contract item 287 288 else 289 raise Program_Error; 290 end if; 291 292 -- Contract items related to package bodies. The applicable pragmas are: 293 -- Refined_States 294 295 elsif Ekind (Id) = E_Package_Body then 296 if Nam = Name_Refined_State then 297 Set_Next_Pragma (Prag, Classifications (Items)); 298 Set_Classifications (Items, Prag); 299 300 -- The pragma is not a proper contract item 301 302 else 303 raise Program_Error; 304 end if; 305 306 -- Contract items related to subprogram or entry declarations. The 307 -- applicable pragmas are: 308 -- Contract_Cases 309 -- Depends 310 -- Global 311 -- Post 312 -- Postcondition 313 -- Pre 314 -- Precondition 315 -- Test_Case 316 317 elsif Ekind_In (Id, E_Entry, E_Entry_Family) 318 or else Is_Generic_Subprogram (Id) 319 or else Is_Subprogram (Id) 320 then 321 if Nam_In (Nam, Name_Precondition, 322 Name_Postcondition, 323 Name_Pre, 324 Name_Post, 325 Name_uPre, 326 Name_uPost) 327 then 328 -- Before we add a precondition or postcondition to the list, 329 -- make sure we do not have a disallowed duplicate, which can 330 -- happen if we use a pragma for Pre[_Class] or Post[_Class] 331 -- instead of the corresponding aspect. 332 333 if not From_Aspect_Specification (Prag) 334 and then Nam_In (Nam, Name_Pre_Class, 335 Name_Pre, 336 Name_uPre, 337 Name_Post_Class, 338 Name_Post, 339 Name_uPost) 340 then 341 N := Pre_Post_Conditions (Items); 342 while Present (N) loop 343 if not Split_PPC (N) 344 and then Original_Aspect_Name (N) = Nam 345 then 346 Error_Msg_Sloc := Sloc (N); 347 Error_Msg_NE 348 ("duplication of aspect for & given#", Prag, Id); 349 return; 350 else 351 N := Next_Pragma (N); 352 end if; 353 end loop; 354 end if; 355 356 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); 357 Set_Pre_Post_Conditions (Items, Prag); 358 359 elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then 360 Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); 361 Set_Contract_Test_Cases (Items, Prag); 362 363 elsif Nam_In (Nam, Name_Depends, Name_Global) then 364 Set_Next_Pragma (Prag, Classifications (Items)); 365 Set_Classifications (Items, Prag); 366 367 -- The pragma is not a proper contract item 368 369 else 370 raise Program_Error; 371 end if; 372 373 -- Contract items related to subprogram bodies. The applicable pragmas 374 -- are: 375 -- Refined_Depends 376 -- Refined_Global 377 -- Refined_Post 378 379 elsif Ekind (Id) = E_Subprogram_Body then 380 if Nam = Name_Refined_Post then 381 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); 382 Set_Pre_Post_Conditions (Items, Prag); 383 384 elsif Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then 385 Set_Next_Pragma (Prag, Classifications (Items)); 386 Set_Classifications (Items, Prag); 387 388 -- The pragma is not a proper contract item 389 390 else 391 raise Program_Error; 392 end if; 393 394 -- Contract items related to variables. The applicable pragmas are: 395 -- Async_Readers 396 -- Async_Writers 397 -- Effective_Reads 398 -- Effective_Writes 399 -- Part_Of 400 401 elsif Ekind (Id) = E_Variable then 402 if Nam_In (Nam, Name_Async_Readers, 403 Name_Async_Writers, 404 Name_Effective_Reads, 405 Name_Effective_Writes, 406 Name_Part_Of) 407 then 408 Set_Next_Pragma (Prag, Classifications (Items)); 409 Set_Classifications (Items, Prag); 410 411 -- The pragma is not a proper contract item 412 413 else 414 raise Program_Error; 415 end if; 416 end if; 417 end Add_Contract_Item; 418 419 ---------------------------- 420 -- Add_Global_Declaration -- 421 ---------------------------- 422 423 procedure Add_Global_Declaration (N : Node_Id) is 424 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 425 426 begin 427 if No (Declarations (Aux_Node)) then 428 Set_Declarations (Aux_Node, New_List); 429 end if; 430 431 Append_To (Declarations (Aux_Node), N); 432 Analyze (N); 433 end Add_Global_Declaration; 434 435 -------------------------------- 436 -- Address_Integer_Convert_OK -- 437 -------------------------------- 438 439 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 440 begin 441 if Allow_Integer_Address 442 and then ((Is_Descendent_Of_Address (T1) 443 and then Is_Private_Type (T1) 444 and then Is_Integer_Type (T2)) 445 or else 446 (Is_Descendent_Of_Address (T2) 447 and then Is_Private_Type (T2) 448 and then Is_Integer_Type (T1))) 449 then 450 return True; 451 else 452 return False; 453 end if; 454 end Address_Integer_Convert_OK; 455 456 ----------------- 457 -- Addressable -- 458 ----------------- 459 460 -- For now, just 8/16/32/64. but analyze later if AAMP is special??? 461 462 function Addressable (V : Uint) return Boolean is 463 begin 464 return V = Uint_8 or else 465 V = Uint_16 or else 466 V = Uint_32 or else 467 V = Uint_64; 468 end Addressable; 469 470 function Addressable (V : Int) return Boolean is 471 begin 472 return V = 8 or else 473 V = 16 or else 474 V = 32 or else 475 V = 64; 476 end Addressable; 477 478 ----------------------- 479 -- Alignment_In_Bits -- 480 ----------------------- 481 482 function Alignment_In_Bits (E : Entity_Id) return Uint is 483 begin 484 return Alignment (E) * System_Storage_Unit; 485 end Alignment_In_Bits; 486 487 --------------------------------- 488 -- Append_Inherited_Subprogram -- 489 --------------------------------- 490 491 procedure Append_Inherited_Subprogram (S : Entity_Id) is 492 Par : constant Entity_Id := Alias (S); 493 -- The parent subprogram 494 495 Scop : constant Entity_Id := Scope (Par); 496 -- The scope of definition of the parent subprogram 497 498 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 499 -- The derived type of which S is a primitive operation 500 501 Decl : Node_Id; 502 Next_E : Entity_Id; 503 504 begin 505 if Ekind (Current_Scope) = E_Package 506 and then In_Private_Part (Current_Scope) 507 and then Has_Private_Declaration (Typ) 508 and then Is_Tagged_Type (Typ) 509 and then Scop = Current_Scope 510 then 511 -- The inherited operation is available at the earliest place after 512 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only 513 -- relevant for type extensions. If the parent operation appears 514 -- after the type extension, the operation is not visible. 515 516 Decl := First 517 (Visible_Declarations 518 (Package_Specification (Current_Scope))); 519 while Present (Decl) loop 520 if Nkind (Decl) = N_Private_Extension_Declaration 521 and then Defining_Entity (Decl) = Typ 522 then 523 if Sloc (Decl) > Sloc (Par) then 524 Next_E := Next_Entity (Par); 525 Set_Next_Entity (Par, S); 526 Set_Next_Entity (S, Next_E); 527 return; 528 529 else 530 exit; 531 end if; 532 end if; 533 534 Next (Decl); 535 end loop; 536 end if; 537 538 -- If partial view is not a type extension, or it appears before the 539 -- subprogram declaration, insert normally at end of entity list. 540 541 Append_Entity (S, Current_Scope); 542 end Append_Inherited_Subprogram; 543 544 ----------------------------------------- 545 -- Apply_Compile_Time_Constraint_Error -- 546 ----------------------------------------- 547 548 procedure Apply_Compile_Time_Constraint_Error 549 (N : Node_Id; 550 Msg : String; 551 Reason : RT_Exception_Code; 552 Ent : Entity_Id := Empty; 553 Typ : Entity_Id := Empty; 554 Loc : Source_Ptr := No_Location; 555 Rep : Boolean := True; 556 Warn : Boolean := False) 557 is 558 Stat : constant Boolean := Is_Static_Expression (N); 559 R_Stat : constant Node_Id := 560 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 561 Rtyp : Entity_Id; 562 563 begin 564 if No (Typ) then 565 Rtyp := Etype (N); 566 else 567 Rtyp := Typ; 568 end if; 569 570 Discard_Node 571 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 572 573 if not Rep then 574 return; 575 end if; 576 577 -- Now we replace the node by an N_Raise_Constraint_Error node 578 -- This does not need reanalyzing, so set it as analyzed now. 579 580 Rewrite (N, R_Stat); 581 Set_Analyzed (N, True); 582 583 Set_Etype (N, Rtyp); 584 Set_Raises_Constraint_Error (N); 585 586 -- Now deal with possible local raise handling 587 588 Possible_Local_Raise (N, Standard_Constraint_Error); 589 590 -- If the original expression was marked as static, the result is 591 -- still marked as static, but the Raises_Constraint_Error flag is 592 -- always set so that further static evaluation is not attempted. 593 594 if Stat then 595 Set_Is_Static_Expression (N); 596 end if; 597 end Apply_Compile_Time_Constraint_Error; 598 599 --------------------------- 600 -- Async_Readers_Enabled -- 601 --------------------------- 602 603 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 604 begin 605 return Has_Enabled_Property (Id, Name_Async_Readers); 606 end Async_Readers_Enabled; 607 608 --------------------------- 609 -- Async_Writers_Enabled -- 610 --------------------------- 611 612 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 613 begin 614 return Has_Enabled_Property (Id, Name_Async_Writers); 615 end Async_Writers_Enabled; 616 617 -------------------------------------- 618 -- Available_Full_View_Of_Component -- 619 -------------------------------------- 620 621 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 622 ST : constant Entity_Id := Scope (T); 623 SCT : constant Entity_Id := Scope (Component_Type (T)); 624 begin 625 return In_Open_Scopes (ST) 626 and then In_Open_Scopes (SCT) 627 and then Scope_Depth (ST) >= Scope_Depth (SCT); 628 end Available_Full_View_Of_Component; 629 630 ------------------- 631 -- Bad_Attribute -- 632 ------------------- 633 634 procedure Bad_Attribute 635 (N : Node_Id; 636 Nam : Name_Id; 637 Warn : Boolean := False) 638 is 639 begin 640 Error_Msg_Warn := Warn; 641 Error_Msg_N ("unrecognized attribute&<", N); 642 643 -- Check for possible misspelling 644 645 Error_Msg_Name_1 := First_Attribute_Name; 646 while Error_Msg_Name_1 <= Last_Attribute_Name loop 647 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 648 Error_Msg_N -- CODEFIX 649 ("\possible misspelling of %<", N); 650 exit; 651 end if; 652 653 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 654 end loop; 655 end Bad_Attribute; 656 657 -------------------------------- 658 -- Bad_Predicated_Subtype_Use -- 659 -------------------------------- 660 661 procedure Bad_Predicated_Subtype_Use 662 (Msg : String; 663 N : Node_Id; 664 Typ : Entity_Id; 665 Suggest_Static : Boolean := False) 666 is 667 begin 668 if Has_Predicates (Typ) then 669 if Is_Generic_Actual_Type (Typ) then 670 Error_Msg_Warn := SPARK_Mode /= On; 671 Error_Msg_FE (Msg & "<<", N, Typ); 672 Error_Msg_F ("\Program_Error [<<", N); 673 Insert_Action (N, 674 Make_Raise_Program_Error (Sloc (N), 675 Reason => PE_Bad_Predicated_Generic_Type)); 676 677 else 678 Error_Msg_FE (Msg, N, Typ); 679 end if; 680 681 -- Emit an optional suggestion on how to remedy the error if the 682 -- context warrants it. 683 684 if Suggest_Static and then Present (Static_Predicate (Typ)) then 685 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 686 end if; 687 end if; 688 end Bad_Predicated_Subtype_Use; 689 690 ---------------------------------------- 691 -- Bad_Unordered_Enumeration_Reference -- 692 ---------------------------------------- 693 694 function Bad_Unordered_Enumeration_Reference 695 (N : Node_Id; 696 T : Entity_Id) return Boolean 697 is 698 begin 699 return Is_Enumeration_Type (T) 700 and then Comes_From_Source (N) 701 and then Warn_On_Unordered_Enumeration_Type 702 and then not Has_Pragma_Ordered (T) 703 and then not In_Same_Extended_Unit (N, T); 704 end Bad_Unordered_Enumeration_Reference; 705 706 -------------------------- 707 -- Build_Actual_Subtype -- 708 -------------------------- 709 710 function Build_Actual_Subtype 711 (T : Entity_Id; 712 N : Node_Or_Entity_Id) return Node_Id 713 is 714 Loc : Source_Ptr; 715 -- Normally Sloc (N), but may point to corresponding body in some cases 716 717 Constraints : List_Id; 718 Decl : Node_Id; 719 Discr : Entity_Id; 720 Hi : Node_Id; 721 Lo : Node_Id; 722 Subt : Entity_Id; 723 Disc_Type : Entity_Id; 724 Obj : Node_Id; 725 726 begin 727 Loc := Sloc (N); 728 729 if Nkind (N) = N_Defining_Identifier then 730 Obj := New_Occurrence_Of (N, Loc); 731 732 -- If this is a formal parameter of a subprogram declaration, and 733 -- we are compiling the body, we want the declaration for the 734 -- actual subtype to carry the source position of the body, to 735 -- prevent anomalies in gdb when stepping through the code. 736 737 if Is_Formal (N) then 738 declare 739 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 740 begin 741 if Nkind (Decl) = N_Subprogram_Declaration 742 and then Present (Corresponding_Body (Decl)) 743 then 744 Loc := Sloc (Corresponding_Body (Decl)); 745 end if; 746 end; 747 end if; 748 749 else 750 Obj := N; 751 end if; 752 753 if Is_Array_Type (T) then 754 Constraints := New_List; 755 for J in 1 .. Number_Dimensions (T) loop 756 757 -- Build an array subtype declaration with the nominal subtype and 758 -- the bounds of the actual. Add the declaration in front of the 759 -- local declarations for the subprogram, for analysis before any 760 -- reference to the formal in the body. 761 762 Lo := 763 Make_Attribute_Reference (Loc, 764 Prefix => 765 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 766 Attribute_Name => Name_First, 767 Expressions => New_List ( 768 Make_Integer_Literal (Loc, J))); 769 770 Hi := 771 Make_Attribute_Reference (Loc, 772 Prefix => 773 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 774 Attribute_Name => Name_Last, 775 Expressions => New_List ( 776 Make_Integer_Literal (Loc, J))); 777 778 Append (Make_Range (Loc, Lo, Hi), Constraints); 779 end loop; 780 781 -- If the type has unknown discriminants there is no constrained 782 -- subtype to build. This is never called for a formal or for a 783 -- lhs, so returning the type is ok ??? 784 785 elsif Has_Unknown_Discriminants (T) then 786 return T; 787 788 else 789 Constraints := New_List; 790 791 -- Type T is a generic derived type, inherit the discriminants from 792 -- the parent type. 793 794 if Is_Private_Type (T) 795 and then No (Full_View (T)) 796 797 -- T was flagged as an error if it was declared as a formal 798 -- derived type with known discriminants. In this case there 799 -- is no need to look at the parent type since T already carries 800 -- its own discriminants. 801 802 and then not Error_Posted (T) 803 then 804 Disc_Type := Etype (Base_Type (T)); 805 else 806 Disc_Type := T; 807 end if; 808 809 Discr := First_Discriminant (Disc_Type); 810 while Present (Discr) loop 811 Append_To (Constraints, 812 Make_Selected_Component (Loc, 813 Prefix => 814 Duplicate_Subexpr_No_Checks (Obj), 815 Selector_Name => New_Occurrence_Of (Discr, Loc))); 816 Next_Discriminant (Discr); 817 end loop; 818 end if; 819 820 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 821 Set_Is_Internal (Subt); 822 823 Decl := 824 Make_Subtype_Declaration (Loc, 825 Defining_Identifier => Subt, 826 Subtype_Indication => 827 Make_Subtype_Indication (Loc, 828 Subtype_Mark => New_Occurrence_Of (T, Loc), 829 Constraint => 830 Make_Index_Or_Discriminant_Constraint (Loc, 831 Constraints => Constraints))); 832 833 Mark_Rewrite_Insertion (Decl); 834 return Decl; 835 end Build_Actual_Subtype; 836 837 --------------------------------------- 838 -- Build_Actual_Subtype_Of_Component -- 839 --------------------------------------- 840 841 function Build_Actual_Subtype_Of_Component 842 (T : Entity_Id; 843 N : Node_Id) return Node_Id 844 is 845 Loc : constant Source_Ptr := Sloc (N); 846 P : constant Node_Id := Prefix (N); 847 D : Elmt_Id; 848 Id : Node_Id; 849 Index_Typ : Entity_Id; 850 851 Desig_Typ : Entity_Id; 852 -- This is either a copy of T, or if T is an access type, then it is 853 -- the directly designated type of this access type. 854 855 function Build_Actual_Array_Constraint return List_Id; 856 -- If one or more of the bounds of the component depends on 857 -- discriminants, build actual constraint using the discriminants 858 -- of the prefix. 859 860 function Build_Actual_Record_Constraint return List_Id; 861 -- Similar to previous one, for discriminated components constrained 862 -- by the discriminant of the enclosing object. 863 864 ----------------------------------- 865 -- Build_Actual_Array_Constraint -- 866 ----------------------------------- 867 868 function Build_Actual_Array_Constraint return List_Id is 869 Constraints : constant List_Id := New_List; 870 Indx : Node_Id; 871 Hi : Node_Id; 872 Lo : Node_Id; 873 Old_Hi : Node_Id; 874 Old_Lo : Node_Id; 875 876 begin 877 Indx := First_Index (Desig_Typ); 878 while Present (Indx) loop 879 Old_Lo := Type_Low_Bound (Etype (Indx)); 880 Old_Hi := Type_High_Bound (Etype (Indx)); 881 882 if Denotes_Discriminant (Old_Lo) then 883 Lo := 884 Make_Selected_Component (Loc, 885 Prefix => New_Copy_Tree (P), 886 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 887 888 else 889 Lo := New_Copy_Tree (Old_Lo); 890 891 -- The new bound will be reanalyzed in the enclosing 892 -- declaration. For literal bounds that come from a type 893 -- declaration, the type of the context must be imposed, so 894 -- insure that analysis will take place. For non-universal 895 -- types this is not strictly necessary. 896 897 Set_Analyzed (Lo, False); 898 end if; 899 900 if Denotes_Discriminant (Old_Hi) then 901 Hi := 902 Make_Selected_Component (Loc, 903 Prefix => New_Copy_Tree (P), 904 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 905 906 else 907 Hi := New_Copy_Tree (Old_Hi); 908 Set_Analyzed (Hi, False); 909 end if; 910 911 Append (Make_Range (Loc, Lo, Hi), Constraints); 912 Next_Index (Indx); 913 end loop; 914 915 return Constraints; 916 end Build_Actual_Array_Constraint; 917 918 ------------------------------------ 919 -- Build_Actual_Record_Constraint -- 920 ------------------------------------ 921 922 function Build_Actual_Record_Constraint return List_Id is 923 Constraints : constant List_Id := New_List; 924 D : Elmt_Id; 925 D_Val : Node_Id; 926 927 begin 928 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 929 while Present (D) loop 930 if Denotes_Discriminant (Node (D)) then 931 D_Val := Make_Selected_Component (Loc, 932 Prefix => New_Copy_Tree (P), 933 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 934 935 else 936 D_Val := New_Copy_Tree (Node (D)); 937 end if; 938 939 Append (D_Val, Constraints); 940 Next_Elmt (D); 941 end loop; 942 943 return Constraints; 944 end Build_Actual_Record_Constraint; 945 946 -- Start of processing for Build_Actual_Subtype_Of_Component 947 948 begin 949 -- Why the test for Spec_Expression mode here??? 950 951 if In_Spec_Expression then 952 return Empty; 953 954 -- More comments for the rest of this body would be good ??? 955 956 elsif Nkind (N) = N_Explicit_Dereference then 957 if Is_Composite_Type (T) 958 and then not Is_Constrained (T) 959 and then not (Is_Class_Wide_Type (T) 960 and then Is_Constrained (Root_Type (T))) 961 and then not Has_Unknown_Discriminants (T) 962 then 963 -- If the type of the dereference is already constrained, it is an 964 -- actual subtype. 965 966 if Is_Array_Type (Etype (N)) 967 and then Is_Constrained (Etype (N)) 968 then 969 return Empty; 970 else 971 Remove_Side_Effects (P); 972 return Build_Actual_Subtype (T, N); 973 end if; 974 else 975 return Empty; 976 end if; 977 end if; 978 979 if Ekind (T) = E_Access_Subtype then 980 Desig_Typ := Designated_Type (T); 981 else 982 Desig_Typ := T; 983 end if; 984 985 if Ekind (Desig_Typ) = E_Array_Subtype then 986 Id := First_Index (Desig_Typ); 987 while Present (Id) loop 988 Index_Typ := Underlying_Type (Etype (Id)); 989 990 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 991 or else 992 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 993 then 994 Remove_Side_Effects (P); 995 return 996 Build_Component_Subtype 997 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 998 end if; 999 1000 Next_Index (Id); 1001 end loop; 1002 1003 elsif Is_Composite_Type (Desig_Typ) 1004 and then Has_Discriminants (Desig_Typ) 1005 and then not Has_Unknown_Discriminants (Desig_Typ) 1006 then 1007 if Is_Private_Type (Desig_Typ) 1008 and then No (Discriminant_Constraint (Desig_Typ)) 1009 then 1010 Desig_Typ := Full_View (Desig_Typ); 1011 end if; 1012 1013 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1014 while Present (D) loop 1015 if Denotes_Discriminant (Node (D)) then 1016 Remove_Side_Effects (P); 1017 return 1018 Build_Component_Subtype ( 1019 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 1020 end if; 1021 1022 Next_Elmt (D); 1023 end loop; 1024 end if; 1025 1026 -- If none of the above, the actual and nominal subtypes are the same 1027 1028 return Empty; 1029 end Build_Actual_Subtype_Of_Component; 1030 1031 ----------------------------- 1032 -- Build_Component_Subtype -- 1033 ----------------------------- 1034 1035 function Build_Component_Subtype 1036 (C : List_Id; 1037 Loc : Source_Ptr; 1038 T : Entity_Id) return Node_Id 1039 is 1040 Subt : Entity_Id; 1041 Decl : Node_Id; 1042 1043 begin 1044 -- Unchecked_Union components do not require component subtypes 1045 1046 if Is_Unchecked_Union (T) then 1047 return Empty; 1048 end if; 1049 1050 Subt := Make_Temporary (Loc, 'S'); 1051 Set_Is_Internal (Subt); 1052 1053 Decl := 1054 Make_Subtype_Declaration (Loc, 1055 Defining_Identifier => Subt, 1056 Subtype_Indication => 1057 Make_Subtype_Indication (Loc, 1058 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 1059 Constraint => 1060 Make_Index_Or_Discriminant_Constraint (Loc, 1061 Constraints => C))); 1062 1063 Mark_Rewrite_Insertion (Decl); 1064 return Decl; 1065 end Build_Component_Subtype; 1066 1067 --------------------------- 1068 -- Build_Default_Subtype -- 1069 --------------------------- 1070 1071 function Build_Default_Subtype 1072 (T : Entity_Id; 1073 N : Node_Id) return Entity_Id 1074 is 1075 Loc : constant Source_Ptr := Sloc (N); 1076 Disc : Entity_Id; 1077 1078 Bas : Entity_Id; 1079 -- The base type that is to be constrained by the defaults 1080 1081 begin 1082 if not Has_Discriminants (T) or else Is_Constrained (T) then 1083 return T; 1084 end if; 1085 1086 Bas := Base_Type (T); 1087 1088 -- If T is non-private but its base type is private, this is the 1089 -- completion of a subtype declaration whose parent type is private 1090 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 1091 -- are to be found in the full view of the base. 1092 1093 if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then 1094 Bas := Full_View (Bas); 1095 end if; 1096 1097 Disc := First_Discriminant (T); 1098 1099 if No (Discriminant_Default_Value (Disc)) then 1100 return T; 1101 end if; 1102 1103 declare 1104 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 1105 Constraints : constant List_Id := New_List; 1106 Decl : Node_Id; 1107 1108 begin 1109 while Present (Disc) loop 1110 Append_To (Constraints, 1111 New_Copy_Tree (Discriminant_Default_Value (Disc))); 1112 Next_Discriminant (Disc); 1113 end loop; 1114 1115 Decl := 1116 Make_Subtype_Declaration (Loc, 1117 Defining_Identifier => Act, 1118 Subtype_Indication => 1119 Make_Subtype_Indication (Loc, 1120 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 1121 Constraint => 1122 Make_Index_Or_Discriminant_Constraint (Loc, 1123 Constraints => Constraints))); 1124 1125 Insert_Action (N, Decl); 1126 Analyze (Decl); 1127 return Act; 1128 end; 1129 end Build_Default_Subtype; 1130 1131 -------------------------------------------- 1132 -- Build_Discriminal_Subtype_Of_Component -- 1133 -------------------------------------------- 1134 1135 function Build_Discriminal_Subtype_Of_Component 1136 (T : Entity_Id) return Node_Id 1137 is 1138 Loc : constant Source_Ptr := Sloc (T); 1139 D : Elmt_Id; 1140 Id : Node_Id; 1141 1142 function Build_Discriminal_Array_Constraint return List_Id; 1143 -- If one or more of the bounds of the component depends on 1144 -- discriminants, build actual constraint using the discriminants 1145 -- of the prefix. 1146 1147 function Build_Discriminal_Record_Constraint return List_Id; 1148 -- Similar to previous one, for discriminated components constrained by 1149 -- the discriminant of the enclosing object. 1150 1151 ---------------------------------------- 1152 -- Build_Discriminal_Array_Constraint -- 1153 ---------------------------------------- 1154 1155 function Build_Discriminal_Array_Constraint return List_Id is 1156 Constraints : constant List_Id := New_List; 1157 Indx : Node_Id; 1158 Hi : Node_Id; 1159 Lo : Node_Id; 1160 Old_Hi : Node_Id; 1161 Old_Lo : Node_Id; 1162 1163 begin 1164 Indx := First_Index (T); 1165 while Present (Indx) loop 1166 Old_Lo := Type_Low_Bound (Etype (Indx)); 1167 Old_Hi := Type_High_Bound (Etype (Indx)); 1168 1169 if Denotes_Discriminant (Old_Lo) then 1170 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 1171 1172 else 1173 Lo := New_Copy_Tree (Old_Lo); 1174 end if; 1175 1176 if Denotes_Discriminant (Old_Hi) then 1177 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 1178 1179 else 1180 Hi := New_Copy_Tree (Old_Hi); 1181 end if; 1182 1183 Append (Make_Range (Loc, Lo, Hi), Constraints); 1184 Next_Index (Indx); 1185 end loop; 1186 1187 return Constraints; 1188 end Build_Discriminal_Array_Constraint; 1189 1190 ----------------------------------------- 1191 -- Build_Discriminal_Record_Constraint -- 1192 ----------------------------------------- 1193 1194 function Build_Discriminal_Record_Constraint return List_Id is 1195 Constraints : constant List_Id := New_List; 1196 D : Elmt_Id; 1197 D_Val : Node_Id; 1198 1199 begin 1200 D := First_Elmt (Discriminant_Constraint (T)); 1201 while Present (D) loop 1202 if Denotes_Discriminant (Node (D)) then 1203 D_Val := 1204 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 1205 1206 else 1207 D_Val := New_Copy_Tree (Node (D)); 1208 end if; 1209 1210 Append (D_Val, Constraints); 1211 Next_Elmt (D); 1212 end loop; 1213 1214 return Constraints; 1215 end Build_Discriminal_Record_Constraint; 1216 1217 -- Start of processing for Build_Discriminal_Subtype_Of_Component 1218 1219 begin 1220 if Ekind (T) = E_Array_Subtype then 1221 Id := First_Index (T); 1222 while Present (Id) loop 1223 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else 1224 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 1225 then 1226 return Build_Component_Subtype 1227 (Build_Discriminal_Array_Constraint, Loc, T); 1228 end if; 1229 1230 Next_Index (Id); 1231 end loop; 1232 1233 elsif Ekind (T) = E_Record_Subtype 1234 and then Has_Discriminants (T) 1235 and then not Has_Unknown_Discriminants (T) 1236 then 1237 D := First_Elmt (Discriminant_Constraint (T)); 1238 while Present (D) loop 1239 if Denotes_Discriminant (Node (D)) then 1240 return Build_Component_Subtype 1241 (Build_Discriminal_Record_Constraint, Loc, T); 1242 end if; 1243 1244 Next_Elmt (D); 1245 end loop; 1246 end if; 1247 1248 -- If none of the above, the actual and nominal subtypes are the same 1249 1250 return Empty; 1251 end Build_Discriminal_Subtype_Of_Component; 1252 1253 ------------------------------ 1254 -- Build_Elaboration_Entity -- 1255 ------------------------------ 1256 1257 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 1258 Loc : constant Source_Ptr := Sloc (N); 1259 Decl : Node_Id; 1260 Elab_Ent : Entity_Id; 1261 1262 procedure Set_Package_Name (Ent : Entity_Id); 1263 -- Given an entity, sets the fully qualified name of the entity in 1264 -- Name_Buffer, with components separated by double underscores. This 1265 -- is a recursive routine that climbs the scope chain to Standard. 1266 1267 ---------------------- 1268 -- Set_Package_Name -- 1269 ---------------------- 1270 1271 procedure Set_Package_Name (Ent : Entity_Id) is 1272 begin 1273 if Scope (Ent) /= Standard_Standard then 1274 Set_Package_Name (Scope (Ent)); 1275 1276 declare 1277 Nam : constant String := Get_Name_String (Chars (Ent)); 1278 begin 1279 Name_Buffer (Name_Len + 1) := '_'; 1280 Name_Buffer (Name_Len + 2) := '_'; 1281 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 1282 Name_Len := Name_Len + Nam'Length + 2; 1283 end; 1284 1285 else 1286 Get_Name_String (Chars (Ent)); 1287 end if; 1288 end Set_Package_Name; 1289 1290 -- Start of processing for Build_Elaboration_Entity 1291 1292 begin 1293 -- Ignore if already constructed 1294 1295 if Present (Elaboration_Entity (Spec_Id)) then 1296 return; 1297 end if; 1298 1299 -- Ignore in ASIS mode, elaboration entity is not in source and plays 1300 -- no role in analysis. 1301 1302 if ASIS_Mode then 1303 return; 1304 end if; 1305 1306 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 1307 -- name with dots replaced by double underscore. We have to manually 1308 -- construct this name, since it will be elaborated in the outer scope, 1309 -- and thus will not have the unit name automatically prepended. 1310 1311 Set_Package_Name (Spec_Id); 1312 Add_Str_To_Name_Buffer ("_E"); 1313 1314 -- Create elaboration counter 1315 1316 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 1317 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 1318 1319 Decl := 1320 Make_Object_Declaration (Loc, 1321 Defining_Identifier => Elab_Ent, 1322 Object_Definition => 1323 New_Occurrence_Of (Standard_Short_Integer, Loc), 1324 Expression => Make_Integer_Literal (Loc, Uint_0)); 1325 1326 Push_Scope (Standard_Standard); 1327 Add_Global_Declaration (Decl); 1328 Pop_Scope; 1329 1330 -- Reset True_Constant indication, since we will indeed assign a value 1331 -- to the variable in the binder main. We also kill the Current_Value 1332 -- and Last_Assignment fields for the same reason. 1333 1334 Set_Is_True_Constant (Elab_Ent, False); 1335 Set_Current_Value (Elab_Ent, Empty); 1336 Set_Last_Assignment (Elab_Ent, Empty); 1337 1338 -- We do not want any further qualification of the name (if we did not 1339 -- do this, we would pick up the name of the generic package in the case 1340 -- of a library level generic instantiation). 1341 1342 Set_Has_Qualified_Name (Elab_Ent); 1343 Set_Has_Fully_Qualified_Name (Elab_Ent); 1344 end Build_Elaboration_Entity; 1345 1346 -------------------------------- 1347 -- Build_Explicit_Dereference -- 1348 -------------------------------- 1349 1350 procedure Build_Explicit_Dereference 1351 (Expr : Node_Id; 1352 Disc : Entity_Id) 1353 is 1354 Loc : constant Source_Ptr := Sloc (Expr); 1355 begin 1356 1357 -- An entity of a type with a reference aspect is overloaded with 1358 -- both interpretations: with and without the dereference. Now that 1359 -- the dereference is made explicit, set the type of the node properly, 1360 -- to prevent anomalies in the backend. Same if the expression is an 1361 -- overloaded function call whose return type has a reference aspect. 1362 1363 if Is_Entity_Name (Expr) then 1364 Set_Etype (Expr, Etype (Entity (Expr))); 1365 1366 elsif Nkind (Expr) = N_Function_Call then 1367 Set_Etype (Expr, Etype (Name (Expr))); 1368 end if; 1369 1370 Set_Is_Overloaded (Expr, False); 1371 Rewrite (Expr, 1372 Make_Explicit_Dereference (Loc, 1373 Prefix => 1374 Make_Selected_Component (Loc, 1375 Prefix => Relocate_Node (Expr), 1376 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 1377 Set_Etype (Prefix (Expr), Etype (Disc)); 1378 Set_Etype (Expr, Designated_Type (Etype (Disc))); 1379 end Build_Explicit_Dereference; 1380 1381 ----------------------------------- 1382 -- Cannot_Raise_Constraint_Error -- 1383 ----------------------------------- 1384 1385 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 1386 begin 1387 if Compile_Time_Known_Value (Expr) then 1388 return True; 1389 1390 elsif Do_Range_Check (Expr) then 1391 return False; 1392 1393 elsif Raises_Constraint_Error (Expr) then 1394 return False; 1395 1396 else 1397 case Nkind (Expr) is 1398 when N_Identifier => 1399 return True; 1400 1401 when N_Expanded_Name => 1402 return True; 1403 1404 when N_Selected_Component => 1405 return not Do_Discriminant_Check (Expr); 1406 1407 when N_Attribute_Reference => 1408 if Do_Overflow_Check (Expr) then 1409 return False; 1410 1411 elsif No (Expressions (Expr)) then 1412 return True; 1413 1414 else 1415 declare 1416 N : Node_Id; 1417 1418 begin 1419 N := First (Expressions (Expr)); 1420 while Present (N) loop 1421 if Cannot_Raise_Constraint_Error (N) then 1422 Next (N); 1423 else 1424 return False; 1425 end if; 1426 end loop; 1427 1428 return True; 1429 end; 1430 end if; 1431 1432 when N_Type_Conversion => 1433 if Do_Overflow_Check (Expr) 1434 or else Do_Length_Check (Expr) 1435 or else Do_Tag_Check (Expr) 1436 then 1437 return False; 1438 else 1439 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1440 end if; 1441 1442 when N_Unchecked_Type_Conversion => 1443 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1444 1445 when N_Unary_Op => 1446 if Do_Overflow_Check (Expr) then 1447 return False; 1448 else 1449 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1450 end if; 1451 1452 when N_Op_Divide | 1453 N_Op_Mod | 1454 N_Op_Rem 1455 => 1456 if Do_Division_Check (Expr) 1457 or else Do_Overflow_Check (Expr) 1458 then 1459 return False; 1460 else 1461 return 1462 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1463 and then 1464 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1465 end if; 1466 1467 when N_Op_Add | 1468 N_Op_And | 1469 N_Op_Concat | 1470 N_Op_Eq | 1471 N_Op_Expon | 1472 N_Op_Ge | 1473 N_Op_Gt | 1474 N_Op_Le | 1475 N_Op_Lt | 1476 N_Op_Multiply | 1477 N_Op_Ne | 1478 N_Op_Or | 1479 N_Op_Rotate_Left | 1480 N_Op_Rotate_Right | 1481 N_Op_Shift_Left | 1482 N_Op_Shift_Right | 1483 N_Op_Shift_Right_Arithmetic | 1484 N_Op_Subtract | 1485 N_Op_Xor 1486 => 1487 if Do_Overflow_Check (Expr) then 1488 return False; 1489 else 1490 return 1491 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1492 and then 1493 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1494 end if; 1495 1496 when others => 1497 return False; 1498 end case; 1499 end if; 1500 end Cannot_Raise_Constraint_Error; 1501 1502 ----------------------------------------- 1503 -- Check_Dynamically_Tagged_Expression -- 1504 ----------------------------------------- 1505 1506 procedure Check_Dynamically_Tagged_Expression 1507 (Expr : Node_Id; 1508 Typ : Entity_Id; 1509 Related_Nod : Node_Id) 1510 is 1511 begin 1512 pragma Assert (Is_Tagged_Type (Typ)); 1513 1514 -- In order to avoid spurious errors when analyzing the expanded code, 1515 -- this check is done only for nodes that come from source and for 1516 -- actuals of generic instantiations. 1517 1518 if (Comes_From_Source (Related_Nod) 1519 or else In_Generic_Actual (Expr)) 1520 and then (Is_Class_Wide_Type (Etype (Expr)) 1521 or else Is_Dynamically_Tagged (Expr)) 1522 and then Is_Tagged_Type (Typ) 1523 and then not Is_Class_Wide_Type (Typ) 1524 then 1525 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 1526 end if; 1527 end Check_Dynamically_Tagged_Expression; 1528 1529 ----------------------------------------------- 1530 -- Check_Expression_Against_Static_Predicate -- 1531 ----------------------------------------------- 1532 1533 procedure Check_Expression_Against_Static_Predicate 1534 (Expr : Node_Id; 1535 Typ : Entity_Id) 1536 is 1537 begin 1538 -- When the predicate is static and the value of the expression is known 1539 -- at compile time, evaluate the predicate check. A type is non-static 1540 -- when it has aspect Dynamic_Predicate. 1541 1542 if Compile_Time_Known_Value (Expr) 1543 and then Has_Predicates (Typ) 1544 and then Present (Static_Predicate (Typ)) 1545 and then not Has_Dynamic_Predicate_Aspect (Typ) 1546 then 1547 -- Either -gnatc is enabled or the expression is ok 1548 1549 if Operating_Mode < Generate_Code 1550 or else Eval_Static_Predicate_Check (Expr, Typ) 1551 then 1552 null; 1553 1554 -- The expression is prohibited by the static predicate 1555 1556 else 1557 Error_Msg_NE 1558 ("?static expression fails static predicate check on &", 1559 Expr, Typ); 1560 end if; 1561 end if; 1562 end Check_Expression_Against_Static_Predicate; 1563 1564 -------------------------- 1565 -- Check_Fully_Declared -- 1566 -------------------------- 1567 1568 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 1569 begin 1570 if Ekind (T) = E_Incomplete_Type then 1571 1572 -- Ada 2005 (AI-50217): If the type is available through a limited 1573 -- with_clause, verify that its full view has been analyzed. 1574 1575 if From_Limited_With (T) 1576 and then Present (Non_Limited_View (T)) 1577 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 1578 then 1579 -- The non-limited view is fully declared 1580 null; 1581 1582 else 1583 Error_Msg_NE 1584 ("premature usage of incomplete}", N, First_Subtype (T)); 1585 end if; 1586 1587 -- Need comments for these tests ??? 1588 1589 elsif Has_Private_Component (T) 1590 and then not Is_Generic_Type (Root_Type (T)) 1591 and then not In_Spec_Expression 1592 then 1593 -- Special case: if T is the anonymous type created for a single 1594 -- task or protected object, use the name of the source object. 1595 1596 if Is_Concurrent_Type (T) 1597 and then not Comes_From_Source (T) 1598 and then Nkind (N) = N_Object_Declaration 1599 then 1600 Error_Msg_NE ("type of& has incomplete component", N, 1601 Defining_Identifier (N)); 1602 1603 else 1604 Error_Msg_NE 1605 ("premature usage of incomplete}", N, First_Subtype (T)); 1606 end if; 1607 end if; 1608 end Check_Fully_Declared; 1609 1610 ------------------------------------- 1611 -- Check_Function_Writable_Actuals -- 1612 ------------------------------------- 1613 1614 procedure Check_Function_Writable_Actuals (N : Node_Id) is 1615 Writable_Actuals_List : Elist_Id := No_Elist; 1616 Identifiers_List : Elist_Id := No_Elist; 1617 Error_Node : Node_Id := Empty; 1618 1619 procedure Collect_Identifiers (N : Node_Id); 1620 -- In a single traversal of subtree N collect in Writable_Actuals_List 1621 -- all the actuals of functions with writable actuals, and in the list 1622 -- Identifiers_List collect all the identifiers that are not actuals of 1623 -- functions with writable actuals. If a writable actual is referenced 1624 -- twice as writable actual then Error_Node is set to reference its 1625 -- second occurrence, the error is reported, and the tree traversal 1626 -- is abandoned. 1627 1628 function Get_Function_Id (Call : Node_Id) return Entity_Id; 1629 -- Return the entity associated with the function call 1630 1631 procedure Preanalyze_Without_Errors (N : Node_Id); 1632 -- Preanalyze N without reporting errors. Very dubious, you can't just 1633 -- go analyzing things more than once??? 1634 1635 ------------------------- 1636 -- Collect_Identifiers -- 1637 ------------------------- 1638 1639 procedure Collect_Identifiers (N : Node_Id) is 1640 1641 function Check_Node (N : Node_Id) return Traverse_Result; 1642 -- Process a single node during the tree traversal to collect the 1643 -- writable actuals of functions and all the identifiers which are 1644 -- not writable actuals of functions. 1645 1646 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 1647 -- Returns True if List has a node whose Entity is Entity (N) 1648 1649 ------------------------- 1650 -- Check_Function_Call -- 1651 ------------------------- 1652 1653 function Check_Node (N : Node_Id) return Traverse_Result is 1654 Is_Writable_Actual : Boolean := False; 1655 Id : Entity_Id; 1656 1657 begin 1658 if Nkind (N) = N_Identifier then 1659 1660 -- No analysis possible if the entity is not decorated 1661 1662 if No (Entity (N)) then 1663 return Skip; 1664 1665 -- Don't collect identifiers of packages, called functions, etc 1666 1667 elsif Ekind_In (Entity (N), E_Package, 1668 E_Function, 1669 E_Procedure, 1670 E_Entry) 1671 then 1672 return Skip; 1673 1674 -- Analyze if N is a writable actual of a function 1675 1676 elsif Nkind (Parent (N)) = N_Function_Call then 1677 declare 1678 Call : constant Node_Id := Parent (N); 1679 Actual : Node_Id; 1680 Formal : Node_Id; 1681 1682 begin 1683 Id := Get_Function_Id (Call); 1684 1685 Formal := First_Formal (Id); 1686 Actual := First_Actual (Call); 1687 while Present (Actual) and then Present (Formal) loop 1688 if Actual = N then 1689 if Ekind_In (Formal, E_Out_Parameter, 1690 E_In_Out_Parameter) 1691 then 1692 Is_Writable_Actual := True; 1693 end if; 1694 1695 exit; 1696 end if; 1697 1698 Next_Formal (Formal); 1699 Next_Actual (Actual); 1700 end loop; 1701 end; 1702 end if; 1703 1704 if Is_Writable_Actual then 1705 if Contains (Writable_Actuals_List, N) then 1706 Error_Msg_NE 1707 ("value may be affected by call to& " 1708 & "because order of evaluation is arbitrary", N, Id); 1709 Error_Node := N; 1710 return Abandon; 1711 end if; 1712 1713 if Writable_Actuals_List = No_Elist then 1714 Writable_Actuals_List := New_Elmt_List; 1715 end if; 1716 1717 Append_Elmt (N, Writable_Actuals_List); 1718 else 1719 if Identifiers_List = No_Elist then 1720 Identifiers_List := New_Elmt_List; 1721 end if; 1722 1723 Append_Unique_Elmt (N, Identifiers_List); 1724 end if; 1725 end if; 1726 1727 return OK; 1728 end Check_Node; 1729 1730 -------------- 1731 -- Contains -- 1732 -------------- 1733 1734 function Contains 1735 (List : Elist_Id; 1736 N : Node_Id) return Boolean 1737 is 1738 pragma Assert (Nkind (N) in N_Has_Entity); 1739 1740 Elmt : Elmt_Id; 1741 1742 begin 1743 if List = No_Elist then 1744 return False; 1745 end if; 1746 1747 Elmt := First_Elmt (List); 1748 while Present (Elmt) loop 1749 if Entity (Node (Elmt)) = Entity (N) then 1750 return True; 1751 else 1752 Next_Elmt (Elmt); 1753 end if; 1754 end loop; 1755 1756 return False; 1757 end Contains; 1758 1759 ------------------ 1760 -- Do_Traversal -- 1761 ------------------ 1762 1763 procedure Do_Traversal is new Traverse_Proc (Check_Node); 1764 -- The traversal procedure 1765 1766 -- Start of processing for Collect_Identifiers 1767 1768 begin 1769 if Present (Error_Node) then 1770 return; 1771 end if; 1772 1773 if Nkind (N) in N_Subexpr 1774 and then Is_Static_Expression (N) 1775 then 1776 return; 1777 end if; 1778 1779 Do_Traversal (N); 1780 end Collect_Identifiers; 1781 1782 --------------------- 1783 -- Get_Function_Id -- 1784 --------------------- 1785 1786 function Get_Function_Id (Call : Node_Id) return Entity_Id is 1787 Nam : constant Node_Id := Name (Call); 1788 Id : Entity_Id; 1789 1790 begin 1791 if Nkind (Nam) = N_Explicit_Dereference then 1792 Id := Etype (Nam); 1793 pragma Assert (Ekind (Id) = E_Subprogram_Type); 1794 1795 elsif Nkind (Nam) = N_Selected_Component then 1796 Id := Entity (Selector_Name (Nam)); 1797 1798 elsif Nkind (Nam) = N_Indexed_Component then 1799 Id := Entity (Selector_Name (Prefix (Nam))); 1800 1801 else 1802 Id := Entity (Nam); 1803 end if; 1804 1805 return Id; 1806 end Get_Function_Id; 1807 1808 --------------------------- 1809 -- Preanalyze_Expression -- 1810 --------------------------- 1811 1812 procedure Preanalyze_Without_Errors (N : Node_Id) is 1813 Status : constant Boolean := Get_Ignore_Errors; 1814 begin 1815 Set_Ignore_Errors (True); 1816 Preanalyze (N); 1817 Set_Ignore_Errors (Status); 1818 end Preanalyze_Without_Errors; 1819 1820 -- Start of processing for Check_Function_Writable_Actuals 1821 1822 begin 1823 -- The check only applies to Ada 2012 code, and only to constructs that 1824 -- have multiple constituents whose order of evaluation is not specified 1825 -- by the language. 1826 1827 if Ada_Version < Ada_2012 1828 or else (not (Nkind (N) in N_Op) 1829 and then not (Nkind (N) in N_Membership_Test) 1830 and then not Nkind_In (N, N_Range, 1831 N_Aggregate, 1832 N_Extension_Aggregate, 1833 N_Full_Type_Declaration, 1834 N_Function_Call, 1835 N_Procedure_Call_Statement, 1836 N_Entry_Call_Statement)) 1837 or else (Nkind (N) = N_Full_Type_Declaration 1838 and then not Is_Record_Type (Defining_Identifier (N))) 1839 1840 -- In addition, this check only applies to source code, not to code 1841 -- generated by constraint checks. 1842 1843 or else not Comes_From_Source (N) 1844 then 1845 return; 1846 end if; 1847 1848 -- If a construct C has two or more direct constituents that are names 1849 -- or expressions whose evaluation may occur in an arbitrary order, at 1850 -- least one of which contains a function call with an in out or out 1851 -- parameter, then the construct is legal only if: for each name N that 1852 -- is passed as a parameter of mode in out or out to some inner function 1853 -- call C2 (not including the construct C itself), there is no other 1854 -- name anywhere within a direct constituent of the construct C other 1855 -- than the one containing C2, that is known to refer to the same 1856 -- object (RM 6.4.1(6.17/3)). 1857 1858 case Nkind (N) is 1859 when N_Range => 1860 Collect_Identifiers (Low_Bound (N)); 1861 Collect_Identifiers (High_Bound (N)); 1862 1863 when N_Op | N_Membership_Test => 1864 declare 1865 Expr : Node_Id; 1866 begin 1867 Collect_Identifiers (Left_Opnd (N)); 1868 1869 if Present (Right_Opnd (N)) then 1870 Collect_Identifiers (Right_Opnd (N)); 1871 end if; 1872 1873 if Nkind_In (N, N_In, N_Not_In) 1874 and then Present (Alternatives (N)) 1875 then 1876 Expr := First (Alternatives (N)); 1877 while Present (Expr) loop 1878 Collect_Identifiers (Expr); 1879 1880 Next (Expr); 1881 end loop; 1882 end if; 1883 end; 1884 1885 when N_Full_Type_Declaration => 1886 declare 1887 function Get_Record_Part (N : Node_Id) return Node_Id; 1888 -- Return the record part of this record type definition 1889 1890 function Get_Record_Part (N : Node_Id) return Node_Id is 1891 Type_Def : constant Node_Id := Type_Definition (N); 1892 begin 1893 if Nkind (Type_Def) = N_Derived_Type_Definition then 1894 return Record_Extension_Part (Type_Def); 1895 else 1896 return Type_Def; 1897 end if; 1898 end Get_Record_Part; 1899 1900 Comp : Node_Id; 1901 Def_Id : Entity_Id := Defining_Identifier (N); 1902 Rec : Node_Id := Get_Record_Part (N); 1903 1904 begin 1905 -- No need to perform any analysis if the record has no 1906 -- components 1907 1908 if No (Rec) or else No (Component_List (Rec)) then 1909 return; 1910 end if; 1911 1912 -- Collect the identifiers starting from the deepest 1913 -- derivation. Done to report the error in the deepest 1914 -- derivation. 1915 1916 loop 1917 if Present (Component_List (Rec)) then 1918 Comp := First (Component_Items (Component_List (Rec))); 1919 while Present (Comp) loop 1920 if Nkind (Comp) = N_Component_Declaration 1921 and then Present (Expression (Comp)) 1922 then 1923 Collect_Identifiers (Expression (Comp)); 1924 end if; 1925 1926 Next (Comp); 1927 end loop; 1928 end if; 1929 1930 exit when No (Underlying_Type (Etype (Def_Id))) 1931 or else Base_Type (Underlying_Type (Etype (Def_Id))) 1932 = Def_Id; 1933 1934 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 1935 Rec := Get_Record_Part (Parent (Def_Id)); 1936 end loop; 1937 end; 1938 1939 when N_Subprogram_Call | 1940 N_Entry_Call_Statement => 1941 declare 1942 Id : constant Entity_Id := Get_Function_Id (N); 1943 Formal : Node_Id; 1944 Actual : Node_Id; 1945 1946 begin 1947 Formal := First_Formal (Id); 1948 Actual := First_Actual (N); 1949 while Present (Actual) and then Present (Formal) loop 1950 if Ekind_In (Formal, E_Out_Parameter, 1951 E_In_Out_Parameter) 1952 then 1953 Collect_Identifiers (Actual); 1954 end if; 1955 1956 Next_Formal (Formal); 1957 Next_Actual (Actual); 1958 end loop; 1959 end; 1960 1961 when N_Aggregate | 1962 N_Extension_Aggregate => 1963 declare 1964 Assoc : Node_Id; 1965 Choice : Node_Id; 1966 Comp_Expr : Node_Id; 1967 1968 begin 1969 -- Handle the N_Others_Choice of array aggregates with static 1970 -- bounds. There is no need to perform this analysis in 1971 -- aggregates without static bounds since we cannot evaluate 1972 -- if the N_Others_Choice covers several elements. There is 1973 -- no need to handle the N_Others choice of record aggregates 1974 -- since at this stage it has been already expanded by 1975 -- Resolve_Record_Aggregate. 1976 1977 if Is_Array_Type (Etype (N)) 1978 and then Nkind (N) = N_Aggregate 1979 and then Present (Aggregate_Bounds (N)) 1980 and then Compile_Time_Known_Bounds (Etype (N)) 1981 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 1982 > Expr_Value (Low_Bound (Aggregate_Bounds (N))) 1983 then 1984 declare 1985 Count_Components : Uint := Uint_0; 1986 Num_Components : Uint; 1987 Others_Assoc : Node_Id; 1988 Others_Choice : Node_Id := Empty; 1989 Others_Box_Present : Boolean := False; 1990 1991 begin 1992 -- Count positional associations 1993 1994 if Present (Expressions (N)) then 1995 Comp_Expr := First (Expressions (N)); 1996 while Present (Comp_Expr) loop 1997 Count_Components := Count_Components + 1; 1998 Next (Comp_Expr); 1999 end loop; 2000 end if; 2001 2002 -- Count the rest of elements and locate the N_Others 2003 -- choice (if any) 2004 2005 Assoc := First (Component_Associations (N)); 2006 while Present (Assoc) loop 2007 Choice := First (Choices (Assoc)); 2008 while Present (Choice) loop 2009 if Nkind (Choice) = N_Others_Choice then 2010 Others_Assoc := Assoc; 2011 Others_Choice := Choice; 2012 Others_Box_Present := Box_Present (Assoc); 2013 2014 -- Count several components 2015 2016 elsif Nkind_In (Choice, N_Range, 2017 N_Subtype_Indication) 2018 or else (Is_Entity_Name (Choice) 2019 and then Is_Type (Entity (Choice))) 2020 then 2021 declare 2022 L, H : Node_Id; 2023 begin 2024 Get_Index_Bounds (Choice, L, H); 2025 pragma Assert 2026 (Compile_Time_Known_Value (L) 2027 and then Compile_Time_Known_Value (H)); 2028 Count_Components := 2029 Count_Components 2030 + Expr_Value (H) - Expr_Value (L) + 1; 2031 end; 2032 2033 -- Count single component. No other case available 2034 -- since we are handling an aggregate with static 2035 -- bounds. 2036 2037 else 2038 pragma Assert (Is_Static_Expression (Choice) 2039 or else Nkind (Choice) = N_Identifier 2040 or else Nkind (Choice) = N_Integer_Literal); 2041 2042 Count_Components := Count_Components + 1; 2043 end if; 2044 2045 Next (Choice); 2046 end loop; 2047 2048 Next (Assoc); 2049 end loop; 2050 2051 Num_Components := 2052 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 2053 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 2054 2055 pragma Assert (Count_Components <= Num_Components); 2056 2057 -- Handle the N_Others choice if it covers several 2058 -- components 2059 2060 if Present (Others_Choice) 2061 and then (Num_Components - Count_Components) > 1 2062 then 2063 if not Others_Box_Present then 2064 2065 -- At this stage, if expansion is active, the 2066 -- expression of the others choice has not been 2067 -- analyzed. Hence we generate a duplicate and 2068 -- we analyze it silently to have available the 2069 -- minimum decoration required to collect the 2070 -- identifiers. 2071 2072 if not Expander_Active then 2073 Comp_Expr := Expression (Others_Assoc); 2074 else 2075 Comp_Expr := 2076 New_Copy_Tree (Expression (Others_Assoc)); 2077 Preanalyze_Without_Errors (Comp_Expr); 2078 end if; 2079 2080 Collect_Identifiers (Comp_Expr); 2081 2082 if Writable_Actuals_List /= No_Elist then 2083 2084 -- As suggested by Robert, at current stage we 2085 -- report occurrences of this case as warnings. 2086 2087 Error_Msg_N 2088 ("writable function parameter may affect " 2089 & "value in other component because order " 2090 & "of evaluation is unspecified?", 2091 Node (First_Elmt (Writable_Actuals_List))); 2092 end if; 2093 end if; 2094 end if; 2095 end; 2096 end if; 2097 2098 -- Handle ancestor part of extension aggregates 2099 2100 if Nkind (N) = N_Extension_Aggregate then 2101 Collect_Identifiers (Ancestor_Part (N)); 2102 end if; 2103 2104 -- Handle positional associations 2105 2106 if Present (Expressions (N)) then 2107 Comp_Expr := First (Expressions (N)); 2108 while Present (Comp_Expr) loop 2109 if not Is_Static_Expression (Comp_Expr) then 2110 Collect_Identifiers (Comp_Expr); 2111 end if; 2112 2113 Next (Comp_Expr); 2114 end loop; 2115 end if; 2116 2117 -- Handle discrete associations 2118 2119 if Present (Component_Associations (N)) then 2120 Assoc := First (Component_Associations (N)); 2121 while Present (Assoc) loop 2122 2123 if not Box_Present (Assoc) then 2124 Choice := First (Choices (Assoc)); 2125 while Present (Choice) loop 2126 2127 -- For now we skip discriminants since it requires 2128 -- performing the analysis in two phases: first one 2129 -- analyzing discriminants and second one analyzing 2130 -- the rest of components since discriminants are 2131 -- evaluated prior to components: too much extra 2132 -- work to detect a corner case??? 2133 2134 if Nkind (Choice) in N_Has_Entity 2135 and then Present (Entity (Choice)) 2136 and then Ekind (Entity (Choice)) = E_Discriminant 2137 then 2138 null; 2139 2140 elsif Box_Present (Assoc) then 2141 null; 2142 2143 else 2144 if not Analyzed (Expression (Assoc)) then 2145 Comp_Expr := 2146 New_Copy_Tree (Expression (Assoc)); 2147 Set_Parent (Comp_Expr, Parent (N)); 2148 Preanalyze_Without_Errors (Comp_Expr); 2149 else 2150 Comp_Expr := Expression (Assoc); 2151 end if; 2152 2153 Collect_Identifiers (Comp_Expr); 2154 end if; 2155 2156 Next (Choice); 2157 end loop; 2158 end if; 2159 2160 Next (Assoc); 2161 end loop; 2162 end if; 2163 end; 2164 2165 when others => 2166 return; 2167 end case; 2168 2169 -- No further action needed if we already reported an error 2170 2171 if Present (Error_Node) then 2172 return; 2173 end if; 2174 2175 -- Check if some writable argument of a function is referenced 2176 2177 if Writable_Actuals_List /= No_Elist 2178 and then Identifiers_List /= No_Elist 2179 then 2180 declare 2181 Elmt_1 : Elmt_Id; 2182 Elmt_2 : Elmt_Id; 2183 2184 begin 2185 Elmt_1 := First_Elmt (Writable_Actuals_List); 2186 while Present (Elmt_1) loop 2187 Elmt_2 := First_Elmt (Identifiers_List); 2188 while Present (Elmt_2) loop 2189 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 2190 case Nkind (Parent (Node (Elmt_2))) is 2191 when N_Aggregate | 2192 N_Component_Association | 2193 N_Component_Declaration => 2194 Error_Msg_N 2195 ("value may be affected by call in other " 2196 & "component because they are evaluated " 2197 & "in unspecified order", 2198 Node (Elmt_2)); 2199 2200 when N_In | N_Not_In => 2201 Error_Msg_N 2202 ("value may be affected by call in other " 2203 & "alternative because they are evaluated " 2204 & "in unspecified order", 2205 Node (Elmt_2)); 2206 2207 when others => 2208 Error_Msg_N 2209 ("value of actual may be affected by call in " 2210 & "other actual because they are evaluated " 2211 & "in unspecified order", 2212 Node (Elmt_2)); 2213 end case; 2214 end if; 2215 2216 Next_Elmt (Elmt_2); 2217 end loop; 2218 2219 Next_Elmt (Elmt_1); 2220 end loop; 2221 end; 2222 end if; 2223 end Check_Function_Writable_Actuals; 2224 2225 -------------------------------- 2226 -- Check_Implicit_Dereference -- 2227 -------------------------------- 2228 2229 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is 2230 Disc : Entity_Id; 2231 Desig : Entity_Id; 2232 2233 begin 2234 if Ada_Version < Ada_2012 2235 or else not Has_Implicit_Dereference (Base_Type (Typ)) 2236 then 2237 return; 2238 2239 elsif not Comes_From_Source (Nam) then 2240 return; 2241 2242 elsif Is_Entity_Name (Nam) 2243 and then Is_Type (Entity (Nam)) 2244 then 2245 null; 2246 2247 else 2248 Disc := First_Discriminant (Typ); 2249 while Present (Disc) loop 2250 if Has_Implicit_Dereference (Disc) then 2251 Desig := Designated_Type (Etype (Disc)); 2252 Add_One_Interp (Nam, Disc, Desig); 2253 exit; 2254 end if; 2255 2256 Next_Discriminant (Disc); 2257 end loop; 2258 end if; 2259 end Check_Implicit_Dereference; 2260 2261 ---------------------------------- 2262 -- Check_Internal_Protected_Use -- 2263 ---------------------------------- 2264 2265 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 2266 S : Entity_Id; 2267 Prot : Entity_Id; 2268 2269 begin 2270 S := Current_Scope; 2271 while Present (S) loop 2272 if S = Standard_Standard then 2273 return; 2274 2275 elsif Ekind (S) = E_Function 2276 and then Ekind (Scope (S)) = E_Protected_Type 2277 then 2278 Prot := Scope (S); 2279 exit; 2280 end if; 2281 2282 S := Scope (S); 2283 end loop; 2284 2285 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then 2286 2287 -- An indirect function call (e.g. a callback within a protected 2288 -- function body) is not statically illegal. If the access type is 2289 -- anonymous and is the type of an access parameter, the scope of Nam 2290 -- will be the protected type, but it is not a protected operation. 2291 2292 if Ekind (Nam) = E_Subprogram_Type 2293 and then 2294 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification 2295 then 2296 null; 2297 2298 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 2299 Error_Msg_N 2300 ("within protected function cannot use protected " 2301 & "procedure in renaming or as generic actual", N); 2302 2303 elsif Nkind (N) = N_Attribute_Reference then 2304 Error_Msg_N 2305 ("within protected function cannot take access of " 2306 & " protected procedure", N); 2307 2308 else 2309 Error_Msg_N 2310 ("within protected function, protected object is constant", N); 2311 Error_Msg_N 2312 ("\cannot call operation that may modify it", N); 2313 end if; 2314 end if; 2315 end Check_Internal_Protected_Use; 2316 2317 --------------------------------------- 2318 -- Check_Later_Vs_Basic_Declarations -- 2319 --------------------------------------- 2320 2321 procedure Check_Later_Vs_Basic_Declarations 2322 (Decls : List_Id; 2323 During_Parsing : Boolean) 2324 is 2325 Body_Sloc : Source_Ptr; 2326 Decl : Node_Id; 2327 2328 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 2329 -- Return whether Decl is considered as a declarative item. 2330 -- When During_Parsing is True, the semantics of Ada 83 is followed. 2331 -- When During_Parsing is False, the semantics of SPARK is followed. 2332 2333 ------------------------------- 2334 -- Is_Later_Declarative_Item -- 2335 ------------------------------- 2336 2337 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 2338 begin 2339 if Nkind (Decl) in N_Later_Decl_Item then 2340 return True; 2341 2342 elsif Nkind (Decl) = N_Pragma then 2343 return True; 2344 2345 elsif During_Parsing then 2346 return False; 2347 2348 -- In SPARK, a package declaration is not considered as a later 2349 -- declarative item. 2350 2351 elsif Nkind (Decl) = N_Package_Declaration then 2352 return False; 2353 2354 -- In SPARK, a renaming is considered as a later declarative item 2355 2356 elsif Nkind (Decl) in N_Renaming_Declaration then 2357 return True; 2358 2359 else 2360 return False; 2361 end if; 2362 end Is_Later_Declarative_Item; 2363 2364 -- Start of Check_Later_Vs_Basic_Declarations 2365 2366 begin 2367 Decl := First (Decls); 2368 2369 -- Loop through sequence of basic declarative items 2370 2371 Outer : while Present (Decl) loop 2372 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 2373 and then Nkind (Decl) not in N_Body_Stub 2374 then 2375 Next (Decl); 2376 2377 -- Once a body is encountered, we only allow later declarative 2378 -- items. The inner loop checks the rest of the list. 2379 2380 else 2381 Body_Sloc := Sloc (Decl); 2382 2383 Inner : while Present (Decl) loop 2384 if not Is_Later_Declarative_Item (Decl) then 2385 if During_Parsing then 2386 if Ada_Version = Ada_83 then 2387 Error_Msg_Sloc := Body_Sloc; 2388 Error_Msg_N 2389 ("(Ada 83) decl cannot appear after body#", Decl); 2390 end if; 2391 else 2392 Error_Msg_Sloc := Body_Sloc; 2393 Check_SPARK_Restriction 2394 ("decl cannot appear after body#", Decl); 2395 end if; 2396 end if; 2397 2398 Next (Decl); 2399 end loop Inner; 2400 end if; 2401 end loop Outer; 2402 end Check_Later_Vs_Basic_Declarations; 2403 2404 ------------------------- 2405 -- Check_Nested_Access -- 2406 ------------------------- 2407 2408 procedure Check_Nested_Access (Ent : Entity_Id) is 2409 Scop : constant Entity_Id := Current_Scope; 2410 Current_Subp : Entity_Id; 2411 Enclosing : Entity_Id; 2412 2413 begin 2414 -- Currently only enabled for VM back-ends for efficiency, should we 2415 -- enable it more systematically ??? 2416 2417 -- Check for Is_Imported needs commenting below ??? 2418 2419 if VM_Target /= No_VM 2420 and then (Ekind (Ent) = E_Variable 2421 or else 2422 Ekind (Ent) = E_Constant 2423 or else 2424 Ekind (Ent) = E_Loop_Parameter) 2425 and then Scope (Ent) /= Empty 2426 and then not Is_Library_Level_Entity (Ent) 2427 and then not Is_Imported (Ent) 2428 then 2429 if Is_Subprogram (Scop) 2430 or else Is_Generic_Subprogram (Scop) 2431 or else Is_Entry (Scop) 2432 then 2433 Current_Subp := Scop; 2434 else 2435 Current_Subp := Current_Subprogram; 2436 end if; 2437 2438 Enclosing := Enclosing_Subprogram (Ent); 2439 2440 if Enclosing /= Empty 2441 and then Enclosing /= Current_Subp 2442 then 2443 Set_Has_Up_Level_Access (Ent, True); 2444 end if; 2445 end if; 2446 end Check_Nested_Access; 2447 2448 --------------------------- 2449 -- Check_No_Hidden_State -- 2450 --------------------------- 2451 2452 procedure Check_No_Hidden_State (Id : Entity_Id) is 2453 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean; 2454 -- Determine whether the entity of a package denoted by Pkg has a null 2455 -- abstract state. 2456 2457 ----------------------------- 2458 -- Has_Null_Abstract_State -- 2459 ----------------------------- 2460 2461 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is 2462 States : constant Elist_Id := Abstract_States (Pkg); 2463 2464 begin 2465 -- Check first available state of related package. A null abstract 2466 -- state always appears as the sole element of the state list. 2467 2468 return 2469 Present (States) 2470 and then Is_Null_State (Node (First_Elmt (States))); 2471 end Has_Null_Abstract_State; 2472 2473 -- Local variables 2474 2475 Context : Entity_Id := Empty; 2476 Not_Visible : Boolean := False; 2477 Scop : Entity_Id; 2478 2479 -- Start of processing for Check_No_Hidden_State 2480 2481 begin 2482 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); 2483 2484 -- Find the proper context where the object or state appears 2485 2486 Scop := Scope (Id); 2487 while Present (Scop) loop 2488 Context := Scop; 2489 2490 -- Keep track of the context's visibility 2491 2492 Not_Visible := Not_Visible or else In_Private_Part (Context); 2493 2494 -- Prevent the search from going too far 2495 2496 if Context = Standard_Standard then 2497 return; 2498 2499 -- Objects and states that appear immediately within a subprogram or 2500 -- inside a construct nested within a subprogram do not introduce a 2501 -- hidden state. They behave as local variable declarations. 2502 2503 elsif Is_Subprogram (Context) then 2504 return; 2505 2506 -- When examining a package body, use the entity of the spec as it 2507 -- carries the abstract state declarations. 2508 2509 elsif Ekind (Context) = E_Package_Body then 2510 Context := Spec_Entity (Context); 2511 end if; 2512 2513 -- Stop the traversal when a package subject to a null abstract state 2514 -- has been found. 2515 2516 if Ekind_In (Context, E_Generic_Package, E_Package) 2517 and then Has_Null_Abstract_State (Context) 2518 then 2519 exit; 2520 end if; 2521 2522 Scop := Scope (Scop); 2523 end loop; 2524 2525 -- At this point we know that there is at least one package with a null 2526 -- abstract state in visibility. Emit an error message unconditionally 2527 -- if the entity being processed is a state because the placement of the 2528 -- related package is irrelevant. This is not the case for objects as 2529 -- the intermediate context matters. 2530 2531 if Present (Context) 2532 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 2533 then 2534 Error_Msg_N ("cannot introduce hidden state &", Id); 2535 Error_Msg_NE ("\package & has null abstract state", Id, Context); 2536 end if; 2537 end Check_No_Hidden_State; 2538 2539 ------------------------------------------ 2540 -- Check_Potentially_Blocking_Operation -- 2541 ------------------------------------------ 2542 2543 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 2544 S : Entity_Id; 2545 2546 begin 2547 -- N is one of the potentially blocking operations listed in 9.5.1(8). 2548 -- When pragma Detect_Blocking is active, the run time will raise 2549 -- Program_Error. Here we only issue a warning, since we generally 2550 -- support the use of potentially blocking operations in the absence 2551 -- of the pragma. 2552 2553 -- Indirect blocking through a subprogram call cannot be diagnosed 2554 -- statically without interprocedural analysis, so we do not attempt 2555 -- to do it here. 2556 2557 S := Scope (Current_Scope); 2558 while Present (S) and then S /= Standard_Standard loop 2559 if Is_Protected_Type (S) then 2560 Error_Msg_N 2561 ("potentially blocking operation in protected operation??", N); 2562 return; 2563 end if; 2564 2565 S := Scope (S); 2566 end loop; 2567 end Check_Potentially_Blocking_Operation; 2568 2569 --------------------------------- 2570 -- Check_Result_And_Post_State -- 2571 --------------------------------- 2572 2573 procedure Check_Result_And_Post_State 2574 (Prag : Node_Id; 2575 Result_Seen : in out Boolean) 2576 is 2577 procedure Check_Expression (Expr : Node_Id); 2578 -- Perform the 'Result and post-state checks on a given expression 2579 2580 function Is_Function_Result (N : Node_Id) return Traverse_Result; 2581 -- Attempt to find attribute 'Result in a subtree denoted by N 2582 2583 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 2584 -- Determine whether source node N denotes "True" or "False" 2585 2586 function Mentions_Post_State (N : Node_Id) return Boolean; 2587 -- Determine whether a subtree denoted by N mentions any construct that 2588 -- denotes a post-state. 2589 2590 procedure Check_Function_Result is 2591 new Traverse_Proc (Is_Function_Result); 2592 2593 ---------------------- 2594 -- Check_Expression -- 2595 ---------------------- 2596 2597 procedure Check_Expression (Expr : Node_Id) is 2598 begin 2599 if not Is_Trivial_Boolean (Expr) then 2600 Check_Function_Result (Expr); 2601 2602 if not Mentions_Post_State (Expr) then 2603 if Pragma_Name (Prag) = Name_Contract_Cases then 2604 Error_Msg_N 2605 ("contract case refers only to pre-state?T?", Expr); 2606 2607 elsif Pragma_Name (Prag) = Name_Refined_Post then 2608 Error_Msg_N 2609 ("refined postcondition refers only to pre-state?T?", 2610 Prag); 2611 2612 else 2613 Error_Msg_N 2614 ("postcondition refers only to pre-state?T?", Prag); 2615 end if; 2616 end if; 2617 end if; 2618 end Check_Expression; 2619 2620 ------------------------ 2621 -- Is_Function_Result -- 2622 ------------------------ 2623 2624 function Is_Function_Result (N : Node_Id) return Traverse_Result is 2625 begin 2626 if Is_Attribute_Result (N) then 2627 Result_Seen := True; 2628 return Abandon; 2629 2630 -- Continue the traversal 2631 2632 else 2633 return OK; 2634 end if; 2635 end Is_Function_Result; 2636 2637 ------------------------ 2638 -- Is_Trivial_Boolean -- 2639 ------------------------ 2640 2641 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 2642 begin 2643 return 2644 Comes_From_Source (N) 2645 and then Is_Entity_Name (N) 2646 and then (Entity (N) = Standard_True 2647 or else Entity (N) = Standard_False); 2648 end Is_Trivial_Boolean; 2649 2650 ------------------------- 2651 -- Mentions_Post_State -- 2652 ------------------------- 2653 2654 function Mentions_Post_State (N : Node_Id) return Boolean is 2655 Post_State_Seen : Boolean := False; 2656 2657 function Is_Post_State (N : Node_Id) return Traverse_Result; 2658 -- Attempt to find a construct that denotes a post-state. If this is 2659 -- the case, set flag Post_State_Seen. 2660 2661 ------------------- 2662 -- Is_Post_State -- 2663 ------------------- 2664 2665 function Is_Post_State (N : Node_Id) return Traverse_Result is 2666 Ent : Entity_Id; 2667 2668 begin 2669 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then 2670 Post_State_Seen := True; 2671 return Abandon; 2672 2673 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then 2674 Ent := Entity (N); 2675 2676 -- The entity may be modifiable through an implicit dereference 2677 2678 if No (Ent) 2679 or else Ekind (Ent) in Assignable_Kind 2680 or else (Is_Access_Type (Etype (Ent)) 2681 and then Nkind (Parent (N)) = N_Selected_Component) 2682 then 2683 Post_State_Seen := True; 2684 return Abandon; 2685 end if; 2686 2687 elsif Nkind (N) = N_Attribute_Reference then 2688 if Attribute_Name (N) = Name_Old then 2689 return Skip; 2690 2691 elsif Attribute_Name (N) = Name_Result then 2692 Post_State_Seen := True; 2693 return Abandon; 2694 end if; 2695 end if; 2696 2697 return OK; 2698 end Is_Post_State; 2699 2700 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 2701 2702 -- Start of processing for Mentions_Post_State 2703 2704 begin 2705 Find_Post_State (N); 2706 2707 return Post_State_Seen; 2708 end Mentions_Post_State; 2709 2710 -- Local variables 2711 2712 Expr : constant Node_Id := 2713 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 2714 Nam : constant Name_Id := Pragma_Name (Prag); 2715 CCase : Node_Id; 2716 2717 -- Start of processing for Check_Result_And_Post_State 2718 2719 begin 2720 -- Examine all consequences 2721 2722 if Nam = Name_Contract_Cases then 2723 CCase := First (Component_Associations (Expr)); 2724 while Present (CCase) loop 2725 Check_Expression (Expression (CCase)); 2726 2727 Next (CCase); 2728 end loop; 2729 2730 -- Examine the expression of a postcondition 2731 2732 else pragma Assert (Nam_In (Nam, Name_Postcondition, Name_Refined_Post)); 2733 Check_Expression (Expr); 2734 end if; 2735 end Check_Result_And_Post_State; 2736 2737 --------------------------------- 2738 -- Check_SPARK_Mode_In_Generic -- 2739 --------------------------------- 2740 2741 procedure Check_SPARK_Mode_In_Generic (N : Node_Id) is 2742 Aspect : Node_Id; 2743 2744 begin 2745 -- Try to find aspect SPARK_Mode and flag it as illegal 2746 2747 if Has_Aspects (N) then 2748 Aspect := First (Aspect_Specifications (N)); 2749 while Present (Aspect) loop 2750 if Get_Aspect_Id (Aspect) = Aspect_SPARK_Mode then 2751 Error_Msg_Name_1 := Name_SPARK_Mode; 2752 Error_Msg_N 2753 ("incorrect placement of aspect % on a generic", Aspect); 2754 exit; 2755 end if; 2756 2757 Next (Aspect); 2758 end loop; 2759 end if; 2760 end Check_SPARK_Mode_In_Generic; 2761 2762 ------------------------------ 2763 -- Check_Unprotected_Access -- 2764 ------------------------------ 2765 2766 procedure Check_Unprotected_Access 2767 (Context : Node_Id; 2768 Expr : Node_Id) 2769 is 2770 Cont_Encl_Typ : Entity_Id; 2771 Pref_Encl_Typ : Entity_Id; 2772 2773 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 2774 -- Check whether Obj is a private component of a protected object. 2775 -- Return the protected type where the component resides, Empty 2776 -- otherwise. 2777 2778 function Is_Public_Operation return Boolean; 2779 -- Verify that the enclosing operation is callable from outside the 2780 -- protected object, to minimize false positives. 2781 2782 ------------------------------ 2783 -- Enclosing_Protected_Type -- 2784 ------------------------------ 2785 2786 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 2787 begin 2788 if Is_Entity_Name (Obj) then 2789 declare 2790 Ent : Entity_Id := Entity (Obj); 2791 2792 begin 2793 -- The object can be a renaming of a private component, use 2794 -- the original record component. 2795 2796 if Is_Prival (Ent) then 2797 Ent := Prival_Link (Ent); 2798 end if; 2799 2800 if Is_Protected_Type (Scope (Ent)) then 2801 return Scope (Ent); 2802 end if; 2803 end; 2804 end if; 2805 2806 -- For indexed and selected components, recursively check the prefix 2807 2808 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 2809 return Enclosing_Protected_Type (Prefix (Obj)); 2810 2811 -- The object does not denote a protected component 2812 2813 else 2814 return Empty; 2815 end if; 2816 end Enclosing_Protected_Type; 2817 2818 ------------------------- 2819 -- Is_Public_Operation -- 2820 ------------------------- 2821 2822 function Is_Public_Operation return Boolean is 2823 S : Entity_Id; 2824 E : Entity_Id; 2825 2826 begin 2827 S := Current_Scope; 2828 while Present (S) 2829 and then S /= Pref_Encl_Typ 2830 loop 2831 if Scope (S) = Pref_Encl_Typ then 2832 E := First_Entity (Pref_Encl_Typ); 2833 while Present (E) 2834 and then E /= First_Private_Entity (Pref_Encl_Typ) 2835 loop 2836 if E = S then 2837 return True; 2838 end if; 2839 Next_Entity (E); 2840 end loop; 2841 end if; 2842 2843 S := Scope (S); 2844 end loop; 2845 2846 return False; 2847 end Is_Public_Operation; 2848 2849 -- Start of processing for Check_Unprotected_Access 2850 2851 begin 2852 if Nkind (Expr) = N_Attribute_Reference 2853 and then Attribute_Name (Expr) = Name_Unchecked_Access 2854 then 2855 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 2856 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 2857 2858 -- Check whether we are trying to export a protected component to a 2859 -- context with an equal or lower access level. 2860 2861 if Present (Pref_Encl_Typ) 2862 and then No (Cont_Encl_Typ) 2863 and then Is_Public_Operation 2864 and then Scope_Depth (Pref_Encl_Typ) >= 2865 Object_Access_Level (Context) 2866 then 2867 Error_Msg_N 2868 ("??possible unprotected access to protected data", Expr); 2869 end if; 2870 end if; 2871 end Check_Unprotected_Access; 2872 2873 --------------- 2874 -- Check_VMS -- 2875 --------------- 2876 2877 procedure Check_VMS (Construct : Node_Id) is 2878 begin 2879 if not OpenVMS_On_Target then 2880 Error_Msg_N 2881 ("this construct is allowed only in Open'V'M'S", Construct); 2882 end if; 2883 end Check_VMS; 2884 2885 ------------------------ 2886 -- Collect_Interfaces -- 2887 ------------------------ 2888 2889 procedure Collect_Interfaces 2890 (T : Entity_Id; 2891 Ifaces_List : out Elist_Id; 2892 Exclude_Parents : Boolean := False; 2893 Use_Full_View : Boolean := True) 2894 is 2895 procedure Collect (Typ : Entity_Id); 2896 -- Subsidiary subprogram used to traverse the whole list 2897 -- of directly and indirectly implemented interfaces 2898 2899 ------------- 2900 -- Collect -- 2901 ------------- 2902 2903 procedure Collect (Typ : Entity_Id) is 2904 Ancestor : Entity_Id; 2905 Full_T : Entity_Id; 2906 Id : Node_Id; 2907 Iface : Entity_Id; 2908 2909 begin 2910 Full_T := Typ; 2911 2912 -- Handle private types 2913 2914 if Use_Full_View 2915 and then Is_Private_Type (Typ) 2916 and then Present (Full_View (Typ)) 2917 then 2918 Full_T := Full_View (Typ); 2919 end if; 2920 2921 -- Include the ancestor if we are generating the whole list of 2922 -- abstract interfaces. 2923 2924 if Etype (Full_T) /= Typ 2925 2926 -- Protect the frontend against wrong sources. For example: 2927 2928 -- package P is 2929 -- type A is tagged null record; 2930 -- type B is new A with private; 2931 -- type C is new A with private; 2932 -- private 2933 -- type B is new C with null record; 2934 -- type C is new B with null record; 2935 -- end P; 2936 2937 and then Etype (Full_T) /= T 2938 then 2939 Ancestor := Etype (Full_T); 2940 Collect (Ancestor); 2941 2942 if Is_Interface (Ancestor) 2943 and then not Exclude_Parents 2944 then 2945 Append_Unique_Elmt (Ancestor, Ifaces_List); 2946 end if; 2947 end if; 2948 2949 -- Traverse the graph of ancestor interfaces 2950 2951 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 2952 Id := First (Abstract_Interface_List (Full_T)); 2953 while Present (Id) loop 2954 Iface := Etype (Id); 2955 2956 -- Protect against wrong uses. For example: 2957 -- type I is interface; 2958 -- type O is tagged null record; 2959 -- type Wrong is new I and O with null record; -- ERROR 2960 2961 if Is_Interface (Iface) then 2962 if Exclude_Parents 2963 and then Etype (T) /= T 2964 and then Interface_Present_In_Ancestor (Etype (T), Iface) 2965 then 2966 null; 2967 else 2968 Collect (Iface); 2969 Append_Unique_Elmt (Iface, Ifaces_List); 2970 end if; 2971 end if; 2972 2973 Next (Id); 2974 end loop; 2975 end if; 2976 end Collect; 2977 2978 -- Start of processing for Collect_Interfaces 2979 2980 begin 2981 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 2982 Ifaces_List := New_Elmt_List; 2983 Collect (T); 2984 end Collect_Interfaces; 2985 2986 ---------------------------------- 2987 -- Collect_Interface_Components -- 2988 ---------------------------------- 2989 2990 procedure Collect_Interface_Components 2991 (Tagged_Type : Entity_Id; 2992 Components_List : out Elist_Id) 2993 is 2994 procedure Collect (Typ : Entity_Id); 2995 -- Subsidiary subprogram used to climb to the parents 2996 2997 ------------- 2998 -- Collect -- 2999 ------------- 3000 3001 procedure Collect (Typ : Entity_Id) is 3002 Tag_Comp : Entity_Id; 3003 Parent_Typ : Entity_Id; 3004 3005 begin 3006 -- Handle private types 3007 3008 if Present (Full_View (Etype (Typ))) then 3009 Parent_Typ := Full_View (Etype (Typ)); 3010 else 3011 Parent_Typ := Etype (Typ); 3012 end if; 3013 3014 if Parent_Typ /= Typ 3015 3016 -- Protect the frontend against wrong sources. For example: 3017 3018 -- package P is 3019 -- type A is tagged null record; 3020 -- type B is new A with private; 3021 -- type C is new A with private; 3022 -- private 3023 -- type B is new C with null record; 3024 -- type C is new B with null record; 3025 -- end P; 3026 3027 and then Parent_Typ /= Tagged_Type 3028 then 3029 Collect (Parent_Typ); 3030 end if; 3031 3032 -- Collect the components containing tags of secondary dispatch 3033 -- tables. 3034 3035 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 3036 while Present (Tag_Comp) loop 3037 pragma Assert (Present (Related_Type (Tag_Comp))); 3038 Append_Elmt (Tag_Comp, Components_List); 3039 3040 Tag_Comp := Next_Tag_Component (Tag_Comp); 3041 end loop; 3042 end Collect; 3043 3044 -- Start of processing for Collect_Interface_Components 3045 3046 begin 3047 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 3048 and then Is_Tagged_Type (Tagged_Type)); 3049 3050 Components_List := New_Elmt_List; 3051 Collect (Tagged_Type); 3052 end Collect_Interface_Components; 3053 3054 ----------------------------- 3055 -- Collect_Interfaces_Info -- 3056 ----------------------------- 3057 3058 procedure Collect_Interfaces_Info 3059 (T : Entity_Id; 3060 Ifaces_List : out Elist_Id; 3061 Components_List : out Elist_Id; 3062 Tags_List : out Elist_Id) 3063 is 3064 Comps_List : Elist_Id; 3065 Comp_Elmt : Elmt_Id; 3066 Comp_Iface : Entity_Id; 3067 Iface_Elmt : Elmt_Id; 3068 Iface : Entity_Id; 3069 3070 function Search_Tag (Iface : Entity_Id) return Entity_Id; 3071 -- Search for the secondary tag associated with the interface type 3072 -- Iface that is implemented by T. 3073 3074 ---------------- 3075 -- Search_Tag -- 3076 ---------------- 3077 3078 function Search_Tag (Iface : Entity_Id) return Entity_Id is 3079 ADT : Elmt_Id; 3080 begin 3081 if not Is_CPP_Class (T) then 3082 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 3083 else 3084 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 3085 end if; 3086 3087 while Present (ADT) 3088 and then Is_Tag (Node (ADT)) 3089 and then Related_Type (Node (ADT)) /= Iface 3090 loop 3091 -- Skip secondary dispatch table referencing thunks to user 3092 -- defined primitives covered by this interface. 3093 3094 pragma Assert (Has_Suffix (Node (ADT), 'P')); 3095 Next_Elmt (ADT); 3096 3097 -- Skip secondary dispatch tables of Ada types 3098 3099 if not Is_CPP_Class (T) then 3100 3101 -- Skip secondary dispatch table referencing thunks to 3102 -- predefined primitives. 3103 3104 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 3105 Next_Elmt (ADT); 3106 3107 -- Skip secondary dispatch table referencing user-defined 3108 -- primitives covered by this interface. 3109 3110 pragma Assert (Has_Suffix (Node (ADT), 'D')); 3111 Next_Elmt (ADT); 3112 3113 -- Skip secondary dispatch table referencing predefined 3114 -- primitives. 3115 3116 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 3117 Next_Elmt (ADT); 3118 end if; 3119 end loop; 3120 3121 pragma Assert (Is_Tag (Node (ADT))); 3122 return Node (ADT); 3123 end Search_Tag; 3124 3125 -- Start of processing for Collect_Interfaces_Info 3126 3127 begin 3128 Collect_Interfaces (T, Ifaces_List); 3129 Collect_Interface_Components (T, Comps_List); 3130 3131 -- Search for the record component and tag associated with each 3132 -- interface type of T. 3133 3134 Components_List := New_Elmt_List; 3135 Tags_List := New_Elmt_List; 3136 3137 Iface_Elmt := First_Elmt (Ifaces_List); 3138 while Present (Iface_Elmt) loop 3139 Iface := Node (Iface_Elmt); 3140 3141 -- Associate the primary tag component and the primary dispatch table 3142 -- with all the interfaces that are parents of T 3143 3144 if Is_Ancestor (Iface, T, Use_Full_View => True) then 3145 Append_Elmt (First_Tag_Component (T), Components_List); 3146 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 3147 3148 -- Otherwise search for the tag component and secondary dispatch 3149 -- table of Iface 3150 3151 else 3152 Comp_Elmt := First_Elmt (Comps_List); 3153 while Present (Comp_Elmt) loop 3154 Comp_Iface := Related_Type (Node (Comp_Elmt)); 3155 3156 if Comp_Iface = Iface 3157 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 3158 then 3159 Append_Elmt (Node (Comp_Elmt), Components_List); 3160 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 3161 exit; 3162 end if; 3163 3164 Next_Elmt (Comp_Elmt); 3165 end loop; 3166 pragma Assert (Present (Comp_Elmt)); 3167 end if; 3168 3169 Next_Elmt (Iface_Elmt); 3170 end loop; 3171 end Collect_Interfaces_Info; 3172 3173 --------------------- 3174 -- Collect_Parents -- 3175 --------------------- 3176 3177 procedure Collect_Parents 3178 (T : Entity_Id; 3179 List : out Elist_Id; 3180 Use_Full_View : Boolean := True) 3181 is 3182 Current_Typ : Entity_Id := T; 3183 Parent_Typ : Entity_Id; 3184 3185 begin 3186 List := New_Elmt_List; 3187 3188 -- No action if the if the type has no parents 3189 3190 if T = Etype (T) then 3191 return; 3192 end if; 3193 3194 loop 3195 Parent_Typ := Etype (Current_Typ); 3196 3197 if Is_Private_Type (Parent_Typ) 3198 and then Present (Full_View (Parent_Typ)) 3199 and then Use_Full_View 3200 then 3201 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 3202 end if; 3203 3204 Append_Elmt (Parent_Typ, List); 3205 3206 exit when Parent_Typ = Current_Typ; 3207 Current_Typ := Parent_Typ; 3208 end loop; 3209 end Collect_Parents; 3210 3211 ---------------------------------- 3212 -- Collect_Primitive_Operations -- 3213 ---------------------------------- 3214 3215 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 3216 B_Type : constant Entity_Id := Base_Type (T); 3217 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 3218 B_Scope : Entity_Id := Scope (B_Type); 3219 Op_List : Elist_Id; 3220 Formal : Entity_Id; 3221 Is_Prim : Boolean; 3222 Is_Type_In_Pkg : Boolean; 3223 Formal_Derived : Boolean := False; 3224 Id : Entity_Id; 3225 3226 function Match (E : Entity_Id) return Boolean; 3227 -- True if E's base type is B_Type, or E is of an anonymous access type 3228 -- and the base type of its designated type is B_Type. 3229 3230 ----------- 3231 -- Match -- 3232 ----------- 3233 3234 function Match (E : Entity_Id) return Boolean is 3235 Etyp : Entity_Id := Etype (E); 3236 3237 begin 3238 if Ekind (Etyp) = E_Anonymous_Access_Type then 3239 Etyp := Designated_Type (Etyp); 3240 end if; 3241 3242 return Base_Type (Etyp) = B_Type; 3243 end Match; 3244 3245 -- Start of processing for Collect_Primitive_Operations 3246 3247 begin 3248 -- For tagged types, the primitive operations are collected as they 3249 -- are declared, and held in an explicit list which is simply returned. 3250 3251 if Is_Tagged_Type (B_Type) then 3252 return Primitive_Operations (B_Type); 3253 3254 -- An untagged generic type that is a derived type inherits the 3255 -- primitive operations of its parent type. Other formal types only 3256 -- have predefined operators, which are not explicitly represented. 3257 3258 elsif Is_Generic_Type (B_Type) then 3259 if Nkind (B_Decl) = N_Formal_Type_Declaration 3260 and then Nkind (Formal_Type_Definition (B_Decl)) 3261 = N_Formal_Derived_Type_Definition 3262 then 3263 Formal_Derived := True; 3264 else 3265 return New_Elmt_List; 3266 end if; 3267 end if; 3268 3269 Op_List := New_Elmt_List; 3270 3271 if B_Scope = Standard_Standard then 3272 if B_Type = Standard_String then 3273 Append_Elmt (Standard_Op_Concat, Op_List); 3274 3275 elsif B_Type = Standard_Wide_String then 3276 Append_Elmt (Standard_Op_Concatw, Op_List); 3277 3278 else 3279 null; 3280 end if; 3281 3282 -- Locate the primitive subprograms of the type 3283 3284 else 3285 -- The primitive operations appear after the base type, except 3286 -- if the derivation happens within the private part of B_Scope 3287 -- and the type is a private type, in which case both the type 3288 -- and some primitive operations may appear before the base 3289 -- type, and the list of candidates starts after the type. 3290 3291 if In_Open_Scopes (B_Scope) 3292 and then Scope (T) = B_Scope 3293 and then In_Private_Part (B_Scope) 3294 then 3295 Id := Next_Entity (T); 3296 else 3297 Id := Next_Entity (B_Type); 3298 end if; 3299 3300 -- Set flag if this is a type in a package spec 3301 3302 Is_Type_In_Pkg := 3303 Is_Package_Or_Generic_Package (B_Scope) 3304 and then 3305 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 3306 N_Package_Body; 3307 3308 while Present (Id) loop 3309 3310 -- Test whether the result type or any of the parameter types of 3311 -- each subprogram following the type match that type when the 3312 -- type is declared in a package spec, is a derived type, or the 3313 -- subprogram is marked as primitive. (The Is_Primitive test is 3314 -- needed to find primitives of nonderived types in declarative 3315 -- parts that happen to override the predefined "=" operator.) 3316 3317 -- Note that generic formal subprograms are not considered to be 3318 -- primitive operations and thus are never inherited. 3319 3320 if Is_Overloadable (Id) 3321 and then (Is_Type_In_Pkg 3322 or else Is_Derived_Type (B_Type) 3323 or else Is_Primitive (Id)) 3324 and then Nkind (Parent (Parent (Id))) 3325 not in N_Formal_Subprogram_Declaration 3326 then 3327 Is_Prim := False; 3328 3329 if Match (Id) then 3330 Is_Prim := True; 3331 3332 else 3333 Formal := First_Formal (Id); 3334 while Present (Formal) loop 3335 if Match (Formal) then 3336 Is_Prim := True; 3337 exit; 3338 end if; 3339 3340 Next_Formal (Formal); 3341 end loop; 3342 end if; 3343 3344 -- For a formal derived type, the only primitives are the ones 3345 -- inherited from the parent type. Operations appearing in the 3346 -- package declaration are not primitive for it. 3347 3348 if Is_Prim 3349 and then (not Formal_Derived 3350 or else Present (Alias (Id))) 3351 then 3352 -- In the special case of an equality operator aliased to 3353 -- an overriding dispatching equality belonging to the same 3354 -- type, we don't include it in the list of primitives. 3355 -- This avoids inheriting multiple equality operators when 3356 -- deriving from untagged private types whose full type is 3357 -- tagged, which can otherwise cause ambiguities. Note that 3358 -- this should only happen for this kind of untagged parent 3359 -- type, since normally dispatching operations are inherited 3360 -- using the type's Primitive_Operations list. 3361 3362 if Chars (Id) = Name_Op_Eq 3363 and then Is_Dispatching_Operation (Id) 3364 and then Present (Alias (Id)) 3365 and then Present (Overridden_Operation (Alias (Id))) 3366 and then Base_Type (Etype (First_Entity (Id))) = 3367 Base_Type (Etype (First_Entity (Alias (Id)))) 3368 then 3369 null; 3370 3371 -- Include the subprogram in the list of primitives 3372 3373 else 3374 Append_Elmt (Id, Op_List); 3375 end if; 3376 end if; 3377 end if; 3378 3379 Next_Entity (Id); 3380 3381 -- For a type declared in System, some of its operations may 3382 -- appear in the target-specific extension to System. 3383 3384 if No (Id) 3385 and then B_Scope = RTU_Entity (System) 3386 and then Present_System_Aux 3387 then 3388 B_Scope := System_Aux_Id; 3389 Id := First_Entity (System_Aux_Id); 3390 end if; 3391 end loop; 3392 end if; 3393 3394 return Op_List; 3395 end Collect_Primitive_Operations; 3396 3397 ----------------------------------- 3398 -- Compile_Time_Constraint_Error -- 3399 ----------------------------------- 3400 3401 function Compile_Time_Constraint_Error 3402 (N : Node_Id; 3403 Msg : String; 3404 Ent : Entity_Id := Empty; 3405 Loc : Source_Ptr := No_Location; 3406 Warn : Boolean := False) return Node_Id 3407 is 3408 Msgc : String (1 .. Msg'Length + 3); 3409 -- Copy of message, with room for possible ?? or << and ! at end 3410 3411 Msgl : Natural; 3412 Wmsg : Boolean; 3413 P : Node_Id; 3414 OldP : Node_Id; 3415 Msgs : Boolean; 3416 Eloc : Source_Ptr; 3417 3418 begin 3419 -- If this is a warning, convert it into an error if we are in code 3420 -- subject to SPARK_Mode being set ON. 3421 3422 Error_Msg_Warn := SPARK_Mode /= On; 3423 3424 -- A static constraint error in an instance body is not a fatal error. 3425 -- we choose to inhibit the message altogether, because there is no 3426 -- obvious node (for now) on which to post it. On the other hand the 3427 -- offending node must be replaced with a constraint_error in any case. 3428 3429 -- No messages are generated if we already posted an error on this node 3430 3431 if not Error_Posted (N) then 3432 if Loc /= No_Location then 3433 Eloc := Loc; 3434 else 3435 Eloc := Sloc (N); 3436 end if; 3437 3438 -- Copy message to Msgc, converting any ? in the message into 3439 -- < instead, so that we have an error in GNATprove mode. 3440 3441 Msgl := Msg'Length; 3442 3443 for J in 1 .. Msgl loop 3444 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then 3445 Msgc (J) := '<'; 3446 else 3447 Msgc (J) := Msg (J); 3448 end if; 3449 end loop; 3450 3451 -- Message is a warning, even in Ada 95 case 3452 3453 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 3454 Wmsg := True; 3455 3456 -- In Ada 83, all messages are warnings. In the private part and 3457 -- the body of an instance, constraint_checks are only warnings. 3458 -- We also make this a warning if the Warn parameter is set. 3459 3460 elsif Warn 3461 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 3462 then 3463 Msgl := Msgl + 1; 3464 Msgc (Msgl) := '<'; 3465 Msgl := Msgl + 1; 3466 Msgc (Msgl) := '<'; 3467 Wmsg := True; 3468 3469 elsif In_Instance_Not_Visible then 3470 Msgl := Msgl + 1; 3471 Msgc (Msgl) := '<'; 3472 Msgl := Msgl + 1; 3473 Msgc (Msgl) := '<'; 3474 Wmsg := True; 3475 3476 -- Otherwise we have a real error message (Ada 95 static case) 3477 -- and we make this an unconditional message. Note that in the 3478 -- warning case we do not make the message unconditional, it seems 3479 -- quite reasonable to delete messages like this (about exceptions 3480 -- that will be raised) in dead code. 3481 3482 else 3483 Wmsg := False; 3484 Msgl := Msgl + 1; 3485 Msgc (Msgl) := '!'; 3486 end if; 3487 3488 -- Should we generate a warning? The answer is not quite yes. The 3489 -- very annoying exception occurs in the case of a short circuit 3490 -- operator where the left operand is static and decisive. Climb 3491 -- parents to see if that is the case we have here. Conditional 3492 -- expressions with decisive conditions are a similar situation. 3493 3494 Msgs := True; 3495 P := N; 3496 loop 3497 OldP := P; 3498 P := Parent (P); 3499 3500 -- And then with False as left operand 3501 3502 if Nkind (P) = N_And_Then 3503 and then Compile_Time_Known_Value (Left_Opnd (P)) 3504 and then Is_False (Expr_Value (Left_Opnd (P))) 3505 then 3506 Msgs := False; 3507 exit; 3508 3509 -- OR ELSE with True as left operand 3510 3511 elsif Nkind (P) = N_Or_Else 3512 and then Compile_Time_Known_Value (Left_Opnd (P)) 3513 and then Is_True (Expr_Value (Left_Opnd (P))) 3514 then 3515 Msgs := False; 3516 exit; 3517 3518 -- If expression 3519 3520 elsif Nkind (P) = N_If_Expression then 3521 declare 3522 Cond : constant Node_Id := First (Expressions (P)); 3523 Texp : constant Node_Id := Next (Cond); 3524 Fexp : constant Node_Id := Next (Texp); 3525 3526 begin 3527 if Compile_Time_Known_Value (Cond) then 3528 3529 -- Condition is True and we are in the right operand 3530 3531 if Is_True (Expr_Value (Cond)) 3532 and then OldP = Fexp 3533 then 3534 Msgs := False; 3535 exit; 3536 3537 -- Condition is False and we are in the left operand 3538 3539 elsif Is_False (Expr_Value (Cond)) 3540 and then OldP = Texp 3541 then 3542 Msgs := False; 3543 exit; 3544 end if; 3545 end if; 3546 end; 3547 3548 -- Special case for component association in aggregates, where 3549 -- we want to keep climbing up to the parent aggregate. 3550 3551 elsif Nkind (P) = N_Component_Association 3552 and then Nkind (Parent (P)) = N_Aggregate 3553 then 3554 null; 3555 3556 -- Keep going if within subexpression 3557 3558 else 3559 exit when Nkind (P) not in N_Subexpr; 3560 end if; 3561 end loop; 3562 3563 if Msgs then 3564 Error_Msg_Warn := SPARK_Mode /= On; 3565 3566 if Present (Ent) then 3567 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 3568 else 3569 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 3570 end if; 3571 3572 if Wmsg then 3573 3574 -- Check whether the context is an Init_Proc 3575 3576 if Inside_Init_Proc then 3577 declare 3578 Conc_Typ : constant Entity_Id := 3579 Corresponding_Concurrent_Type 3580 (Entity (Parameter_Type (First 3581 (Parameter_Specifications 3582 (Parent (Current_Scope)))))); 3583 3584 begin 3585 -- Don't complain if the corresponding concurrent type 3586 -- doesn't come from source (i.e. a single task/protected 3587 -- object). 3588 3589 if Present (Conc_Typ) 3590 and then not Comes_From_Source (Conc_Typ) 3591 then 3592 Error_Msg_NEL 3593 ("\& [<<", N, Standard_Constraint_Error, Eloc); 3594 3595 else 3596 if GNATprove_Mode then 3597 Error_Msg_NEL 3598 ("\& would have been raised for objects of this " 3599 & "type", N, Standard_Constraint_Error, Eloc); 3600 else 3601 Error_Msg_NEL 3602 ("\& will be raised for objects of this type??", 3603 N, Standard_Constraint_Error, Eloc); 3604 end if; 3605 end if; 3606 end; 3607 3608 else 3609 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 3610 end if; 3611 3612 else 3613 Error_Msg ("\static expression fails Constraint_Check", Eloc); 3614 Set_Error_Posted (N); 3615 end if; 3616 end if; 3617 end if; 3618 3619 return N; 3620 end Compile_Time_Constraint_Error; 3621 3622 ----------------------- 3623 -- Conditional_Delay -- 3624 ----------------------- 3625 3626 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 3627 begin 3628 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 3629 Set_Has_Delayed_Freeze (New_Ent); 3630 end if; 3631 end Conditional_Delay; 3632 3633 ---------------------------- 3634 -- Contains_Refined_State -- 3635 ---------------------------- 3636 3637 function Contains_Refined_State (Prag : Node_Id) return Boolean is 3638 function Has_State_In_Dependency (List : Node_Id) return Boolean; 3639 -- Determine whether a dependency list mentions a state with a visible 3640 -- refinement. 3641 3642 function Has_State_In_Global (List : Node_Id) return Boolean; 3643 -- Determine whether a global list mentions a state with a visible 3644 -- refinement. 3645 3646 function Is_Refined_State (Item : Node_Id) return Boolean; 3647 -- Determine whether Item is a reference to an abstract state with a 3648 -- visible refinement. 3649 3650 ----------------------------- 3651 -- Has_State_In_Dependency -- 3652 ----------------------------- 3653 3654 function Has_State_In_Dependency (List : Node_Id) return Boolean is 3655 Clause : Node_Id; 3656 Output : Node_Id; 3657 3658 begin 3659 -- A null dependency list does not mention any states 3660 3661 if Nkind (List) = N_Null then 3662 return False; 3663 3664 -- Dependency clauses appear as component associations of an 3665 -- aggregate. 3666 3667 elsif Nkind (List) = N_Aggregate 3668 and then Present (Component_Associations (List)) 3669 then 3670 Clause := First (Component_Associations (List)); 3671 while Present (Clause) loop 3672 3673 -- Inspect the outputs of a dependency clause 3674 3675 Output := First (Choices (Clause)); 3676 while Present (Output) loop 3677 if Is_Refined_State (Output) then 3678 return True; 3679 end if; 3680 3681 Next (Output); 3682 end loop; 3683 3684 -- Inspect the outputs of a dependency clause 3685 3686 if Is_Refined_State (Expression (Clause)) then 3687 return True; 3688 end if; 3689 3690 Next (Clause); 3691 end loop; 3692 3693 -- If we get here, then none of the dependency clauses mention a 3694 -- state with visible refinement. 3695 3696 return False; 3697 3698 -- An illegal pragma managed to sneak in 3699 3700 else 3701 raise Program_Error; 3702 end if; 3703 end Has_State_In_Dependency; 3704 3705 ------------------------- 3706 -- Has_State_In_Global -- 3707 ------------------------- 3708 3709 function Has_State_In_Global (List : Node_Id) return Boolean is 3710 Item : Node_Id; 3711 3712 begin 3713 -- A null global list does not mention any states 3714 3715 if Nkind (List) = N_Null then 3716 return False; 3717 3718 -- Simple global list or moded global list declaration 3719 3720 elsif Nkind (List) = N_Aggregate then 3721 3722 -- The declaration of a simple global list appear as a collection 3723 -- of expressions. 3724 3725 if Present (Expressions (List)) then 3726 Item := First (Expressions (List)); 3727 while Present (Item) loop 3728 if Is_Refined_State (Item) then 3729 return True; 3730 end if; 3731 3732 Next (Item); 3733 end loop; 3734 3735 -- The declaration of a moded global list appears as a collection 3736 -- of component associations where individual choices denote 3737 -- modes. 3738 3739 else 3740 Item := First (Component_Associations (List)); 3741 while Present (Item) loop 3742 if Has_State_In_Global (Expression (Item)) then 3743 return True; 3744 end if; 3745 3746 Next (Item); 3747 end loop; 3748 end if; 3749 3750 -- If we get here, then the simple/moded global list did not 3751 -- mention any states with a visible refinement. 3752 3753 return False; 3754 3755 -- Single global item declaration 3756 3757 elsif Is_Entity_Name (List) then 3758 return Is_Refined_State (List); 3759 3760 -- An illegal pragma managed to sneak in 3761 3762 else 3763 raise Program_Error; 3764 end if; 3765 end Has_State_In_Global; 3766 3767 ---------------------- 3768 -- Is_Refined_State -- 3769 ---------------------- 3770 3771 function Is_Refined_State (Item : Node_Id) return Boolean is 3772 Elmt : Node_Id; 3773 Item_Id : Entity_Id; 3774 3775 begin 3776 if Nkind (Item) = N_Null then 3777 return False; 3778 3779 -- States cannot be subject to attribute 'Result. This case arises 3780 -- in dependency relations. 3781 3782 elsif Nkind (Item) = N_Attribute_Reference 3783 and then Attribute_Name (Item) = Name_Result 3784 then 3785 return False; 3786 3787 -- Multiple items appear as an aggregate. This case arises in 3788 -- dependency relations. 3789 3790 elsif Nkind (Item) = N_Aggregate 3791 and then Present (Expressions (Item)) 3792 then 3793 Elmt := First (Expressions (Item)); 3794 while Present (Elmt) loop 3795 if Is_Refined_State (Elmt) then 3796 return True; 3797 end if; 3798 3799 Next (Elmt); 3800 end loop; 3801 3802 -- If we get here, then none of the inputs or outputs reference a 3803 -- state with visible refinement. 3804 3805 return False; 3806 3807 -- Single item 3808 3809 else 3810 Item_Id := Entity_Of (Item); 3811 3812 return 3813 Present (Item_Id) 3814 and then Ekind (Item_Id) = E_Abstract_State 3815 and then Has_Visible_Refinement (Item_Id); 3816 end if; 3817 end Is_Refined_State; 3818 3819 -- Local variables 3820 3821 Arg : constant Node_Id := 3822 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 3823 Nam : constant Name_Id := Pragma_Name (Prag); 3824 3825 -- Start of processing for Contains_Refined_State 3826 3827 begin 3828 if Nam = Name_Depends then 3829 return Has_State_In_Dependency (Arg); 3830 3831 else pragma Assert (Nam = Name_Global); 3832 return Has_State_In_Global (Arg); 3833 end if; 3834 end Contains_Refined_State; 3835 3836 ------------------------- 3837 -- Copy_Component_List -- 3838 ------------------------- 3839 3840 function Copy_Component_List 3841 (R_Typ : Entity_Id; 3842 Loc : Source_Ptr) return List_Id 3843 is 3844 Comp : Node_Id; 3845 Comps : constant List_Id := New_List; 3846 3847 begin 3848 Comp := First_Component (Underlying_Type (R_Typ)); 3849 while Present (Comp) loop 3850 if Comes_From_Source (Comp) then 3851 declare 3852 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 3853 begin 3854 Append_To (Comps, 3855 Make_Component_Declaration (Loc, 3856 Defining_Identifier => 3857 Make_Defining_Identifier (Loc, Chars (Comp)), 3858 Component_Definition => 3859 New_Copy_Tree 3860 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 3861 end; 3862 end if; 3863 3864 Next_Component (Comp); 3865 end loop; 3866 3867 return Comps; 3868 end Copy_Component_List; 3869 3870 ------------------------- 3871 -- Copy_Parameter_List -- 3872 ------------------------- 3873 3874 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 3875 Loc : constant Source_Ptr := Sloc (Subp_Id); 3876 Plist : List_Id; 3877 Formal : Entity_Id; 3878 3879 begin 3880 if No (First_Formal (Subp_Id)) then 3881 return No_List; 3882 else 3883 Plist := New_List; 3884 Formal := First_Formal (Subp_Id); 3885 while Present (Formal) loop 3886 Append 3887 (Make_Parameter_Specification (Loc, 3888 Defining_Identifier => 3889 Make_Defining_Identifier (Sloc (Formal), 3890 Chars => Chars (Formal)), 3891 In_Present => In_Present (Parent (Formal)), 3892 Out_Present => Out_Present (Parent (Formal)), 3893 Parameter_Type => 3894 New_Occurrence_Of (Etype (Formal), Loc), 3895 Expression => 3896 New_Copy_Tree (Expression (Parent (Formal)))), 3897 Plist); 3898 3899 Next_Formal (Formal); 3900 end loop; 3901 end if; 3902 3903 return Plist; 3904 end Copy_Parameter_List; 3905 3906 -------------------------------- 3907 -- Corresponding_Generic_Type -- 3908 -------------------------------- 3909 3910 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 3911 Inst : Entity_Id; 3912 Gen : Entity_Id; 3913 Typ : Entity_Id; 3914 3915 begin 3916 if not Is_Generic_Actual_Type (T) then 3917 return Any_Type; 3918 3919 -- If the actual is the actual of an enclosing instance, resolution 3920 -- was correct in the generic. 3921 3922 elsif Nkind (Parent (T)) = N_Subtype_Declaration 3923 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 3924 and then 3925 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 3926 then 3927 return Any_Type; 3928 3929 else 3930 Inst := Scope (T); 3931 3932 if Is_Wrapper_Package (Inst) then 3933 Inst := Related_Instance (Inst); 3934 end if; 3935 3936 Gen := 3937 Generic_Parent 3938 (Specification (Unit_Declaration_Node (Inst))); 3939 3940 -- Generic actual has the same name as the corresponding formal 3941 3942 Typ := First_Entity (Gen); 3943 while Present (Typ) loop 3944 if Chars (Typ) = Chars (T) then 3945 return Typ; 3946 end if; 3947 3948 Next_Entity (Typ); 3949 end loop; 3950 3951 return Any_Type; 3952 end if; 3953 end Corresponding_Generic_Type; 3954 3955 -------------------- 3956 -- Current_Entity -- 3957 -------------------- 3958 3959 -- The currently visible definition for a given identifier is the 3960 -- one most chained at the start of the visibility chain, i.e. the 3961 -- one that is referenced by the Node_Id value of the name of the 3962 -- given identifier. 3963 3964 function Current_Entity (N : Node_Id) return Entity_Id is 3965 begin 3966 return Get_Name_Entity_Id (Chars (N)); 3967 end Current_Entity; 3968 3969 ----------------------------- 3970 -- Current_Entity_In_Scope -- 3971 ----------------------------- 3972 3973 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 3974 E : Entity_Id; 3975 CS : constant Entity_Id := Current_Scope; 3976 3977 Transient_Case : constant Boolean := Scope_Is_Transient; 3978 3979 begin 3980 E := Get_Name_Entity_Id (Chars (N)); 3981 while Present (E) 3982 and then Scope (E) /= CS 3983 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 3984 loop 3985 E := Homonym (E); 3986 end loop; 3987 3988 return E; 3989 end Current_Entity_In_Scope; 3990 3991 ------------------- 3992 -- Current_Scope -- 3993 ------------------- 3994 3995 function Current_Scope return Entity_Id is 3996 begin 3997 if Scope_Stack.Last = -1 then 3998 return Standard_Standard; 3999 else 4000 declare 4001 C : constant Entity_Id := 4002 Scope_Stack.Table (Scope_Stack.Last).Entity; 4003 begin 4004 if Present (C) then 4005 return C; 4006 else 4007 return Standard_Standard; 4008 end if; 4009 end; 4010 end if; 4011 end Current_Scope; 4012 4013 ------------------------ 4014 -- Current_Subprogram -- 4015 ------------------------ 4016 4017 function Current_Subprogram return Entity_Id is 4018 Scop : constant Entity_Id := Current_Scope; 4019 begin 4020 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then 4021 return Scop; 4022 else 4023 return Enclosing_Subprogram (Scop); 4024 end if; 4025 end Current_Subprogram; 4026 4027 ---------------------------------- 4028 -- Deepest_Type_Access_Level -- 4029 ---------------------------------- 4030 4031 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 4032 begin 4033 if Ekind (Typ) = E_Anonymous_Access_Type 4034 and then not Is_Local_Anonymous_Access (Typ) 4035 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 4036 then 4037 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 4038 -- access type. 4039 4040 return 4041 Scope_Depth (Enclosing_Dynamic_Scope 4042 (Defining_Identifier 4043 (Associated_Node_For_Itype (Typ)))); 4044 4045 -- For generic formal type, return Int'Last (infinite). 4046 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 4047 4048 elsif Is_Generic_Type (Root_Type (Typ)) then 4049 return UI_From_Int (Int'Last); 4050 4051 else 4052 return Type_Access_Level (Typ); 4053 end if; 4054 end Deepest_Type_Access_Level; 4055 4056 --------------------- 4057 -- Defining_Entity -- 4058 --------------------- 4059 4060 function Defining_Entity (N : Node_Id) return Entity_Id is 4061 K : constant Node_Kind := Nkind (N); 4062 Err : Entity_Id := Empty; 4063 4064 begin 4065 case K is 4066 when 4067 N_Subprogram_Declaration | 4068 N_Abstract_Subprogram_Declaration | 4069 N_Subprogram_Body | 4070 N_Package_Declaration | 4071 N_Subprogram_Renaming_Declaration | 4072 N_Subprogram_Body_Stub | 4073 N_Generic_Subprogram_Declaration | 4074 N_Generic_Package_Declaration | 4075 N_Formal_Subprogram_Declaration | 4076 N_Expression_Function 4077 => 4078 return Defining_Entity (Specification (N)); 4079 4080 when 4081 N_Component_Declaration | 4082 N_Defining_Program_Unit_Name | 4083 N_Discriminant_Specification | 4084 N_Entry_Body | 4085 N_Entry_Declaration | 4086 N_Entry_Index_Specification | 4087 N_Exception_Declaration | 4088 N_Exception_Renaming_Declaration | 4089 N_Formal_Object_Declaration | 4090 N_Formal_Package_Declaration | 4091 N_Formal_Type_Declaration | 4092 N_Full_Type_Declaration | 4093 N_Implicit_Label_Declaration | 4094 N_Incomplete_Type_Declaration | 4095 N_Loop_Parameter_Specification | 4096 N_Number_Declaration | 4097 N_Object_Declaration | 4098 N_Object_Renaming_Declaration | 4099 N_Package_Body_Stub | 4100 N_Parameter_Specification | 4101 N_Private_Extension_Declaration | 4102 N_Private_Type_Declaration | 4103 N_Protected_Body | 4104 N_Protected_Body_Stub | 4105 N_Protected_Type_Declaration | 4106 N_Single_Protected_Declaration | 4107 N_Single_Task_Declaration | 4108 N_Subtype_Declaration | 4109 N_Task_Body | 4110 N_Task_Body_Stub | 4111 N_Task_Type_Declaration 4112 => 4113 return Defining_Identifier (N); 4114 4115 when N_Subunit => 4116 return Defining_Entity (Proper_Body (N)); 4117 4118 when 4119 N_Function_Instantiation | 4120 N_Function_Specification | 4121 N_Generic_Function_Renaming_Declaration | 4122 N_Generic_Package_Renaming_Declaration | 4123 N_Generic_Procedure_Renaming_Declaration | 4124 N_Package_Body | 4125 N_Package_Instantiation | 4126 N_Package_Renaming_Declaration | 4127 N_Package_Specification | 4128 N_Procedure_Instantiation | 4129 N_Procedure_Specification 4130 => 4131 declare 4132 Nam : constant Node_Id := Defining_Unit_Name (N); 4133 4134 begin 4135 if Nkind (Nam) in N_Entity then 4136 return Nam; 4137 4138 -- For Error, make up a name and attach to declaration 4139 -- so we can continue semantic analysis 4140 4141 elsif Nam = Error then 4142 Err := Make_Temporary (Sloc (N), 'T'); 4143 Set_Defining_Unit_Name (N, Err); 4144 4145 return Err; 4146 4147 -- If not an entity, get defining identifier 4148 4149 else 4150 return Defining_Identifier (Nam); 4151 end if; 4152 end; 4153 4154 when N_Block_Statement => 4155 return Entity (Identifier (N)); 4156 4157 when others => 4158 raise Program_Error; 4159 4160 end case; 4161 end Defining_Entity; 4162 4163 -------------------------- 4164 -- Denotes_Discriminant -- 4165 -------------------------- 4166 4167 function Denotes_Discriminant 4168 (N : Node_Id; 4169 Check_Concurrent : Boolean := False) return Boolean 4170 is 4171 E : Entity_Id; 4172 begin 4173 if not Is_Entity_Name (N) 4174 or else No (Entity (N)) 4175 then 4176 return False; 4177 else 4178 E := Entity (N); 4179 end if; 4180 4181 -- If we are checking for a protected type, the discriminant may have 4182 -- been rewritten as the corresponding discriminal of the original type 4183 -- or of the corresponding concurrent record, depending on whether we 4184 -- are in the spec or body of the protected type. 4185 4186 return Ekind (E) = E_Discriminant 4187 or else 4188 (Check_Concurrent 4189 and then Ekind (E) = E_In_Parameter 4190 and then Present (Discriminal_Link (E)) 4191 and then 4192 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 4193 or else 4194 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 4195 4196 end Denotes_Discriminant; 4197 4198 ------------------------- 4199 -- Denotes_Same_Object -- 4200 ------------------------- 4201 4202 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 4203 Obj1 : Node_Id := A1; 4204 Obj2 : Node_Id := A2; 4205 4206 function Has_Prefix (N : Node_Id) return Boolean; 4207 -- Return True if N has attribute Prefix 4208 4209 function Is_Renaming (N : Node_Id) return Boolean; 4210 -- Return true if N names a renaming entity 4211 4212 function Is_Valid_Renaming (N : Node_Id) return Boolean; 4213 -- For renamings, return False if the prefix of any dereference within 4214 -- the renamed object_name is a variable, or any expression within the 4215 -- renamed object_name contains references to variables or calls on 4216 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 4217 4218 ---------------- 4219 -- Has_Prefix -- 4220 ---------------- 4221 4222 function Has_Prefix (N : Node_Id) return Boolean is 4223 begin 4224 return 4225 Nkind_In (N, 4226 N_Attribute_Reference, 4227 N_Expanded_Name, 4228 N_Explicit_Dereference, 4229 N_Indexed_Component, 4230 N_Reference, 4231 N_Selected_Component, 4232 N_Slice); 4233 end Has_Prefix; 4234 4235 ----------------- 4236 -- Is_Renaming -- 4237 ----------------- 4238 4239 function Is_Renaming (N : Node_Id) return Boolean is 4240 begin 4241 return Is_Entity_Name (N) 4242 and then Present (Renamed_Entity (Entity (N))); 4243 end Is_Renaming; 4244 4245 ----------------------- 4246 -- Is_Valid_Renaming -- 4247 ----------------------- 4248 4249 function Is_Valid_Renaming (N : Node_Id) return Boolean is 4250 4251 function Check_Renaming (N : Node_Id) return Boolean; 4252 -- Recursive function used to traverse all the prefixes of N 4253 4254 function Check_Renaming (N : Node_Id) return Boolean is 4255 begin 4256 if Is_Renaming (N) 4257 and then not Check_Renaming (Renamed_Entity (Entity (N))) 4258 then 4259 return False; 4260 end if; 4261 4262 if Nkind (N) = N_Indexed_Component then 4263 declare 4264 Indx : Node_Id; 4265 4266 begin 4267 Indx := First (Expressions (N)); 4268 while Present (Indx) loop 4269 if not Is_OK_Static_Expression (Indx) then 4270 return False; 4271 end if; 4272 4273 Next_Index (Indx); 4274 end loop; 4275 end; 4276 end if; 4277 4278 if Has_Prefix (N) then 4279 declare 4280 P : constant Node_Id := Prefix (N); 4281 4282 begin 4283 if Nkind (N) = N_Explicit_Dereference 4284 and then Is_Variable (P) 4285 then 4286 return False; 4287 4288 elsif Is_Entity_Name (P) 4289 and then Ekind (Entity (P)) = E_Function 4290 then 4291 return False; 4292 4293 elsif Nkind (P) = N_Function_Call then 4294 return False; 4295 end if; 4296 4297 -- Recursion to continue traversing the prefix of the 4298 -- renaming expression 4299 4300 return Check_Renaming (P); 4301 end; 4302 end if; 4303 4304 return True; 4305 end Check_Renaming; 4306 4307 -- Start of processing for Is_Valid_Renaming 4308 4309 begin 4310 return Check_Renaming (N); 4311 end Is_Valid_Renaming; 4312 4313 -- Start of processing for Denotes_Same_Object 4314 4315 begin 4316 -- Both names statically denote the same stand-alone object or parameter 4317 -- (RM 6.4.1(6.5/3)) 4318 4319 if Is_Entity_Name (Obj1) 4320 and then Is_Entity_Name (Obj2) 4321 and then Entity (Obj1) = Entity (Obj2) 4322 then 4323 return True; 4324 end if; 4325 4326 -- For renamings, the prefix of any dereference within the renamed 4327 -- object_name is not a variable, and any expression within the 4328 -- renamed object_name contains no references to variables nor 4329 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 4330 4331 if Is_Renaming (Obj1) then 4332 if Is_Valid_Renaming (Obj1) then 4333 Obj1 := Renamed_Entity (Entity (Obj1)); 4334 else 4335 return False; 4336 end if; 4337 end if; 4338 4339 if Is_Renaming (Obj2) then 4340 if Is_Valid_Renaming (Obj2) then 4341 Obj2 := Renamed_Entity (Entity (Obj2)); 4342 else 4343 return False; 4344 end if; 4345 end if; 4346 4347 -- No match if not same node kind (such cases are handled by 4348 -- Denotes_Same_Prefix) 4349 4350 if Nkind (Obj1) /= Nkind (Obj2) then 4351 return False; 4352 4353 -- After handling valid renamings, one of the two names statically 4354 -- denoted a renaming declaration whose renamed object_name is known 4355 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 4356 4357 elsif Is_Entity_Name (Obj1) then 4358 if Is_Entity_Name (Obj2) then 4359 return Entity (Obj1) = Entity (Obj2); 4360 else 4361 return False; 4362 end if; 4363 4364 -- Both names are selected_components, their prefixes are known to 4365 -- denote the same object, and their selector_names denote the same 4366 -- component (RM 6.4.1(6.6/3) 4367 4368 elsif Nkind (Obj1) = N_Selected_Component then 4369 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 4370 and then 4371 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 4372 4373 -- Both names are dereferences and the dereferenced names are known to 4374 -- denote the same object (RM 6.4.1(6.7/3)) 4375 4376 elsif Nkind (Obj1) = N_Explicit_Dereference then 4377 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 4378 4379 -- Both names are indexed_components, their prefixes are known to denote 4380 -- the same object, and each of the pairs of corresponding index values 4381 -- are either both static expressions with the same static value or both 4382 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 4383 4384 elsif Nkind (Obj1) = N_Indexed_Component then 4385 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 4386 return False; 4387 else 4388 declare 4389 Indx1 : Node_Id; 4390 Indx2 : Node_Id; 4391 4392 begin 4393 Indx1 := First (Expressions (Obj1)); 4394 Indx2 := First (Expressions (Obj2)); 4395 while Present (Indx1) loop 4396 4397 -- Indexes must denote the same static value or same object 4398 4399 if Is_OK_Static_Expression (Indx1) then 4400 if not Is_OK_Static_Expression (Indx2) then 4401 return False; 4402 4403 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 4404 return False; 4405 end if; 4406 4407 elsif not Denotes_Same_Object (Indx1, Indx2) then 4408 return False; 4409 end if; 4410 4411 Next (Indx1); 4412 Next (Indx2); 4413 end loop; 4414 4415 return True; 4416 end; 4417 end if; 4418 4419 -- Both names are slices, their prefixes are known to denote the same 4420 -- object, and the two slices have statically matching index constraints 4421 -- (RM 6.4.1(6.9/3)) 4422 4423 elsif Nkind (Obj1) = N_Slice 4424 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 4425 then 4426 declare 4427 Lo1, Lo2, Hi1, Hi2 : Node_Id; 4428 4429 begin 4430 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 4431 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 4432 4433 -- Check whether bounds are statically identical. There is no 4434 -- attempt to detect partial overlap of slices. 4435 4436 return Denotes_Same_Object (Lo1, Lo2) 4437 and then Denotes_Same_Object (Hi1, Hi2); 4438 end; 4439 4440 -- In the recursion, literals appear as indexes. 4441 4442 elsif Nkind (Obj1) = N_Integer_Literal 4443 and then Nkind (Obj2) = N_Integer_Literal 4444 then 4445 return Intval (Obj1) = Intval (Obj2); 4446 4447 else 4448 return False; 4449 end if; 4450 end Denotes_Same_Object; 4451 4452 ------------------------- 4453 -- Denotes_Same_Prefix -- 4454 ------------------------- 4455 4456 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 4457 4458 begin 4459 if Is_Entity_Name (A1) then 4460 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 4461 and then not Is_Access_Type (Etype (A1)) 4462 then 4463 return Denotes_Same_Object (A1, Prefix (A2)) 4464 or else Denotes_Same_Prefix (A1, Prefix (A2)); 4465 else 4466 return False; 4467 end if; 4468 4469 elsif Is_Entity_Name (A2) then 4470 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 4471 4472 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 4473 and then 4474 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 4475 then 4476 declare 4477 Root1, Root2 : Node_Id; 4478 Depth1, Depth2 : Int := 0; 4479 4480 begin 4481 Root1 := Prefix (A1); 4482 while not Is_Entity_Name (Root1) loop 4483 if not Nkind_In 4484 (Root1, N_Selected_Component, N_Indexed_Component) 4485 then 4486 return False; 4487 else 4488 Root1 := Prefix (Root1); 4489 end if; 4490 4491 Depth1 := Depth1 + 1; 4492 end loop; 4493 4494 Root2 := Prefix (A2); 4495 while not Is_Entity_Name (Root2) loop 4496 if not Nkind_In 4497 (Root2, N_Selected_Component, N_Indexed_Component) 4498 then 4499 return False; 4500 else 4501 Root2 := Prefix (Root2); 4502 end if; 4503 4504 Depth2 := Depth2 + 1; 4505 end loop; 4506 4507 -- If both have the same depth and they do not denote the same 4508 -- object, they are disjoint and no warning is needed. 4509 4510 if Depth1 = Depth2 then 4511 return False; 4512 4513 elsif Depth1 > Depth2 then 4514 Root1 := Prefix (A1); 4515 for I in 1 .. Depth1 - Depth2 - 1 loop 4516 Root1 := Prefix (Root1); 4517 end loop; 4518 4519 return Denotes_Same_Object (Root1, A2); 4520 4521 else 4522 Root2 := Prefix (A2); 4523 for I in 1 .. Depth2 - Depth1 - 1 loop 4524 Root2 := Prefix (Root2); 4525 end loop; 4526 4527 return Denotes_Same_Object (A1, Root2); 4528 end if; 4529 end; 4530 4531 else 4532 return False; 4533 end if; 4534 end Denotes_Same_Prefix; 4535 4536 ---------------------- 4537 -- Denotes_Variable -- 4538 ---------------------- 4539 4540 function Denotes_Variable (N : Node_Id) return Boolean is 4541 begin 4542 return Is_Variable (N) and then Paren_Count (N) = 0; 4543 end Denotes_Variable; 4544 4545 ----------------------------- 4546 -- Depends_On_Discriminant -- 4547 ----------------------------- 4548 4549 function Depends_On_Discriminant (N : Node_Id) return Boolean is 4550 L : Node_Id; 4551 H : Node_Id; 4552 4553 begin 4554 Get_Index_Bounds (N, L, H); 4555 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 4556 end Depends_On_Discriminant; 4557 4558 ------------------------- 4559 -- Designate_Same_Unit -- 4560 ------------------------- 4561 4562 function Designate_Same_Unit 4563 (Name1 : Node_Id; 4564 Name2 : Node_Id) return Boolean 4565 is 4566 K1 : constant Node_Kind := Nkind (Name1); 4567 K2 : constant Node_Kind := Nkind (Name2); 4568 4569 function Prefix_Node (N : Node_Id) return Node_Id; 4570 -- Returns the parent unit name node of a defining program unit name 4571 -- or the prefix if N is a selected component or an expanded name. 4572 4573 function Select_Node (N : Node_Id) return Node_Id; 4574 -- Returns the defining identifier node of a defining program unit 4575 -- name or the selector node if N is a selected component or an 4576 -- expanded name. 4577 4578 ----------------- 4579 -- Prefix_Node -- 4580 ----------------- 4581 4582 function Prefix_Node (N : Node_Id) return Node_Id is 4583 begin 4584 if Nkind (N) = N_Defining_Program_Unit_Name then 4585 return Name (N); 4586 4587 else 4588 return Prefix (N); 4589 end if; 4590 end Prefix_Node; 4591 4592 ----------------- 4593 -- Select_Node -- 4594 ----------------- 4595 4596 function Select_Node (N : Node_Id) return Node_Id is 4597 begin 4598 if Nkind (N) = N_Defining_Program_Unit_Name then 4599 return Defining_Identifier (N); 4600 4601 else 4602 return Selector_Name (N); 4603 end if; 4604 end Select_Node; 4605 4606 -- Start of processing for Designate_Next_Unit 4607 4608 begin 4609 if (K1 = N_Identifier or else 4610 K1 = N_Defining_Identifier) 4611 and then 4612 (K2 = N_Identifier or else 4613 K2 = N_Defining_Identifier) 4614 then 4615 return Chars (Name1) = Chars (Name2); 4616 4617 elsif 4618 (K1 = N_Expanded_Name or else 4619 K1 = N_Selected_Component or else 4620 K1 = N_Defining_Program_Unit_Name) 4621 and then 4622 (K2 = N_Expanded_Name or else 4623 K2 = N_Selected_Component or else 4624 K2 = N_Defining_Program_Unit_Name) 4625 then 4626 return 4627 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 4628 and then 4629 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 4630 4631 else 4632 return False; 4633 end if; 4634 end Designate_Same_Unit; 4635 4636 ------------------------------------------ 4637 -- function Dynamic_Accessibility_Level -- 4638 ------------------------------------------ 4639 4640 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 4641 E : Entity_Id; 4642 Loc : constant Source_Ptr := Sloc (Expr); 4643 4644 function Make_Level_Literal (Level : Uint) return Node_Id; 4645 -- Construct an integer literal representing an accessibility level 4646 -- with its type set to Natural. 4647 4648 ------------------------ 4649 -- Make_Level_Literal -- 4650 ------------------------ 4651 4652 function Make_Level_Literal (Level : Uint) return Node_Id is 4653 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 4654 begin 4655 Set_Etype (Result, Standard_Natural); 4656 return Result; 4657 end Make_Level_Literal; 4658 4659 -- Start of processing for Dynamic_Accessibility_Level 4660 4661 begin 4662 if Is_Entity_Name (Expr) then 4663 E := Entity (Expr); 4664 4665 if Present (Renamed_Object (E)) then 4666 return Dynamic_Accessibility_Level (Renamed_Object (E)); 4667 end if; 4668 4669 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 4670 if Present (Extra_Accessibility (E)) then 4671 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 4672 end if; 4673 end if; 4674 end if; 4675 4676 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 4677 4678 case Nkind (Expr) is 4679 4680 -- For access discriminant, the level of the enclosing object 4681 4682 when N_Selected_Component => 4683 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 4684 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 4685 E_Anonymous_Access_Type 4686 then 4687 return Make_Level_Literal (Object_Access_Level (Expr)); 4688 end if; 4689 4690 when N_Attribute_Reference => 4691 case Get_Attribute_Id (Attribute_Name (Expr)) is 4692 4693 -- For X'Access, the level of the prefix X 4694 4695 when Attribute_Access => 4696 return Make_Level_Literal 4697 (Object_Access_Level (Prefix (Expr))); 4698 4699 -- Treat the unchecked attributes as library-level 4700 4701 when Attribute_Unchecked_Access | 4702 Attribute_Unrestricted_Access => 4703 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 4704 4705 -- No other access-valued attributes 4706 4707 when others => 4708 raise Program_Error; 4709 end case; 4710 4711 when N_Allocator => 4712 4713 -- Unimplemented: depends on context. As an actual parameter where 4714 -- formal type is anonymous, use 4715 -- Scope_Depth (Current_Scope) + 1. 4716 -- For other cases, see 3.10.2(14/3) and following. ??? 4717 4718 null; 4719 4720 when N_Type_Conversion => 4721 if not Is_Local_Anonymous_Access (Etype (Expr)) then 4722 4723 -- Handle type conversions introduced for a rename of an 4724 -- Ada 2012 stand-alone object of an anonymous access type. 4725 4726 return Dynamic_Accessibility_Level (Expression (Expr)); 4727 end if; 4728 4729 when others => 4730 null; 4731 end case; 4732 4733 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 4734 end Dynamic_Accessibility_Level; 4735 4736 ----------------------------------- 4737 -- Effective_Extra_Accessibility -- 4738 ----------------------------------- 4739 4740 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 4741 begin 4742 if Present (Renamed_Object (Id)) 4743 and then Is_Entity_Name (Renamed_Object (Id)) 4744 then 4745 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 4746 else 4747 return Extra_Accessibility (Id); 4748 end if; 4749 end Effective_Extra_Accessibility; 4750 4751 ----------------------------- 4752 -- Effective_Reads_Enabled -- 4753 ----------------------------- 4754 4755 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 4756 begin 4757 return Has_Enabled_Property (Id, Name_Effective_Reads); 4758 end Effective_Reads_Enabled; 4759 4760 ------------------------------ 4761 -- Effective_Writes_Enabled -- 4762 ------------------------------ 4763 4764 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 4765 begin 4766 return Has_Enabled_Property (Id, Name_Effective_Writes); 4767 end Effective_Writes_Enabled; 4768 4769 ------------------------------ 4770 -- Enclosing_Comp_Unit_Node -- 4771 ------------------------------ 4772 4773 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 4774 Current_Node : Node_Id; 4775 4776 begin 4777 Current_Node := N; 4778 while Present (Current_Node) 4779 and then Nkind (Current_Node) /= N_Compilation_Unit 4780 loop 4781 Current_Node := Parent (Current_Node); 4782 end loop; 4783 4784 if Nkind (Current_Node) /= N_Compilation_Unit then 4785 return Empty; 4786 else 4787 return Current_Node; 4788 end if; 4789 end Enclosing_Comp_Unit_Node; 4790 4791 -------------------------- 4792 -- Enclosing_CPP_Parent -- 4793 -------------------------- 4794 4795 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 4796 Parent_Typ : Entity_Id := Typ; 4797 4798 begin 4799 while not Is_CPP_Class (Parent_Typ) 4800 and then Etype (Parent_Typ) /= Parent_Typ 4801 loop 4802 Parent_Typ := Etype (Parent_Typ); 4803 4804 if Is_Private_Type (Parent_Typ) then 4805 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 4806 end if; 4807 end loop; 4808 4809 pragma Assert (Is_CPP_Class (Parent_Typ)); 4810 return Parent_Typ; 4811 end Enclosing_CPP_Parent; 4812 4813 ---------------------------- 4814 -- Enclosing_Generic_Body -- 4815 ---------------------------- 4816 4817 function Enclosing_Generic_Body 4818 (N : Node_Id) return Node_Id 4819 is 4820 P : Node_Id; 4821 Decl : Node_Id; 4822 Spec : Node_Id; 4823 4824 begin 4825 P := Parent (N); 4826 while Present (P) loop 4827 if Nkind (P) = N_Package_Body 4828 or else Nkind (P) = N_Subprogram_Body 4829 then 4830 Spec := Corresponding_Spec (P); 4831 4832 if Present (Spec) then 4833 Decl := Unit_Declaration_Node (Spec); 4834 4835 if Nkind (Decl) = N_Generic_Package_Declaration 4836 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 4837 then 4838 return P; 4839 end if; 4840 end if; 4841 end if; 4842 4843 P := Parent (P); 4844 end loop; 4845 4846 return Empty; 4847 end Enclosing_Generic_Body; 4848 4849 ---------------------------- 4850 -- Enclosing_Generic_Unit -- 4851 ---------------------------- 4852 4853 function Enclosing_Generic_Unit 4854 (N : Node_Id) return Node_Id 4855 is 4856 P : Node_Id; 4857 Decl : Node_Id; 4858 Spec : Node_Id; 4859 4860 begin 4861 P := Parent (N); 4862 while Present (P) loop 4863 if Nkind (P) = N_Generic_Package_Declaration 4864 or else Nkind (P) = N_Generic_Subprogram_Declaration 4865 then 4866 return P; 4867 4868 elsif Nkind (P) = N_Package_Body 4869 or else Nkind (P) = N_Subprogram_Body 4870 then 4871 Spec := Corresponding_Spec (P); 4872 4873 if Present (Spec) then 4874 Decl := Unit_Declaration_Node (Spec); 4875 4876 if Nkind (Decl) = N_Generic_Package_Declaration 4877 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 4878 then 4879 return Decl; 4880 end if; 4881 end if; 4882 end if; 4883 4884 P := Parent (P); 4885 end loop; 4886 4887 return Empty; 4888 end Enclosing_Generic_Unit; 4889 4890 ------------------------------- 4891 -- Enclosing_Lib_Unit_Entity -- 4892 ------------------------------- 4893 4894 function Enclosing_Lib_Unit_Entity 4895 (E : Entity_Id := Current_Scope) return Entity_Id 4896 is 4897 Unit_Entity : Entity_Id; 4898 4899 begin 4900 -- Look for enclosing library unit entity by following scope links. 4901 -- Equivalent to, but faster than indexing through the scope stack. 4902 4903 Unit_Entity := E; 4904 while (Present (Scope (Unit_Entity)) 4905 and then Scope (Unit_Entity) /= Standard_Standard) 4906 and not Is_Child_Unit (Unit_Entity) 4907 loop 4908 Unit_Entity := Scope (Unit_Entity); 4909 end loop; 4910 4911 return Unit_Entity; 4912 end Enclosing_Lib_Unit_Entity; 4913 4914 ----------------------- 4915 -- Enclosing_Package -- 4916 ----------------------- 4917 4918 function Enclosing_Package (E : Entity_Id) return Entity_Id is 4919 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 4920 4921 begin 4922 if Dynamic_Scope = Standard_Standard then 4923 return Standard_Standard; 4924 4925 elsif Dynamic_Scope = Empty then 4926 return Empty; 4927 4928 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 4929 E_Generic_Package) 4930 then 4931 return Dynamic_Scope; 4932 4933 else 4934 return Enclosing_Package (Dynamic_Scope); 4935 end if; 4936 end Enclosing_Package; 4937 4938 -------------------------- 4939 -- Enclosing_Subprogram -- 4940 -------------------------- 4941 4942 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 4943 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 4944 4945 begin 4946 if Dynamic_Scope = Standard_Standard then 4947 return Empty; 4948 4949 elsif Dynamic_Scope = Empty then 4950 return Empty; 4951 4952 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then 4953 return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); 4954 4955 elsif Ekind (Dynamic_Scope) = E_Block 4956 or else Ekind (Dynamic_Scope) = E_Return_Statement 4957 then 4958 return Enclosing_Subprogram (Dynamic_Scope); 4959 4960 elsif Ekind (Dynamic_Scope) = E_Task_Type then 4961 return Get_Task_Body_Procedure (Dynamic_Scope); 4962 4963 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type 4964 and then Present (Full_View (Dynamic_Scope)) 4965 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type 4966 then 4967 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); 4968 4969 -- No body is generated if the protected operation is eliminated 4970 4971 elsif Convention (Dynamic_Scope) = Convention_Protected 4972 and then not Is_Eliminated (Dynamic_Scope) 4973 and then Present (Protected_Body_Subprogram (Dynamic_Scope)) 4974 then 4975 return Protected_Body_Subprogram (Dynamic_Scope); 4976 4977 else 4978 return Dynamic_Scope; 4979 end if; 4980 end Enclosing_Subprogram; 4981 4982 ------------------------ 4983 -- Ensure_Freeze_Node -- 4984 ------------------------ 4985 4986 procedure Ensure_Freeze_Node (E : Entity_Id) is 4987 FN : Node_Id; 4988 begin 4989 if No (Freeze_Node (E)) then 4990 FN := Make_Freeze_Entity (Sloc (E)); 4991 Set_Has_Delayed_Freeze (E); 4992 Set_Freeze_Node (E, FN); 4993 Set_Access_Types_To_Process (FN, No_Elist); 4994 Set_TSS_Elist (FN, No_Elist); 4995 Set_Entity (FN, E); 4996 end if; 4997 end Ensure_Freeze_Node; 4998 4999 ---------------- 5000 -- Enter_Name -- 5001 ---------------- 5002 5003 procedure Enter_Name (Def_Id : Entity_Id) is 5004 C : constant Entity_Id := Current_Entity (Def_Id); 5005 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 5006 S : constant Entity_Id := Current_Scope; 5007 5008 begin 5009 Generate_Definition (Def_Id); 5010 5011 -- Add new name to current scope declarations. Check for duplicate 5012 -- declaration, which may or may not be a genuine error. 5013 5014 if Present (E) then 5015 5016 -- Case of previous entity entered because of a missing declaration 5017 -- or else a bad subtype indication. Best is to use the new entity, 5018 -- and make the previous one invisible. 5019 5020 if Etype (E) = Any_Type then 5021 Set_Is_Immediately_Visible (E, False); 5022 5023 -- Case of renaming declaration constructed for package instances. 5024 -- if there is an explicit declaration with the same identifier, 5025 -- the renaming is not immediately visible any longer, but remains 5026 -- visible through selected component notation. 5027 5028 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 5029 and then not Comes_From_Source (E) 5030 then 5031 Set_Is_Immediately_Visible (E, False); 5032 5033 -- The new entity may be the package renaming, which has the same 5034 -- same name as a generic formal which has been seen already. 5035 5036 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 5037 and then not Comes_From_Source (Def_Id) 5038 then 5039 Set_Is_Immediately_Visible (E, False); 5040 5041 -- For a fat pointer corresponding to a remote access to subprogram, 5042 -- we use the same identifier as the RAS type, so that the proper 5043 -- name appears in the stub. This type is only retrieved through 5044 -- the RAS type and never by visibility, and is not added to the 5045 -- visibility list (see below). 5046 5047 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 5048 and then Present (Corresponding_Remote_Type (Def_Id)) 5049 then 5050 null; 5051 5052 -- Case of an implicit operation or derived literal. The new entity 5053 -- hides the implicit one, which is removed from all visibility, 5054 -- i.e. the entity list of its scope, and homonym chain of its name. 5055 5056 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 5057 or else Is_Internal (E) 5058 then 5059 declare 5060 Prev : Entity_Id; 5061 Prev_Vis : Entity_Id; 5062 Decl : constant Node_Id := Parent (E); 5063 5064 begin 5065 -- If E is an implicit declaration, it cannot be the first 5066 -- entity in the scope. 5067 5068 Prev := First_Entity (Current_Scope); 5069 while Present (Prev) 5070 and then Next_Entity (Prev) /= E 5071 loop 5072 Next_Entity (Prev); 5073 end loop; 5074 5075 if No (Prev) then 5076 5077 -- If E is not on the entity chain of the current scope, 5078 -- it is an implicit declaration in the generic formal 5079 -- part of a generic subprogram. When analyzing the body, 5080 -- the generic formals are visible but not on the entity 5081 -- chain of the subprogram. The new entity will become 5082 -- the visible one in the body. 5083 5084 pragma Assert 5085 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 5086 null; 5087 5088 else 5089 Set_Next_Entity (Prev, Next_Entity (E)); 5090 5091 if No (Next_Entity (Prev)) then 5092 Set_Last_Entity (Current_Scope, Prev); 5093 end if; 5094 5095 if E = Current_Entity (E) then 5096 Prev_Vis := Empty; 5097 5098 else 5099 Prev_Vis := Current_Entity (E); 5100 while Homonym (Prev_Vis) /= E loop 5101 Prev_Vis := Homonym (Prev_Vis); 5102 end loop; 5103 end if; 5104 5105 if Present (Prev_Vis) then 5106 5107 -- Skip E in the visibility chain 5108 5109 Set_Homonym (Prev_Vis, Homonym (E)); 5110 5111 else 5112 Set_Name_Entity_Id (Chars (E), Homonym (E)); 5113 end if; 5114 end if; 5115 end; 5116 5117 -- This section of code could use a comment ??? 5118 5119 elsif Present (Etype (E)) 5120 and then Is_Concurrent_Type (Etype (E)) 5121 and then E = Def_Id 5122 then 5123 return; 5124 5125 -- If the homograph is a protected component renaming, it should not 5126 -- be hiding the current entity. Such renamings are treated as weak 5127 -- declarations. 5128 5129 elsif Is_Prival (E) then 5130 Set_Is_Immediately_Visible (E, False); 5131 5132 -- In this case the current entity is a protected component renaming. 5133 -- Perform minimal decoration by setting the scope and return since 5134 -- the prival should not be hiding other visible entities. 5135 5136 elsif Is_Prival (Def_Id) then 5137 Set_Scope (Def_Id, Current_Scope); 5138 return; 5139 5140 -- Analogous to privals, the discriminal generated for an entry index 5141 -- parameter acts as a weak declaration. Perform minimal decoration 5142 -- to avoid bogus errors. 5143 5144 elsif Is_Discriminal (Def_Id) 5145 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 5146 then 5147 Set_Scope (Def_Id, Current_Scope); 5148 return; 5149 5150 -- In the body or private part of an instance, a type extension may 5151 -- introduce a component with the same name as that of an actual. The 5152 -- legality rule is not enforced, but the semantics of the full type 5153 -- with two components of same name are not clear at this point??? 5154 5155 elsif In_Instance_Not_Visible then 5156 null; 5157 5158 -- When compiling a package body, some child units may have become 5159 -- visible. They cannot conflict with local entities that hide them. 5160 5161 elsif Is_Child_Unit (E) 5162 and then In_Open_Scopes (Scope (E)) 5163 and then not Is_Immediately_Visible (E) 5164 then 5165 null; 5166 5167 -- Conversely, with front-end inlining we may compile the parent body 5168 -- first, and a child unit subsequently. The context is now the 5169 -- parent spec, and body entities are not visible. 5170 5171 elsif Is_Child_Unit (Def_Id) 5172 and then Is_Package_Body_Entity (E) 5173 and then not In_Package_Body (Current_Scope) 5174 then 5175 null; 5176 5177 -- Case of genuine duplicate declaration 5178 5179 else 5180 Error_Msg_Sloc := Sloc (E); 5181 5182 -- If the previous declaration is an incomplete type declaration 5183 -- this may be an attempt to complete it with a private type. The 5184 -- following avoids confusing cascaded errors. 5185 5186 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 5187 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 5188 then 5189 Error_Msg_N 5190 ("incomplete type cannot be completed with a private " & 5191 "declaration", Parent (Def_Id)); 5192 Set_Is_Immediately_Visible (E, False); 5193 Set_Full_View (E, Def_Id); 5194 5195 -- An inherited component of a record conflicts with a new 5196 -- discriminant. The discriminant is inserted first in the scope, 5197 -- but the error should be posted on it, not on the component. 5198 5199 elsif Ekind (E) = E_Discriminant 5200 and then Present (Scope (Def_Id)) 5201 and then Scope (Def_Id) /= Current_Scope 5202 then 5203 Error_Msg_Sloc := Sloc (Def_Id); 5204 Error_Msg_N ("& conflicts with declaration#", E); 5205 return; 5206 5207 -- If the name of the unit appears in its own context clause, a 5208 -- dummy package with the name has already been created, and the 5209 -- error emitted. Try to continue quietly. 5210 5211 elsif Error_Posted (E) 5212 and then Sloc (E) = No_Location 5213 and then Nkind (Parent (E)) = N_Package_Specification 5214 and then Current_Scope = Standard_Standard 5215 then 5216 Set_Scope (Def_Id, Current_Scope); 5217 return; 5218 5219 else 5220 Error_Msg_N ("& conflicts with declaration#", Def_Id); 5221 5222 -- Avoid cascaded messages with duplicate components in 5223 -- derived types. 5224 5225 if Ekind_In (E, E_Component, E_Discriminant) then 5226 return; 5227 end if; 5228 end if; 5229 5230 if Nkind (Parent (Parent (Def_Id))) = 5231 N_Generic_Subprogram_Declaration 5232 and then Def_Id = 5233 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 5234 then 5235 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 5236 end if; 5237 5238 -- If entity is in standard, then we are in trouble, because it 5239 -- means that we have a library package with a duplicated name. 5240 -- That's hard to recover from, so abort. 5241 5242 if S = Standard_Standard then 5243 raise Unrecoverable_Error; 5244 5245 -- Otherwise we continue with the declaration. Having two 5246 -- identical declarations should not cause us too much trouble. 5247 5248 else 5249 null; 5250 end if; 5251 end if; 5252 end if; 5253 5254 -- If we fall through, declaration is OK, at least OK enough to continue 5255 5256 -- If Def_Id is a discriminant or a record component we are in the midst 5257 -- of inheriting components in a derived record definition. Preserve 5258 -- their Ekind and Etype. 5259 5260 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 5261 null; 5262 5263 -- If a type is already set, leave it alone (happens when a type 5264 -- declaration is reanalyzed following a call to the optimizer). 5265 5266 elsif Present (Etype (Def_Id)) then 5267 null; 5268 5269 -- Otherwise, the kind E_Void insures that premature uses of the entity 5270 -- will be detected. Any_Type insures that no cascaded errors will occur 5271 5272 else 5273 Set_Ekind (Def_Id, E_Void); 5274 Set_Etype (Def_Id, Any_Type); 5275 end if; 5276 5277 -- Inherited discriminants and components in derived record types are 5278 -- immediately visible. Itypes are not. 5279 5280 -- Unless the Itype is for a record type with a corresponding remote 5281 -- type (what is that about, it was not commented ???) 5282 5283 if Ekind_In (Def_Id, E_Discriminant, E_Component) 5284 or else 5285 ((not Is_Record_Type (Def_Id) 5286 or else No (Corresponding_Remote_Type (Def_Id))) 5287 and then not Is_Itype (Def_Id)) 5288 then 5289 Set_Is_Immediately_Visible (Def_Id); 5290 Set_Current_Entity (Def_Id); 5291 end if; 5292 5293 Set_Homonym (Def_Id, C); 5294 Append_Entity (Def_Id, S); 5295 Set_Public_Status (Def_Id); 5296 5297 -- Declaring a homonym is not allowed in SPARK ... 5298 5299 if Present (C) 5300 and then Restriction_Check_Required (SPARK_05) 5301 then 5302 declare 5303 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 5304 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 5305 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 5306 5307 begin 5308 -- ... unless the new declaration is in a subprogram, and the 5309 -- visible declaration is a variable declaration or a parameter 5310 -- specification outside that subprogram. 5311 5312 if Present (Enclosing_Subp) 5313 and then Nkind_In (Parent (C), N_Object_Declaration, 5314 N_Parameter_Specification) 5315 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 5316 then 5317 null; 5318 5319 -- ... or the new declaration is in a package, and the visible 5320 -- declaration occurs outside that package. 5321 5322 elsif Present (Enclosing_Pack) 5323 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 5324 then 5325 null; 5326 5327 -- ... or the new declaration is a component declaration in a 5328 -- record type definition. 5329 5330 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 5331 null; 5332 5333 -- Don't issue error for non-source entities 5334 5335 elsif Comes_From_Source (Def_Id) 5336 and then Comes_From_Source (C) 5337 then 5338 Error_Msg_Sloc := Sloc (C); 5339 Check_SPARK_Restriction 5340 ("redeclaration of identifier &#", Def_Id); 5341 end if; 5342 end; 5343 end if; 5344 5345 -- Warn if new entity hides an old one 5346 5347 if Warn_On_Hiding and then Present (C) 5348 5349 -- Don't warn for record components since they always have a well 5350 -- defined scope which does not confuse other uses. Note that in 5351 -- some cases, Ekind has not been set yet. 5352 5353 and then Ekind (C) /= E_Component 5354 and then Ekind (C) /= E_Discriminant 5355 and then Nkind (Parent (C)) /= N_Component_Declaration 5356 and then Ekind (Def_Id) /= E_Component 5357 and then Ekind (Def_Id) /= E_Discriminant 5358 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 5359 5360 -- Don't warn for one character variables. It is too common to use 5361 -- such variables as locals and will just cause too many false hits. 5362 5363 and then Length_Of_Name (Chars (C)) /= 1 5364 5365 -- Don't warn for non-source entities 5366 5367 and then Comes_From_Source (C) 5368 and then Comes_From_Source (Def_Id) 5369 5370 -- Don't warn unless entity in question is in extended main source 5371 5372 and then In_Extended_Main_Source_Unit (Def_Id) 5373 5374 -- Finally, the hidden entity must be either immediately visible or 5375 -- use visible (i.e. from a used package). 5376 5377 and then 5378 (Is_Immediately_Visible (C) 5379 or else 5380 Is_Potentially_Use_Visible (C)) 5381 then 5382 Error_Msg_Sloc := Sloc (C); 5383 Error_Msg_N ("declaration hides &#?h?", Def_Id); 5384 end if; 5385 end Enter_Name; 5386 5387 --------------- 5388 -- Entity_Of -- 5389 --------------- 5390 5391 function Entity_Of (N : Node_Id) return Entity_Id is 5392 Id : Entity_Id; 5393 5394 begin 5395 Id := Empty; 5396 5397 if Is_Entity_Name (N) then 5398 Id := Entity (N); 5399 5400 -- Follow a possible chain of renamings to reach the root renamed 5401 -- object. 5402 5403 while Present (Id) and then Present (Renamed_Object (Id)) loop 5404 if Is_Entity_Name (Renamed_Object (Id)) then 5405 Id := Entity (Renamed_Object (Id)); 5406 else 5407 Id := Empty; 5408 exit; 5409 end if; 5410 end loop; 5411 end if; 5412 5413 return Id; 5414 end Entity_Of; 5415 5416 -------------------------- 5417 -- Explain_Limited_Type -- 5418 -------------------------- 5419 5420 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 5421 C : Entity_Id; 5422 5423 begin 5424 -- For array, component type must be limited 5425 5426 if Is_Array_Type (T) then 5427 Error_Msg_Node_2 := T; 5428 Error_Msg_NE 5429 ("\component type& of type& is limited", N, Component_Type (T)); 5430 Explain_Limited_Type (Component_Type (T), N); 5431 5432 elsif Is_Record_Type (T) then 5433 5434 -- No need for extra messages if explicit limited record 5435 5436 if Is_Limited_Record (Base_Type (T)) then 5437 return; 5438 end if; 5439 5440 -- Otherwise find a limited component. Check only components that 5441 -- come from source, or inherited components that appear in the 5442 -- source of the ancestor. 5443 5444 C := First_Component (T); 5445 while Present (C) loop 5446 if Is_Limited_Type (Etype (C)) 5447 and then 5448 (Comes_From_Source (C) 5449 or else 5450 (Present (Original_Record_Component (C)) 5451 and then 5452 Comes_From_Source (Original_Record_Component (C)))) 5453 then 5454 Error_Msg_Node_2 := T; 5455 Error_Msg_NE ("\component& of type& has limited type", N, C); 5456 Explain_Limited_Type (Etype (C), N); 5457 return; 5458 end if; 5459 5460 Next_Component (C); 5461 end loop; 5462 5463 -- The type may be declared explicitly limited, even if no component 5464 -- of it is limited, in which case we fall out of the loop. 5465 return; 5466 end if; 5467 end Explain_Limited_Type; 5468 5469 ----------------- 5470 -- Find_Actual -- 5471 ----------------- 5472 5473 procedure Find_Actual 5474 (N : Node_Id; 5475 Formal : out Entity_Id; 5476 Call : out Node_Id) 5477 is 5478 Parnt : constant Node_Id := Parent (N); 5479 Actual : Node_Id; 5480 5481 begin 5482 if (Nkind (Parnt) = N_Indexed_Component 5483 or else 5484 Nkind (Parnt) = N_Selected_Component) 5485 and then N = Prefix (Parnt) 5486 then 5487 Find_Actual (Parnt, Formal, Call); 5488 return; 5489 5490 elsif Nkind (Parnt) = N_Parameter_Association 5491 and then N = Explicit_Actual_Parameter (Parnt) 5492 then 5493 Call := Parent (Parnt); 5494 5495 elsif Nkind (Parnt) in N_Subprogram_Call then 5496 Call := Parnt; 5497 5498 else 5499 Formal := Empty; 5500 Call := Empty; 5501 return; 5502 end if; 5503 5504 -- If we have a call to a subprogram look for the parameter. Note that 5505 -- we exclude overloaded calls, since we don't know enough to be sure 5506 -- of giving the right answer in this case. 5507 5508 if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) 5509 and then Is_Entity_Name (Name (Call)) 5510 and then Present (Entity (Name (Call))) 5511 and then Is_Overloadable (Entity (Name (Call))) 5512 and then not Is_Overloaded (Name (Call)) 5513 then 5514 -- Fall here if we are definitely a parameter 5515 5516 Actual := First_Actual (Call); 5517 Formal := First_Formal (Entity (Name (Call))); 5518 while Present (Formal) and then Present (Actual) loop 5519 if Actual = N then 5520 return; 5521 else 5522 Actual := Next_Actual (Actual); 5523 Formal := Next_Formal (Formal); 5524 end if; 5525 end loop; 5526 end if; 5527 5528 -- Fall through here if we did not find matching actual 5529 5530 Formal := Empty; 5531 Call := Empty; 5532 end Find_Actual; 5533 5534 --------------------------- 5535 -- Find_Body_Discriminal -- 5536 --------------------------- 5537 5538 function Find_Body_Discriminal 5539 (Spec_Discriminant : Entity_Id) return Entity_Id 5540 is 5541 Tsk : Entity_Id; 5542 Disc : Entity_Id; 5543 5544 begin 5545 -- If expansion is suppressed, then the scope can be the concurrent type 5546 -- itself rather than a corresponding concurrent record type. 5547 5548 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 5549 Tsk := Scope (Spec_Discriminant); 5550 5551 else 5552 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 5553 5554 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 5555 end if; 5556 5557 -- Find discriminant of original concurrent type, and use its current 5558 -- discriminal, which is the renaming within the task/protected body. 5559 5560 Disc := First_Discriminant (Tsk); 5561 while Present (Disc) loop 5562 if Chars (Disc) = Chars (Spec_Discriminant) then 5563 return Discriminal (Disc); 5564 end if; 5565 5566 Next_Discriminant (Disc); 5567 end loop; 5568 5569 -- That loop should always succeed in finding a matching entry and 5570 -- returning. Fatal error if not. 5571 5572 raise Program_Error; 5573 end Find_Body_Discriminal; 5574 5575 ------------------------------------- 5576 -- Find_Corresponding_Discriminant -- 5577 ------------------------------------- 5578 5579 function Find_Corresponding_Discriminant 5580 (Id : Node_Id; 5581 Typ : Entity_Id) return Entity_Id 5582 is 5583 Par_Disc : Entity_Id; 5584 Old_Disc : Entity_Id; 5585 New_Disc : Entity_Id; 5586 5587 begin 5588 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 5589 5590 -- The original type may currently be private, and the discriminant 5591 -- only appear on its full view. 5592 5593 if Is_Private_Type (Scope (Par_Disc)) 5594 and then not Has_Discriminants (Scope (Par_Disc)) 5595 and then Present (Full_View (Scope (Par_Disc))) 5596 then 5597 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 5598 else 5599 Old_Disc := First_Discriminant (Scope (Par_Disc)); 5600 end if; 5601 5602 if Is_Class_Wide_Type (Typ) then 5603 New_Disc := First_Discriminant (Root_Type (Typ)); 5604 else 5605 New_Disc := First_Discriminant (Typ); 5606 end if; 5607 5608 while Present (Old_Disc) and then Present (New_Disc) loop 5609 if Old_Disc = Par_Disc then 5610 return New_Disc; 5611 else 5612 Next_Discriminant (Old_Disc); 5613 Next_Discriminant (New_Disc); 5614 end if; 5615 end loop; 5616 5617 -- Should always find it 5618 5619 raise Program_Error; 5620 end Find_Corresponding_Discriminant; 5621 5622 ---------------------------------- 5623 -- Find_Enclosing_Iterator_Loop -- 5624 ---------------------------------- 5625 5626 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 5627 Constr : Node_Id; 5628 S : Entity_Id; 5629 5630 begin 5631 -- Traverse the scope chain looking for an iterator loop. Such loops are 5632 -- usually transformed into blocks, hence the use of Original_Node. 5633 5634 S := Id; 5635 while Present (S) and then S /= Standard_Standard loop 5636 if Ekind (S) = E_Loop 5637 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 5638 then 5639 Constr := Original_Node (Label_Construct (Parent (S))); 5640 5641 if Nkind (Constr) = N_Loop_Statement 5642 and then Present (Iteration_Scheme (Constr)) 5643 and then Nkind (Iterator_Specification 5644 (Iteration_Scheme (Constr))) = 5645 N_Iterator_Specification 5646 then 5647 return S; 5648 end if; 5649 end if; 5650 5651 S := Scope (S); 5652 end loop; 5653 5654 return Empty; 5655 end Find_Enclosing_Iterator_Loop; 5656 5657 ------------------------------------ 5658 -- Find_Loop_In_Conditional_Block -- 5659 ------------------------------------ 5660 5661 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 5662 Stmt : Node_Id; 5663 5664 begin 5665 Stmt := N; 5666 5667 if Nkind (Stmt) = N_If_Statement then 5668 Stmt := First (Then_Statements (Stmt)); 5669 end if; 5670 5671 pragma Assert (Nkind (Stmt) = N_Block_Statement); 5672 5673 -- Inspect the statements of the conditional block. In general the loop 5674 -- should be the first statement in the statement sequence of the block, 5675 -- but the finalization machinery may have introduced extra object 5676 -- declarations. 5677 5678 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 5679 while Present (Stmt) loop 5680 if Nkind (Stmt) = N_Loop_Statement then 5681 return Stmt; 5682 end if; 5683 5684 Next (Stmt); 5685 end loop; 5686 5687 -- The expansion of attribute 'Loop_Entry produced a malformed block 5688 5689 raise Program_Error; 5690 end Find_Loop_In_Conditional_Block; 5691 5692 -------------------------- 5693 -- Find_Overlaid_Entity -- 5694 -------------------------- 5695 5696 procedure Find_Overlaid_Entity 5697 (N : Node_Id; 5698 Ent : out Entity_Id; 5699 Off : out Boolean) 5700 is 5701 Expr : Node_Id; 5702 5703 begin 5704 -- We are looking for one of the two following forms: 5705 5706 -- for X'Address use Y'Address 5707 5708 -- or 5709 5710 -- Const : constant Address := expr; 5711 -- ... 5712 -- for X'Address use Const; 5713 5714 -- In the second case, the expr is either Y'Address, or recursively a 5715 -- constant that eventually references Y'Address. 5716 5717 Ent := Empty; 5718 Off := False; 5719 5720 if Nkind (N) = N_Attribute_Definition_Clause 5721 and then Chars (N) = Name_Address 5722 then 5723 Expr := Expression (N); 5724 5725 -- This loop checks the form of the expression for Y'Address, 5726 -- using recursion to deal with intermediate constants. 5727 5728 loop 5729 -- Check for Y'Address 5730 5731 if Nkind (Expr) = N_Attribute_Reference 5732 and then Attribute_Name (Expr) = Name_Address 5733 then 5734 Expr := Prefix (Expr); 5735 exit; 5736 5737 -- Check for Const where Const is a constant entity 5738 5739 elsif Is_Entity_Name (Expr) 5740 and then Ekind (Entity (Expr)) = E_Constant 5741 then 5742 Expr := Constant_Value (Entity (Expr)); 5743 5744 -- Anything else does not need checking 5745 5746 else 5747 return; 5748 end if; 5749 end loop; 5750 5751 -- This loop checks the form of the prefix for an entity, using 5752 -- recursion to deal with intermediate components. 5753 5754 loop 5755 -- Check for Y where Y is an entity 5756 5757 if Is_Entity_Name (Expr) then 5758 Ent := Entity (Expr); 5759 return; 5760 5761 -- Check for components 5762 5763 elsif 5764 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 5765 then 5766 Expr := Prefix (Expr); 5767 Off := True; 5768 5769 -- Anything else does not need checking 5770 5771 else 5772 return; 5773 end if; 5774 end loop; 5775 end if; 5776 end Find_Overlaid_Entity; 5777 5778 ------------------------- 5779 -- Find_Parameter_Type -- 5780 ------------------------- 5781 5782 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 5783 begin 5784 if Nkind (Param) /= N_Parameter_Specification then 5785 return Empty; 5786 5787 -- For an access parameter, obtain the type from the formal entity 5788 -- itself, because access to subprogram nodes do not carry a type. 5789 -- Shouldn't we always use the formal entity ??? 5790 5791 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 5792 return Etype (Defining_Identifier (Param)); 5793 5794 else 5795 return Etype (Parameter_Type (Param)); 5796 end if; 5797 end Find_Parameter_Type; 5798 5799 ----------------------------------- 5800 -- Find_Placement_In_State_Space -- 5801 ----------------------------------- 5802 5803 procedure Find_Placement_In_State_Space 5804 (Item_Id : Entity_Id; 5805 Placement : out State_Space_Kind; 5806 Pack_Id : out Entity_Id) 5807 is 5808 Context : Entity_Id; 5809 5810 begin 5811 -- Assume that the item does not appear in the state space of a package 5812 5813 Placement := Not_In_Package; 5814 Pack_Id := Empty; 5815 5816 -- Climb the scope stack and examine the enclosing context 5817 5818 Context := Scope (Item_Id); 5819 while Present (Context) and then Context /= Standard_Standard loop 5820 if Ekind (Context) = E_Package then 5821 Pack_Id := Context; 5822 5823 -- A package body is a cut off point for the traversal as the item 5824 -- cannot be visible to the outside from this point on. Note that 5825 -- this test must be done first as a body is also classified as a 5826 -- private part. 5827 5828 if In_Package_Body (Context) then 5829 Placement := Body_State_Space; 5830 return; 5831 5832 -- The private part of a package is a cut off point for the 5833 -- traversal as the item cannot be visible to the outside from 5834 -- this point on. 5835 5836 elsif In_Private_Part (Context) then 5837 Placement := Private_State_Space; 5838 return; 5839 5840 -- When the item appears in the visible state space of a package, 5841 -- continue to climb the scope stack as this may not be the final 5842 -- state space. 5843 5844 else 5845 Placement := Visible_State_Space; 5846 5847 -- The visible state space of a child unit acts as the proper 5848 -- placement of an item. 5849 5850 if Is_Child_Unit (Context) then 5851 return; 5852 end if; 5853 end if; 5854 5855 -- The item or its enclosing package appear in a construct that has 5856 -- no state space. 5857 5858 else 5859 Placement := Not_In_Package; 5860 return; 5861 end if; 5862 5863 Context := Scope (Context); 5864 end loop; 5865 end Find_Placement_In_State_Space; 5866 5867 ----------------------------- 5868 -- Find_Static_Alternative -- 5869 ----------------------------- 5870 5871 function Find_Static_Alternative (N : Node_Id) return Node_Id is 5872 Expr : constant Node_Id := Expression (N); 5873 Val : constant Uint := Expr_Value (Expr); 5874 Alt : Node_Id; 5875 Choice : Node_Id; 5876 5877 begin 5878 Alt := First (Alternatives (N)); 5879 5880 Search : loop 5881 if Nkind (Alt) /= N_Pragma then 5882 Choice := First (Discrete_Choices (Alt)); 5883 while Present (Choice) loop 5884 5885 -- Others choice, always matches 5886 5887 if Nkind (Choice) = N_Others_Choice then 5888 exit Search; 5889 5890 -- Range, check if value is in the range 5891 5892 elsif Nkind (Choice) = N_Range then 5893 exit Search when 5894 Val >= Expr_Value (Low_Bound (Choice)) 5895 and then 5896 Val <= Expr_Value (High_Bound (Choice)); 5897 5898 -- Choice is a subtype name. Note that we know it must 5899 -- be a static subtype, since otherwise it would have 5900 -- been diagnosed as illegal. 5901 5902 elsif Is_Entity_Name (Choice) 5903 and then Is_Type (Entity (Choice)) 5904 then 5905 exit Search when Is_In_Range (Expr, Etype (Choice), 5906 Assume_Valid => False); 5907 5908 -- Choice is a subtype indication 5909 5910 elsif Nkind (Choice) = N_Subtype_Indication then 5911 declare 5912 C : constant Node_Id := Constraint (Choice); 5913 R : constant Node_Id := Range_Expression (C); 5914 5915 begin 5916 exit Search when 5917 Val >= Expr_Value (Low_Bound (R)) 5918 and then 5919 Val <= Expr_Value (High_Bound (R)); 5920 end; 5921 5922 -- Choice is a simple expression 5923 5924 else 5925 exit Search when Val = Expr_Value (Choice); 5926 end if; 5927 5928 Next (Choice); 5929 end loop; 5930 end if; 5931 5932 Next (Alt); 5933 pragma Assert (Present (Alt)); 5934 end loop Search; 5935 5936 -- The above loop *must* terminate by finding a match, since 5937 -- we know the case statement is valid, and the value of the 5938 -- expression is known at compile time. When we fall out of 5939 -- the loop, Alt points to the alternative that we know will 5940 -- be selected at run time. 5941 5942 return Alt; 5943 end Find_Static_Alternative; 5944 5945 ------------------ 5946 -- First_Actual -- 5947 ------------------ 5948 5949 function First_Actual (Node : Node_Id) return Node_Id is 5950 N : Node_Id; 5951 5952 begin 5953 if No (Parameter_Associations (Node)) then 5954 return Empty; 5955 end if; 5956 5957 N := First (Parameter_Associations (Node)); 5958 5959 if Nkind (N) = N_Parameter_Association then 5960 return First_Named_Actual (Node); 5961 else 5962 return N; 5963 end if; 5964 end First_Actual; 5965 5966 ----------------------- 5967 -- Gather_Components -- 5968 ----------------------- 5969 5970 procedure Gather_Components 5971 (Typ : Entity_Id; 5972 Comp_List : Node_Id; 5973 Governed_By : List_Id; 5974 Into : Elist_Id; 5975 Report_Errors : out Boolean) 5976 is 5977 Assoc : Node_Id; 5978 Variant : Node_Id; 5979 Discrete_Choice : Node_Id; 5980 Comp_Item : Node_Id; 5981 5982 Discrim : Entity_Id; 5983 Discrim_Name : Node_Id; 5984 Discrim_Value : Node_Id; 5985 5986 begin 5987 Report_Errors := False; 5988 5989 if No (Comp_List) or else Null_Present (Comp_List) then 5990 return; 5991 5992 elsif Present (Component_Items (Comp_List)) then 5993 Comp_Item := First (Component_Items (Comp_List)); 5994 5995 else 5996 Comp_Item := Empty; 5997 end if; 5998 5999 while Present (Comp_Item) loop 6000 6001 -- Skip the tag of a tagged record, the interface tags, as well 6002 -- as all items that are not user components (anonymous types, 6003 -- rep clauses, Parent field, controller field). 6004 6005 if Nkind (Comp_Item) = N_Component_Declaration then 6006 declare 6007 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 6008 begin 6009 if not Is_Tag (Comp) 6010 and then Chars (Comp) /= Name_uParent 6011 then 6012 Append_Elmt (Comp, Into); 6013 end if; 6014 end; 6015 end if; 6016 6017 Next (Comp_Item); 6018 end loop; 6019 6020 if No (Variant_Part (Comp_List)) then 6021 return; 6022 else 6023 Discrim_Name := Name (Variant_Part (Comp_List)); 6024 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 6025 end if; 6026 6027 -- Look for the discriminant that governs this variant part. 6028 -- The discriminant *must* be in the Governed_By List 6029 6030 Assoc := First (Governed_By); 6031 Find_Constraint : loop 6032 Discrim := First (Choices (Assoc)); 6033 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) 6034 or else (Present (Corresponding_Discriminant (Entity (Discrim))) 6035 and then 6036 Chars (Corresponding_Discriminant (Entity (Discrim))) = 6037 Chars (Discrim_Name)) 6038 or else Chars (Original_Record_Component (Entity (Discrim))) 6039 = Chars (Discrim_Name); 6040 6041 if No (Next (Assoc)) then 6042 if not Is_Constrained (Typ) 6043 and then Is_Derived_Type (Typ) 6044 and then Present (Stored_Constraint (Typ)) 6045 then 6046 -- If the type is a tagged type with inherited discriminants, 6047 -- use the stored constraint on the parent in order to find 6048 -- the values of discriminants that are otherwise hidden by an 6049 -- explicit constraint. Renamed discriminants are handled in 6050 -- the code above. 6051 6052 -- If several parent discriminants are renamed by a single 6053 -- discriminant of the derived type, the call to obtain the 6054 -- Corresponding_Discriminant field only retrieves the last 6055 -- of them. We recover the constraint on the others from the 6056 -- Stored_Constraint as well. 6057 6058 declare 6059 D : Entity_Id; 6060 C : Elmt_Id; 6061 6062 begin 6063 D := First_Discriminant (Etype (Typ)); 6064 C := First_Elmt (Stored_Constraint (Typ)); 6065 while Present (D) and then Present (C) loop 6066 if Chars (Discrim_Name) = Chars (D) then 6067 if Is_Entity_Name (Node (C)) 6068 and then Entity (Node (C)) = Entity (Discrim) 6069 then 6070 -- D is renamed by Discrim, whose value is given in 6071 -- Assoc. 6072 6073 null; 6074 6075 else 6076 Assoc := 6077 Make_Component_Association (Sloc (Typ), 6078 New_List 6079 (New_Occurrence_Of (D, Sloc (Typ))), 6080 Duplicate_Subexpr_No_Checks (Node (C))); 6081 end if; 6082 exit Find_Constraint; 6083 end if; 6084 6085 Next_Discriminant (D); 6086 Next_Elmt (C); 6087 end loop; 6088 end; 6089 end if; 6090 end if; 6091 6092 if No (Next (Assoc)) then 6093 Error_Msg_NE (" missing value for discriminant&", 6094 First (Governed_By), Discrim_Name); 6095 Report_Errors := True; 6096 return; 6097 end if; 6098 6099 Next (Assoc); 6100 end loop Find_Constraint; 6101 6102 Discrim_Value := Expression (Assoc); 6103 6104 if not Is_OK_Static_Expression (Discrim_Value) then 6105 Error_Msg_FE 6106 ("value for discriminant & must be static!", 6107 Discrim_Value, Discrim); 6108 Why_Not_Static (Discrim_Value); 6109 Report_Errors := True; 6110 return; 6111 end if; 6112 6113 Search_For_Discriminant_Value : declare 6114 Low : Node_Id; 6115 High : Node_Id; 6116 6117 UI_High : Uint; 6118 UI_Low : Uint; 6119 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 6120 6121 begin 6122 Find_Discrete_Value : while Present (Variant) loop 6123 Discrete_Choice := First (Discrete_Choices (Variant)); 6124 while Present (Discrete_Choice) loop 6125 exit Find_Discrete_Value when 6126 Nkind (Discrete_Choice) = N_Others_Choice; 6127 6128 Get_Index_Bounds (Discrete_Choice, Low, High); 6129 6130 UI_Low := Expr_Value (Low); 6131 UI_High := Expr_Value (High); 6132 6133 exit Find_Discrete_Value when 6134 UI_Low <= UI_Discrim_Value 6135 and then 6136 UI_High >= UI_Discrim_Value; 6137 6138 Next (Discrete_Choice); 6139 end loop; 6140 6141 Next_Non_Pragma (Variant); 6142 end loop Find_Discrete_Value; 6143 end Search_For_Discriminant_Value; 6144 6145 if No (Variant) then 6146 Error_Msg_NE 6147 ("value of discriminant & is out of range", Discrim_Value, Discrim); 6148 Report_Errors := True; 6149 return; 6150 end if; 6151 6152 -- If we have found the corresponding choice, recursively add its 6153 -- components to the Into list. 6154 6155 Gather_Components 6156 (Empty, Component_List (Variant), Governed_By, Into, Report_Errors); 6157 end Gather_Components; 6158 6159 ------------------------ 6160 -- Get_Actual_Subtype -- 6161 ------------------------ 6162 6163 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 6164 Typ : constant Entity_Id := Etype (N); 6165 Utyp : Entity_Id := Underlying_Type (Typ); 6166 Decl : Node_Id; 6167 Atyp : Entity_Id; 6168 6169 begin 6170 if No (Utyp) then 6171 Utyp := Typ; 6172 end if; 6173 6174 -- If what we have is an identifier that references a subprogram 6175 -- formal, or a variable or constant object, then we get the actual 6176 -- subtype from the referenced entity if one has been built. 6177 6178 if Nkind (N) = N_Identifier 6179 and then 6180 (Is_Formal (Entity (N)) 6181 or else Ekind (Entity (N)) = E_Constant 6182 or else Ekind (Entity (N)) = E_Variable) 6183 and then Present (Actual_Subtype (Entity (N))) 6184 then 6185 return Actual_Subtype (Entity (N)); 6186 6187 -- Actual subtype of unchecked union is always itself. We never need 6188 -- the "real" actual subtype. If we did, we couldn't get it anyway 6189 -- because the discriminant is not available. The restrictions on 6190 -- Unchecked_Union are designed to make sure that this is OK. 6191 6192 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 6193 return Typ; 6194 6195 -- Here for the unconstrained case, we must find actual subtype 6196 -- No actual subtype is available, so we must build it on the fly. 6197 6198 -- Checking the type, not the underlying type, for constrainedness 6199 -- seems to be necessary. Maybe all the tests should be on the type??? 6200 6201 elsif (not Is_Constrained (Typ)) 6202 and then (Is_Array_Type (Utyp) 6203 or else (Is_Record_Type (Utyp) 6204 and then Has_Discriminants (Utyp))) 6205 and then not Has_Unknown_Discriminants (Utyp) 6206 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 6207 then 6208 -- Nothing to do if in spec expression (why not???) 6209 6210 if In_Spec_Expression then 6211 return Typ; 6212 6213 elsif Is_Private_Type (Typ) 6214 and then not Has_Discriminants (Typ) 6215 then 6216 -- If the type has no discriminants, there is no subtype to 6217 -- build, even if the underlying type is discriminated. 6218 6219 return Typ; 6220 6221 -- Else build the actual subtype 6222 6223 else 6224 Decl := Build_Actual_Subtype (Typ, N); 6225 Atyp := Defining_Identifier (Decl); 6226 6227 -- If Build_Actual_Subtype generated a new declaration then use it 6228 6229 if Atyp /= Typ then 6230 6231 -- The actual subtype is an Itype, so analyze the declaration, 6232 -- but do not attach it to the tree, to get the type defined. 6233 6234 Set_Parent (Decl, N); 6235 Set_Is_Itype (Atyp); 6236 Analyze (Decl, Suppress => All_Checks); 6237 Set_Associated_Node_For_Itype (Atyp, N); 6238 Set_Has_Delayed_Freeze (Atyp, False); 6239 6240 -- We need to freeze the actual subtype immediately. This is 6241 -- needed, because otherwise this Itype will not get frozen 6242 -- at all, and it is always safe to freeze on creation because 6243 -- any associated types must be frozen at this point. 6244 6245 Freeze_Itype (Atyp, N); 6246 return Atyp; 6247 6248 -- Otherwise we did not build a declaration, so return original 6249 6250 else 6251 return Typ; 6252 end if; 6253 end if; 6254 6255 -- For all remaining cases, the actual subtype is the same as 6256 -- the nominal type. 6257 6258 else 6259 return Typ; 6260 end if; 6261 end Get_Actual_Subtype; 6262 6263 ------------------------------------- 6264 -- Get_Actual_Subtype_If_Available -- 6265 ------------------------------------- 6266 6267 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 6268 Typ : constant Entity_Id := Etype (N); 6269 6270 begin 6271 -- If what we have is an identifier that references a subprogram 6272 -- formal, or a variable or constant object, then we get the actual 6273 -- subtype from the referenced entity if one has been built. 6274 6275 if Nkind (N) = N_Identifier 6276 and then 6277 (Is_Formal (Entity (N)) 6278 or else Ekind (Entity (N)) = E_Constant 6279 or else Ekind (Entity (N)) = E_Variable) 6280 and then Present (Actual_Subtype (Entity (N))) 6281 then 6282 return Actual_Subtype (Entity (N)); 6283 6284 -- Otherwise the Etype of N is returned unchanged 6285 6286 else 6287 return Typ; 6288 end if; 6289 end Get_Actual_Subtype_If_Available; 6290 6291 ------------------------ 6292 -- Get_Body_From_Stub -- 6293 ------------------------ 6294 6295 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 6296 begin 6297 return Proper_Body (Unit (Library_Unit (N))); 6298 end Get_Body_From_Stub; 6299 6300 --------------------- 6301 -- Get_Cursor_Type -- 6302 --------------------- 6303 6304 function Get_Cursor_Type 6305 (Aspect : Node_Id; 6306 Typ : Entity_Id) return Entity_Id 6307 is 6308 Assoc : Node_Id; 6309 Func : Entity_Id; 6310 First_Op : Entity_Id; 6311 Cursor : Entity_Id; 6312 6313 begin 6314 -- If error already detected, return 6315 6316 if Error_Posted (Aspect) then 6317 return Any_Type; 6318 end if; 6319 6320 -- The cursor type for an Iterable aspect is the return type of a 6321 -- non-overloaded First primitive operation. Locate association for 6322 -- First. 6323 6324 Assoc := First (Component_Associations (Expression (Aspect))); 6325 First_Op := Any_Id; 6326 while Present (Assoc) loop 6327 if Chars (First (Choices (Assoc))) = Name_First then 6328 First_Op := Expression (Assoc); 6329 exit; 6330 end if; 6331 6332 Next (Assoc); 6333 end loop; 6334 6335 if First_Op = Any_Id then 6336 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 6337 return Any_Type; 6338 end if; 6339 6340 Cursor := Any_Type; 6341 6342 -- Locate function with desired name and profile in scope of type 6343 6344 Func := First_Entity (Scope (Typ)); 6345 while Present (Func) loop 6346 if Chars (Func) = Chars (First_Op) 6347 and then Ekind (Func) = E_Function 6348 and then Present (First_Formal (Func)) 6349 and then Etype (First_Formal (Func)) = Typ 6350 and then No (Next_Formal (First_Formal (Func))) 6351 then 6352 if Cursor /= Any_Type then 6353 Error_Msg_N 6354 ("Operation First for iterable type must be unique", Aspect); 6355 return Any_Type; 6356 else 6357 Cursor := Etype (Func); 6358 end if; 6359 end if; 6360 6361 Next_Entity (Func); 6362 end loop; 6363 6364 -- If not found, no way to resolve remaining primitives. 6365 6366 if Cursor = Any_Type then 6367 Error_Msg_N 6368 ("No legal primitive operation First for Iterable type", Aspect); 6369 end if; 6370 6371 return Cursor; 6372 end Get_Cursor_Type; 6373 6374 ------------------------------- 6375 -- Get_Default_External_Name -- 6376 ------------------------------- 6377 6378 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 6379 begin 6380 Get_Decoded_Name_String (Chars (E)); 6381 6382 if Opt.External_Name_Imp_Casing = Uppercase then 6383 Set_Casing (All_Upper_Case); 6384 else 6385 Set_Casing (All_Lower_Case); 6386 end if; 6387 6388 return 6389 Make_String_Literal (Sloc (E), 6390 Strval => String_From_Name_Buffer); 6391 end Get_Default_External_Name; 6392 6393 -------------------------- 6394 -- Get_Enclosing_Object -- 6395 -------------------------- 6396 6397 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 6398 begin 6399 if Is_Entity_Name (N) then 6400 return Entity (N); 6401 else 6402 case Nkind (N) is 6403 when N_Indexed_Component | 6404 N_Slice | 6405 N_Selected_Component => 6406 6407 -- If not generating code, a dereference may be left implicit. 6408 -- In thoses cases, return Empty. 6409 6410 if Is_Access_Type (Etype (Prefix (N))) then 6411 return Empty; 6412 else 6413 return Get_Enclosing_Object (Prefix (N)); 6414 end if; 6415 6416 when N_Type_Conversion => 6417 return Get_Enclosing_Object (Expression (N)); 6418 6419 when others => 6420 return Empty; 6421 end case; 6422 end if; 6423 end Get_Enclosing_Object; 6424 6425 --------------------------- 6426 -- Get_Enum_Lit_From_Pos -- 6427 --------------------------- 6428 6429 function Get_Enum_Lit_From_Pos 6430 (T : Entity_Id; 6431 Pos : Uint; 6432 Loc : Source_Ptr) return Node_Id 6433 is 6434 Btyp : Entity_Id := Base_Type (T); 6435 Lit : Node_Id; 6436 6437 begin 6438 -- In the case where the literal is of type Character, Wide_Character 6439 -- or Wide_Wide_Character or of a type derived from them, there needs 6440 -- to be some special handling since there is no explicit chain of 6441 -- literals to search. Instead, an N_Character_Literal node is created 6442 -- with the appropriate Char_Code and Chars fields. 6443 6444 if Is_Standard_Character_Type (T) then 6445 Set_Character_Literal_Name (UI_To_CC (Pos)); 6446 return 6447 Make_Character_Literal (Loc, 6448 Chars => Name_Find, 6449 Char_Literal_Value => Pos); 6450 6451 -- For all other cases, we have a complete table of literals, and 6452 -- we simply iterate through the chain of literal until the one 6453 -- with the desired position value is found. 6454 -- 6455 6456 else 6457 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 6458 Btyp := Full_View (Btyp); 6459 end if; 6460 6461 Lit := First_Literal (Btyp); 6462 for J in 1 .. UI_To_Int (Pos) loop 6463 Next_Literal (Lit); 6464 end loop; 6465 6466 return New_Occurrence_Of (Lit, Loc); 6467 end if; 6468 end Get_Enum_Lit_From_Pos; 6469 6470 --------------------------------- 6471 -- Get_Ensures_From_CTC_Pragma -- 6472 --------------------------------- 6473 6474 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is 6475 Args : constant List_Id := Pragma_Argument_Associations (N); 6476 Res : Node_Id; 6477 6478 begin 6479 if List_Length (Args) = 4 then 6480 Res := Pick (Args, 4); 6481 6482 elsif List_Length (Args) = 3 then 6483 Res := Pick (Args, 3); 6484 6485 if Chars (Res) /= Name_Ensures then 6486 Res := Empty; 6487 end if; 6488 6489 else 6490 Res := Empty; 6491 end if; 6492 6493 return Res; 6494 end Get_Ensures_From_CTC_Pragma; 6495 6496 ------------------------ 6497 -- Get_Generic_Entity -- 6498 ------------------------ 6499 6500 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 6501 Ent : constant Entity_Id := Entity (Name (N)); 6502 begin 6503 if Present (Renamed_Object (Ent)) then 6504 return Renamed_Object (Ent); 6505 else 6506 return Ent; 6507 end if; 6508 end Get_Generic_Entity; 6509 6510 ------------------------------------- 6511 -- Get_Incomplete_View_Of_Ancestor -- 6512 ------------------------------------- 6513 6514 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 6515 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 6516 Par_Scope : Entity_Id; 6517 Par_Type : Entity_Id; 6518 6519 begin 6520 -- The incomplete view of an ancestor is only relevant for private 6521 -- derived types in child units. 6522 6523 if not Is_Derived_Type (E) 6524 or else not Is_Child_Unit (Cur_Unit) 6525 then 6526 return Empty; 6527 6528 else 6529 Par_Scope := Scope (Cur_Unit); 6530 if No (Par_Scope) then 6531 return Empty; 6532 end if; 6533 6534 Par_Type := Etype (Base_Type (E)); 6535 6536 -- Traverse list of ancestor types until we find one declared in 6537 -- a parent or grandparent unit (two levels seem sufficient). 6538 6539 while Present (Par_Type) loop 6540 if Scope (Par_Type) = Par_Scope 6541 or else Scope (Par_Type) = Scope (Par_Scope) 6542 then 6543 return Par_Type; 6544 6545 elsif not Is_Derived_Type (Par_Type) then 6546 return Empty; 6547 6548 else 6549 Par_Type := Etype (Base_Type (Par_Type)); 6550 end if; 6551 end loop; 6552 6553 -- If none found, there is no relevant ancestor type. 6554 6555 return Empty; 6556 end if; 6557 end Get_Incomplete_View_Of_Ancestor; 6558 6559 ---------------------- 6560 -- Get_Index_Bounds -- 6561 ---------------------- 6562 6563 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is 6564 Kind : constant Node_Kind := Nkind (N); 6565 R : Node_Id; 6566 6567 begin 6568 if Kind = N_Range then 6569 L := Low_Bound (N); 6570 H := High_Bound (N); 6571 6572 elsif Kind = N_Subtype_Indication then 6573 R := Range_Expression (Constraint (N)); 6574 6575 if R = Error then 6576 L := Error; 6577 H := Error; 6578 return; 6579 6580 else 6581 L := Low_Bound (Range_Expression (Constraint (N))); 6582 H := High_Bound (Range_Expression (Constraint (N))); 6583 end if; 6584 6585 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 6586 if Error_Posted (Scalar_Range (Entity (N))) then 6587 L := Error; 6588 H := Error; 6589 6590 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then 6591 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H); 6592 6593 else 6594 L := Low_Bound (Scalar_Range (Entity (N))); 6595 H := High_Bound (Scalar_Range (Entity (N))); 6596 end if; 6597 6598 else 6599 -- N is an expression, indicating a range with one value 6600 6601 L := N; 6602 H := N; 6603 end if; 6604 end Get_Index_Bounds; 6605 6606 --------------------------------- 6607 -- Get_Iterable_Type_Primitive -- 6608 --------------------------------- 6609 6610 function Get_Iterable_Type_Primitive 6611 (Typ : Entity_Id; 6612 Nam : Name_Id) return Entity_Id 6613 is 6614 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 6615 Assoc : Node_Id; 6616 6617 begin 6618 if No (Funcs) then 6619 return Empty; 6620 6621 else 6622 Assoc := First (Component_Associations (Funcs)); 6623 while Present (Assoc) loop 6624 if Chars (First (Choices (Assoc))) = Nam then 6625 return Entity (Expression (Assoc)); 6626 end if; 6627 6628 Assoc := Next (Assoc); 6629 end loop; 6630 6631 return Empty; 6632 end if; 6633 end Get_Iterable_Type_Primitive; 6634 6635 ---------------------------------- 6636 -- Get_Library_Unit_Name_string -- 6637 ---------------------------------- 6638 6639 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 6640 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 6641 6642 begin 6643 Get_Unit_Name_String (Unit_Name_Id); 6644 6645 -- Remove seven last character (" (spec)" or " (body)") 6646 6647 Name_Len := Name_Len - 7; 6648 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 6649 end Get_Library_Unit_Name_String; 6650 6651 ------------------------ 6652 -- Get_Name_Entity_Id -- 6653 ------------------------ 6654 6655 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 6656 begin 6657 return Entity_Id (Get_Name_Table_Info (Id)); 6658 end Get_Name_Entity_Id; 6659 6660 ------------------------------ 6661 -- Get_Name_From_CTC_Pragma -- 6662 ------------------------------ 6663 6664 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 6665 Arg : constant Node_Id := 6666 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 6667 begin 6668 return Strval (Expr_Value_S (Arg)); 6669 end Get_Name_From_CTC_Pragma; 6670 6671 ------------------- 6672 -- Get_Pragma_Id -- 6673 ------------------- 6674 6675 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 6676 begin 6677 return Get_Pragma_Id (Pragma_Name (N)); 6678 end Get_Pragma_Id; 6679 6680 ----------------------- 6681 -- Get_Reason_String -- 6682 ----------------------- 6683 6684 procedure Get_Reason_String (N : Node_Id) is 6685 begin 6686 if Nkind (N) = N_String_Literal then 6687 Store_String_Chars (Strval (N)); 6688 6689 elsif Nkind (N) = N_Op_Concat then 6690 Get_Reason_String (Left_Opnd (N)); 6691 Get_Reason_String (Right_Opnd (N)); 6692 6693 -- If not of required form, error 6694 6695 else 6696 Error_Msg_N 6697 ("Reason for pragma Warnings has wrong form", N); 6698 Error_Msg_N 6699 ("\must be string literal or concatenation of string literals", N); 6700 return; 6701 end if; 6702 end Get_Reason_String; 6703 6704 --------------------------- 6705 -- Get_Referenced_Object -- 6706 --------------------------- 6707 6708 function Get_Referenced_Object (N : Node_Id) return Node_Id is 6709 R : Node_Id; 6710 6711 begin 6712 R := N; 6713 while Is_Entity_Name (R) 6714 and then Present (Renamed_Object (Entity (R))) 6715 loop 6716 R := Renamed_Object (Entity (R)); 6717 end loop; 6718 6719 return R; 6720 end Get_Referenced_Object; 6721 6722 ------------------------ 6723 -- Get_Renamed_Entity -- 6724 ------------------------ 6725 6726 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 6727 R : Entity_Id; 6728 6729 begin 6730 R := E; 6731 while Present (Renamed_Entity (R)) loop 6732 R := Renamed_Entity (R); 6733 end loop; 6734 6735 return R; 6736 end Get_Renamed_Entity; 6737 6738 ---------------------------------- 6739 -- Get_Requires_From_CTC_Pragma -- 6740 ---------------------------------- 6741 6742 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is 6743 Args : constant List_Id := Pragma_Argument_Associations (N); 6744 Res : Node_Id; 6745 6746 begin 6747 if List_Length (Args) >= 3 then 6748 Res := Pick (Args, 3); 6749 6750 if Chars (Res) /= Name_Requires then 6751 Res := Empty; 6752 end if; 6753 6754 else 6755 Res := Empty; 6756 end if; 6757 6758 return Res; 6759 end Get_Requires_From_CTC_Pragma; 6760 6761 ------------------------- 6762 -- Get_Subprogram_Body -- 6763 ------------------------- 6764 6765 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is 6766 Decl : Node_Id; 6767 6768 begin 6769 Decl := Unit_Declaration_Node (E); 6770 6771 if Nkind (Decl) = N_Subprogram_Body then 6772 return Decl; 6773 6774 -- The below comment is bad, because it is possible for 6775 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ??? 6776 6777 else -- Nkind (Decl) = N_Subprogram_Declaration 6778 6779 if Present (Corresponding_Body (Decl)) then 6780 return Unit_Declaration_Node (Corresponding_Body (Decl)); 6781 6782 -- Imported subprogram case 6783 6784 else 6785 return Empty; 6786 end if; 6787 end if; 6788 end Get_Subprogram_Body; 6789 6790 --------------------------- 6791 -- Get_Subprogram_Entity -- 6792 --------------------------- 6793 6794 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 6795 Subp : Node_Id; 6796 Subp_Id : Entity_Id; 6797 6798 begin 6799 if Nkind (Nod) = N_Accept_Statement then 6800 Subp := Entry_Direct_Name (Nod); 6801 6802 elsif Nkind (Nod) = N_Slice then 6803 Subp := Prefix (Nod); 6804 6805 else 6806 Subp := Name (Nod); 6807 end if; 6808 6809 -- Strip the subprogram call 6810 6811 loop 6812 if Nkind_In (Subp, N_Explicit_Dereference, 6813 N_Indexed_Component, 6814 N_Selected_Component) 6815 then 6816 Subp := Prefix (Subp); 6817 6818 elsif Nkind_In (Subp, N_Type_Conversion, 6819 N_Unchecked_Type_Conversion) 6820 then 6821 Subp := Expression (Subp); 6822 6823 else 6824 exit; 6825 end if; 6826 end loop; 6827 6828 -- Extract the entity of the subprogram call 6829 6830 if Is_Entity_Name (Subp) then 6831 Subp_Id := Entity (Subp); 6832 6833 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 6834 Subp_Id := Directly_Designated_Type (Subp_Id); 6835 end if; 6836 6837 if Is_Subprogram (Subp_Id) then 6838 return Subp_Id; 6839 else 6840 return Empty; 6841 end if; 6842 6843 -- The search did not find a construct that denotes a subprogram 6844 6845 else 6846 return Empty; 6847 end if; 6848 end Get_Subprogram_Entity; 6849 6850 ----------------------------- 6851 -- Get_Task_Body_Procedure -- 6852 ----------------------------- 6853 6854 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is 6855 begin 6856 -- Note: A task type may be the completion of a private type with 6857 -- discriminants. When performing elaboration checks on a task 6858 -- declaration, the current view of the type may be the private one, 6859 -- and the procedure that holds the body of the task is held in its 6860 -- underlying type. 6861 6862 -- This is an odd function, why not have Task_Body_Procedure do 6863 -- the following digging??? 6864 6865 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 6866 end Get_Task_Body_Procedure; 6867 6868 ----------------------- 6869 -- Has_Access_Values -- 6870 ----------------------- 6871 6872 function Has_Access_Values (T : Entity_Id) return Boolean is 6873 Typ : constant Entity_Id := Underlying_Type (T); 6874 6875 begin 6876 -- Case of a private type which is not completed yet. This can only 6877 -- happen in the case of a generic format type appearing directly, or 6878 -- as a component of the type to which this function is being applied 6879 -- at the top level. Return False in this case, since we certainly do 6880 -- not know that the type contains access types. 6881 6882 if No (Typ) then 6883 return False; 6884 6885 elsif Is_Access_Type (Typ) then 6886 return True; 6887 6888 elsif Is_Array_Type (Typ) then 6889 return Has_Access_Values (Component_Type (Typ)); 6890 6891 elsif Is_Record_Type (Typ) then 6892 declare 6893 Comp : Entity_Id; 6894 6895 begin 6896 -- Loop to Check components 6897 6898 Comp := First_Component_Or_Discriminant (Typ); 6899 while Present (Comp) loop 6900 6901 -- Check for access component, tag field does not count, even 6902 -- though it is implemented internally using an access type. 6903 6904 if Has_Access_Values (Etype (Comp)) 6905 and then Chars (Comp) /= Name_uTag 6906 then 6907 return True; 6908 end if; 6909 6910 Next_Component_Or_Discriminant (Comp); 6911 end loop; 6912 end; 6913 6914 return False; 6915 6916 else 6917 return False; 6918 end if; 6919 end Has_Access_Values; 6920 6921 ------------------------------ 6922 -- Has_Compatible_Alignment -- 6923 ------------------------------ 6924 6925 function Has_Compatible_Alignment 6926 (Obj : Entity_Id; 6927 Expr : Node_Id) return Alignment_Result 6928 is 6929 function Has_Compatible_Alignment_Internal 6930 (Obj : Entity_Id; 6931 Expr : Node_Id; 6932 Default : Alignment_Result) return Alignment_Result; 6933 -- This is the internal recursive function that actually does the work. 6934 -- There is one additional parameter, which says what the result should 6935 -- be if no alignment information is found, and there is no definite 6936 -- indication of compatible alignments. At the outer level, this is set 6937 -- to Unknown, but for internal recursive calls in the case where types 6938 -- are known to be correct, it is set to Known_Compatible. 6939 6940 --------------------------------------- 6941 -- Has_Compatible_Alignment_Internal -- 6942 --------------------------------------- 6943 6944 function Has_Compatible_Alignment_Internal 6945 (Obj : Entity_Id; 6946 Expr : Node_Id; 6947 Default : Alignment_Result) return Alignment_Result 6948 is 6949 Result : Alignment_Result := Known_Compatible; 6950 -- Holds the current status of the result. Note that once a value of 6951 -- Known_Incompatible is set, it is sticky and does not get changed 6952 -- to Unknown (the value in Result only gets worse as we go along, 6953 -- never better). 6954 6955 Offs : Uint := No_Uint; 6956 -- Set to a factor of the offset from the base object when Expr is a 6957 -- selected or indexed component, based on Component_Bit_Offset and 6958 -- Component_Size respectively. A negative value is used to represent 6959 -- a value which is not known at compile time. 6960 6961 procedure Check_Prefix; 6962 -- Checks the prefix recursively in the case where the expression 6963 -- is an indexed or selected component. 6964 6965 procedure Set_Result (R : Alignment_Result); 6966 -- If R represents a worse outcome (unknown instead of known 6967 -- compatible, or known incompatible), then set Result to R. 6968 6969 ------------------ 6970 -- Check_Prefix -- 6971 ------------------ 6972 6973 procedure Check_Prefix is 6974 begin 6975 -- The subtlety here is that in doing a recursive call to check 6976 -- the prefix, we have to decide what to do in the case where we 6977 -- don't find any specific indication of an alignment problem. 6978 6979 -- At the outer level, we normally set Unknown as the result in 6980 -- this case, since we can only set Known_Compatible if we really 6981 -- know that the alignment value is OK, but for the recursive 6982 -- call, in the case where the types match, and we have not 6983 -- specified a peculiar alignment for the object, we are only 6984 -- concerned about suspicious rep clauses, the default case does 6985 -- not affect us, since the compiler will, in the absence of such 6986 -- rep clauses, ensure that the alignment is correct. 6987 6988 if Default = Known_Compatible 6989 or else 6990 (Etype (Obj) = Etype (Expr) 6991 and then (Unknown_Alignment (Obj) 6992 or else 6993 Alignment (Obj) = Alignment (Etype (Obj)))) 6994 then 6995 Set_Result 6996 (Has_Compatible_Alignment_Internal 6997 (Obj, Prefix (Expr), Known_Compatible)); 6998 6999 -- In all other cases, we need a full check on the prefix 7000 7001 else 7002 Set_Result 7003 (Has_Compatible_Alignment_Internal 7004 (Obj, Prefix (Expr), Unknown)); 7005 end if; 7006 end Check_Prefix; 7007 7008 ---------------- 7009 -- Set_Result -- 7010 ---------------- 7011 7012 procedure Set_Result (R : Alignment_Result) is 7013 begin 7014 if R > Result then 7015 Result := R; 7016 end if; 7017 end Set_Result; 7018 7019 -- Start of processing for Has_Compatible_Alignment_Internal 7020 7021 begin 7022 -- If Expr is a selected component, we must make sure there is no 7023 -- potentially troublesome component clause, and that the record is 7024 -- not packed. 7025 7026 if Nkind (Expr) = N_Selected_Component then 7027 7028 -- Packed record always generate unknown alignment 7029 7030 if Is_Packed (Etype (Prefix (Expr))) then 7031 Set_Result (Unknown); 7032 end if; 7033 7034 -- Check prefix and component offset 7035 7036 Check_Prefix; 7037 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 7038 7039 -- If Expr is an indexed component, we must make sure there is no 7040 -- potentially troublesome Component_Size clause and that the array 7041 -- is not bit-packed. 7042 7043 elsif Nkind (Expr) = N_Indexed_Component then 7044 declare 7045 Typ : constant Entity_Id := Etype (Prefix (Expr)); 7046 Ind : constant Node_Id := First_Index (Typ); 7047 7048 begin 7049 -- Bit packed array always generates unknown alignment 7050 7051 if Is_Bit_Packed_Array (Typ) then 7052 Set_Result (Unknown); 7053 end if; 7054 7055 -- Check prefix and component offset 7056 7057 Check_Prefix; 7058 Offs := Component_Size (Typ); 7059 7060 -- Small optimization: compute the full offset when possible 7061 7062 if Offs /= No_Uint 7063 and then Offs > Uint_0 7064 and then Present (Ind) 7065 and then Nkind (Ind) = N_Range 7066 and then Compile_Time_Known_Value (Low_Bound (Ind)) 7067 and then Compile_Time_Known_Value (First (Expressions (Expr))) 7068 then 7069 Offs := Offs * (Expr_Value (First (Expressions (Expr))) 7070 - Expr_Value (Low_Bound ((Ind)))); 7071 end if; 7072 end; 7073 end if; 7074 7075 -- If we have a null offset, the result is entirely determined by 7076 -- the base object and has already been computed recursively. 7077 7078 if Offs = Uint_0 then 7079 null; 7080 7081 -- Case where we know the alignment of the object 7082 7083 elsif Known_Alignment (Obj) then 7084 declare 7085 ObjA : constant Uint := Alignment (Obj); 7086 ExpA : Uint := No_Uint; 7087 SizA : Uint := No_Uint; 7088 7089 begin 7090 -- If alignment of Obj is 1, then we are always OK 7091 7092 if ObjA = 1 then 7093 Set_Result (Known_Compatible); 7094 7095 -- Alignment of Obj is greater than 1, so we need to check 7096 7097 else 7098 -- If we have an offset, see if it is compatible 7099 7100 if Offs /= No_Uint and Offs > Uint_0 then 7101 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 7102 Set_Result (Known_Incompatible); 7103 end if; 7104 7105 -- See if Expr is an object with known alignment 7106 7107 elsif Is_Entity_Name (Expr) 7108 and then Known_Alignment (Entity (Expr)) 7109 then 7110 ExpA := Alignment (Entity (Expr)); 7111 7112 -- Otherwise, we can use the alignment of the type of 7113 -- Expr given that we already checked for 7114 -- discombobulating rep clauses for the cases of indexed 7115 -- and selected components above. 7116 7117 elsif Known_Alignment (Etype (Expr)) then 7118 ExpA := Alignment (Etype (Expr)); 7119 7120 -- Otherwise the alignment is unknown 7121 7122 else 7123 Set_Result (Default); 7124 end if; 7125 7126 -- If we got an alignment, see if it is acceptable 7127 7128 if ExpA /= No_Uint and then ExpA < ObjA then 7129 Set_Result (Known_Incompatible); 7130 end if; 7131 7132 -- If Expr is not a piece of a larger object, see if size 7133 -- is given. If so, check that it is not too small for the 7134 -- required alignment. 7135 7136 if Offs /= No_Uint then 7137 null; 7138 7139 -- See if Expr is an object with known size 7140 7141 elsif Is_Entity_Name (Expr) 7142 and then Known_Static_Esize (Entity (Expr)) 7143 then 7144 SizA := Esize (Entity (Expr)); 7145 7146 -- Otherwise, we check the object size of the Expr type 7147 7148 elsif Known_Static_Esize (Etype (Expr)) then 7149 SizA := Esize (Etype (Expr)); 7150 end if; 7151 7152 -- If we got a size, see if it is a multiple of the Obj 7153 -- alignment, if not, then the alignment cannot be 7154 -- acceptable, since the size is always a multiple of the 7155 -- alignment. 7156 7157 if SizA /= No_Uint then 7158 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 7159 Set_Result (Known_Incompatible); 7160 end if; 7161 end if; 7162 end if; 7163 end; 7164 7165 -- If we do not know required alignment, any non-zero offset is a 7166 -- potential problem (but certainly may be OK, so result is unknown). 7167 7168 elsif Offs /= No_Uint then 7169 Set_Result (Unknown); 7170 7171 -- If we can't find the result by direct comparison of alignment 7172 -- values, then there is still one case that we can determine known 7173 -- result, and that is when we can determine that the types are the 7174 -- same, and no alignments are specified. Then we known that the 7175 -- alignments are compatible, even if we don't know the alignment 7176 -- value in the front end. 7177 7178 elsif Etype (Obj) = Etype (Expr) then 7179 7180 -- Types are the same, but we have to check for possible size 7181 -- and alignments on the Expr object that may make the alignment 7182 -- different, even though the types are the same. 7183 7184 if Is_Entity_Name (Expr) then 7185 7186 -- First check alignment of the Expr object. Any alignment less 7187 -- than Maximum_Alignment is worrisome since this is the case 7188 -- where we do not know the alignment of Obj. 7189 7190 if Known_Alignment (Entity (Expr)) 7191 and then 7192 UI_To_Int (Alignment (Entity (Expr))) < 7193 Ttypes.Maximum_Alignment 7194 then 7195 Set_Result (Unknown); 7196 7197 -- Now check size of Expr object. Any size that is not an 7198 -- even multiple of Maximum_Alignment is also worrisome 7199 -- since it may cause the alignment of the object to be less 7200 -- than the alignment of the type. 7201 7202 elsif Known_Static_Esize (Entity (Expr)) 7203 and then 7204 (UI_To_Int (Esize (Entity (Expr))) mod 7205 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 7206 /= 0 7207 then 7208 Set_Result (Unknown); 7209 7210 -- Otherwise same type is decisive 7211 7212 else 7213 Set_Result (Known_Compatible); 7214 end if; 7215 end if; 7216 7217 -- Another case to deal with is when there is an explicit size or 7218 -- alignment clause when the types are not the same. If so, then the 7219 -- result is Unknown. We don't need to do this test if the Default is 7220 -- Unknown, since that result will be set in any case. 7221 7222 elsif Default /= Unknown 7223 and then (Has_Size_Clause (Etype (Expr)) 7224 or else 7225 Has_Alignment_Clause (Etype (Expr))) 7226 then 7227 Set_Result (Unknown); 7228 7229 -- If no indication found, set default 7230 7231 else 7232 Set_Result (Default); 7233 end if; 7234 7235 -- Return worst result found 7236 7237 return Result; 7238 end Has_Compatible_Alignment_Internal; 7239 7240 -- Start of processing for Has_Compatible_Alignment 7241 7242 begin 7243 -- If Obj has no specified alignment, then set alignment from the type 7244 -- alignment. Perhaps we should always do this, but for sure we should 7245 -- do it when there is an address clause since we can do more if the 7246 -- alignment is known. 7247 7248 if Unknown_Alignment (Obj) then 7249 Set_Alignment (Obj, Alignment (Etype (Obj))); 7250 end if; 7251 7252 -- Now do the internal call that does all the work 7253 7254 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown); 7255 end Has_Compatible_Alignment; 7256 7257 ---------------------- 7258 -- Has_Declarations -- 7259 ---------------------- 7260 7261 function Has_Declarations (N : Node_Id) return Boolean is 7262 begin 7263 return Nkind_In (Nkind (N), N_Accept_Statement, 7264 N_Block_Statement, 7265 N_Compilation_Unit_Aux, 7266 N_Entry_Body, 7267 N_Package_Body, 7268 N_Protected_Body, 7269 N_Subprogram_Body, 7270 N_Task_Body, 7271 N_Package_Specification); 7272 end Has_Declarations; 7273 7274 ------------------- 7275 -- Has_Denormals -- 7276 ------------------- 7277 7278 function Has_Denormals (E : Entity_Id) return Boolean is 7279 begin 7280 return Is_Floating_Point_Type (E) 7281 and then Denorm_On_Target 7282 and then not Vax_Float (E); 7283 end Has_Denormals; 7284 7285 ------------------------------------------- 7286 -- Has_Discriminant_Dependent_Constraint -- 7287 ------------------------------------------- 7288 7289 function Has_Discriminant_Dependent_Constraint 7290 (Comp : Entity_Id) return Boolean 7291 is 7292 Comp_Decl : constant Node_Id := Parent (Comp); 7293 Subt_Indic : constant Node_Id := 7294 Subtype_Indication (Component_Definition (Comp_Decl)); 7295 Constr : Node_Id; 7296 Assn : Node_Id; 7297 7298 begin 7299 if Nkind (Subt_Indic) = N_Subtype_Indication then 7300 Constr := Constraint (Subt_Indic); 7301 7302 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 7303 Assn := First (Constraints (Constr)); 7304 while Present (Assn) loop 7305 case Nkind (Assn) is 7306 when N_Subtype_Indication | 7307 N_Range | 7308 N_Identifier 7309 => 7310 if Depends_On_Discriminant (Assn) then 7311 return True; 7312 end if; 7313 7314 when N_Discriminant_Association => 7315 if Depends_On_Discriminant (Expression (Assn)) then 7316 return True; 7317 end if; 7318 7319 when others => 7320 null; 7321 7322 end case; 7323 7324 Next (Assn); 7325 end loop; 7326 end if; 7327 end if; 7328 7329 return False; 7330 end Has_Discriminant_Dependent_Constraint; 7331 7332 -------------------------- 7333 -- Has_Enabled_Property -- 7334 -------------------------- 7335 7336 function Has_Enabled_Property 7337 (Item_Id : Entity_Id; 7338 Property : Name_Id) return Boolean 7339 is 7340 function State_Has_Enabled_Property return Boolean; 7341 -- Determine whether a state denoted by Item_Id has the property 7342 7343 function Variable_Has_Enabled_Property return Boolean; 7344 -- Determine whether a variable denoted by Item_Id has the property 7345 7346 -------------------------------- 7347 -- State_Has_Enabled_Property -- 7348 -------------------------------- 7349 7350 function State_Has_Enabled_Property return Boolean is 7351 Decl : constant Node_Id := Parent (Item_Id); 7352 Opt : Node_Id; 7353 Opt_Nam : Node_Id; 7354 Prop : Node_Id; 7355 Prop_Nam : Node_Id; 7356 Props : Node_Id; 7357 7358 begin 7359 -- The declaration of an external abstract state appears as an 7360 -- extension aggregate. If this is not the case, properties can never 7361 -- be set. 7362 7363 if Nkind (Decl) /= N_Extension_Aggregate then 7364 return False; 7365 end if; 7366 7367 -- When External appears as a simple option, it automatically enables 7368 -- all properties. 7369 7370 Opt := First (Expressions (Decl)); 7371 while Present (Opt) loop 7372 if Nkind (Opt) = N_Identifier 7373 and then Chars (Opt) = Name_External 7374 then 7375 return True; 7376 end if; 7377 7378 Next (Opt); 7379 end loop; 7380 7381 -- When External specifies particular properties, inspect those and 7382 -- find the desired one (if any). 7383 7384 Opt := First (Component_Associations (Decl)); 7385 while Present (Opt) loop 7386 Opt_Nam := First (Choices (Opt)); 7387 7388 if Nkind (Opt_Nam) = N_Identifier 7389 and then Chars (Opt_Nam) = Name_External 7390 then 7391 Props := Expression (Opt); 7392 7393 -- Multiple properties appear as an aggregate 7394 7395 if Nkind (Props) = N_Aggregate then 7396 7397 -- Simple property form 7398 7399 Prop := First (Expressions (Props)); 7400 while Present (Prop) loop 7401 if Chars (Prop) = Property then 7402 return True; 7403 end if; 7404 7405 Next (Prop); 7406 end loop; 7407 7408 -- Property with expression form 7409 7410 Prop := First (Component_Associations (Props)); 7411 while Present (Prop) loop 7412 Prop_Nam := First (Choices (Prop)); 7413 7414 if Chars (Prop_Nam) = Property then 7415 return Is_True (Expr_Value (Expression (Prop))); 7416 end if; 7417 7418 Next (Prop); 7419 end loop; 7420 7421 -- Single property 7422 7423 else 7424 return Chars (Props) = Property; 7425 end if; 7426 end if; 7427 7428 Next (Opt); 7429 end loop; 7430 7431 return False; 7432 end State_Has_Enabled_Property; 7433 7434 ----------------------------------- 7435 -- Variable_Has_Enabled_Property -- 7436 ----------------------------------- 7437 7438 function Variable_Has_Enabled_Property return Boolean is 7439 AR : constant Node_Id := 7440 Get_Pragma (Item_Id, Pragma_Async_Readers); 7441 AW : constant Node_Id := 7442 Get_Pragma (Item_Id, Pragma_Async_Writers); 7443 ER : constant Node_Id := 7444 Get_Pragma (Item_Id, Pragma_Effective_Reads); 7445 EW : constant Node_Id := 7446 Get_Pragma (Item_Id, Pragma_Effective_Writes); 7447 begin 7448 -- A non-volatile object can never possess external properties 7449 7450 if not Is_SPARK_Volatile_Object (Item_Id) then 7451 return False; 7452 7453 -- External properties related to variables come in two flavors - 7454 -- explicit and implicit. The explicit case is characterized by the 7455 -- presence of a property pragma while the implicit case lacks all 7456 -- such pragmas. 7457 7458 elsif Property = Name_Async_Readers 7459 and then 7460 (Present (AR) 7461 or else 7462 (No (AW) and then No (ER) and then No (EW))) 7463 then 7464 return True; 7465 7466 elsif Property = Name_Async_Writers 7467 and then 7468 (Present (AW) 7469 or else 7470 (No (AR) and then No (ER) and then No (EW))) 7471 then 7472 return True; 7473 7474 elsif Property = Name_Effective_Reads 7475 and then 7476 (Present (ER) 7477 or else 7478 (No (AR) and then No (AW) and then No (EW))) 7479 then 7480 return True; 7481 7482 elsif Property = Name_Effective_Writes 7483 and then 7484 (Present (EW) 7485 or else 7486 (No (AR) and then No (AW) and then No (ER))) 7487 then 7488 return True; 7489 7490 else 7491 return False; 7492 end if; 7493 end Variable_Has_Enabled_Property; 7494 7495 -- Start of processing for Has_Enabled_Property 7496 7497 begin 7498 if Ekind (Item_Id) = E_Abstract_State then 7499 return State_Has_Enabled_Property; 7500 7501 else pragma Assert (Ekind (Item_Id) = E_Variable); 7502 return Variable_Has_Enabled_Property; 7503 end if; 7504 end Has_Enabled_Property; 7505 7506 -------------------- 7507 -- Has_Infinities -- 7508 -------------------- 7509 7510 function Has_Infinities (E : Entity_Id) return Boolean is 7511 begin 7512 return 7513 Is_Floating_Point_Type (E) 7514 and then Nkind (Scalar_Range (E)) = N_Range 7515 and then Includes_Infinities (Scalar_Range (E)); 7516 end Has_Infinities; 7517 7518 -------------------- 7519 -- Has_Interfaces -- 7520 -------------------- 7521 7522 function Has_Interfaces 7523 (T : Entity_Id; 7524 Use_Full_View : Boolean := True) return Boolean 7525 is 7526 Typ : Entity_Id := Base_Type (T); 7527 7528 begin 7529 -- Handle concurrent types 7530 7531 if Is_Concurrent_Type (Typ) then 7532 Typ := Corresponding_Record_Type (Typ); 7533 end if; 7534 7535 if not Present (Typ) 7536 or else not Is_Record_Type (Typ) 7537 or else not Is_Tagged_Type (Typ) 7538 then 7539 return False; 7540 end if; 7541 7542 -- Handle private types 7543 7544 if Use_Full_View 7545 and then Present (Full_View (Typ)) 7546 then 7547 Typ := Full_View (Typ); 7548 end if; 7549 7550 -- Handle concurrent record types 7551 7552 if Is_Concurrent_Record_Type (Typ) 7553 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 7554 then 7555 return True; 7556 end if; 7557 7558 loop 7559 if Is_Interface (Typ) 7560 or else 7561 (Is_Record_Type (Typ) 7562 and then Present (Interfaces (Typ)) 7563 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 7564 then 7565 return True; 7566 end if; 7567 7568 exit when Etype (Typ) = Typ 7569 7570 -- Handle private types 7571 7572 or else (Present (Full_View (Etype (Typ))) 7573 and then Full_View (Etype (Typ)) = Typ) 7574 7575 -- Protect the frontend against wrong source with cyclic 7576 -- derivations 7577 7578 or else Etype (Typ) = T; 7579 7580 -- Climb to the ancestor type handling private types 7581 7582 if Present (Full_View (Etype (Typ))) then 7583 Typ := Full_View (Etype (Typ)); 7584 else 7585 Typ := Etype (Typ); 7586 end if; 7587 end loop; 7588 7589 return False; 7590 end Has_Interfaces; 7591 7592 --------------------------------- 7593 -- Has_No_Obvious_Side_Effects -- 7594 --------------------------------- 7595 7596 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 7597 begin 7598 -- For now, just handle literals, constants, and non-volatile 7599 -- variables and expressions combining these with operators or 7600 -- short circuit forms. 7601 7602 if Nkind (N) in N_Numeric_Or_String_Literal then 7603 return True; 7604 7605 elsif Nkind (N) = N_Character_Literal then 7606 return True; 7607 7608 elsif Nkind (N) in N_Unary_Op then 7609 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 7610 7611 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 7612 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 7613 and then 7614 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 7615 7616 elsif Nkind (N) = N_Expression_With_Actions 7617 and then 7618 Is_Empty_List (Actions (N)) 7619 then 7620 return Has_No_Obvious_Side_Effects (Expression (N)); 7621 7622 elsif Nkind (N) in N_Has_Entity then 7623 return Present (Entity (N)) 7624 and then Ekind_In (Entity (N), E_Variable, 7625 E_Constant, 7626 E_Enumeration_Literal, 7627 E_In_Parameter, 7628 E_Out_Parameter, 7629 E_In_Out_Parameter) 7630 and then not Is_Volatile (Entity (N)); 7631 7632 else 7633 return False; 7634 end if; 7635 end Has_No_Obvious_Side_Effects; 7636 7637 ------------------------ 7638 -- Has_Null_Exclusion -- 7639 ------------------------ 7640 7641 function Has_Null_Exclusion (N : Node_Id) return Boolean is 7642 begin 7643 case Nkind (N) is 7644 when N_Access_Definition | 7645 N_Access_Function_Definition | 7646 N_Access_Procedure_Definition | 7647 N_Access_To_Object_Definition | 7648 N_Allocator | 7649 N_Derived_Type_Definition | 7650 N_Function_Specification | 7651 N_Subtype_Declaration => 7652 return Null_Exclusion_Present (N); 7653 7654 when N_Component_Definition | 7655 N_Formal_Object_Declaration | 7656 N_Object_Renaming_Declaration => 7657 if Present (Subtype_Mark (N)) then 7658 return Null_Exclusion_Present (N); 7659 else pragma Assert (Present (Access_Definition (N))); 7660 return Null_Exclusion_Present (Access_Definition (N)); 7661 end if; 7662 7663 when N_Discriminant_Specification => 7664 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 7665 return Null_Exclusion_Present (Discriminant_Type (N)); 7666 else 7667 return Null_Exclusion_Present (N); 7668 end if; 7669 7670 when N_Object_Declaration => 7671 if Nkind (Object_Definition (N)) = N_Access_Definition then 7672 return Null_Exclusion_Present (Object_Definition (N)); 7673 else 7674 return Null_Exclusion_Present (N); 7675 end if; 7676 7677 when N_Parameter_Specification => 7678 if Nkind (Parameter_Type (N)) = N_Access_Definition then 7679 return Null_Exclusion_Present (Parameter_Type (N)); 7680 else 7681 return Null_Exclusion_Present (N); 7682 end if; 7683 7684 when others => 7685 return False; 7686 7687 end case; 7688 end Has_Null_Exclusion; 7689 7690 ------------------------ 7691 -- Has_Null_Extension -- 7692 ------------------------ 7693 7694 function Has_Null_Extension (T : Entity_Id) return Boolean is 7695 B : constant Entity_Id := Base_Type (T); 7696 Comps : Node_Id; 7697 Ext : Node_Id; 7698 7699 begin 7700 if Nkind (Parent (B)) = N_Full_Type_Declaration 7701 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 7702 then 7703 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 7704 7705 if Present (Ext) then 7706 if Null_Present (Ext) then 7707 return True; 7708 else 7709 Comps := Component_List (Ext); 7710 7711 -- The null component list is rewritten during analysis to 7712 -- include the parent component. Any other component indicates 7713 -- that the extension was not originally null. 7714 7715 return Null_Present (Comps) 7716 or else No (Next (First (Component_Items (Comps)))); 7717 end if; 7718 else 7719 return False; 7720 end if; 7721 7722 else 7723 return False; 7724 end if; 7725 end Has_Null_Extension; 7726 7727 ------------------------------- 7728 -- Has_Overriding_Initialize -- 7729 ------------------------------- 7730 7731 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 7732 BT : constant Entity_Id := Base_Type (T); 7733 P : Elmt_Id; 7734 7735 begin 7736 if Is_Controlled (BT) then 7737 if Is_RTU (Scope (BT), Ada_Finalization) then 7738 return False; 7739 7740 elsif Present (Primitive_Operations (BT)) then 7741 P := First_Elmt (Primitive_Operations (BT)); 7742 while Present (P) loop 7743 declare 7744 Init : constant Entity_Id := Node (P); 7745 Formal : constant Entity_Id := First_Formal (Init); 7746 begin 7747 if Ekind (Init) = E_Procedure 7748 and then Chars (Init) = Name_Initialize 7749 and then Comes_From_Source (Init) 7750 and then Present (Formal) 7751 and then Etype (Formal) = BT 7752 and then No (Next_Formal (Formal)) 7753 and then (Ada_Version < Ada_2012 7754 or else not Null_Present (Parent (Init))) 7755 then 7756 return True; 7757 end if; 7758 end; 7759 7760 Next_Elmt (P); 7761 end loop; 7762 end if; 7763 7764 -- Here if type itself does not have a non-null Initialize operation: 7765 -- check immediate ancestor. 7766 7767 if Is_Derived_Type (BT) 7768 and then Has_Overriding_Initialize (Etype (BT)) 7769 then 7770 return True; 7771 end if; 7772 end if; 7773 7774 return False; 7775 end Has_Overriding_Initialize; 7776 7777 -------------------------------------- 7778 -- Has_Preelaborable_Initialization -- 7779 -------------------------------------- 7780 7781 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 7782 Has_PE : Boolean; 7783 7784 procedure Check_Components (E : Entity_Id); 7785 -- Check component/discriminant chain, sets Has_PE False if a component 7786 -- or discriminant does not meet the preelaborable initialization rules. 7787 7788 ---------------------- 7789 -- Check_Components -- 7790 ---------------------- 7791 7792 procedure Check_Components (E : Entity_Id) is 7793 Ent : Entity_Id; 7794 Exp : Node_Id; 7795 7796 function Is_Preelaborable_Expression (N : Node_Id) return Boolean; 7797 -- Returns True if and only if the expression denoted by N does not 7798 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). 7799 7800 --------------------------------- 7801 -- Is_Preelaborable_Expression -- 7802 --------------------------------- 7803 7804 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is 7805 Exp : Node_Id; 7806 Assn : Node_Id; 7807 Choice : Node_Id; 7808 Comp_Type : Entity_Id; 7809 Is_Array_Aggr : Boolean; 7810 7811 begin 7812 if Is_Static_Expression (N) then 7813 return True; 7814 7815 elsif Nkind (N) = N_Null then 7816 return True; 7817 7818 -- Attributes are allowed in general, even if their prefix is a 7819 -- formal type. (It seems that certain attributes known not to be 7820 -- static might not be allowed, but there are no rules to prevent 7821 -- them.) 7822 7823 elsif Nkind (N) = N_Attribute_Reference then 7824 return True; 7825 7826 -- The name of a discriminant evaluated within its parent type is 7827 -- defined to be preelaborable (10.2.1(8)). Note that we test for 7828 -- names that denote discriminals as well as discriminants to 7829 -- catch references occurring within init procs. 7830 7831 elsif Is_Entity_Name (N) 7832 and then 7833 (Ekind (Entity (N)) = E_Discriminant 7834 or else 7835 ((Ekind (Entity (N)) = E_Constant 7836 or else Ekind (Entity (N)) = E_In_Parameter) 7837 and then Present (Discriminal_Link (Entity (N))))) 7838 then 7839 return True; 7840 7841 elsif Nkind (N) = N_Qualified_Expression then 7842 return Is_Preelaborable_Expression (Expression (N)); 7843 7844 -- For aggregates we have to check that each of the associations 7845 -- is preelaborable. 7846 7847 elsif Nkind (N) = N_Aggregate 7848 or else Nkind (N) = N_Extension_Aggregate 7849 then 7850 Is_Array_Aggr := Is_Array_Type (Etype (N)); 7851 7852 if Is_Array_Aggr then 7853 Comp_Type := Component_Type (Etype (N)); 7854 end if; 7855 7856 -- Check the ancestor part of extension aggregates, which must 7857 -- be either the name of a type that has preelaborable init or 7858 -- an expression that is preelaborable. 7859 7860 if Nkind (N) = N_Extension_Aggregate then 7861 declare 7862 Anc_Part : constant Node_Id := Ancestor_Part (N); 7863 7864 begin 7865 if Is_Entity_Name (Anc_Part) 7866 and then Is_Type (Entity (Anc_Part)) 7867 then 7868 if not Has_Preelaborable_Initialization 7869 (Entity (Anc_Part)) 7870 then 7871 return False; 7872 end if; 7873 7874 elsif not Is_Preelaborable_Expression (Anc_Part) then 7875 return False; 7876 end if; 7877 end; 7878 end if; 7879 7880 -- Check positional associations 7881 7882 Exp := First (Expressions (N)); 7883 while Present (Exp) loop 7884 if not Is_Preelaborable_Expression (Exp) then 7885 return False; 7886 end if; 7887 7888 Next (Exp); 7889 end loop; 7890 7891 -- Check named associations 7892 7893 Assn := First (Component_Associations (N)); 7894 while Present (Assn) loop 7895 Choice := First (Choices (Assn)); 7896 while Present (Choice) loop 7897 if Is_Array_Aggr then 7898 if Nkind (Choice) = N_Others_Choice then 7899 null; 7900 7901 elsif Nkind (Choice) = N_Range then 7902 if not Is_Static_Range (Choice) then 7903 return False; 7904 end if; 7905 7906 elsif not Is_Static_Expression (Choice) then 7907 return False; 7908 end if; 7909 7910 else 7911 Comp_Type := Etype (Choice); 7912 end if; 7913 7914 Next (Choice); 7915 end loop; 7916 7917 -- If the association has a <> at this point, then we have 7918 -- to check whether the component's type has preelaborable 7919 -- initialization. Note that this only occurs when the 7920 -- association's corresponding component does not have a 7921 -- default expression, the latter case having already been 7922 -- expanded as an expression for the association. 7923 7924 if Box_Present (Assn) then 7925 if not Has_Preelaborable_Initialization (Comp_Type) then 7926 return False; 7927 end if; 7928 7929 -- In the expression case we check whether the expression 7930 -- is preelaborable. 7931 7932 elsif 7933 not Is_Preelaborable_Expression (Expression (Assn)) 7934 then 7935 return False; 7936 end if; 7937 7938 Next (Assn); 7939 end loop; 7940 7941 -- If we get here then aggregate as a whole is preelaborable 7942 7943 return True; 7944 7945 -- All other cases are not preelaborable 7946 7947 else 7948 return False; 7949 end if; 7950 end Is_Preelaborable_Expression; 7951 7952 -- Start of processing for Check_Components 7953 7954 begin 7955 -- Loop through entities of record or protected type 7956 7957 Ent := E; 7958 while Present (Ent) loop 7959 7960 -- We are interested only in components and discriminants 7961 7962 Exp := Empty; 7963 7964 case Ekind (Ent) is 7965 when E_Component => 7966 7967 -- Get default expression if any. If there is no declaration 7968 -- node, it means we have an internal entity. The parent and 7969 -- tag fields are examples of such entities. For such cases, 7970 -- we just test the type of the entity. 7971 7972 if Present (Declaration_Node (Ent)) then 7973 Exp := Expression (Declaration_Node (Ent)); 7974 end if; 7975 7976 when E_Discriminant => 7977 7978 -- Note: for a renamed discriminant, the Declaration_Node 7979 -- may point to the one from the ancestor, and have a 7980 -- different expression, so use the proper attribute to 7981 -- retrieve the expression from the derived constraint. 7982 7983 Exp := Discriminant_Default_Value (Ent); 7984 7985 when others => 7986 goto Check_Next_Entity; 7987 end case; 7988 7989 -- A component has PI if it has no default expression and the 7990 -- component type has PI. 7991 7992 if No (Exp) then 7993 if not Has_Preelaborable_Initialization (Etype (Ent)) then 7994 Has_PE := False; 7995 exit; 7996 end if; 7997 7998 -- Require the default expression to be preelaborable 7999 8000 elsif not Is_Preelaborable_Expression (Exp) then 8001 Has_PE := False; 8002 exit; 8003 end if; 8004 8005 <<Check_Next_Entity>> 8006 Next_Entity (Ent); 8007 end loop; 8008 end Check_Components; 8009 8010 -- Start of processing for Has_Preelaborable_Initialization 8011 8012 begin 8013 -- Immediate return if already marked as known preelaborable init. This 8014 -- covers types for which this function has already been called once 8015 -- and returned True (in which case the result is cached), and also 8016 -- types to which a pragma Preelaborable_Initialization applies. 8017 8018 if Known_To_Have_Preelab_Init (E) then 8019 return True; 8020 end if; 8021 8022 -- If the type is a subtype representing a generic actual type, then 8023 -- test whether its base type has preelaborable initialization since 8024 -- the subtype representing the actual does not inherit this attribute 8025 -- from the actual or formal. (but maybe it should???) 8026 8027 if Is_Generic_Actual_Type (E) then 8028 return Has_Preelaborable_Initialization (Base_Type (E)); 8029 end if; 8030 8031 -- All elementary types have preelaborable initialization 8032 8033 if Is_Elementary_Type (E) then 8034 Has_PE := True; 8035 8036 -- Array types have PI if the component type has PI 8037 8038 elsif Is_Array_Type (E) then 8039 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 8040 8041 -- A derived type has preelaborable initialization if its parent type 8042 -- has preelaborable initialization and (in the case of a derived record 8043 -- extension) if the non-inherited components all have preelaborable 8044 -- initialization. However, a user-defined controlled type with an 8045 -- overriding Initialize procedure does not have preelaborable 8046 -- initialization. 8047 8048 elsif Is_Derived_Type (E) then 8049 8050 -- If the derived type is a private extension then it doesn't have 8051 -- preelaborable initialization. 8052 8053 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 8054 return False; 8055 end if; 8056 8057 -- First check whether ancestor type has preelaborable initialization 8058 8059 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 8060 8061 -- If OK, check extension components (if any) 8062 8063 if Has_PE and then Is_Record_Type (E) then 8064 Check_Components (First_Entity (E)); 8065 end if; 8066 8067 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 8068 -- with a user defined Initialize procedure does not have PI. 8069 8070 if Has_PE 8071 and then Is_Controlled (E) 8072 and then Has_Overriding_Initialize (E) 8073 then 8074 Has_PE := False; 8075 end if; 8076 8077 -- Private types not derived from a type having preelaborable init and 8078 -- that are not marked with pragma Preelaborable_Initialization do not 8079 -- have preelaborable initialization. 8080 8081 elsif Is_Private_Type (E) then 8082 return False; 8083 8084 -- Record type has PI if it is non private and all components have PI 8085 8086 elsif Is_Record_Type (E) then 8087 Has_PE := True; 8088 Check_Components (First_Entity (E)); 8089 8090 -- Protected types must not have entries, and components must meet 8091 -- same set of rules as for record components. 8092 8093 elsif Is_Protected_Type (E) then 8094 if Has_Entries (E) then 8095 Has_PE := False; 8096 else 8097 Has_PE := True; 8098 Check_Components (First_Entity (E)); 8099 Check_Components (First_Private_Entity (E)); 8100 end if; 8101 8102 -- Type System.Address always has preelaborable initialization 8103 8104 elsif Is_RTE (E, RE_Address) then 8105 Has_PE := True; 8106 8107 -- In all other cases, type does not have preelaborable initialization 8108 8109 else 8110 return False; 8111 end if; 8112 8113 -- If type has preelaborable initialization, cache result 8114 8115 if Has_PE then 8116 Set_Known_To_Have_Preelab_Init (E); 8117 end if; 8118 8119 return Has_PE; 8120 end Has_Preelaborable_Initialization; 8121 8122 --------------------------- 8123 -- Has_Private_Component -- 8124 --------------------------- 8125 8126 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 8127 Btype : Entity_Id := Base_Type (Type_Id); 8128 Component : Entity_Id; 8129 8130 begin 8131 if Error_Posted (Type_Id) 8132 or else Error_Posted (Btype) 8133 then 8134 return False; 8135 end if; 8136 8137 if Is_Class_Wide_Type (Btype) then 8138 Btype := Root_Type (Btype); 8139 end if; 8140 8141 if Is_Private_Type (Btype) then 8142 declare 8143 UT : constant Entity_Id := Underlying_Type (Btype); 8144 begin 8145 if No (UT) then 8146 if No (Full_View (Btype)) then 8147 return not Is_Generic_Type (Btype) 8148 and then not Is_Generic_Type (Root_Type (Btype)); 8149 else 8150 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 8151 end if; 8152 else 8153 return not Is_Frozen (UT) and then Has_Private_Component (UT); 8154 end if; 8155 end; 8156 8157 elsif Is_Array_Type (Btype) then 8158 return Has_Private_Component (Component_Type (Btype)); 8159 8160 elsif Is_Record_Type (Btype) then 8161 Component := First_Component (Btype); 8162 while Present (Component) loop 8163 if Has_Private_Component (Etype (Component)) then 8164 return True; 8165 end if; 8166 8167 Next_Component (Component); 8168 end loop; 8169 8170 return False; 8171 8172 elsif Is_Protected_Type (Btype) 8173 and then Present (Corresponding_Record_Type (Btype)) 8174 then 8175 return Has_Private_Component (Corresponding_Record_Type (Btype)); 8176 8177 else 8178 return False; 8179 end if; 8180 end Has_Private_Component; 8181 8182 ---------------------- 8183 -- Has_Signed_Zeros -- 8184 ---------------------- 8185 8186 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 8187 begin 8188 return Is_Floating_Point_Type (E) 8189 and then Signed_Zeros_On_Target 8190 and then not Vax_Float (E); 8191 end Has_Signed_Zeros; 8192 8193 ----------------------------- 8194 -- Has_Static_Array_Bounds -- 8195 ----------------------------- 8196 8197 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 8198 Ndims : constant Nat := Number_Dimensions (Typ); 8199 8200 Index : Node_Id; 8201 Low : Node_Id; 8202 High : Node_Id; 8203 8204 begin 8205 -- Unconstrained types do not have static bounds 8206 8207 if not Is_Constrained (Typ) then 8208 return False; 8209 end if; 8210 8211 -- First treat string literals specially, as the lower bound and length 8212 -- of string literals are not stored like those of arrays. 8213 8214 -- A string literal always has static bounds 8215 8216 if Ekind (Typ) = E_String_Literal_Subtype then 8217 return True; 8218 end if; 8219 8220 -- Treat all dimensions in turn 8221 8222 Index := First_Index (Typ); 8223 for Indx in 1 .. Ndims loop 8224 8225 -- In case of an erroneous index which is not a discrete type, return 8226 -- that the type is not static. 8227 8228 if not Is_Discrete_Type (Etype (Index)) 8229 or else Etype (Index) = Any_Type 8230 then 8231 return False; 8232 end if; 8233 8234 Get_Index_Bounds (Index, Low, High); 8235 8236 if Error_Posted (Low) or else Error_Posted (High) then 8237 return False; 8238 end if; 8239 8240 if Is_OK_Static_Expression (Low) 8241 and then 8242 Is_OK_Static_Expression (High) 8243 then 8244 null; 8245 else 8246 return False; 8247 end if; 8248 8249 Next (Index); 8250 end loop; 8251 8252 -- If we fall through the loop, all indexes matched 8253 8254 return True; 8255 end Has_Static_Array_Bounds; 8256 8257 ---------------- 8258 -- Has_Stream -- 8259 ---------------- 8260 8261 function Has_Stream (T : Entity_Id) return Boolean is 8262 E : Entity_Id; 8263 8264 begin 8265 if No (T) then 8266 return False; 8267 8268 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 8269 return True; 8270 8271 elsif Is_Array_Type (T) then 8272 return Has_Stream (Component_Type (T)); 8273 8274 elsif Is_Record_Type (T) then 8275 E := First_Component (T); 8276 while Present (E) loop 8277 if Has_Stream (Etype (E)) then 8278 return True; 8279 else 8280 Next_Component (E); 8281 end if; 8282 end loop; 8283 8284 return False; 8285 8286 elsif Is_Private_Type (T) then 8287 return Has_Stream (Underlying_Type (T)); 8288 8289 else 8290 return False; 8291 end if; 8292 end Has_Stream; 8293 8294 ---------------- 8295 -- Has_Suffix -- 8296 ---------------- 8297 8298 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 8299 begin 8300 Get_Name_String (Chars (E)); 8301 return Name_Buffer (Name_Len) = Suffix; 8302 end Has_Suffix; 8303 8304 ---------------- 8305 -- Add_Suffix -- 8306 ---------------- 8307 8308 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 8309 begin 8310 Get_Name_String (Chars (E)); 8311 Add_Char_To_Name_Buffer (Suffix); 8312 return Name_Find; 8313 end Add_Suffix; 8314 8315 ------------------- 8316 -- Remove_Suffix -- 8317 ------------------- 8318 8319 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 8320 begin 8321 pragma Assert (Has_Suffix (E, Suffix)); 8322 Get_Name_String (Chars (E)); 8323 Name_Len := Name_Len - 1; 8324 return Name_Find; 8325 end Remove_Suffix; 8326 8327 -------------------------- 8328 -- Has_Tagged_Component -- 8329 -------------------------- 8330 8331 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 8332 Comp : Entity_Id; 8333 8334 begin 8335 if Is_Private_Type (Typ) 8336 and then Present (Underlying_Type (Typ)) 8337 then 8338 return Has_Tagged_Component (Underlying_Type (Typ)); 8339 8340 elsif Is_Array_Type (Typ) then 8341 return Has_Tagged_Component (Component_Type (Typ)); 8342 8343 elsif Is_Tagged_Type (Typ) then 8344 return True; 8345 8346 elsif Is_Record_Type (Typ) then 8347 Comp := First_Component (Typ); 8348 while Present (Comp) loop 8349 if Has_Tagged_Component (Etype (Comp)) then 8350 return True; 8351 end if; 8352 8353 Next_Component (Comp); 8354 end loop; 8355 8356 return False; 8357 8358 else 8359 return False; 8360 end if; 8361 end Has_Tagged_Component; 8362 8363 ---------------------------- 8364 -- Has_Volatile_Component -- 8365 ---------------------------- 8366 8367 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 8368 Comp : Entity_Id; 8369 8370 begin 8371 if Has_Volatile_Components (Typ) then 8372 return True; 8373 8374 elsif Is_Array_Type (Typ) then 8375 return Is_Volatile (Component_Type (Typ)); 8376 8377 elsif Is_Record_Type (Typ) then 8378 Comp := First_Component (Typ); 8379 while Present (Comp) loop 8380 if Is_Volatile_Object (Comp) then 8381 return True; 8382 end if; 8383 8384 Comp := Next_Component (Comp); 8385 end loop; 8386 end if; 8387 8388 return False; 8389 end Has_Volatile_Component; 8390 8391 ------------------------- 8392 -- Implementation_Kind -- 8393 ------------------------- 8394 8395 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 8396 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 8397 Arg : Node_Id; 8398 begin 8399 pragma Assert (Present (Impl_Prag)); 8400 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 8401 return Chars (Get_Pragma_Arg (Arg)); 8402 end Implementation_Kind; 8403 8404 -------------------------- 8405 -- Implements_Interface -- 8406 -------------------------- 8407 8408 function Implements_Interface 8409 (Typ_Ent : Entity_Id; 8410 Iface_Ent : Entity_Id; 8411 Exclude_Parents : Boolean := False) return Boolean 8412 is 8413 Ifaces_List : Elist_Id; 8414 Elmt : Elmt_Id; 8415 Iface : Entity_Id := Base_Type (Iface_Ent); 8416 Typ : Entity_Id := Base_Type (Typ_Ent); 8417 8418 begin 8419 if Is_Class_Wide_Type (Typ) then 8420 Typ := Root_Type (Typ); 8421 end if; 8422 8423 if not Has_Interfaces (Typ) then 8424 return False; 8425 end if; 8426 8427 if Is_Class_Wide_Type (Iface) then 8428 Iface := Root_Type (Iface); 8429 end if; 8430 8431 Collect_Interfaces (Typ, Ifaces_List); 8432 8433 Elmt := First_Elmt (Ifaces_List); 8434 while Present (Elmt) loop 8435 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 8436 and then Exclude_Parents 8437 then 8438 null; 8439 8440 elsif Node (Elmt) = Iface then 8441 return True; 8442 end if; 8443 8444 Next_Elmt (Elmt); 8445 end loop; 8446 8447 return False; 8448 end Implements_Interface; 8449 8450 ------------------------------------ 8451 -- In_Assertion_Expression_Pragma -- 8452 ------------------------------------ 8453 8454 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 8455 Par : Node_Id; 8456 Prag : Node_Id := Empty; 8457 8458 begin 8459 -- Climb the parent chain looking for an enclosing pragma 8460 8461 Par := N; 8462 while Present (Par) loop 8463 if Nkind (Par) = N_Pragma then 8464 Prag := Par; 8465 exit; 8466 8467 -- Precondition-like pragmas are expanded into if statements, check 8468 -- the original node instead. 8469 8470 elsif Nkind (Original_Node (Par)) = N_Pragma then 8471 Prag := Original_Node (Par); 8472 exit; 8473 8474 -- Prevent the search from going too far 8475 8476 elsif Is_Body_Or_Package_Declaration (Par) then 8477 return False; 8478 end if; 8479 8480 Par := Parent (Par); 8481 end loop; 8482 8483 return 8484 Present (Prag) 8485 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 8486 end In_Assertion_Expression_Pragma; 8487 8488 ----------------- 8489 -- In_Instance -- 8490 ----------------- 8491 8492 function In_Instance return Boolean is 8493 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 8494 S : Entity_Id; 8495 8496 begin 8497 S := Current_Scope; 8498 while Present (S) 8499 and then S /= Standard_Standard 8500 loop 8501 if (Ekind (S) = E_Function 8502 or else Ekind (S) = E_Package 8503 or else Ekind (S) = E_Procedure) 8504 and then Is_Generic_Instance (S) 8505 then 8506 -- A child instance is always compiled in the context of a parent 8507 -- instance. Nevertheless, the actuals are not analyzed in an 8508 -- instance context. We detect this case by examining the current 8509 -- compilation unit, which must be a child instance, and checking 8510 -- that it is not currently on the scope stack. 8511 8512 if Is_Child_Unit (Curr_Unit) 8513 and then 8514 Nkind (Unit (Cunit (Current_Sem_Unit))) 8515 = N_Package_Instantiation 8516 and then not In_Open_Scopes (Curr_Unit) 8517 then 8518 return False; 8519 else 8520 return True; 8521 end if; 8522 end if; 8523 8524 S := Scope (S); 8525 end loop; 8526 8527 return False; 8528 end In_Instance; 8529 8530 ---------------------- 8531 -- In_Instance_Body -- 8532 ---------------------- 8533 8534 function In_Instance_Body return Boolean is 8535 S : Entity_Id; 8536 8537 begin 8538 S := Current_Scope; 8539 while Present (S) 8540 and then S /= Standard_Standard 8541 loop 8542 if (Ekind (S) = E_Function 8543 or else Ekind (S) = E_Procedure) 8544 and then Is_Generic_Instance (S) 8545 then 8546 return True; 8547 8548 elsif Ekind (S) = E_Package 8549 and then In_Package_Body (S) 8550 and then Is_Generic_Instance (S) 8551 then 8552 return True; 8553 end if; 8554 8555 S := Scope (S); 8556 end loop; 8557 8558 return False; 8559 end In_Instance_Body; 8560 8561 ----------------------------- 8562 -- In_Instance_Not_Visible -- 8563 ----------------------------- 8564 8565 function In_Instance_Not_Visible return Boolean is 8566 S : Entity_Id; 8567 8568 begin 8569 S := Current_Scope; 8570 while Present (S) 8571 and then S /= Standard_Standard 8572 loop 8573 if (Ekind (S) = E_Function 8574 or else Ekind (S) = E_Procedure) 8575 and then Is_Generic_Instance (S) 8576 then 8577 return True; 8578 8579 elsif Ekind (S) = E_Package 8580 and then (In_Package_Body (S) or else In_Private_Part (S)) 8581 and then Is_Generic_Instance (S) 8582 then 8583 return True; 8584 end if; 8585 8586 S := Scope (S); 8587 end loop; 8588 8589 return False; 8590 end In_Instance_Not_Visible; 8591 8592 ------------------------------ 8593 -- In_Instance_Visible_Part -- 8594 ------------------------------ 8595 8596 function In_Instance_Visible_Part return Boolean is 8597 S : Entity_Id; 8598 8599 begin 8600 S := Current_Scope; 8601 while Present (S) 8602 and then S /= Standard_Standard 8603 loop 8604 if Ekind (S) = E_Package 8605 and then Is_Generic_Instance (S) 8606 and then not In_Package_Body (S) 8607 and then not In_Private_Part (S) 8608 then 8609 return True; 8610 end if; 8611 8612 S := Scope (S); 8613 end loop; 8614 8615 return False; 8616 end In_Instance_Visible_Part; 8617 8618 --------------------- 8619 -- In_Package_Body -- 8620 --------------------- 8621 8622 function In_Package_Body return Boolean is 8623 S : Entity_Id; 8624 8625 begin 8626 S := Current_Scope; 8627 while Present (S) 8628 and then S /= Standard_Standard 8629 loop 8630 if Ekind (S) = E_Package 8631 and then In_Package_Body (S) 8632 then 8633 return True; 8634 else 8635 S := Scope (S); 8636 end if; 8637 end loop; 8638 8639 return False; 8640 end In_Package_Body; 8641 8642 -------------------------------- 8643 -- In_Parameter_Specification -- 8644 -------------------------------- 8645 8646 function In_Parameter_Specification (N : Node_Id) return Boolean is 8647 PN : Node_Id; 8648 8649 begin 8650 PN := Parent (N); 8651 while Present (PN) loop 8652 if Nkind (PN) = N_Parameter_Specification then 8653 return True; 8654 end if; 8655 8656 PN := Parent (PN); 8657 end loop; 8658 8659 return False; 8660 end In_Parameter_Specification; 8661 8662 -------------------------- 8663 -- In_Pragma_Expression -- 8664 -------------------------- 8665 8666 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 8667 P : Node_Id; 8668 begin 8669 P := Parent (N); 8670 loop 8671 if No (P) then 8672 return False; 8673 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 8674 return True; 8675 else 8676 P := Parent (P); 8677 end if; 8678 end loop; 8679 end In_Pragma_Expression; 8680 8681 ------------------------------------- 8682 -- In_Reverse_Storage_Order_Object -- 8683 ------------------------------------- 8684 8685 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 8686 Pref : Node_Id; 8687 Btyp : Entity_Id := Empty; 8688 8689 begin 8690 -- Climb up indexed components 8691 8692 Pref := N; 8693 loop 8694 case Nkind (Pref) is 8695 when N_Selected_Component => 8696 Pref := Prefix (Pref); 8697 exit; 8698 8699 when N_Indexed_Component => 8700 Pref := Prefix (Pref); 8701 8702 when others => 8703 Pref := Empty; 8704 exit; 8705 end case; 8706 end loop; 8707 8708 if Present (Pref) then 8709 Btyp := Base_Type (Etype (Pref)); 8710 end if; 8711 8712 return 8713 Present (Btyp) 8714 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 8715 and then Reverse_Storage_Order (Btyp); 8716 end In_Reverse_Storage_Order_Object; 8717 8718 -------------------------------------- 8719 -- In_Subprogram_Or_Concurrent_Unit -- 8720 -------------------------------------- 8721 8722 function In_Subprogram_Or_Concurrent_Unit return Boolean is 8723 E : Entity_Id; 8724 K : Entity_Kind; 8725 8726 begin 8727 -- Use scope chain to check successively outer scopes 8728 8729 E := Current_Scope; 8730 loop 8731 K := Ekind (E); 8732 8733 if K in Subprogram_Kind 8734 or else K in Concurrent_Kind 8735 or else K in Generic_Subprogram_Kind 8736 then 8737 return True; 8738 8739 elsif E = Standard_Standard then 8740 return False; 8741 end if; 8742 8743 E := Scope (E); 8744 end loop; 8745 end In_Subprogram_Or_Concurrent_Unit; 8746 8747 --------------------- 8748 -- In_Visible_Part -- 8749 --------------------- 8750 8751 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 8752 begin 8753 return 8754 Is_Package_Or_Generic_Package (Scope_Id) 8755 and then In_Open_Scopes (Scope_Id) 8756 and then not In_Package_Body (Scope_Id) 8757 and then not In_Private_Part (Scope_Id); 8758 end In_Visible_Part; 8759 8760 -------------------------------- 8761 -- Incomplete_Or_Private_View -- 8762 -------------------------------- 8763 8764 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is 8765 function Inspect_Decls 8766 (Decls : List_Id; 8767 Taft : Boolean := False) return Entity_Id; 8768 -- Check whether a declarative region contains the incomplete or private 8769 -- view of Typ. 8770 8771 ------------------- 8772 -- Inspect_Decls -- 8773 ------------------- 8774 8775 function Inspect_Decls 8776 (Decls : List_Id; 8777 Taft : Boolean := False) return Entity_Id 8778 is 8779 Decl : Node_Id; 8780 Match : Node_Id; 8781 8782 begin 8783 Decl := First (Decls); 8784 while Present (Decl) loop 8785 Match := Empty; 8786 8787 if Taft then 8788 if Nkind (Decl) = N_Incomplete_Type_Declaration then 8789 Match := Defining_Identifier (Decl); 8790 end if; 8791 8792 else 8793 if Nkind_In (Decl, N_Private_Extension_Declaration, 8794 N_Private_Type_Declaration) 8795 then 8796 Match := Defining_Identifier (Decl); 8797 end if; 8798 end if; 8799 8800 if Present (Match) 8801 and then Present (Full_View (Match)) 8802 and then Full_View (Match) = Typ 8803 then 8804 return Match; 8805 end if; 8806 8807 Next (Decl); 8808 end loop; 8809 8810 return Empty; 8811 end Inspect_Decls; 8812 8813 -- Local variables 8814 8815 Prev : Entity_Id; 8816 8817 -- Start of processing for Incomplete_Or_Partial_View 8818 8819 begin 8820 -- Incomplete type case 8821 8822 Prev := Current_Entity_In_Scope (Typ); 8823 8824 if Present (Prev) 8825 and then Is_Incomplete_Type (Prev) 8826 and then Present (Full_View (Prev)) 8827 and then Full_View (Prev) = Typ 8828 then 8829 return Prev; 8830 end if; 8831 8832 -- Private or Taft amendment type case 8833 8834 declare 8835 Pkg : constant Entity_Id := Scope (Typ); 8836 Pkg_Decl : Node_Id := Pkg; 8837 8838 begin 8839 if Ekind (Pkg) = E_Package then 8840 while Nkind (Pkg_Decl) /= N_Package_Specification loop 8841 Pkg_Decl := Parent (Pkg_Decl); 8842 end loop; 8843 8844 -- It is knows that Typ has a private view, look for it in the 8845 -- visible declarations of the enclosing scope. A special case 8846 -- of this is when the two views have been exchanged - the full 8847 -- appears earlier than the private. 8848 8849 if Has_Private_Declaration (Typ) then 8850 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 8851 8852 -- Exchanged view case, look in the private declarations 8853 8854 if No (Prev) then 8855 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 8856 end if; 8857 8858 return Prev; 8859 8860 -- Otherwise if this is the package body, then Typ is a potential 8861 -- Taft amendment type. The incomplete view should be located in 8862 -- the private declarations of the enclosing scope. 8863 8864 elsif In_Package_Body (Pkg) then 8865 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 8866 end if; 8867 end if; 8868 end; 8869 8870 -- The type has no incomplete or private view 8871 8872 return Empty; 8873 end Incomplete_Or_Private_View; 8874 8875 --------------------------------- 8876 -- Insert_Explicit_Dereference -- 8877 --------------------------------- 8878 8879 procedure Insert_Explicit_Dereference (N : Node_Id) is 8880 New_Prefix : constant Node_Id := Relocate_Node (N); 8881 Ent : Entity_Id := Empty; 8882 Pref : Node_Id; 8883 I : Interp_Index; 8884 It : Interp; 8885 T : Entity_Id; 8886 8887 begin 8888 Save_Interps (N, New_Prefix); 8889 8890 Rewrite (N, 8891 Make_Explicit_Dereference (Sloc (Parent (N)), 8892 Prefix => New_Prefix)); 8893 8894 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 8895 8896 if Is_Overloaded (New_Prefix) then 8897 8898 -- The dereference is also overloaded, and its interpretations are 8899 -- the designated types of the interpretations of the original node. 8900 8901 Set_Etype (N, Any_Type); 8902 8903 Get_First_Interp (New_Prefix, I, It); 8904 while Present (It.Nam) loop 8905 T := It.Typ; 8906 8907 if Is_Access_Type (T) then 8908 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 8909 end if; 8910 8911 Get_Next_Interp (I, It); 8912 end loop; 8913 8914 End_Interp_List; 8915 8916 else 8917 -- Prefix is unambiguous: mark the original prefix (which might 8918 -- Come_From_Source) as a reference, since the new (relocated) one 8919 -- won't be taken into account. 8920 8921 if Is_Entity_Name (New_Prefix) then 8922 Ent := Entity (New_Prefix); 8923 Pref := New_Prefix; 8924 8925 -- For a retrieval of a subcomponent of some composite object, 8926 -- retrieve the ultimate entity if there is one. 8927 8928 elsif Nkind (New_Prefix) = N_Selected_Component 8929 or else Nkind (New_Prefix) = N_Indexed_Component 8930 then 8931 Pref := Prefix (New_Prefix); 8932 while Present (Pref) 8933 and then 8934 (Nkind (Pref) = N_Selected_Component 8935 or else Nkind (Pref) = N_Indexed_Component) 8936 loop 8937 Pref := Prefix (Pref); 8938 end loop; 8939 8940 if Present (Pref) and then Is_Entity_Name (Pref) then 8941 Ent := Entity (Pref); 8942 end if; 8943 end if; 8944 8945 -- Place the reference on the entity node 8946 8947 if Present (Ent) then 8948 Generate_Reference (Ent, Pref); 8949 end if; 8950 end if; 8951 end Insert_Explicit_Dereference; 8952 8953 ------------------------------------------ 8954 -- Inspect_Deferred_Constant_Completion -- 8955 ------------------------------------------ 8956 8957 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 8958 Decl : Node_Id; 8959 8960 begin 8961 Decl := First (Decls); 8962 while Present (Decl) loop 8963 8964 -- Deferred constant signature 8965 8966 if Nkind (Decl) = N_Object_Declaration 8967 and then Constant_Present (Decl) 8968 and then No (Expression (Decl)) 8969 8970 -- No need to check internally generated constants 8971 8972 and then Comes_From_Source (Decl) 8973 8974 -- The constant is not completed. A full object declaration or a 8975 -- pragma Import complete a deferred constant. 8976 8977 and then not Has_Completion (Defining_Identifier (Decl)) 8978 then 8979 Error_Msg_N 8980 ("constant declaration requires initialization expression", 8981 Defining_Identifier (Decl)); 8982 end if; 8983 8984 Decl := Next (Decl); 8985 end loop; 8986 end Inspect_Deferred_Constant_Completion; 8987 8988 ----------------------------- 8989 -- Is_Actual_Out_Parameter -- 8990 ----------------------------- 8991 8992 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 8993 Formal : Entity_Id; 8994 Call : Node_Id; 8995 begin 8996 Find_Actual (N, Formal, Call); 8997 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 8998 end Is_Actual_Out_Parameter; 8999 9000 ------------------------- 9001 -- Is_Actual_Parameter -- 9002 ------------------------- 9003 9004 function Is_Actual_Parameter (N : Node_Id) return Boolean is 9005 PK : constant Node_Kind := Nkind (Parent (N)); 9006 9007 begin 9008 case PK is 9009 when N_Parameter_Association => 9010 return N = Explicit_Actual_Parameter (Parent (N)); 9011 9012 when N_Subprogram_Call => 9013 return Is_List_Member (N) 9014 and then 9015 List_Containing (N) = Parameter_Associations (Parent (N)); 9016 9017 when others => 9018 return False; 9019 end case; 9020 end Is_Actual_Parameter; 9021 9022 -------------------------------- 9023 -- Is_Actual_Tagged_Parameter -- 9024 -------------------------------- 9025 9026 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 9027 Formal : Entity_Id; 9028 Call : Node_Id; 9029 begin 9030 Find_Actual (N, Formal, Call); 9031 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 9032 end Is_Actual_Tagged_Parameter; 9033 9034 --------------------- 9035 -- Is_Aliased_View -- 9036 --------------------- 9037 9038 function Is_Aliased_View (Obj : Node_Id) return Boolean is 9039 E : Entity_Id; 9040 9041 begin 9042 if Is_Entity_Name (Obj) then 9043 E := Entity (Obj); 9044 9045 return 9046 (Is_Object (E) 9047 and then 9048 (Is_Aliased (E) 9049 or else (Present (Renamed_Object (E)) 9050 and then Is_Aliased_View (Renamed_Object (E))))) 9051 9052 or else ((Is_Formal (E) 9053 or else Ekind (E) = E_Generic_In_Out_Parameter 9054 or else Ekind (E) = E_Generic_In_Parameter) 9055 and then Is_Tagged_Type (Etype (E))) 9056 9057 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 9058 9059 -- Current instance of type, either directly or as rewritten 9060 -- reference to the current object. 9061 9062 or else (Is_Entity_Name (Original_Node (Obj)) 9063 and then Present (Entity (Original_Node (Obj))) 9064 and then Is_Type (Entity (Original_Node (Obj)))) 9065 9066 or else (Is_Type (E) and then E = Current_Scope) 9067 9068 or else (Is_Incomplete_Or_Private_Type (E) 9069 and then Full_View (E) = Current_Scope) 9070 9071 -- Ada 2012 AI05-0053: the return object of an extended return 9072 -- statement is aliased if its type is immutably limited. 9073 9074 or else (Is_Return_Object (E) 9075 and then Is_Limited_View (Etype (E))); 9076 9077 elsif Nkind (Obj) = N_Selected_Component then 9078 return Is_Aliased (Entity (Selector_Name (Obj))); 9079 9080 elsif Nkind (Obj) = N_Indexed_Component then 9081 return Has_Aliased_Components (Etype (Prefix (Obj))) 9082 or else 9083 (Is_Access_Type (Etype (Prefix (Obj))) 9084 and then Has_Aliased_Components 9085 (Designated_Type (Etype (Prefix (Obj))))); 9086 9087 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 9088 return Is_Tagged_Type (Etype (Obj)) 9089 and then Is_Aliased_View (Expression (Obj)); 9090 9091 elsif Nkind (Obj) = N_Explicit_Dereference then 9092 return Nkind (Original_Node (Obj)) /= N_Function_Call; 9093 9094 else 9095 return False; 9096 end if; 9097 end Is_Aliased_View; 9098 9099 ------------------------- 9100 -- Is_Ancestor_Package -- 9101 ------------------------- 9102 9103 function Is_Ancestor_Package 9104 (E1 : Entity_Id; 9105 E2 : Entity_Id) return Boolean 9106 is 9107 Par : Entity_Id; 9108 9109 begin 9110 Par := E2; 9111 while Present (Par) 9112 and then Par /= Standard_Standard 9113 loop 9114 if Par = E1 then 9115 return True; 9116 end if; 9117 9118 Par := Scope (Par); 9119 end loop; 9120 9121 return False; 9122 end Is_Ancestor_Package; 9123 9124 ---------------------- 9125 -- Is_Atomic_Object -- 9126 ---------------------- 9127 9128 function Is_Atomic_Object (N : Node_Id) return Boolean is 9129 9130 function Object_Has_Atomic_Components (N : Node_Id) return Boolean; 9131 -- Determines if given object has atomic components 9132 9133 function Is_Atomic_Prefix (N : Node_Id) return Boolean; 9134 -- If prefix is an implicit dereference, examine designated type 9135 9136 ---------------------- 9137 -- Is_Atomic_Prefix -- 9138 ---------------------- 9139 9140 function Is_Atomic_Prefix (N : Node_Id) return Boolean is 9141 begin 9142 if Is_Access_Type (Etype (N)) then 9143 return 9144 Has_Atomic_Components (Designated_Type (Etype (N))); 9145 else 9146 return Object_Has_Atomic_Components (N); 9147 end if; 9148 end Is_Atomic_Prefix; 9149 9150 ---------------------------------- 9151 -- Object_Has_Atomic_Components -- 9152 ---------------------------------- 9153 9154 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is 9155 begin 9156 if Has_Atomic_Components (Etype (N)) 9157 or else Is_Atomic (Etype (N)) 9158 then 9159 return True; 9160 9161 elsif Is_Entity_Name (N) 9162 and then (Has_Atomic_Components (Entity (N)) 9163 or else Is_Atomic (Entity (N))) 9164 then 9165 return True; 9166 9167 elsif Nkind (N) = N_Selected_Component 9168 and then Is_Atomic (Entity (Selector_Name (N))) 9169 then 9170 return True; 9171 9172 elsif Nkind (N) = N_Indexed_Component 9173 or else Nkind (N) = N_Selected_Component 9174 then 9175 return Is_Atomic_Prefix (Prefix (N)); 9176 9177 else 9178 return False; 9179 end if; 9180 end Object_Has_Atomic_Components; 9181 9182 -- Start of processing for Is_Atomic_Object 9183 9184 begin 9185 -- Predicate is not relevant to subprograms 9186 9187 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then 9188 return False; 9189 9190 elsif Is_Atomic (Etype (N)) 9191 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) 9192 then 9193 return True; 9194 9195 elsif Nkind (N) = N_Selected_Component 9196 and then Is_Atomic (Entity (Selector_Name (N))) 9197 then 9198 return True; 9199 9200 elsif Nkind (N) = N_Indexed_Component 9201 or else Nkind (N) = N_Selected_Component 9202 then 9203 return Is_Atomic_Prefix (Prefix (N)); 9204 9205 else 9206 return False; 9207 end if; 9208 end Is_Atomic_Object; 9209 9210 ------------------------- 9211 -- Is_Attribute_Result -- 9212 ------------------------- 9213 9214 function Is_Attribute_Result (N : Node_Id) return Boolean is 9215 begin 9216 return 9217 Nkind (N) = N_Attribute_Reference 9218 and then Attribute_Name (N) = Name_Result; 9219 end Is_Attribute_Result; 9220 9221 ------------------------------------ 9222 -- Is_Body_Or_Package_Declaration -- 9223 ------------------------------------ 9224 9225 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 9226 begin 9227 return Nkind_In (N, N_Entry_Body, 9228 N_Package_Body, 9229 N_Package_Declaration, 9230 N_Protected_Body, 9231 N_Subprogram_Body, 9232 N_Task_Body); 9233 end Is_Body_Or_Package_Declaration; 9234 9235 ----------------------- 9236 -- Is_Bounded_String -- 9237 ----------------------- 9238 9239 function Is_Bounded_String (T : Entity_Id) return Boolean is 9240 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 9241 9242 begin 9243 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 9244 -- Super_String, or one of the [Wide_]Wide_ versions. This will 9245 -- be True for all the Bounded_String types in instances of the 9246 -- Generic_Bounded_Length generics, and for types derived from those. 9247 9248 return Present (Under) 9249 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 9250 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 9251 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 9252 end Is_Bounded_String; 9253 9254 ------------------------- 9255 -- Is_Child_Or_Sibling -- 9256 ------------------------- 9257 9258 function Is_Child_Or_Sibling 9259 (Pack_1 : Entity_Id; 9260 Pack_2 : Entity_Id) return Boolean 9261 is 9262 function Distance_From_Standard (Pack : Entity_Id) return Nat; 9263 -- Given an arbitrary package, return the number of "climbs" necessary 9264 -- to reach scope Standard_Standard. 9265 9266 procedure Equalize_Depths 9267 (Pack : in out Entity_Id; 9268 Depth : in out Nat; 9269 Depth_To_Reach : Nat); 9270 -- Given an arbitrary package, its depth and a target depth to reach, 9271 -- climb the scope chain until the said depth is reached. The pointer 9272 -- to the package and its depth a modified during the climb. 9273 9274 ---------------------------- 9275 -- Distance_From_Standard -- 9276 ---------------------------- 9277 9278 function Distance_From_Standard (Pack : Entity_Id) return Nat is 9279 Dist : Nat; 9280 Scop : Entity_Id; 9281 9282 begin 9283 Dist := 0; 9284 Scop := Pack; 9285 while Present (Scop) and then Scop /= Standard_Standard loop 9286 Dist := Dist + 1; 9287 Scop := Scope (Scop); 9288 end loop; 9289 9290 return Dist; 9291 end Distance_From_Standard; 9292 9293 --------------------- 9294 -- Equalize_Depths -- 9295 --------------------- 9296 9297 procedure Equalize_Depths 9298 (Pack : in out Entity_Id; 9299 Depth : in out Nat; 9300 Depth_To_Reach : Nat) 9301 is 9302 begin 9303 -- The package must be at a greater or equal depth 9304 9305 if Depth < Depth_To_Reach then 9306 raise Program_Error; 9307 end if; 9308 9309 -- Climb the scope chain until the desired depth is reached 9310 9311 while Present (Pack) and then Depth /= Depth_To_Reach loop 9312 Pack := Scope (Pack); 9313 Depth := Depth - 1; 9314 end loop; 9315 end Equalize_Depths; 9316 9317 -- Local variables 9318 9319 P_1 : Entity_Id := Pack_1; 9320 P_1_Child : Boolean := False; 9321 P_1_Depth : Nat := Distance_From_Standard (P_1); 9322 P_2 : Entity_Id := Pack_2; 9323 P_2_Child : Boolean := False; 9324 P_2_Depth : Nat := Distance_From_Standard (P_2); 9325 9326 -- Start of processing for Is_Child_Or_Sibling 9327 9328 begin 9329 pragma Assert 9330 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 9331 9332 -- Both packages denote the same entity, therefore they cannot be 9333 -- children or siblings. 9334 9335 if P_1 = P_2 then 9336 return False; 9337 9338 -- One of the packages is at a deeper level than the other. Note that 9339 -- both may still come from differen hierarchies. 9340 9341 -- (root) P_2 9342 -- / \ : 9343 -- X P_2 or X 9344 -- : : 9345 -- P_1 P_1 9346 9347 elsif P_1_Depth > P_2_Depth then 9348 Equalize_Depths 9349 (Pack => P_1, 9350 Depth => P_1_Depth, 9351 Depth_To_Reach => P_2_Depth); 9352 P_1_Child := True; 9353 9354 -- (root) P_1 9355 -- / \ : 9356 -- P_1 X or X 9357 -- : : 9358 -- P_2 P_2 9359 9360 elsif P_2_Depth > P_1_Depth then 9361 Equalize_Depths 9362 (Pack => P_2, 9363 Depth => P_2_Depth, 9364 Depth_To_Reach => P_1_Depth); 9365 P_2_Child := True; 9366 end if; 9367 9368 -- At this stage the package pointers have been elevated to the same 9369 -- depth. If the related entities are the same, then one package is a 9370 -- potential child of the other: 9371 9372 -- P_1 9373 -- : 9374 -- X became P_1 P_2 or vica versa 9375 -- : 9376 -- P_2 9377 9378 if P_1 = P_2 then 9379 if P_1_Child then 9380 return Is_Child_Unit (Pack_1); 9381 9382 else pragma Assert (P_2_Child); 9383 return Is_Child_Unit (Pack_2); 9384 end if; 9385 9386 -- The packages may come from the same package chain or from entirely 9387 -- different hierarcies. To determine this, climb the scope stack until 9388 -- a common root is found. 9389 9390 -- (root) (root 1) (root 2) 9391 -- / \ | | 9392 -- P_1 P_2 P_1 P_2 9393 9394 else 9395 while Present (P_1) and then Present (P_2) loop 9396 9397 -- The two packages may be siblings 9398 9399 if P_1 = P_2 then 9400 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 9401 end if; 9402 9403 P_1 := Scope (P_1); 9404 P_2 := Scope (P_2); 9405 end loop; 9406 end if; 9407 9408 return False; 9409 end Is_Child_Or_Sibling; 9410 9411 ----------------------------- 9412 -- Is_Concurrent_Interface -- 9413 ----------------------------- 9414 9415 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 9416 begin 9417 return 9418 Is_Interface (T) 9419 and then 9420 (Is_Protected_Interface (T) 9421 or else Is_Synchronized_Interface (T) 9422 or else Is_Task_Interface (T)); 9423 end Is_Concurrent_Interface; 9424 9425 --------------------------- 9426 -- Is_Container_Element -- 9427 --------------------------- 9428 9429 function Is_Container_Element (Exp : Node_Id) return Boolean is 9430 Loc : constant Source_Ptr := Sloc (Exp); 9431 Pref : constant Node_Id := Prefix (Exp); 9432 9433 Call : Node_Id; 9434 -- Call to an indexing aspect 9435 9436 Cont_Typ : Entity_Id; 9437 -- The type of the container being accessed 9438 9439 Elem_Typ : Entity_Id; 9440 -- Its element type 9441 9442 Indexing : Entity_Id; 9443 Is_Const : Boolean; 9444 -- Indicates that constant indexing is used, and the element is thus 9445 -- a constant. 9446 9447 Ref_Typ : Entity_Id; 9448 -- The reference type returned by the indexing operation 9449 9450 begin 9451 -- If C is a container, in a context that imposes the element type of 9452 -- that container, the indexing notation C (X) is rewritten as: 9453 9454 -- Indexing (C, X).Discr.all 9455 9456 -- where Indexing is one of the indexing aspects of the container. 9457 -- If the context does not require a reference, the construct can be 9458 -- rewritten as 9459 9460 -- Element (C, X) 9461 9462 -- First, verify that the construct has the proper form 9463 9464 if not Expander_Active then 9465 return False; 9466 9467 elsif Nkind (Pref) /= N_Selected_Component then 9468 return False; 9469 9470 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 9471 return False; 9472 9473 else 9474 Call := Prefix (Pref); 9475 Ref_Typ := Etype (Call); 9476 end if; 9477 9478 if not Has_Implicit_Dereference (Ref_Typ) 9479 or else No (First (Parameter_Associations (Call))) 9480 or else not Is_Entity_Name (Name (Call)) 9481 then 9482 return False; 9483 end if; 9484 9485 -- Retrieve type of container object, and its iterator aspects 9486 9487 Cont_Typ := Etype (First (Parameter_Associations (Call))); 9488 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 9489 Is_Const := False; 9490 9491 if No (Indexing) then 9492 9493 -- Container should have at least one indexing operation 9494 9495 return False; 9496 9497 elsif Entity (Name (Call)) /= Entity (Indexing) then 9498 9499 -- This may be a variable indexing operation 9500 9501 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 9502 9503 if No (Indexing) 9504 or else Entity (Name (Call)) /= Entity (Indexing) 9505 then 9506 return False; 9507 end if; 9508 9509 else 9510 Is_Const := True; 9511 end if; 9512 9513 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 9514 9515 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 9516 return False; 9517 end if; 9518 9519 -- Check that the expression is not the target of an assignment, in 9520 -- which case the rewriting is not possible. 9521 9522 if not Is_Const then 9523 declare 9524 Par : Node_Id; 9525 9526 begin 9527 Par := Exp; 9528 while Present (Par) 9529 loop 9530 if Nkind (Parent (Par)) = N_Assignment_Statement 9531 and then Par = Name (Parent (Par)) 9532 then 9533 return False; 9534 9535 -- A renaming produces a reference, and the transformation 9536 -- does not apply. 9537 9538 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 9539 return False; 9540 9541 elsif Nkind_In 9542 (Nkind (Parent (Par)), N_Function_Call, 9543 N_Procedure_Call_Statement, 9544 N_Entry_Call_Statement) 9545 then 9546 -- Check that the element is not part of an actual for an 9547 -- in-out parameter. 9548 9549 declare 9550 F : Entity_Id; 9551 A : Node_Id; 9552 9553 begin 9554 F := First_Formal (Entity (Name (Parent (Par)))); 9555 A := First (Parameter_Associations (Parent (Par))); 9556 while Present (F) loop 9557 if A = Par and then Ekind (F) /= E_In_Parameter then 9558 return False; 9559 end if; 9560 9561 Next_Formal (F); 9562 Next (A); 9563 end loop; 9564 end; 9565 9566 -- E_In_Parameter in a call: element is not modified. 9567 9568 exit; 9569 end if; 9570 9571 Par := Parent (Par); 9572 end loop; 9573 end; 9574 end if; 9575 9576 -- The expression has the proper form and the context requires the 9577 -- element type. Retrieve the Element function of the container and 9578 -- rewrite the construct as a call to it. 9579 9580 declare 9581 Op : Elmt_Id; 9582 9583 begin 9584 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 9585 while Present (Op) loop 9586 exit when Chars (Node (Op)) = Name_Element; 9587 Next_Elmt (Op); 9588 end loop; 9589 9590 if No (Op) then 9591 return False; 9592 9593 else 9594 Rewrite (Exp, 9595 Make_Function_Call (Loc, 9596 Name => New_Occurrence_Of (Node (Op), Loc), 9597 Parameter_Associations => Parameter_Associations (Call))); 9598 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 9599 return True; 9600 end if; 9601 end; 9602 end Is_Container_Element; 9603 9604 ----------------------- 9605 -- Is_Constant_Bound -- 9606 ----------------------- 9607 9608 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 9609 begin 9610 if Compile_Time_Known_Value (Exp) then 9611 return True; 9612 9613 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 9614 return Is_Constant_Object (Entity (Exp)) 9615 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 9616 9617 elsif Nkind (Exp) in N_Binary_Op then 9618 return Is_Constant_Bound (Left_Opnd (Exp)) 9619 and then Is_Constant_Bound (Right_Opnd (Exp)) 9620 and then Scope (Entity (Exp)) = Standard_Standard; 9621 9622 else 9623 return False; 9624 end if; 9625 end Is_Constant_Bound; 9626 9627 -------------------------------------- 9628 -- Is_Controlling_Limited_Procedure -- 9629 -------------------------------------- 9630 9631 function Is_Controlling_Limited_Procedure 9632 (Proc_Nam : Entity_Id) return Boolean 9633 is 9634 Param_Typ : Entity_Id := Empty; 9635 9636 begin 9637 if Ekind (Proc_Nam) = E_Procedure 9638 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 9639 then 9640 Param_Typ := Etype (Parameter_Type (First ( 9641 Parameter_Specifications (Parent (Proc_Nam))))); 9642 9643 -- In this case where an Itype was created, the procedure call has been 9644 -- rewritten. 9645 9646 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 9647 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 9648 and then 9649 Present (Parameter_Associations 9650 (Associated_Node_For_Itype (Proc_Nam))) 9651 then 9652 Param_Typ := 9653 Etype (First (Parameter_Associations 9654 (Associated_Node_For_Itype (Proc_Nam)))); 9655 end if; 9656 9657 if Present (Param_Typ) then 9658 return 9659 Is_Interface (Param_Typ) 9660 and then Is_Limited_Record (Param_Typ); 9661 end if; 9662 9663 return False; 9664 end Is_Controlling_Limited_Procedure; 9665 9666 ----------------------------- 9667 -- Is_CPP_Constructor_Call -- 9668 ----------------------------- 9669 9670 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 9671 begin 9672 return Nkind (N) = N_Function_Call 9673 and then Is_CPP_Class (Etype (Etype (N))) 9674 and then Is_Constructor (Entity (Name (N))) 9675 and then Is_Imported (Entity (Name (N))); 9676 end Is_CPP_Constructor_Call; 9677 9678 ----------------- 9679 -- Is_Delegate -- 9680 ----------------- 9681 9682 function Is_Delegate (T : Entity_Id) return Boolean is 9683 Desig_Type : Entity_Id; 9684 9685 begin 9686 if VM_Target /= CLI_Target then 9687 return False; 9688 end if; 9689 9690 -- Access-to-subprograms are delegates in CIL 9691 9692 if Ekind (T) = E_Access_Subprogram_Type then 9693 return True; 9694 end if; 9695 9696 if Ekind (T) not in Access_Kind then 9697 9698 -- A delegate is a managed pointer. If no designated type is defined 9699 -- it means that it's not a delegate. 9700 9701 return False; 9702 end if; 9703 9704 Desig_Type := Etype (Directly_Designated_Type (T)); 9705 9706 if not Is_Tagged_Type (Desig_Type) then 9707 return False; 9708 end if; 9709 9710 -- Test if the type is inherited from [mscorlib]System.Delegate 9711 9712 while Etype (Desig_Type) /= Desig_Type loop 9713 if Chars (Scope (Desig_Type)) /= No_Name 9714 and then Is_Imported (Scope (Desig_Type)) 9715 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" 9716 then 9717 return True; 9718 end if; 9719 9720 Desig_Type := Etype (Desig_Type); 9721 end loop; 9722 9723 return False; 9724 end Is_Delegate; 9725 9726 ---------------------------------------------- 9727 -- Is_Dependent_Component_Of_Mutable_Object -- 9728 ---------------------------------------------- 9729 9730 function Is_Dependent_Component_Of_Mutable_Object 9731 (Object : Node_Id) return Boolean 9732 is 9733 P : Node_Id; 9734 Prefix_Type : Entity_Id; 9735 P_Aliased : Boolean := False; 9736 Comp : Entity_Id; 9737 9738 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; 9739 -- Returns True if and only if Comp is declared within a variant part 9740 9741 -------------------------------- 9742 -- Is_Declared_Within_Variant -- 9743 -------------------------------- 9744 9745 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 9746 Comp_Decl : constant Node_Id := Parent (Comp); 9747 Comp_List : constant Node_Id := Parent (Comp_Decl); 9748 begin 9749 return Nkind (Parent (Comp_List)) = N_Variant; 9750 end Is_Declared_Within_Variant; 9751 9752 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 9753 9754 begin 9755 if Is_Variable (Object) then 9756 9757 if Nkind (Object) = N_Selected_Component then 9758 P := Prefix (Object); 9759 Prefix_Type := Etype (P); 9760 9761 if Is_Entity_Name (P) then 9762 9763 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 9764 Prefix_Type := Base_Type (Prefix_Type); 9765 end if; 9766 9767 if Is_Aliased (Entity (P)) then 9768 P_Aliased := True; 9769 end if; 9770 9771 -- A discriminant check on a selected component may be expanded 9772 -- into a dereference when removing side-effects. Recover the 9773 -- original node and its type, which may be unconstrained. 9774 9775 elsif Nkind (P) = N_Explicit_Dereference 9776 and then not (Comes_From_Source (P)) 9777 then 9778 P := Original_Node (P); 9779 Prefix_Type := Etype (P); 9780 9781 else 9782 -- Check for prefix being an aliased component??? 9783 9784 null; 9785 9786 end if; 9787 9788 -- A heap object is constrained by its initial value 9789 9790 -- Ada 2005 (AI-363): Always assume the object could be mutable in 9791 -- the dereferenced case, since the access value might denote an 9792 -- unconstrained aliased object, whereas in Ada 95 the designated 9793 -- object is guaranteed to be constrained. A worst-case assumption 9794 -- has to apply in Ada 2005 because we can't tell at compile time 9795 -- whether the object is "constrained by its initial value" 9796 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are 9797 -- semantic rules -- these rules are acknowledged to need fixing). 9798 9799 if Ada_Version < Ada_2005 then 9800 if Is_Access_Type (Prefix_Type) 9801 or else Nkind (P) = N_Explicit_Dereference 9802 then 9803 return False; 9804 end if; 9805 9806 elsif Ada_Version >= Ada_2005 then 9807 if Is_Access_Type (Prefix_Type) then 9808 9809 -- If the access type is pool-specific, and there is no 9810 -- constrained partial view of the designated type, then the 9811 -- designated object is known to be constrained. 9812 9813 if Ekind (Prefix_Type) = E_Access_Type 9814 and then not Object_Type_Has_Constrained_Partial_View 9815 (Typ => Designated_Type (Prefix_Type), 9816 Scop => Current_Scope) 9817 then 9818 return False; 9819 9820 -- Otherwise (general access type, or there is a constrained 9821 -- partial view of the designated type), we need to check 9822 -- based on the designated type. 9823 9824 else 9825 Prefix_Type := Designated_Type (Prefix_Type); 9826 end if; 9827 end if; 9828 end if; 9829 9830 Comp := 9831 Original_Record_Component (Entity (Selector_Name (Object))); 9832 9833 -- As per AI-0017, the renaming is illegal in a generic body, even 9834 -- if the subtype is indefinite. 9835 9836 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 9837 9838 if not Is_Constrained (Prefix_Type) 9839 and then (not Is_Indefinite_Subtype (Prefix_Type) 9840 or else 9841 (Is_Generic_Type (Prefix_Type) 9842 and then Ekind (Current_Scope) = E_Generic_Package 9843 and then In_Package_Body (Current_Scope))) 9844 9845 and then (Is_Declared_Within_Variant (Comp) 9846 or else Has_Discriminant_Dependent_Constraint (Comp)) 9847 and then (not P_Aliased or else Ada_Version >= Ada_2005) 9848 then 9849 return True; 9850 9851 -- If the prefix is of an access type at this point, then we want 9852 -- to return False, rather than calling this function recursively 9853 -- on the access object (which itself might be a discriminant- 9854 -- dependent component of some other object, but that isn't 9855 -- relevant to checking the object passed to us). This avoids 9856 -- issuing wrong errors when compiling with -gnatc, where there 9857 -- can be implicit dereferences that have not been expanded. 9858 9859 elsif Is_Access_Type (Etype (Prefix (Object))) then 9860 return False; 9861 9862 else 9863 return 9864 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 9865 end if; 9866 9867 elsif Nkind (Object) = N_Indexed_Component 9868 or else Nkind (Object) = N_Slice 9869 then 9870 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 9871 9872 -- A type conversion that Is_Variable is a view conversion: 9873 -- go back to the denoted object. 9874 9875 elsif Nkind (Object) = N_Type_Conversion then 9876 return 9877 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 9878 end if; 9879 end if; 9880 9881 return False; 9882 end Is_Dependent_Component_Of_Mutable_Object; 9883 9884 --------------------- 9885 -- Is_Dereferenced -- 9886 --------------------- 9887 9888 function Is_Dereferenced (N : Node_Id) return Boolean is 9889 P : constant Node_Id := Parent (N); 9890 begin 9891 return 9892 (Nkind (P) = N_Selected_Component 9893 or else 9894 Nkind (P) = N_Explicit_Dereference 9895 or else 9896 Nkind (P) = N_Indexed_Component 9897 or else 9898 Nkind (P) = N_Slice) 9899 and then Prefix (P) = N; 9900 end Is_Dereferenced; 9901 9902 ---------------------- 9903 -- Is_Descendent_Of -- 9904 ---------------------- 9905 9906 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 9907 T : Entity_Id; 9908 Etyp : Entity_Id; 9909 9910 begin 9911 pragma Assert (Nkind (T1) in N_Entity); 9912 pragma Assert (Nkind (T2) in N_Entity); 9913 9914 T := Base_Type (T1); 9915 9916 -- Immediate return if the types match 9917 9918 if T = T2 then 9919 return True; 9920 9921 -- Comment needed here ??? 9922 9923 elsif Ekind (T) = E_Class_Wide_Type then 9924 return Etype (T) = T2; 9925 9926 -- All other cases 9927 9928 else 9929 loop 9930 Etyp := Etype (T); 9931 9932 -- Done if we found the type we are looking for 9933 9934 if Etyp = T2 then 9935 return True; 9936 9937 -- Done if no more derivations to check 9938 9939 elsif T = T1 9940 or else T = Etyp 9941 then 9942 return False; 9943 9944 -- Following test catches error cases resulting from prev errors 9945 9946 elsif No (Etyp) then 9947 return False; 9948 9949 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 9950 return False; 9951 9952 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 9953 return False; 9954 end if; 9955 9956 T := Base_Type (Etyp); 9957 end loop; 9958 end if; 9959 end Is_Descendent_Of; 9960 9961 ---------------------------- 9962 -- Is_Expression_Function -- 9963 ---------------------------- 9964 9965 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 9966 Decl : Node_Id; 9967 9968 begin 9969 if Ekind (Subp) /= E_Function then 9970 return False; 9971 9972 else 9973 Decl := Unit_Declaration_Node (Subp); 9974 return Nkind (Decl) = N_Subprogram_Declaration 9975 and then 9976 (Nkind (Original_Node (Decl)) = N_Expression_Function 9977 or else 9978 (Present (Corresponding_Body (Decl)) 9979 and then 9980 Nkind (Original_Node 9981 (Unit_Declaration_Node 9982 (Corresponding_Body (Decl)))) = 9983 N_Expression_Function)); 9984 end if; 9985 end Is_Expression_Function; 9986 9987 -------------- 9988 -- Is_False -- 9989 -------------- 9990 9991 function Is_False (U : Uint) return Boolean is 9992 begin 9993 return (U = 0); 9994 end Is_False; 9995 9996 --------------------------- 9997 -- Is_Fixed_Model_Number -- 9998 --------------------------- 9999 10000 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 10001 S : constant Ureal := Small_Value (T); 10002 M : Urealp.Save_Mark; 10003 R : Boolean; 10004 begin 10005 M := Urealp.Mark; 10006 R := (U = UR_Trunc (U / S) * S); 10007 Urealp.Release (M); 10008 return R; 10009 end Is_Fixed_Model_Number; 10010 10011 ------------------------------- 10012 -- Is_Fully_Initialized_Type -- 10013 ------------------------------- 10014 10015 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 10016 begin 10017 -- In Ada2012, a scalar type with an aspect Default_Value 10018 -- is fully initialized. 10019 10020 if Is_Scalar_Type (Typ) then 10021 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ); 10022 10023 elsif Is_Access_Type (Typ) then 10024 return True; 10025 10026 elsif Is_Array_Type (Typ) then 10027 if Is_Fully_Initialized_Type (Component_Type (Typ)) 10028 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 10029 then 10030 return True; 10031 end if; 10032 10033 -- An interesting case, if we have a constrained type one of whose 10034 -- bounds is known to be null, then there are no elements to be 10035 -- initialized, so all the elements are initialized. 10036 10037 if Is_Constrained (Typ) then 10038 declare 10039 Indx : Node_Id; 10040 Indx_Typ : Entity_Id; 10041 Lbd, Hbd : Node_Id; 10042 10043 begin 10044 Indx := First_Index (Typ); 10045 while Present (Indx) loop 10046 if Etype (Indx) = Any_Type then 10047 return False; 10048 10049 -- If index is a range, use directly 10050 10051 elsif Nkind (Indx) = N_Range then 10052 Lbd := Low_Bound (Indx); 10053 Hbd := High_Bound (Indx); 10054 10055 else 10056 Indx_Typ := Etype (Indx); 10057 10058 if Is_Private_Type (Indx_Typ) then 10059 Indx_Typ := Full_View (Indx_Typ); 10060 end if; 10061 10062 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 10063 return False; 10064 else 10065 Lbd := Type_Low_Bound (Indx_Typ); 10066 Hbd := Type_High_Bound (Indx_Typ); 10067 end if; 10068 end if; 10069 10070 if Compile_Time_Known_Value (Lbd) 10071 and then Compile_Time_Known_Value (Hbd) 10072 then 10073 if Expr_Value (Hbd) < Expr_Value (Lbd) then 10074 return True; 10075 end if; 10076 end if; 10077 10078 Next_Index (Indx); 10079 end loop; 10080 end; 10081 end if; 10082 10083 -- If no null indexes, then type is not fully initialized 10084 10085 return False; 10086 10087 -- Record types 10088 10089 elsif Is_Record_Type (Typ) then 10090 if Has_Discriminants (Typ) 10091 and then 10092 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 10093 and then Is_Fully_Initialized_Variant (Typ) 10094 then 10095 return True; 10096 end if; 10097 10098 -- We consider bounded string types to be fully initialized, because 10099 -- otherwise we get false alarms when the Data component is not 10100 -- default-initialized. 10101 10102 if Is_Bounded_String (Typ) then 10103 return True; 10104 end if; 10105 10106 -- Controlled records are considered to be fully initialized if 10107 -- there is a user defined Initialize routine. This may not be 10108 -- entirely correct, but as the spec notes, we are guessing here 10109 -- what is best from the point of view of issuing warnings. 10110 10111 if Is_Controlled (Typ) then 10112 declare 10113 Utyp : constant Entity_Id := Underlying_Type (Typ); 10114 10115 begin 10116 if Present (Utyp) then 10117 declare 10118 Init : constant Entity_Id := 10119 (Find_Prim_Op 10120 (Underlying_Type (Typ), Name_Initialize)); 10121 10122 begin 10123 if Present (Init) 10124 and then Comes_From_Source (Init) 10125 and then not 10126 Is_Predefined_File_Name 10127 (File_Name (Get_Source_File_Index (Sloc (Init)))) 10128 then 10129 return True; 10130 10131 elsif Has_Null_Extension (Typ) 10132 and then 10133 Is_Fully_Initialized_Type 10134 (Etype (Base_Type (Typ))) 10135 then 10136 return True; 10137 end if; 10138 end; 10139 end if; 10140 end; 10141 end if; 10142 10143 -- Otherwise see if all record components are initialized 10144 10145 declare 10146 Ent : Entity_Id; 10147 10148 begin 10149 Ent := First_Entity (Typ); 10150 while Present (Ent) loop 10151 if Ekind (Ent) = E_Component 10152 and then (No (Parent (Ent)) 10153 or else No (Expression (Parent (Ent)))) 10154 and then not Is_Fully_Initialized_Type (Etype (Ent)) 10155 10156 -- Special VM case for tag components, which need to be 10157 -- defined in this case, but are never initialized as VMs 10158 -- are using other dispatching mechanisms. Ignore this 10159 -- uninitialized case. Note that this applies both to the 10160 -- uTag entry and the main vtable pointer (CPP_Class case). 10161 10162 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 10163 then 10164 return False; 10165 end if; 10166 10167 Next_Entity (Ent); 10168 end loop; 10169 end; 10170 10171 -- No uninitialized components, so type is fully initialized. 10172 -- Note that this catches the case of no components as well. 10173 10174 return True; 10175 10176 elsif Is_Concurrent_Type (Typ) then 10177 return True; 10178 10179 elsif Is_Private_Type (Typ) then 10180 declare 10181 U : constant Entity_Id := Underlying_Type (Typ); 10182 10183 begin 10184 if No (U) then 10185 return False; 10186 else 10187 return Is_Fully_Initialized_Type (U); 10188 end if; 10189 end; 10190 10191 else 10192 return False; 10193 end if; 10194 end Is_Fully_Initialized_Type; 10195 10196 ---------------------------------- 10197 -- Is_Fully_Initialized_Variant -- 10198 ---------------------------------- 10199 10200 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 10201 Loc : constant Source_Ptr := Sloc (Typ); 10202 Constraints : constant List_Id := New_List; 10203 Components : constant Elist_Id := New_Elmt_List; 10204 Comp_Elmt : Elmt_Id; 10205 Comp_Id : Node_Id; 10206 Comp_List : Node_Id; 10207 Discr : Entity_Id; 10208 Discr_Val : Node_Id; 10209 10210 Report_Errors : Boolean; 10211 pragma Warnings (Off, Report_Errors); 10212 10213 begin 10214 if Serious_Errors_Detected > 0 then 10215 return False; 10216 end if; 10217 10218 if Is_Record_Type (Typ) 10219 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 10220 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 10221 then 10222 Comp_List := Component_List (Type_Definition (Parent (Typ))); 10223 10224 Discr := First_Discriminant (Typ); 10225 while Present (Discr) loop 10226 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 10227 Discr_Val := Expression (Parent (Discr)); 10228 10229 if Present (Discr_Val) 10230 and then Is_OK_Static_Expression (Discr_Val) 10231 then 10232 Append_To (Constraints, 10233 Make_Component_Association (Loc, 10234 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 10235 Expression => New_Copy (Discr_Val))); 10236 else 10237 return False; 10238 end if; 10239 else 10240 return False; 10241 end if; 10242 10243 Next_Discriminant (Discr); 10244 end loop; 10245 10246 Gather_Components 10247 (Typ => Typ, 10248 Comp_List => Comp_List, 10249 Governed_By => Constraints, 10250 Into => Components, 10251 Report_Errors => Report_Errors); 10252 10253 -- Check that each component present is fully initialized 10254 10255 Comp_Elmt := First_Elmt (Components); 10256 while Present (Comp_Elmt) loop 10257 Comp_Id := Node (Comp_Elmt); 10258 10259 if Ekind (Comp_Id) = E_Component 10260 and then (No (Parent (Comp_Id)) 10261 or else No (Expression (Parent (Comp_Id)))) 10262 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 10263 then 10264 return False; 10265 end if; 10266 10267 Next_Elmt (Comp_Elmt); 10268 end loop; 10269 10270 return True; 10271 10272 elsif Is_Private_Type (Typ) then 10273 declare 10274 U : constant Entity_Id := Underlying_Type (Typ); 10275 10276 begin 10277 if No (U) then 10278 return False; 10279 else 10280 return Is_Fully_Initialized_Variant (U); 10281 end if; 10282 end; 10283 10284 else 10285 return False; 10286 end if; 10287 end Is_Fully_Initialized_Variant; 10288 10289 ---------------------------- 10290 -- Is_Inherited_Operation -- 10291 ---------------------------- 10292 10293 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 10294 pragma Assert (Is_Overloadable (E)); 10295 Kind : constant Node_Kind := Nkind (Parent (E)); 10296 begin 10297 return Kind = N_Full_Type_Declaration 10298 or else Kind = N_Private_Extension_Declaration 10299 or else Kind = N_Subtype_Declaration 10300 or else (Ekind (E) = E_Enumeration_Literal 10301 and then Is_Derived_Type (Etype (E))); 10302 end Is_Inherited_Operation; 10303 10304 ------------------------------------- 10305 -- Is_Inherited_Operation_For_Type -- 10306 ------------------------------------- 10307 10308 function Is_Inherited_Operation_For_Type 10309 (E : Entity_Id; 10310 Typ : Entity_Id) return Boolean 10311 is 10312 begin 10313 -- Check that the operation has been created by the type declaration 10314 10315 return Is_Inherited_Operation (E) 10316 and then Defining_Identifier (Parent (E)) = Typ; 10317 end Is_Inherited_Operation_For_Type; 10318 10319 ----------------- 10320 -- Is_Iterator -- 10321 ----------------- 10322 10323 function Is_Iterator (Typ : Entity_Id) return Boolean is 10324 Ifaces_List : Elist_Id; 10325 Iface_Elmt : Elmt_Id; 10326 Iface : Entity_Id; 10327 10328 begin 10329 if Is_Class_Wide_Type (Typ) 10330 and then 10331 Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, 10332 Name_Reversible_Iterator) 10333 and then 10334 Is_Predefined_File_Name 10335 (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) 10336 then 10337 return True; 10338 10339 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 10340 return False; 10341 10342 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 10343 return True; 10344 10345 else 10346 Collect_Interfaces (Typ, Ifaces_List); 10347 10348 Iface_Elmt := First_Elmt (Ifaces_List); 10349 while Present (Iface_Elmt) loop 10350 Iface := Node (Iface_Elmt); 10351 if Chars (Iface) = Name_Forward_Iterator 10352 and then 10353 Is_Predefined_File_Name 10354 (Unit_File_Name (Get_Source_Unit (Iface))) 10355 then 10356 return True; 10357 end if; 10358 10359 Next_Elmt (Iface_Elmt); 10360 end loop; 10361 10362 return False; 10363 end if; 10364 end Is_Iterator; 10365 10366 ------------------ 10367 -- Is_Junk_Name -- 10368 ------------------ 10369 10370 function Is_Junk_Name (N : Name_Id) return Boolean is 10371 function Match (S : String) return Boolean; 10372 -- Return true if substring S is found in Name_Buffer (1 .. Name_Len) 10373 10374 ----------- 10375 -- Match -- 10376 ----------- 10377 10378 function Match (S : String) return Boolean is 10379 Slen1 : constant Integer := S'Length - 1; 10380 10381 begin 10382 for J in 1 .. Name_Len - S'Length + 1 loop 10383 if Name_Buffer (J .. J + Slen1) = S then 10384 return True; 10385 end if; 10386 end loop; 10387 10388 return False; 10389 end Match; 10390 10391 -- Start of processing for Is_Junk_Name 10392 10393 begin 10394 Get_Unqualified_Decoded_Name_String (N); 10395 Set_All_Upper_Case; 10396 10397 return 10398 Match ("DISCARD") or else 10399 Match ("DUMMY") or else 10400 Match ("IGNORE") or else 10401 Match ("JUNK") or else 10402 Match ("UNUSED"); 10403 end Is_Junk_Name; 10404 10405 ------------ 10406 -- Is_LHS -- 10407 ------------ 10408 10409 -- We seem to have a lot of overlapping functions that do similar things 10410 -- (testing for left hand sides or lvalues???). 10411 10412 function Is_LHS (N : Node_Id) return Is_LHS_Result is 10413 P : constant Node_Id := Parent (N); 10414 10415 begin 10416 -- Return True if we are the left hand side of an assignment statement 10417 10418 if Nkind (P) = N_Assignment_Statement then 10419 if Name (P) = N then 10420 return Yes; 10421 else 10422 return No; 10423 end if; 10424 10425 -- Case of prefix of indexed or selected component or slice 10426 10427 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 10428 and then N = Prefix (P) 10429 then 10430 -- Here we have the case where the parent P is N.Q or N(Q .. R). 10431 -- If P is an LHS, then N is also effectively an LHS, but there 10432 -- is an important exception. If N is of an access type, then 10433 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 10434 -- case this makes N.all a left hand side but not N itself. 10435 10436 -- If we don't know the type yet, this is the case where we return 10437 -- Unknown, since the answer depends on the type which is unknown. 10438 10439 if No (Etype (N)) then 10440 return Unknown; 10441 10442 -- We have an Etype set, so we can check it 10443 10444 elsif Is_Access_Type (Etype (N)) then 10445 return No; 10446 10447 -- OK, not access type case, so just test whole expression 10448 10449 else 10450 return Is_LHS (P); 10451 end if; 10452 10453 -- All other cases are not left hand sides 10454 10455 else 10456 return No; 10457 end if; 10458 end Is_LHS; 10459 10460 ----------------------------- 10461 -- Is_Library_Level_Entity -- 10462 ----------------------------- 10463 10464 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 10465 begin 10466 -- The following is a small optimization, and it also properly handles 10467 -- discriminals, which in task bodies might appear in expressions before 10468 -- the corresponding procedure has been created, and which therefore do 10469 -- not have an assigned scope. 10470 10471 if Is_Formal (E) then 10472 return False; 10473 end if; 10474 10475 -- Normal test is simply that the enclosing dynamic scope is Standard 10476 10477 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 10478 end Is_Library_Level_Entity; 10479 10480 -------------------------------- 10481 -- Is_Limited_Class_Wide_Type -- 10482 -------------------------------- 10483 10484 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 10485 begin 10486 return 10487 Is_Class_Wide_Type (Typ) 10488 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 10489 end Is_Limited_Class_Wide_Type; 10490 10491 --------------------------------- 10492 -- Is_Local_Variable_Reference -- 10493 --------------------------------- 10494 10495 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 10496 begin 10497 if not Is_Entity_Name (Expr) then 10498 return False; 10499 10500 else 10501 declare 10502 Ent : constant Entity_Id := Entity (Expr); 10503 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 10504 begin 10505 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 10506 return False; 10507 else 10508 return Present (Sub) and then Sub = Current_Subprogram; 10509 end if; 10510 end; 10511 end if; 10512 end Is_Local_Variable_Reference; 10513 10514 ------------------------- 10515 -- Is_Object_Reference -- 10516 ------------------------- 10517 10518 function Is_Object_Reference (N : Node_Id) return Boolean is 10519 10520 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 10521 -- Determine whether N is the name of an internally-generated renaming 10522 10523 -------------------------------------- 10524 -- Is_Internally_Generated_Renaming -- 10525 -------------------------------------- 10526 10527 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 10528 P : Node_Id; 10529 10530 begin 10531 P := N; 10532 while Present (P) loop 10533 if Nkind (P) = N_Object_Renaming_Declaration then 10534 return not Comes_From_Source (P); 10535 elsif Is_List_Member (P) then 10536 return False; 10537 end if; 10538 10539 P := Parent (P); 10540 end loop; 10541 10542 return False; 10543 end Is_Internally_Generated_Renaming; 10544 10545 -- Start of processing for Is_Object_Reference 10546 10547 begin 10548 if Is_Entity_Name (N) then 10549 return Present (Entity (N)) and then Is_Object (Entity (N)); 10550 10551 else 10552 case Nkind (N) is 10553 when N_Indexed_Component | N_Slice => 10554 return 10555 Is_Object_Reference (Prefix (N)) 10556 or else Is_Access_Type (Etype (Prefix (N))); 10557 10558 -- In Ada 95, a function call is a constant object; a procedure 10559 -- call is not. 10560 10561 when N_Function_Call => 10562 return Etype (N) /= Standard_Void_Type; 10563 10564 -- Attributes 'Input, 'Old and 'Result produce objects 10565 10566 when N_Attribute_Reference => 10567 return 10568 Nam_In 10569 (Attribute_Name (N), Name_Input, Name_Old, Name_Result); 10570 10571 when N_Selected_Component => 10572 return 10573 Is_Object_Reference (Selector_Name (N)) 10574 and then 10575 (Is_Object_Reference (Prefix (N)) 10576 or else Is_Access_Type (Etype (Prefix (N)))); 10577 10578 when N_Explicit_Dereference => 10579 return True; 10580 10581 -- A view conversion of a tagged object is an object reference 10582 10583 when N_Type_Conversion => 10584 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 10585 and then Is_Tagged_Type (Etype (Expression (N))) 10586 and then Is_Object_Reference (Expression (N)); 10587 10588 -- An unchecked type conversion is considered to be an object if 10589 -- the operand is an object (this construction arises only as a 10590 -- result of expansion activities). 10591 10592 when N_Unchecked_Type_Conversion => 10593 return True; 10594 10595 -- Allow string literals to act as objects as long as they appear 10596 -- in internally-generated renamings. The expansion of iterators 10597 -- may generate such renamings when the range involves a string 10598 -- literal. 10599 10600 when N_String_Literal => 10601 return Is_Internally_Generated_Renaming (Parent (N)); 10602 10603 -- AI05-0003: In Ada 2012 a qualified expression is a name. 10604 -- This allows disambiguation of function calls and the use 10605 -- of aggregates in more contexts. 10606 10607 when N_Qualified_Expression => 10608 if Ada_Version < Ada_2012 then 10609 return False; 10610 else 10611 return Is_Object_Reference (Expression (N)) 10612 or else Nkind (Expression (N)) = N_Aggregate; 10613 end if; 10614 10615 when others => 10616 return False; 10617 end case; 10618 end if; 10619 end Is_Object_Reference; 10620 10621 ----------------------------------- 10622 -- Is_OK_Variable_For_Out_Formal -- 10623 ----------------------------------- 10624 10625 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 10626 begin 10627 Note_Possible_Modification (AV, Sure => True); 10628 10629 -- We must reject parenthesized variable names. Comes_From_Source is 10630 -- checked because there are currently cases where the compiler violates 10631 -- this rule (e.g. passing a task object to its controlled Initialize 10632 -- routine). This should be properly documented in sinfo??? 10633 10634 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 10635 return False; 10636 10637 -- A variable is always allowed 10638 10639 elsif Is_Variable (AV) then 10640 return True; 10641 10642 -- Unchecked conversions are allowed only if they come from the 10643 -- generated code, which sometimes uses unchecked conversions for out 10644 -- parameters in cases where code generation is unaffected. We tell 10645 -- source unchecked conversions by seeing if they are rewrites of 10646 -- an original Unchecked_Conversion function call, or of an explicit 10647 -- conversion of a function call or an aggregate (as may happen in the 10648 -- expansion of a packed array aggregate). 10649 10650 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 10651 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then 10652 return False; 10653 10654 elsif Comes_From_Source (AV) 10655 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 10656 then 10657 return False; 10658 10659 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 10660 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 10661 10662 else 10663 return True; 10664 end if; 10665 10666 -- Normal type conversions are allowed if argument is a variable 10667 10668 elsif Nkind (AV) = N_Type_Conversion then 10669 if Is_Variable (Expression (AV)) 10670 and then Paren_Count (Expression (AV)) = 0 10671 then 10672 Note_Possible_Modification (Expression (AV), Sure => True); 10673 return True; 10674 10675 -- We also allow a non-parenthesized expression that raises 10676 -- constraint error if it rewrites what used to be a variable 10677 10678 elsif Raises_Constraint_Error (Expression (AV)) 10679 and then Paren_Count (Expression (AV)) = 0 10680 and then Is_Variable (Original_Node (Expression (AV))) 10681 then 10682 return True; 10683 10684 -- Type conversion of something other than a variable 10685 10686 else 10687 return False; 10688 end if; 10689 10690 -- If this node is rewritten, then test the original form, if that is 10691 -- OK, then we consider the rewritten node OK (for example, if the 10692 -- original node is a conversion, then Is_Variable will not be true 10693 -- but we still want to allow the conversion if it converts a variable). 10694 10695 elsif Original_Node (AV) /= AV then 10696 10697 -- In Ada 2012, the explicit dereference may be a rewritten call to a 10698 -- Reference function. 10699 10700 if Ada_Version >= Ada_2012 10701 and then Nkind (Original_Node (AV)) = N_Function_Call 10702 and then 10703 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 10704 then 10705 return True; 10706 10707 else 10708 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 10709 end if; 10710 10711 -- All other non-variables are rejected 10712 10713 else 10714 return False; 10715 end if; 10716 end Is_OK_Variable_For_Out_Formal; 10717 10718 ----------------------------------- 10719 -- Is_Partially_Initialized_Type -- 10720 ----------------------------------- 10721 10722 function Is_Partially_Initialized_Type 10723 (Typ : Entity_Id; 10724 Include_Implicit : Boolean := True) return Boolean 10725 is 10726 begin 10727 if Is_Scalar_Type (Typ) then 10728 return False; 10729 10730 elsif Is_Access_Type (Typ) then 10731 return Include_Implicit; 10732 10733 elsif Is_Array_Type (Typ) then 10734 10735 -- If component type is partially initialized, so is array type 10736 10737 if Is_Partially_Initialized_Type 10738 (Component_Type (Typ), Include_Implicit) 10739 then 10740 return True; 10741 10742 -- Otherwise we are only partially initialized if we are fully 10743 -- initialized (this is the empty array case, no point in us 10744 -- duplicating that code here). 10745 10746 else 10747 return Is_Fully_Initialized_Type (Typ); 10748 end if; 10749 10750 elsif Is_Record_Type (Typ) then 10751 10752 -- A discriminated type is always partially initialized if in 10753 -- all mode 10754 10755 if Has_Discriminants (Typ) and then Include_Implicit then 10756 return True; 10757 10758 -- A tagged type is always partially initialized 10759 10760 elsif Is_Tagged_Type (Typ) then 10761 return True; 10762 10763 -- Case of non-discriminated record 10764 10765 else 10766 declare 10767 Ent : Entity_Id; 10768 10769 Component_Present : Boolean := False; 10770 -- Set True if at least one component is present. If no 10771 -- components are present, then record type is fully 10772 -- initialized (another odd case, like the null array). 10773 10774 begin 10775 -- Loop through components 10776 10777 Ent := First_Entity (Typ); 10778 while Present (Ent) loop 10779 if Ekind (Ent) = E_Component then 10780 Component_Present := True; 10781 10782 -- If a component has an initialization expression then 10783 -- the enclosing record type is partially initialized 10784 10785 if Present (Parent (Ent)) 10786 and then Present (Expression (Parent (Ent))) 10787 then 10788 return True; 10789 10790 -- If a component is of a type which is itself partially 10791 -- initialized, then the enclosing record type is also. 10792 10793 elsif Is_Partially_Initialized_Type 10794 (Etype (Ent), Include_Implicit) 10795 then 10796 return True; 10797 end if; 10798 end if; 10799 10800 Next_Entity (Ent); 10801 end loop; 10802 10803 -- No initialized components found. If we found any components 10804 -- they were all uninitialized so the result is false. 10805 10806 if Component_Present then 10807 return False; 10808 10809 -- But if we found no components, then all the components are 10810 -- initialized so we consider the type to be initialized. 10811 10812 else 10813 return True; 10814 end if; 10815 end; 10816 end if; 10817 10818 -- Concurrent types are always fully initialized 10819 10820 elsif Is_Concurrent_Type (Typ) then 10821 return True; 10822 10823 -- For a private type, go to underlying type. If there is no underlying 10824 -- type then just assume this partially initialized. Not clear if this 10825 -- can happen in a non-error case, but no harm in testing for this. 10826 10827 elsif Is_Private_Type (Typ) then 10828 declare 10829 U : constant Entity_Id := Underlying_Type (Typ); 10830 begin 10831 if No (U) then 10832 return True; 10833 else 10834 return Is_Partially_Initialized_Type (U, Include_Implicit); 10835 end if; 10836 end; 10837 10838 -- For any other type (are there any?) assume partially initialized 10839 10840 else 10841 return True; 10842 end if; 10843 end Is_Partially_Initialized_Type; 10844 10845 ------------------------------------ 10846 -- Is_Potentially_Persistent_Type -- 10847 ------------------------------------ 10848 10849 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 10850 Comp : Entity_Id; 10851 Indx : Node_Id; 10852 10853 begin 10854 -- For private type, test corresponding full type 10855 10856 if Is_Private_Type (T) then 10857 return Is_Potentially_Persistent_Type (Full_View (T)); 10858 10859 -- Scalar types are potentially persistent 10860 10861 elsif Is_Scalar_Type (T) then 10862 return True; 10863 10864 -- Record type is potentially persistent if not tagged and the types of 10865 -- all it components are potentially persistent, and no component has 10866 -- an initialization expression. 10867 10868 elsif Is_Record_Type (T) 10869 and then not Is_Tagged_Type (T) 10870 and then not Is_Partially_Initialized_Type (T) 10871 then 10872 Comp := First_Component (T); 10873 while Present (Comp) loop 10874 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 10875 return False; 10876 else 10877 Next_Entity (Comp); 10878 end if; 10879 end loop; 10880 10881 return True; 10882 10883 -- Array type is potentially persistent if its component type is 10884 -- potentially persistent and if all its constraints are static. 10885 10886 elsif Is_Array_Type (T) then 10887 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 10888 return False; 10889 end if; 10890 10891 Indx := First_Index (T); 10892 while Present (Indx) loop 10893 if not Is_OK_Static_Subtype (Etype (Indx)) then 10894 return False; 10895 else 10896 Next_Index (Indx); 10897 end if; 10898 end loop; 10899 10900 return True; 10901 10902 -- All other types are not potentially persistent 10903 10904 else 10905 return False; 10906 end if; 10907 end Is_Potentially_Persistent_Type; 10908 10909 -------------------------------- 10910 -- Is_Potentially_Unevaluated -- 10911 -------------------------------- 10912 10913 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 10914 Par : Node_Id; 10915 Expr : Node_Id; 10916 10917 begin 10918 Expr := N; 10919 Par := Parent (N); 10920 while not Nkind_In (Par, N_If_Expression, 10921 N_Case_Expression, 10922 N_And_Then, 10923 N_Or_Else, 10924 N_In, 10925 N_Not_In) 10926 loop 10927 Expr := Par; 10928 Par := Parent (Par); 10929 10930 -- If the context is not an expression, or if is the result of 10931 -- expansion of an enclosing construct (such as another attribute) 10932 -- the predicate does not apply. 10933 10934 if Nkind (Par) not in N_Subexpr 10935 or else not Comes_From_Source (Par) 10936 then 10937 return False; 10938 end if; 10939 end loop; 10940 10941 if Nkind (Par) = N_If_Expression then 10942 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 10943 10944 elsif Nkind (Par) = N_Case_Expression then 10945 return Expr /= Expression (Par); 10946 10947 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then 10948 return Expr = Right_Opnd (Par); 10949 10950 elsif Nkind_In (Par, N_In, N_Not_In) then 10951 return Expr /= Left_Opnd (Par); 10952 10953 else 10954 return False; 10955 end if; 10956 end Is_Potentially_Unevaluated; 10957 10958 --------------------------------- 10959 -- Is_Protected_Self_Reference -- 10960 --------------------------------- 10961 10962 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 10963 10964 function In_Access_Definition (N : Node_Id) return Boolean; 10965 -- Returns true if N belongs to an access definition 10966 10967 -------------------------- 10968 -- In_Access_Definition -- 10969 -------------------------- 10970 10971 function In_Access_Definition (N : Node_Id) return Boolean is 10972 P : Node_Id; 10973 10974 begin 10975 P := Parent (N); 10976 while Present (P) loop 10977 if Nkind (P) = N_Access_Definition then 10978 return True; 10979 end if; 10980 10981 P := Parent (P); 10982 end loop; 10983 10984 return False; 10985 end In_Access_Definition; 10986 10987 -- Start of processing for Is_Protected_Self_Reference 10988 10989 begin 10990 -- Verify that prefix is analyzed and has the proper form. Note that 10991 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address, 10992 -- which also produce the address of an entity, do not analyze their 10993 -- prefix because they denote entities that are not necessarily visible. 10994 -- Neither of them can apply to a protected type. 10995 10996 return Ada_Version >= Ada_2005 10997 and then Is_Entity_Name (N) 10998 and then Present (Entity (N)) 10999 and then Is_Protected_Type (Entity (N)) 11000 and then In_Open_Scopes (Entity (N)) 11001 and then not In_Access_Definition (N); 11002 end Is_Protected_Self_Reference; 11003 11004 ----------------------------- 11005 -- Is_RCI_Pkg_Spec_Or_Body -- 11006 ----------------------------- 11007 11008 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 11009 11010 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 11011 -- Return True if the unit of Cunit is an RCI package declaration 11012 11013 --------------------------- 11014 -- Is_RCI_Pkg_Decl_Cunit -- 11015 --------------------------- 11016 11017 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 11018 The_Unit : constant Node_Id := Unit (Cunit); 11019 11020 begin 11021 if Nkind (The_Unit) /= N_Package_Declaration then 11022 return False; 11023 end if; 11024 11025 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 11026 end Is_RCI_Pkg_Decl_Cunit; 11027 11028 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 11029 11030 begin 11031 return Is_RCI_Pkg_Decl_Cunit (Cunit) 11032 or else 11033 (Nkind (Unit (Cunit)) = N_Package_Body 11034 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 11035 end Is_RCI_Pkg_Spec_Or_Body; 11036 11037 ----------------------------------------- 11038 -- Is_Remote_Access_To_Class_Wide_Type -- 11039 ----------------------------------------- 11040 11041 function Is_Remote_Access_To_Class_Wide_Type 11042 (E : Entity_Id) return Boolean 11043 is 11044 begin 11045 -- A remote access to class-wide type is a general access to object type 11046 -- declared in the visible part of a Remote_Types or Remote_Call_ 11047 -- Interface unit. 11048 11049 return Ekind (E) = E_General_Access_Type 11050 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 11051 end Is_Remote_Access_To_Class_Wide_Type; 11052 11053 ----------------------------------------- 11054 -- Is_Remote_Access_To_Subprogram_Type -- 11055 ----------------------------------------- 11056 11057 function Is_Remote_Access_To_Subprogram_Type 11058 (E : Entity_Id) return Boolean 11059 is 11060 begin 11061 return (Ekind (E) = E_Access_Subprogram_Type 11062 or else (Ekind (E) = E_Record_Type 11063 and then Present (Corresponding_Remote_Type (E)))) 11064 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 11065 end Is_Remote_Access_To_Subprogram_Type; 11066 11067 -------------------- 11068 -- Is_Remote_Call -- 11069 -------------------- 11070 11071 function Is_Remote_Call (N : Node_Id) return Boolean is 11072 begin 11073 if Nkind (N) not in N_Subprogram_Call then 11074 11075 -- An entry call cannot be remote 11076 11077 return False; 11078 11079 elsif Nkind (Name (N)) in N_Has_Entity 11080 and then Is_Remote_Call_Interface (Entity (Name (N))) 11081 then 11082 -- A subprogram declared in the spec of a RCI package is remote 11083 11084 return True; 11085 11086 elsif Nkind (Name (N)) = N_Explicit_Dereference 11087 and then Is_Remote_Access_To_Subprogram_Type 11088 (Etype (Prefix (Name (N)))) 11089 then 11090 -- The dereference of a RAS is a remote call 11091 11092 return True; 11093 11094 elsif Present (Controlling_Argument (N)) 11095 and then Is_Remote_Access_To_Class_Wide_Type 11096 (Etype (Controlling_Argument (N))) 11097 then 11098 -- Any primitive operation call with a controlling argument of 11099 -- a RACW type is a remote call. 11100 11101 return True; 11102 end if; 11103 11104 -- All other calls are local calls 11105 11106 return False; 11107 end Is_Remote_Call; 11108 11109 ---------------------- 11110 -- Is_Renamed_Entry -- 11111 ---------------------- 11112 11113 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 11114 Orig_Node : Node_Id := Empty; 11115 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 11116 11117 function Is_Entry (Nam : Node_Id) return Boolean; 11118 -- Determine whether Nam is an entry. Traverse selectors if there are 11119 -- nested selected components. 11120 11121 -------------- 11122 -- Is_Entry -- 11123 -------------- 11124 11125 function Is_Entry (Nam : Node_Id) return Boolean is 11126 begin 11127 if Nkind (Nam) = N_Selected_Component then 11128 return Is_Entry (Selector_Name (Nam)); 11129 end if; 11130 11131 return Ekind (Entity (Nam)) = E_Entry; 11132 end Is_Entry; 11133 11134 -- Start of processing for Is_Renamed_Entry 11135 11136 begin 11137 if Present (Alias (Proc_Nam)) then 11138 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 11139 end if; 11140 11141 -- Look for a rewritten subprogram renaming declaration 11142 11143 if Nkind (Subp_Decl) = N_Subprogram_Declaration 11144 and then Present (Original_Node (Subp_Decl)) 11145 then 11146 Orig_Node := Original_Node (Subp_Decl); 11147 end if; 11148 11149 -- The rewritten subprogram is actually an entry 11150 11151 if Present (Orig_Node) 11152 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 11153 and then Is_Entry (Name (Orig_Node)) 11154 then 11155 return True; 11156 end if; 11157 11158 return False; 11159 end Is_Renamed_Entry; 11160 11161 ---------------------------- 11162 -- Is_Reversible_Iterator -- 11163 ---------------------------- 11164 11165 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 11166 Ifaces_List : Elist_Id; 11167 Iface_Elmt : Elmt_Id; 11168 Iface : Entity_Id; 11169 11170 begin 11171 if Is_Class_Wide_Type (Typ) 11172 and then Chars (Etype (Typ)) = Name_Reversible_Iterator 11173 and then 11174 Is_Predefined_File_Name 11175 (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) 11176 then 11177 return True; 11178 11179 elsif not Is_Tagged_Type (Typ) 11180 or else not Is_Derived_Type (Typ) 11181 then 11182 return False; 11183 11184 else 11185 Collect_Interfaces (Typ, Ifaces_List); 11186 11187 Iface_Elmt := First_Elmt (Ifaces_List); 11188 while Present (Iface_Elmt) loop 11189 Iface := Node (Iface_Elmt); 11190 if Chars (Iface) = Name_Reversible_Iterator 11191 and then 11192 Is_Predefined_File_Name 11193 (Unit_File_Name (Get_Source_Unit (Iface))) 11194 then 11195 return True; 11196 end if; 11197 11198 Next_Elmt (Iface_Elmt); 11199 end loop; 11200 end if; 11201 11202 return False; 11203 end Is_Reversible_Iterator; 11204 11205 ---------------------- 11206 -- Is_Selector_Name -- 11207 ---------------------- 11208 11209 function Is_Selector_Name (N : Node_Id) return Boolean is 11210 begin 11211 if not Is_List_Member (N) then 11212 declare 11213 P : constant Node_Id := Parent (N); 11214 K : constant Node_Kind := Nkind (P); 11215 begin 11216 return 11217 (K = N_Expanded_Name or else 11218 K = N_Generic_Association or else 11219 K = N_Parameter_Association or else 11220 K = N_Selected_Component) 11221 and then Selector_Name (P) = N; 11222 end; 11223 11224 else 11225 declare 11226 L : constant List_Id := List_Containing (N); 11227 P : constant Node_Id := Parent (L); 11228 begin 11229 return (Nkind (P) = N_Discriminant_Association 11230 and then Selector_Names (P) = L) 11231 or else 11232 (Nkind (P) = N_Component_Association 11233 and then Choices (P) = L); 11234 end; 11235 end if; 11236 end Is_Selector_Name; 11237 11238 ---------------------------------- 11239 -- Is_SPARK_Initialization_Expr -- 11240 ---------------------------------- 11241 11242 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is 11243 Is_Ok : Boolean; 11244 Expr : Node_Id; 11245 Comp_Assn : Node_Id; 11246 Orig_N : constant Node_Id := Original_Node (N); 11247 11248 begin 11249 Is_Ok := True; 11250 11251 if not Comes_From_Source (Orig_N) then 11252 goto Done; 11253 end if; 11254 11255 pragma Assert (Nkind (Orig_N) in N_Subexpr); 11256 11257 case Nkind (Orig_N) is 11258 when N_Character_Literal | 11259 N_Integer_Literal | 11260 N_Real_Literal | 11261 N_String_Literal => 11262 null; 11263 11264 when N_Identifier | 11265 N_Expanded_Name => 11266 if Is_Entity_Name (Orig_N) 11267 and then Present (Entity (Orig_N)) -- needed in some cases 11268 then 11269 case Ekind (Entity (Orig_N)) is 11270 when E_Constant | 11271 E_Enumeration_Literal | 11272 E_Named_Integer | 11273 E_Named_Real => 11274 null; 11275 when others => 11276 if Is_Type (Entity (Orig_N)) then 11277 null; 11278 else 11279 Is_Ok := False; 11280 end if; 11281 end case; 11282 end if; 11283 11284 when N_Qualified_Expression | 11285 N_Type_Conversion => 11286 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N)); 11287 11288 when N_Unary_Op => 11289 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); 11290 11291 when N_Binary_Op | 11292 N_Short_Circuit | 11293 N_Membership_Test => 11294 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N)) 11295 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); 11296 11297 when N_Aggregate | 11298 N_Extension_Aggregate => 11299 if Nkind (Orig_N) = N_Extension_Aggregate then 11300 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N)); 11301 end if; 11302 11303 Expr := First (Expressions (Orig_N)); 11304 while Present (Expr) loop 11305 if not Is_SPARK_Initialization_Expr (Expr) then 11306 Is_Ok := False; 11307 goto Done; 11308 end if; 11309 11310 Next (Expr); 11311 end loop; 11312 11313 Comp_Assn := First (Component_Associations (Orig_N)); 11314 while Present (Comp_Assn) loop 11315 Expr := Expression (Comp_Assn); 11316 if Present (Expr) -- needed for box association 11317 and then not Is_SPARK_Initialization_Expr (Expr) 11318 then 11319 Is_Ok := False; 11320 goto Done; 11321 end if; 11322 11323 Next (Comp_Assn); 11324 end loop; 11325 11326 when N_Attribute_Reference => 11327 if Nkind (Prefix (Orig_N)) in N_Subexpr then 11328 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N)); 11329 end if; 11330 11331 Expr := First (Expressions (Orig_N)); 11332 while Present (Expr) loop 11333 if not Is_SPARK_Initialization_Expr (Expr) then 11334 Is_Ok := False; 11335 goto Done; 11336 end if; 11337 11338 Next (Expr); 11339 end loop; 11340 11341 -- Selected components might be expanded named not yet resolved, so 11342 -- default on the safe side. (Eg on sparklex.ads) 11343 11344 when N_Selected_Component => 11345 null; 11346 11347 when others => 11348 Is_Ok := False; 11349 end case; 11350 11351 <<Done>> 11352 return Is_Ok; 11353 end Is_SPARK_Initialization_Expr; 11354 11355 ------------------------------- 11356 -- Is_SPARK_Object_Reference -- 11357 ------------------------------- 11358 11359 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is 11360 begin 11361 if Is_Entity_Name (N) then 11362 return Present (Entity (N)) 11363 and then 11364 (Ekind_In (Entity (N), E_Constant, E_Variable) 11365 or else Ekind (Entity (N)) in Formal_Kind); 11366 11367 else 11368 case Nkind (N) is 11369 when N_Selected_Component => 11370 return Is_SPARK_Object_Reference (Prefix (N)); 11371 11372 when others => 11373 return False; 11374 end case; 11375 end if; 11376 end Is_SPARK_Object_Reference; 11377 11378 ------------------------------ 11379 -- Is_SPARK_Volatile_Object -- 11380 ------------------------------ 11381 11382 function Is_SPARK_Volatile_Object (N : Node_Id) return Boolean is 11383 begin 11384 if Nkind (N) = N_Defining_Identifier then 11385 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 11386 11387 elsif Is_Entity_Name (N) then 11388 return 11389 Is_SPARK_Volatile_Object (Entity (N)) 11390 or else Is_Volatile (Etype (N)); 11391 11392 elsif Nkind (N) = N_Expanded_Name then 11393 return Is_SPARK_Volatile_Object (Entity (N)); 11394 11395 elsif Nkind (N) = N_Indexed_Component then 11396 return Is_SPARK_Volatile_Object (Prefix (N)); 11397 11398 elsif Nkind (N) = N_Selected_Component then 11399 return 11400 Is_SPARK_Volatile_Object (Prefix (N)) 11401 or else 11402 Is_SPARK_Volatile_Object (Selector_Name (N)); 11403 11404 else 11405 return False; 11406 end if; 11407 end Is_SPARK_Volatile_Object; 11408 11409 ------------------ 11410 -- Is_Statement -- 11411 ------------------ 11412 11413 function Is_Statement (N : Node_Id) return Boolean is 11414 begin 11415 return 11416 Nkind (N) in N_Statement_Other_Than_Procedure_Call 11417 or else Nkind (N) = N_Procedure_Call_Statement; 11418 end Is_Statement; 11419 11420 -------------------------------------------------- 11421 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 11422 -------------------------------------------------- 11423 11424 function Is_Subprogram_Stub_Without_Prior_Declaration 11425 (N : Node_Id) return Boolean 11426 is 11427 begin 11428 -- A subprogram stub without prior declaration serves as declaration for 11429 -- the actual subprogram body. As such, it has an attached defining 11430 -- entity of E_[Generic_]Function or E_[Generic_]Procedure. 11431 11432 return Nkind (N) = N_Subprogram_Body_Stub 11433 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; 11434 end Is_Subprogram_Stub_Without_Prior_Declaration; 11435 11436 --------------------------------- 11437 -- Is_Synchronized_Tagged_Type -- 11438 --------------------------------- 11439 11440 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 11441 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 11442 11443 begin 11444 -- A task or protected type derived from an interface is a tagged type. 11445 -- Such a tagged type is called a synchronized tagged type, as are 11446 -- synchronized interfaces and private extensions whose declaration 11447 -- includes the reserved word synchronized. 11448 11449 return (Is_Tagged_Type (E) 11450 and then (Kind = E_Task_Type 11451 or else Kind = E_Protected_Type)) 11452 or else 11453 (Is_Interface (E) 11454 and then Is_Synchronized_Interface (E)) 11455 or else 11456 (Ekind (E) = E_Record_Type_With_Private 11457 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 11458 and then (Synchronized_Present (Parent (E)) 11459 or else Is_Synchronized_Interface (Etype (E)))); 11460 end Is_Synchronized_Tagged_Type; 11461 11462 ----------------- 11463 -- Is_Transfer -- 11464 ----------------- 11465 11466 function Is_Transfer (N : Node_Id) return Boolean is 11467 Kind : constant Node_Kind := Nkind (N); 11468 11469 begin 11470 if Kind = N_Simple_Return_Statement 11471 or else 11472 Kind = N_Extended_Return_Statement 11473 or else 11474 Kind = N_Goto_Statement 11475 or else 11476 Kind = N_Raise_Statement 11477 or else 11478 Kind = N_Requeue_Statement 11479 then 11480 return True; 11481 11482 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 11483 and then No (Condition (N)) 11484 then 11485 return True; 11486 11487 elsif Kind = N_Procedure_Call_Statement 11488 and then Is_Entity_Name (Name (N)) 11489 and then Present (Entity (Name (N))) 11490 and then No_Return (Entity (Name (N))) 11491 then 11492 return True; 11493 11494 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 11495 return True; 11496 11497 else 11498 return False; 11499 end if; 11500 end Is_Transfer; 11501 11502 ------------- 11503 -- Is_True -- 11504 ------------- 11505 11506 function Is_True (U : Uint) return Boolean is 11507 begin 11508 return (U /= 0); 11509 end Is_True; 11510 11511 -------------------------------------- 11512 -- Is_Unchecked_Conversion_Instance -- 11513 -------------------------------------- 11514 11515 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 11516 Gen_Par : Entity_Id; 11517 11518 begin 11519 -- Look for a function whose generic parent is the predefined intrinsic 11520 -- function Unchecked_Conversion. 11521 11522 if Ekind (Id) = E_Function then 11523 Gen_Par := Generic_Parent (Parent (Id)); 11524 11525 return 11526 Present (Gen_Par) 11527 and then Chars (Gen_Par) = Name_Unchecked_Conversion 11528 and then Is_Intrinsic_Subprogram (Gen_Par) 11529 and then Is_Predefined_File_Name 11530 (Unit_File_Name (Get_Source_Unit (Gen_Par))); 11531 end if; 11532 11533 return False; 11534 end Is_Unchecked_Conversion_Instance; 11535 11536 ------------------------------- 11537 -- Is_Universal_Numeric_Type -- 11538 ------------------------------- 11539 11540 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 11541 begin 11542 return T = Universal_Integer or else T = Universal_Real; 11543 end Is_Universal_Numeric_Type; 11544 11545 ------------------- 11546 -- Is_Value_Type -- 11547 ------------------- 11548 11549 function Is_Value_Type (T : Entity_Id) return Boolean is 11550 begin 11551 return VM_Target = CLI_Target 11552 and then Nkind (T) in N_Has_Chars 11553 and then Chars (T) /= No_Name 11554 and then Get_Name_String (Chars (T)) = "valuetype"; 11555 end Is_Value_Type; 11556 11557 ---------------------------- 11558 -- Is_Variable_Size_Array -- 11559 ---------------------------- 11560 11561 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 11562 Idx : Node_Id; 11563 11564 begin 11565 pragma Assert (Is_Array_Type (E)); 11566 11567 -- Check if some index is initialized with a non-constant value 11568 11569 Idx := First_Index (E); 11570 while Present (Idx) loop 11571 if Nkind (Idx) = N_Range then 11572 if not Is_Constant_Bound (Low_Bound (Idx)) 11573 or else not Is_Constant_Bound (High_Bound (Idx)) 11574 then 11575 return True; 11576 end if; 11577 end if; 11578 11579 Idx := Next_Index (Idx); 11580 end loop; 11581 11582 return False; 11583 end Is_Variable_Size_Array; 11584 11585 ----------------------------- 11586 -- Is_Variable_Size_Record -- 11587 ----------------------------- 11588 11589 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 11590 Comp : Entity_Id; 11591 Comp_Typ : Entity_Id; 11592 11593 begin 11594 pragma Assert (Is_Record_Type (E)); 11595 11596 Comp := First_Entity (E); 11597 while Present (Comp) loop 11598 Comp_Typ := Etype (Comp); 11599 11600 -- Recursive call if the record type has discriminants 11601 11602 if Is_Record_Type (Comp_Typ) 11603 and then Has_Discriminants (Comp_Typ) 11604 and then Is_Variable_Size_Record (Comp_Typ) 11605 then 11606 return True; 11607 11608 elsif Is_Array_Type (Comp_Typ) 11609 and then Is_Variable_Size_Array (Comp_Typ) 11610 then 11611 return True; 11612 end if; 11613 11614 Next_Entity (Comp); 11615 end loop; 11616 11617 return False; 11618 end Is_Variable_Size_Record; 11619 11620 --------------------- 11621 -- Is_VMS_Operator -- 11622 --------------------- 11623 11624 function Is_VMS_Operator (Op : Entity_Id) return Boolean is 11625 begin 11626 -- The VMS operators are declared in a child of System that is loaded 11627 -- through pragma Extend_System. In some rare cases a program is run 11628 -- with this extension but without indicating that the target is VMS. 11629 11630 return Ekind (Op) = E_Function 11631 and then Is_Intrinsic_Subprogram (Op) 11632 and then 11633 ((Present_System_Aux and then Scope (Op) = System_Aux_Id) 11634 or else 11635 (True_VMS_Target 11636 and then Scope (Scope (Op)) = RTU_Entity (System))); 11637 end Is_VMS_Operator; 11638 11639 ----------------- 11640 -- Is_Variable -- 11641 ----------------- 11642 11643 function Is_Variable 11644 (N : Node_Id; 11645 Use_Original_Node : Boolean := True) return Boolean 11646 is 11647 Orig_Node : Node_Id; 11648 11649 function In_Protected_Function (E : Entity_Id) return Boolean; 11650 -- Within a protected function, the private components of the enclosing 11651 -- protected type are constants. A function nested within a (protected) 11652 -- procedure is not itself protected. Within the body of a protected 11653 -- function the current instance of the protected type is a constant. 11654 11655 function Is_Variable_Prefix (P : Node_Id) return Boolean; 11656 -- Prefixes can involve implicit dereferences, in which case we must 11657 -- test for the case of a reference of a constant access type, which can 11658 -- can never be a variable. 11659 11660 --------------------------- 11661 -- In_Protected_Function -- 11662 --------------------------- 11663 11664 function In_Protected_Function (E : Entity_Id) return Boolean is 11665 Prot : Entity_Id; 11666 S : Entity_Id; 11667 11668 begin 11669 -- E is the current instance of a type 11670 11671 if Is_Type (E) then 11672 Prot := E; 11673 11674 -- E is an object 11675 11676 else 11677 Prot := Scope (E); 11678 end if; 11679 11680 if not Is_Protected_Type (Prot) then 11681 return False; 11682 11683 else 11684 S := Current_Scope; 11685 while Present (S) and then S /= Prot loop 11686 if Ekind (S) = E_Function and then Scope (S) = Prot then 11687 return True; 11688 end if; 11689 11690 S := Scope (S); 11691 end loop; 11692 11693 return False; 11694 end if; 11695 end In_Protected_Function; 11696 11697 ------------------------ 11698 -- Is_Variable_Prefix -- 11699 ------------------------ 11700 11701 function Is_Variable_Prefix (P : Node_Id) return Boolean is 11702 begin 11703 if Is_Access_Type (Etype (P)) then 11704 return not Is_Access_Constant (Root_Type (Etype (P))); 11705 11706 -- For the case of an indexed component whose prefix has a packed 11707 -- array type, the prefix has been rewritten into a type conversion. 11708 -- Determine variable-ness from the converted expression. 11709 11710 elsif Nkind (P) = N_Type_Conversion 11711 and then not Comes_From_Source (P) 11712 and then Is_Array_Type (Etype (P)) 11713 and then Is_Packed (Etype (P)) 11714 then 11715 return Is_Variable (Expression (P)); 11716 11717 else 11718 return Is_Variable (P); 11719 end if; 11720 end Is_Variable_Prefix; 11721 11722 -- Start of processing for Is_Variable 11723 11724 begin 11725 -- Check if we perform the test on the original node since this may be a 11726 -- test of syntactic categories which must not be disturbed by whatever 11727 -- rewriting might have occurred. For example, an aggregate, which is 11728 -- certainly NOT a variable, could be turned into a variable by 11729 -- expansion. 11730 11731 if Use_Original_Node then 11732 Orig_Node := Original_Node (N); 11733 else 11734 Orig_Node := N; 11735 end if; 11736 11737 -- Definitely OK if Assignment_OK is set. Since this is something that 11738 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 11739 11740 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 11741 return True; 11742 11743 -- Normally we go to the original node, but there is one exception where 11744 -- we use the rewritten node, namely when it is an explicit dereference. 11745 -- The generated code may rewrite a prefix which is an access type with 11746 -- an explicit dereference. The dereference is a variable, even though 11747 -- the original node may not be (since it could be a constant of the 11748 -- access type). 11749 11750 -- In Ada 2005 we have a further case to consider: the prefix may be a 11751 -- function call given in prefix notation. The original node appears to 11752 -- be a selected component, but we need to examine the call. 11753 11754 elsif Nkind (N) = N_Explicit_Dereference 11755 and then Nkind (Orig_Node) /= N_Explicit_Dereference 11756 and then Present (Etype (Orig_Node)) 11757 and then Is_Access_Type (Etype (Orig_Node)) 11758 then 11759 -- Note that if the prefix is an explicit dereference that does not 11760 -- come from source, we must check for a rewritten function call in 11761 -- prefixed notation before other forms of rewriting, to prevent a 11762 -- compiler crash. 11763 11764 return 11765 (Nkind (Orig_Node) = N_Function_Call 11766 and then not Is_Access_Constant (Etype (Prefix (N)))) 11767 or else 11768 Is_Variable_Prefix (Original_Node (Prefix (N))); 11769 11770 -- in Ada 2012, the dereference may have been added for a type with 11771 -- a declared implicit dereference aspect. 11772 11773 elsif Nkind (N) = N_Explicit_Dereference 11774 and then Present (Etype (Orig_Node)) 11775 and then Ada_Version >= Ada_2012 11776 and then Has_Implicit_Dereference (Etype (Orig_Node)) 11777 then 11778 return True; 11779 11780 -- A function call is never a variable 11781 11782 elsif Nkind (N) = N_Function_Call then 11783 return False; 11784 11785 -- All remaining checks use the original node 11786 11787 elsif Is_Entity_Name (Orig_Node) 11788 and then Present (Entity (Orig_Node)) 11789 then 11790 declare 11791 E : constant Entity_Id := Entity (Orig_Node); 11792 K : constant Entity_Kind := Ekind (E); 11793 11794 begin 11795 return (K = E_Variable 11796 and then Nkind (Parent (E)) /= N_Exception_Handler) 11797 or else (K = E_Component 11798 and then not In_Protected_Function (E)) 11799 or else K = E_Out_Parameter 11800 or else K = E_In_Out_Parameter 11801 or else K = E_Generic_In_Out_Parameter 11802 11803 -- Current instance of type. If this is a protected type, check 11804 -- we are not within the body of one of its protected functions. 11805 11806 or else (Is_Type (E) 11807 and then In_Open_Scopes (E) 11808 and then not In_Protected_Function (E)) 11809 11810 or else (Is_Incomplete_Or_Private_Type (E) 11811 and then In_Open_Scopes (Full_View (E))); 11812 end; 11813 11814 else 11815 case Nkind (Orig_Node) is 11816 when N_Indexed_Component | N_Slice => 11817 return Is_Variable_Prefix (Prefix (Orig_Node)); 11818 11819 when N_Selected_Component => 11820 return Is_Variable_Prefix (Prefix (Orig_Node)) 11821 and then Is_Variable (Selector_Name (Orig_Node)); 11822 11823 -- For an explicit dereference, the type of the prefix cannot 11824 -- be an access to constant or an access to subprogram. 11825 11826 when N_Explicit_Dereference => 11827 declare 11828 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 11829 begin 11830 return Is_Access_Type (Typ) 11831 and then not Is_Access_Constant (Root_Type (Typ)) 11832 and then Ekind (Typ) /= E_Access_Subprogram_Type; 11833 end; 11834 11835 -- The type conversion is the case where we do not deal with the 11836 -- context dependent special case of an actual parameter. Thus 11837 -- the type conversion is only considered a variable for the 11838 -- purposes of this routine if the target type is tagged. However, 11839 -- a type conversion is considered to be a variable if it does not 11840 -- come from source (this deals for example with the conversions 11841 -- of expressions to their actual subtypes). 11842 11843 when N_Type_Conversion => 11844 return Is_Variable (Expression (Orig_Node)) 11845 and then 11846 (not Comes_From_Source (Orig_Node) 11847 or else 11848 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 11849 and then 11850 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 11851 11852 -- GNAT allows an unchecked type conversion as a variable. This 11853 -- only affects the generation of internal expanded code, since 11854 -- calls to instantiations of Unchecked_Conversion are never 11855 -- considered variables (since they are function calls). 11856 11857 when N_Unchecked_Type_Conversion => 11858 return Is_Variable (Expression (Orig_Node)); 11859 11860 when others => 11861 return False; 11862 end case; 11863 end if; 11864 end Is_Variable; 11865 11866 --------------------------- 11867 -- Is_Visibly_Controlled -- 11868 --------------------------- 11869 11870 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 11871 Root : constant Entity_Id := Root_Type (T); 11872 begin 11873 return Chars (Scope (Root)) = Name_Finalization 11874 and then Chars (Scope (Scope (Root))) = Name_Ada 11875 and then Scope (Scope (Scope (Root))) = Standard_Standard; 11876 end Is_Visibly_Controlled; 11877 11878 ------------------------ 11879 -- Is_Volatile_Object -- 11880 ------------------------ 11881 11882 function Is_Volatile_Object (N : Node_Id) return Boolean is 11883 11884 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 11885 -- If prefix is an implicit dereference, examine designated type 11886 11887 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 11888 -- Determines if given object has volatile components 11889 11890 ------------------------ 11891 -- Is_Volatile_Prefix -- 11892 ------------------------ 11893 11894 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 11895 Typ : constant Entity_Id := Etype (N); 11896 11897 begin 11898 if Is_Access_Type (Typ) then 11899 declare 11900 Dtyp : constant Entity_Id := Designated_Type (Typ); 11901 11902 begin 11903 return Is_Volatile (Dtyp) 11904 or else Has_Volatile_Components (Dtyp); 11905 end; 11906 11907 else 11908 return Object_Has_Volatile_Components (N); 11909 end if; 11910 end Is_Volatile_Prefix; 11911 11912 ------------------------------------ 11913 -- Object_Has_Volatile_Components -- 11914 ------------------------------------ 11915 11916 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 11917 Typ : constant Entity_Id := Etype (N); 11918 11919 begin 11920 if Is_Volatile (Typ) 11921 or else Has_Volatile_Components (Typ) 11922 then 11923 return True; 11924 11925 elsif Is_Entity_Name (N) 11926 and then (Has_Volatile_Components (Entity (N)) 11927 or else Is_Volatile (Entity (N))) 11928 then 11929 return True; 11930 11931 elsif Nkind (N) = N_Indexed_Component 11932 or else Nkind (N) = N_Selected_Component 11933 then 11934 return Is_Volatile_Prefix (Prefix (N)); 11935 11936 else 11937 return False; 11938 end if; 11939 end Object_Has_Volatile_Components; 11940 11941 -- Start of processing for Is_Volatile_Object 11942 11943 begin 11944 if Nkind (N) = N_Defining_Identifier then 11945 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 11946 11947 elsif Nkind (N) = N_Expanded_Name then 11948 return Is_Volatile_Object (Entity (N)); 11949 11950 elsif Is_Volatile (Etype (N)) 11951 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 11952 then 11953 return True; 11954 11955 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 11956 and then Is_Volatile_Prefix (Prefix (N)) 11957 then 11958 return True; 11959 11960 elsif Nkind (N) = N_Selected_Component 11961 and then Is_Volatile (Entity (Selector_Name (N))) 11962 then 11963 return True; 11964 11965 else 11966 return False; 11967 end if; 11968 end Is_Volatile_Object; 11969 11970 --------------------------- 11971 -- Itype_Has_Declaration -- 11972 --------------------------- 11973 11974 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 11975 begin 11976 pragma Assert (Is_Itype (Id)); 11977 return Present (Parent (Id)) 11978 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 11979 N_Subtype_Declaration) 11980 and then Defining_Entity (Parent (Id)) = Id; 11981 end Itype_Has_Declaration; 11982 11983 ------------------------- 11984 -- Kill_Current_Values -- 11985 ------------------------- 11986 11987 procedure Kill_Current_Values 11988 (Ent : Entity_Id; 11989 Last_Assignment_Only : Boolean := False) 11990 is 11991 begin 11992 if Is_Assignable (Ent) then 11993 Set_Last_Assignment (Ent, Empty); 11994 end if; 11995 11996 if Is_Object (Ent) then 11997 if not Last_Assignment_Only then 11998 Kill_Checks (Ent); 11999 Set_Current_Value (Ent, Empty); 12000 12001 if not Can_Never_Be_Null (Ent) then 12002 Set_Is_Known_Non_Null (Ent, False); 12003 end if; 12004 12005 Set_Is_Known_Null (Ent, False); 12006 12007 -- Reset Is_Known_Valid unless type is always valid, or if we have 12008 -- a loop parameter (loop parameters are always valid, since their 12009 -- bounds are defined by the bounds given in the loop header). 12010 12011 if not Is_Known_Valid (Etype (Ent)) 12012 and then Ekind (Ent) /= E_Loop_Parameter 12013 then 12014 Set_Is_Known_Valid (Ent, False); 12015 end if; 12016 end if; 12017 end if; 12018 end Kill_Current_Values; 12019 12020 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 12021 S : Entity_Id; 12022 12023 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 12024 -- Clear current value for entity E and all entities chained to E 12025 12026 ------------------------------------------ 12027 -- Kill_Current_Values_For_Entity_Chain -- 12028 ------------------------------------------ 12029 12030 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 12031 Ent : Entity_Id; 12032 begin 12033 Ent := E; 12034 while Present (Ent) loop 12035 Kill_Current_Values (Ent, Last_Assignment_Only); 12036 Next_Entity (Ent); 12037 end loop; 12038 end Kill_Current_Values_For_Entity_Chain; 12039 12040 -- Start of processing for Kill_Current_Values 12041 12042 begin 12043 -- Kill all saved checks, a special case of killing saved values 12044 12045 if not Last_Assignment_Only then 12046 Kill_All_Checks; 12047 end if; 12048 12049 -- Loop through relevant scopes, which includes the current scope and 12050 -- any parent scopes if the current scope is a block or a package. 12051 12052 S := Current_Scope; 12053 Scope_Loop : loop 12054 12055 -- Clear current values of all entities in current scope 12056 12057 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 12058 12059 -- If scope is a package, also clear current values of all private 12060 -- entities in the scope. 12061 12062 if Is_Package_Or_Generic_Package (S) 12063 or else Is_Concurrent_Type (S) 12064 then 12065 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 12066 end if; 12067 12068 -- If this is a not a subprogram, deal with parents 12069 12070 if not Is_Subprogram (S) then 12071 S := Scope (S); 12072 exit Scope_Loop when S = Standard_Standard; 12073 else 12074 exit Scope_Loop; 12075 end if; 12076 end loop Scope_Loop; 12077 end Kill_Current_Values; 12078 12079 -------------------------- 12080 -- Kill_Size_Check_Code -- 12081 -------------------------- 12082 12083 procedure Kill_Size_Check_Code (E : Entity_Id) is 12084 begin 12085 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 12086 and then Present (Size_Check_Code (E)) 12087 then 12088 Remove (Size_Check_Code (E)); 12089 Set_Size_Check_Code (E, Empty); 12090 end if; 12091 end Kill_Size_Check_Code; 12092 12093 -------------------------- 12094 -- Known_To_Be_Assigned -- 12095 -------------------------- 12096 12097 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 12098 P : constant Node_Id := Parent (N); 12099 12100 begin 12101 case Nkind (P) is 12102 12103 -- Test left side of assignment 12104 12105 when N_Assignment_Statement => 12106 return N = Name (P); 12107 12108 -- Function call arguments are never lvalues 12109 12110 when N_Function_Call => 12111 return False; 12112 12113 -- Positional parameter for procedure or accept call 12114 12115 when N_Procedure_Call_Statement | 12116 N_Accept_Statement 12117 => 12118 declare 12119 Proc : Entity_Id; 12120 Form : Entity_Id; 12121 Act : Node_Id; 12122 12123 begin 12124 Proc := Get_Subprogram_Entity (P); 12125 12126 if No (Proc) then 12127 return False; 12128 end if; 12129 12130 -- If we are not a list member, something is strange, so 12131 -- be conservative and return False. 12132 12133 if not Is_List_Member (N) then 12134 return False; 12135 end if; 12136 12137 -- We are going to find the right formal by stepping forward 12138 -- through the formals, as we step backwards in the actuals. 12139 12140 Form := First_Formal (Proc); 12141 Act := N; 12142 loop 12143 -- If no formal, something is weird, so be conservative 12144 -- and return False. 12145 12146 if No (Form) then 12147 return False; 12148 end if; 12149 12150 Prev (Act); 12151 exit when No (Act); 12152 Next_Formal (Form); 12153 end loop; 12154 12155 return Ekind (Form) /= E_In_Parameter; 12156 end; 12157 12158 -- Named parameter for procedure or accept call 12159 12160 when N_Parameter_Association => 12161 declare 12162 Proc : Entity_Id; 12163 Form : Entity_Id; 12164 12165 begin 12166 Proc := Get_Subprogram_Entity (Parent (P)); 12167 12168 if No (Proc) then 12169 return False; 12170 end if; 12171 12172 -- Loop through formals to find the one that matches 12173 12174 Form := First_Formal (Proc); 12175 loop 12176 -- If no matching formal, that's peculiar, some kind of 12177 -- previous error, so return False to be conservative. 12178 -- Actually this also happens in legal code in the case 12179 -- where P is a parameter association for an Extra_Formal??? 12180 12181 if No (Form) then 12182 return False; 12183 end if; 12184 12185 -- Else test for match 12186 12187 if Chars (Form) = Chars (Selector_Name (P)) then 12188 return Ekind (Form) /= E_In_Parameter; 12189 end if; 12190 12191 Next_Formal (Form); 12192 end loop; 12193 end; 12194 12195 -- Test for appearing in a conversion that itself appears 12196 -- in an lvalue context, since this should be an lvalue. 12197 12198 when N_Type_Conversion => 12199 return Known_To_Be_Assigned (P); 12200 12201 -- All other references are definitely not known to be modifications 12202 12203 when others => 12204 return False; 12205 12206 end case; 12207 end Known_To_Be_Assigned; 12208 12209 --------------------------- 12210 -- Last_Source_Statement -- 12211 --------------------------- 12212 12213 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 12214 N : Node_Id; 12215 12216 begin 12217 N := Last (Statements (HSS)); 12218 while Present (N) loop 12219 exit when Comes_From_Source (N); 12220 Prev (N); 12221 end loop; 12222 12223 return N; 12224 end Last_Source_Statement; 12225 12226 ---------------------------------- 12227 -- Matching_Static_Array_Bounds -- 12228 ---------------------------------- 12229 12230 function Matching_Static_Array_Bounds 12231 (L_Typ : Node_Id; 12232 R_Typ : Node_Id) return Boolean 12233 is 12234 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 12235 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 12236 12237 L_Index : Node_Id; 12238 R_Index : Node_Id; 12239 L_Low : Node_Id; 12240 L_High : Node_Id; 12241 L_Len : Uint; 12242 R_Low : Node_Id; 12243 R_High : Node_Id; 12244 R_Len : Uint; 12245 12246 begin 12247 if L_Ndims /= R_Ndims then 12248 return False; 12249 end if; 12250 12251 -- Unconstrained types do not have static bounds 12252 12253 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 12254 return False; 12255 end if; 12256 12257 -- First treat specially the first dimension, as the lower bound and 12258 -- length of string literals are not stored like those of arrays. 12259 12260 if Ekind (L_Typ) = E_String_Literal_Subtype then 12261 L_Low := String_Literal_Low_Bound (L_Typ); 12262 L_Len := String_Literal_Length (L_Typ); 12263 else 12264 L_Index := First_Index (L_Typ); 12265 Get_Index_Bounds (L_Index, L_Low, L_High); 12266 12267 if Is_OK_Static_Expression (L_Low) 12268 and then Is_OK_Static_Expression (L_High) 12269 then 12270 if Expr_Value (L_High) < Expr_Value (L_Low) then 12271 L_Len := Uint_0; 12272 else 12273 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 12274 end if; 12275 else 12276 return False; 12277 end if; 12278 end if; 12279 12280 if Ekind (R_Typ) = E_String_Literal_Subtype then 12281 R_Low := String_Literal_Low_Bound (R_Typ); 12282 R_Len := String_Literal_Length (R_Typ); 12283 else 12284 R_Index := First_Index (R_Typ); 12285 Get_Index_Bounds (R_Index, R_Low, R_High); 12286 12287 if Is_OK_Static_Expression (R_Low) 12288 and then Is_OK_Static_Expression (R_High) 12289 then 12290 if Expr_Value (R_High) < Expr_Value (R_Low) then 12291 R_Len := Uint_0; 12292 else 12293 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 12294 end if; 12295 else 12296 return False; 12297 end if; 12298 end if; 12299 12300 if Is_OK_Static_Expression (L_Low) 12301 and then Is_OK_Static_Expression (R_Low) 12302 and then Expr_Value (L_Low) = Expr_Value (R_Low) 12303 and then L_Len = R_Len 12304 then 12305 null; 12306 else 12307 return False; 12308 end if; 12309 12310 -- Then treat all other dimensions 12311 12312 for Indx in 2 .. L_Ndims loop 12313 Next (L_Index); 12314 Next (R_Index); 12315 12316 Get_Index_Bounds (L_Index, L_Low, L_High); 12317 Get_Index_Bounds (R_Index, R_Low, R_High); 12318 12319 if Is_OK_Static_Expression (L_Low) 12320 and then Is_OK_Static_Expression (L_High) 12321 and then Is_OK_Static_Expression (R_Low) 12322 and then Is_OK_Static_Expression (R_High) 12323 and then Expr_Value (L_Low) = Expr_Value (R_Low) 12324 and then Expr_Value (L_High) = Expr_Value (R_High) 12325 then 12326 null; 12327 else 12328 return False; 12329 end if; 12330 end loop; 12331 12332 -- If we fall through the loop, all indexes matched 12333 12334 return True; 12335 end Matching_Static_Array_Bounds; 12336 12337 ------------------- 12338 -- May_Be_Lvalue -- 12339 ------------------- 12340 12341 function May_Be_Lvalue (N : Node_Id) return Boolean is 12342 P : constant Node_Id := Parent (N); 12343 12344 begin 12345 case Nkind (P) is 12346 12347 -- Test left side of assignment 12348 12349 when N_Assignment_Statement => 12350 return N = Name (P); 12351 12352 -- Test prefix of component or attribute. Note that the prefix of an 12353 -- explicit or implicit dereference cannot be an l-value. 12354 12355 when N_Attribute_Reference => 12356 return N = Prefix (P) 12357 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)); 12358 12359 -- For an expanded name, the name is an lvalue if the expanded name 12360 -- is an lvalue, but the prefix is never an lvalue, since it is just 12361 -- the scope where the name is found. 12362 12363 when N_Expanded_Name => 12364 if N = Prefix (P) then 12365 return May_Be_Lvalue (P); 12366 else 12367 return False; 12368 end if; 12369 12370 -- For a selected component A.B, A is certainly an lvalue if A.B is. 12371 -- B is a little interesting, if we have A.B := 3, there is some 12372 -- discussion as to whether B is an lvalue or not, we choose to say 12373 -- it is. Note however that A is not an lvalue if it is of an access 12374 -- type since this is an implicit dereference. 12375 12376 when N_Selected_Component => 12377 if N = Prefix (P) 12378 and then Present (Etype (N)) 12379 and then Is_Access_Type (Etype (N)) 12380 then 12381 return False; 12382 else 12383 return May_Be_Lvalue (P); 12384 end if; 12385 12386 -- For an indexed component or slice, the index or slice bounds is 12387 -- never an lvalue. The prefix is an lvalue if the indexed component 12388 -- or slice is an lvalue, except if it is an access type, where we 12389 -- have an implicit dereference. 12390 12391 when N_Indexed_Component | N_Slice => 12392 if N /= Prefix (P) 12393 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 12394 then 12395 return False; 12396 else 12397 return May_Be_Lvalue (P); 12398 end if; 12399 12400 -- Prefix of a reference is an lvalue if the reference is an lvalue 12401 12402 when N_Reference => 12403 return May_Be_Lvalue (P); 12404 12405 -- Prefix of explicit dereference is never an lvalue 12406 12407 when N_Explicit_Dereference => 12408 return False; 12409 12410 -- Positional parameter for subprogram, entry, or accept call. 12411 -- In older versions of Ada function call arguments are never 12412 -- lvalues. In Ada 2012 functions can have in-out parameters. 12413 12414 when N_Subprogram_Call | 12415 N_Entry_Call_Statement | 12416 N_Accept_Statement 12417 => 12418 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 12419 return False; 12420 end if; 12421 12422 -- The following mechanism is clumsy and fragile. A single flag 12423 -- set in Resolve_Actuals would be preferable ??? 12424 12425 declare 12426 Proc : Entity_Id; 12427 Form : Entity_Id; 12428 Act : Node_Id; 12429 12430 begin 12431 Proc := Get_Subprogram_Entity (P); 12432 12433 if No (Proc) then 12434 return True; 12435 end if; 12436 12437 -- If we are not a list member, something is strange, so be 12438 -- conservative and return True. 12439 12440 if not Is_List_Member (N) then 12441 return True; 12442 end if; 12443 12444 -- We are going to find the right formal by stepping forward 12445 -- through the formals, as we step backwards in the actuals. 12446 12447 Form := First_Formal (Proc); 12448 Act := N; 12449 loop 12450 -- If no formal, something is weird, so be conservative and 12451 -- return True. 12452 12453 if No (Form) then 12454 return True; 12455 end if; 12456 12457 Prev (Act); 12458 exit when No (Act); 12459 Next_Formal (Form); 12460 end loop; 12461 12462 return Ekind (Form) /= E_In_Parameter; 12463 end; 12464 12465 -- Named parameter for procedure or accept call 12466 12467 when N_Parameter_Association => 12468 declare 12469 Proc : Entity_Id; 12470 Form : Entity_Id; 12471 12472 begin 12473 Proc := Get_Subprogram_Entity (Parent (P)); 12474 12475 if No (Proc) then 12476 return True; 12477 end if; 12478 12479 -- Loop through formals to find the one that matches 12480 12481 Form := First_Formal (Proc); 12482 loop 12483 -- If no matching formal, that's peculiar, some kind of 12484 -- previous error, so return True to be conservative. 12485 -- Actually happens with legal code for an unresolved call 12486 -- where we may get the wrong homonym??? 12487 12488 if No (Form) then 12489 return True; 12490 end if; 12491 12492 -- Else test for match 12493 12494 if Chars (Form) = Chars (Selector_Name (P)) then 12495 return Ekind (Form) /= E_In_Parameter; 12496 end if; 12497 12498 Next_Formal (Form); 12499 end loop; 12500 end; 12501 12502 -- Test for appearing in a conversion that itself appears in an 12503 -- lvalue context, since this should be an lvalue. 12504 12505 when N_Type_Conversion => 12506 return May_Be_Lvalue (P); 12507 12508 -- Test for appearance in object renaming declaration 12509 12510 when N_Object_Renaming_Declaration => 12511 return True; 12512 12513 -- All other references are definitely not lvalues 12514 12515 when others => 12516 return False; 12517 12518 end case; 12519 end May_Be_Lvalue; 12520 12521 ----------------------- 12522 -- Mark_Coextensions -- 12523 ----------------------- 12524 12525 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 12526 Is_Dynamic : Boolean; 12527 -- Indicates whether the context causes nested coextensions to be 12528 -- dynamic or static 12529 12530 function Mark_Allocator (N : Node_Id) return Traverse_Result; 12531 -- Recognize an allocator node and label it as a dynamic coextension 12532 12533 -------------------- 12534 -- Mark_Allocator -- 12535 -------------------- 12536 12537 function Mark_Allocator (N : Node_Id) return Traverse_Result is 12538 begin 12539 if Nkind (N) = N_Allocator then 12540 if Is_Dynamic then 12541 Set_Is_Dynamic_Coextension (N); 12542 12543 -- If the allocator expression is potentially dynamic, it may 12544 -- be expanded out of order and require dynamic allocation 12545 -- anyway, so we treat the coextension itself as dynamic. 12546 -- Potential optimization ??? 12547 12548 elsif Nkind (Expression (N)) = N_Qualified_Expression 12549 and then Nkind (Expression (Expression (N))) = N_Op_Concat 12550 then 12551 Set_Is_Dynamic_Coextension (N); 12552 else 12553 Set_Is_Static_Coextension (N); 12554 end if; 12555 end if; 12556 12557 return OK; 12558 end Mark_Allocator; 12559 12560 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 12561 12562 -- Start of processing Mark_Coextensions 12563 12564 begin 12565 case Nkind (Context_Nod) is 12566 12567 -- Comment here ??? 12568 12569 when N_Assignment_Statement => 12570 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator; 12571 12572 -- An allocator that is a component of a returned aggregate 12573 -- must be dynamic. 12574 12575 when N_Simple_Return_Statement => 12576 declare 12577 Expr : constant Node_Id := Expression (Context_Nod); 12578 begin 12579 Is_Dynamic := 12580 Nkind (Expr) = N_Allocator 12581 or else 12582 (Nkind (Expr) = N_Qualified_Expression 12583 and then Nkind (Expression (Expr)) = N_Aggregate); 12584 end; 12585 12586 -- An alloctor within an object declaration in an extended return 12587 -- statement is of necessity dynamic. 12588 12589 when N_Object_Declaration => 12590 Is_Dynamic := Nkind (Root_Nod) = N_Allocator 12591 or else 12592 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 12593 12594 -- This routine should not be called for constructs which may not 12595 -- contain coextensions. 12596 12597 when others => 12598 raise Program_Error; 12599 end case; 12600 12601 Mark_Allocators (Root_Nod); 12602 end Mark_Coextensions; 12603 12604 ----------------- 12605 -- Must_Inline -- 12606 ----------------- 12607 12608 function Must_Inline (Subp : Entity_Id) return Boolean is 12609 begin 12610 return 12611 (Optimization_Level = 0 12612 12613 -- AAMP and VM targets have no support for inlining in the backend. 12614 -- Hence we do as much inlining as possible in the front end. 12615 12616 or else AAMP_On_Target 12617 or else VM_Target /= No_VM) 12618 and then Has_Pragma_Inline (Subp) 12619 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining); 12620 end Must_Inline; 12621 12622 ---------------------- 12623 -- Needs_One_Actual -- 12624 ---------------------- 12625 12626 function Needs_One_Actual (E : Entity_Id) return Boolean is 12627 Formal : Entity_Id; 12628 12629 begin 12630 -- Ada 2005 or later, and formals present 12631 12632 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then 12633 Formal := Next_Formal (First_Formal (E)); 12634 while Present (Formal) loop 12635 if No (Default_Value (Formal)) then 12636 return False; 12637 end if; 12638 12639 Next_Formal (Formal); 12640 end loop; 12641 12642 return True; 12643 12644 -- Ada 83/95 or no formals 12645 12646 else 12647 return False; 12648 end if; 12649 end Needs_One_Actual; 12650 12651 ------------------------ 12652 -- New_Copy_List_Tree -- 12653 ------------------------ 12654 12655 function New_Copy_List_Tree (List : List_Id) return List_Id is 12656 NL : List_Id; 12657 E : Node_Id; 12658 12659 begin 12660 if List = No_List then 12661 return No_List; 12662 12663 else 12664 NL := New_List; 12665 E := First (List); 12666 12667 while Present (E) loop 12668 Append (New_Copy_Tree (E), NL); 12669 E := Next (E); 12670 end loop; 12671 12672 return NL; 12673 end if; 12674 end New_Copy_List_Tree; 12675 12676 ------------------- 12677 -- New_Copy_Tree -- 12678 ------------------- 12679 12680 use Atree.Unchecked_Access; 12681 use Atree_Private_Part; 12682 12683 -- Our approach here requires a two pass traversal of the tree. The 12684 -- first pass visits all nodes that eventually will be copied looking 12685 -- for defining Itypes. If any defining Itypes are found, then they are 12686 -- copied, and an entry is added to the replacement map. In the second 12687 -- phase, the tree is copied, using the replacement map to replace any 12688 -- Itype references within the copied tree. 12689 12690 -- The following hash tables are used if the Map supplied has more 12691 -- than hash threshold entries to speed up access to the map. If 12692 -- there are fewer entries, then the map is searched sequentially 12693 -- (because setting up a hash table for only a few entries takes 12694 -- more time than it saves. 12695 12696 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; 12697 -- Hash function used for hash operations 12698 12699 ------------------- 12700 -- New_Copy_Hash -- 12701 ------------------- 12702 12703 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is 12704 begin 12705 return Nat (E) mod (NCT_Header_Num'Last + 1); 12706 end New_Copy_Hash; 12707 12708 --------------- 12709 -- NCT_Assoc -- 12710 --------------- 12711 12712 -- The hash table NCT_Assoc associates old entities in the table 12713 -- with their corresponding new entities (i.e. the pairs of entries 12714 -- presented in the original Map argument are Key-Element pairs). 12715 12716 package NCT_Assoc is new Simple_HTable ( 12717 Header_Num => NCT_Header_Num, 12718 Element => Entity_Id, 12719 No_Element => Empty, 12720 Key => Entity_Id, 12721 Hash => New_Copy_Hash, 12722 Equal => Types."="); 12723 12724 --------------------- 12725 -- NCT_Itype_Assoc -- 12726 --------------------- 12727 12728 -- The hash table NCT_Itype_Assoc contains entries only for those 12729 -- old nodes which have a non-empty Associated_Node_For_Itype set. 12730 -- The key is the associated node, and the element is the new node 12731 -- itself (NOT the associated node for the new node). 12732 12733 package NCT_Itype_Assoc is new Simple_HTable ( 12734 Header_Num => NCT_Header_Num, 12735 Element => Entity_Id, 12736 No_Element => Empty, 12737 Key => Entity_Id, 12738 Hash => New_Copy_Hash, 12739 Equal => Types."="); 12740 12741 -- Start of processing for New_Copy_Tree function 12742 12743 function New_Copy_Tree 12744 (Source : Node_Id; 12745 Map : Elist_Id := No_Elist; 12746 New_Sloc : Source_Ptr := No_Location; 12747 New_Scope : Entity_Id := Empty) return Node_Id 12748 is 12749 Actual_Map : Elist_Id := Map; 12750 -- This is the actual map for the copy. It is initialized with the 12751 -- given elements, and then enlarged as required for Itypes that are 12752 -- copied during the first phase of the copy operation. The visit 12753 -- procedures add elements to this map as Itypes are encountered. 12754 -- The reason we cannot use Map directly, is that it may well be 12755 -- (and normally is) initialized to No_Elist, and if we have mapped 12756 -- entities, we have to reset it to point to a real Elist. 12757 12758 function Assoc (N : Node_Or_Entity_Id) return Node_Id; 12759 -- Called during second phase to map entities into their corresponding 12760 -- copies using Actual_Map. If the argument is not an entity, or is not 12761 -- in Actual_Map, then it is returned unchanged. 12762 12763 procedure Build_NCT_Hash_Tables; 12764 -- Builds hash tables (number of elements >= threshold value) 12765 12766 function Copy_Elist_With_Replacement 12767 (Old_Elist : Elist_Id) return Elist_Id; 12768 -- Called during second phase to copy element list doing replacements 12769 12770 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id); 12771 -- Called during the second phase to process a copied Itype. The actual 12772 -- copy happened during the first phase (so that we could make the entry 12773 -- in the mapping), but we still have to deal with the descendents of 12774 -- the copied Itype and copy them where necessary. 12775 12776 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id; 12777 -- Called during second phase to copy list doing replacements 12778 12779 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id; 12780 -- Called during second phase to copy node doing replacements 12781 12782 procedure Visit_Elist (E : Elist_Id); 12783 -- Called during first phase to visit all elements of an Elist 12784 12785 procedure Visit_Field (F : Union_Id; N : Node_Id); 12786 -- Visit a single field, recursing to call Visit_Node or Visit_List 12787 -- if the field is a syntactic descendent of the current node (i.e. 12788 -- its parent is Node N). 12789 12790 procedure Visit_Itype (Old_Itype : Entity_Id); 12791 -- Called during first phase to visit subsidiary fields of a defining 12792 -- Itype, and also create a copy and make an entry in the replacement 12793 -- map for the new copy. 12794 12795 procedure Visit_List (L : List_Id); 12796 -- Called during first phase to visit all elements of a List 12797 12798 procedure Visit_Node (N : Node_Or_Entity_Id); 12799 -- Called during first phase to visit a node and all its subtrees 12800 12801 ----------- 12802 -- Assoc -- 12803 ----------- 12804 12805 function Assoc (N : Node_Or_Entity_Id) return Node_Id is 12806 E : Elmt_Id; 12807 Ent : Entity_Id; 12808 12809 begin 12810 if not Has_Extension (N) or else No (Actual_Map) then 12811 return N; 12812 12813 elsif NCT_Hash_Tables_Used then 12814 Ent := NCT_Assoc.Get (Entity_Id (N)); 12815 12816 if Present (Ent) then 12817 return Ent; 12818 else 12819 return N; 12820 end if; 12821 12822 -- No hash table used, do serial search 12823 12824 else 12825 E := First_Elmt (Actual_Map); 12826 while Present (E) loop 12827 if Node (E) = N then 12828 return Node (Next_Elmt (E)); 12829 else 12830 E := Next_Elmt (Next_Elmt (E)); 12831 end if; 12832 end loop; 12833 end if; 12834 12835 return N; 12836 end Assoc; 12837 12838 --------------------------- 12839 -- Build_NCT_Hash_Tables -- 12840 --------------------------- 12841 12842 procedure Build_NCT_Hash_Tables is 12843 Elmt : Elmt_Id; 12844 Ent : Entity_Id; 12845 begin 12846 if NCT_Hash_Table_Setup then 12847 NCT_Assoc.Reset; 12848 NCT_Itype_Assoc.Reset; 12849 end if; 12850 12851 Elmt := First_Elmt (Actual_Map); 12852 while Present (Elmt) loop 12853 Ent := Node (Elmt); 12854 12855 -- Get new entity, and associate old and new 12856 12857 Next_Elmt (Elmt); 12858 NCT_Assoc.Set (Ent, Node (Elmt)); 12859 12860 if Is_Type (Ent) then 12861 declare 12862 Anode : constant Entity_Id := 12863 Associated_Node_For_Itype (Ent); 12864 12865 begin 12866 if Present (Anode) then 12867 12868 -- Enter a link between the associated node of the 12869 -- old Itype and the new Itype, for updating later 12870 -- when node is copied. 12871 12872 NCT_Itype_Assoc.Set (Anode, Node (Elmt)); 12873 end if; 12874 end; 12875 end if; 12876 12877 Next_Elmt (Elmt); 12878 end loop; 12879 12880 NCT_Hash_Tables_Used := True; 12881 NCT_Hash_Table_Setup := True; 12882 end Build_NCT_Hash_Tables; 12883 12884 --------------------------------- 12885 -- Copy_Elist_With_Replacement -- 12886 --------------------------------- 12887 12888 function Copy_Elist_With_Replacement 12889 (Old_Elist : Elist_Id) return Elist_Id 12890 is 12891 M : Elmt_Id; 12892 New_Elist : Elist_Id; 12893 12894 begin 12895 if No (Old_Elist) then 12896 return No_Elist; 12897 12898 else 12899 New_Elist := New_Elmt_List; 12900 12901 M := First_Elmt (Old_Elist); 12902 while Present (M) loop 12903 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist); 12904 Next_Elmt (M); 12905 end loop; 12906 end if; 12907 12908 return New_Elist; 12909 end Copy_Elist_With_Replacement; 12910 12911 --------------------------------- 12912 -- Copy_Itype_With_Replacement -- 12913 --------------------------------- 12914 12915 -- This routine exactly parallels its phase one analog Visit_Itype, 12916 12917 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is 12918 begin 12919 -- Translate Next_Entity, Scope and Etype fields, in case they 12920 -- reference entities that have been mapped into copies. 12921 12922 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype))); 12923 Set_Etype (New_Itype, Assoc (Etype (New_Itype))); 12924 12925 if Present (New_Scope) then 12926 Set_Scope (New_Itype, New_Scope); 12927 else 12928 Set_Scope (New_Itype, Assoc (Scope (New_Itype))); 12929 end if; 12930 12931 -- Copy referenced fields 12932 12933 if Is_Discrete_Type (New_Itype) then 12934 Set_Scalar_Range (New_Itype, 12935 Copy_Node_With_Replacement (Scalar_Range (New_Itype))); 12936 12937 elsif Has_Discriminants (Base_Type (New_Itype)) then 12938 Set_Discriminant_Constraint (New_Itype, 12939 Copy_Elist_With_Replacement 12940 (Discriminant_Constraint (New_Itype))); 12941 12942 elsif Is_Array_Type (New_Itype) then 12943 if Present (First_Index (New_Itype)) then 12944 Set_First_Index (New_Itype, 12945 First (Copy_List_With_Replacement 12946 (List_Containing (First_Index (New_Itype))))); 12947 end if; 12948 12949 if Is_Packed (New_Itype) then 12950 Set_Packed_Array_Type (New_Itype, 12951 Copy_Node_With_Replacement 12952 (Packed_Array_Type (New_Itype))); 12953 end if; 12954 end if; 12955 end Copy_Itype_With_Replacement; 12956 12957 -------------------------------- 12958 -- Copy_List_With_Replacement -- 12959 -------------------------------- 12960 12961 function Copy_List_With_Replacement 12962 (Old_List : List_Id) return List_Id 12963 is 12964 New_List : List_Id; 12965 E : Node_Id; 12966 12967 begin 12968 if Old_List = No_List then 12969 return No_List; 12970 12971 else 12972 New_List := Empty_List; 12973 12974 E := First (Old_List); 12975 while Present (E) loop 12976 Append (Copy_Node_With_Replacement (E), New_List); 12977 Next (E); 12978 end loop; 12979 12980 return New_List; 12981 end if; 12982 end Copy_List_With_Replacement; 12983 12984 -------------------------------- 12985 -- Copy_Node_With_Replacement -- 12986 -------------------------------- 12987 12988 function Copy_Node_With_Replacement 12989 (Old_Node : Node_Id) return Node_Id 12990 is 12991 New_Node : Node_Id; 12992 12993 procedure Adjust_Named_Associations 12994 (Old_Node : Node_Id; 12995 New_Node : Node_Id); 12996 -- If a call node has named associations, these are chained through 12997 -- the First_Named_Actual, Next_Named_Actual links. These must be 12998 -- propagated separately to the new parameter list, because these 12999 -- are not syntactic fields. 13000 13001 function Copy_Field_With_Replacement 13002 (Field : Union_Id) return Union_Id; 13003 -- Given Field, which is a field of Old_Node, return a copy of it 13004 -- if it is a syntactic field (i.e. its parent is Node), setting 13005 -- the parent of the copy to poit to New_Node. Otherwise returns 13006 -- the field (possibly mapped if it is an entity). 13007 13008 ------------------------------- 13009 -- Adjust_Named_Associations -- 13010 ------------------------------- 13011 13012 procedure Adjust_Named_Associations 13013 (Old_Node : Node_Id; 13014 New_Node : Node_Id) 13015 is 13016 Old_E : Node_Id; 13017 New_E : Node_Id; 13018 13019 Old_Next : Node_Id; 13020 New_Next : Node_Id; 13021 13022 begin 13023 Old_E := First (Parameter_Associations (Old_Node)); 13024 New_E := First (Parameter_Associations (New_Node)); 13025 while Present (Old_E) loop 13026 if Nkind (Old_E) = N_Parameter_Association 13027 and then Present (Next_Named_Actual (Old_E)) 13028 then 13029 if First_Named_Actual (Old_Node) 13030 = Explicit_Actual_Parameter (Old_E) 13031 then 13032 Set_First_Named_Actual 13033 (New_Node, Explicit_Actual_Parameter (New_E)); 13034 end if; 13035 13036 -- Now scan parameter list from the beginning,to locate 13037 -- next named actual, which can be out of order. 13038 13039 Old_Next := First (Parameter_Associations (Old_Node)); 13040 New_Next := First (Parameter_Associations (New_Node)); 13041 13042 while Nkind (Old_Next) /= N_Parameter_Association 13043 or else Explicit_Actual_Parameter (Old_Next) 13044 /= Next_Named_Actual (Old_E) 13045 loop 13046 Next (Old_Next); 13047 Next (New_Next); 13048 end loop; 13049 13050 Set_Next_Named_Actual 13051 (New_E, Explicit_Actual_Parameter (New_Next)); 13052 end if; 13053 13054 Next (Old_E); 13055 Next (New_E); 13056 end loop; 13057 end Adjust_Named_Associations; 13058 13059 --------------------------------- 13060 -- Copy_Field_With_Replacement -- 13061 --------------------------------- 13062 13063 function Copy_Field_With_Replacement 13064 (Field : Union_Id) return Union_Id 13065 is 13066 begin 13067 if Field = Union_Id (Empty) then 13068 return Field; 13069 13070 elsif Field in Node_Range then 13071 declare 13072 Old_N : constant Node_Id := Node_Id (Field); 13073 New_N : Node_Id; 13074 13075 begin 13076 -- If syntactic field, as indicated by the parent pointer 13077 -- being set, then copy the referenced node recursively. 13078 13079 if Parent (Old_N) = Old_Node then 13080 New_N := Copy_Node_With_Replacement (Old_N); 13081 13082 if New_N /= Old_N then 13083 Set_Parent (New_N, New_Node); 13084 end if; 13085 13086 -- For semantic fields, update possible entity reference 13087 -- from the replacement map. 13088 13089 else 13090 New_N := Assoc (Old_N); 13091 end if; 13092 13093 return Union_Id (New_N); 13094 end; 13095 13096 elsif Field in List_Range then 13097 declare 13098 Old_L : constant List_Id := List_Id (Field); 13099 New_L : List_Id; 13100 13101 begin 13102 -- If syntactic field, as indicated by the parent pointer, 13103 -- then recursively copy the entire referenced list. 13104 13105 if Parent (Old_L) = Old_Node then 13106 New_L := Copy_List_With_Replacement (Old_L); 13107 Set_Parent (New_L, New_Node); 13108 13109 -- For semantic list, just returned unchanged 13110 13111 else 13112 New_L := Old_L; 13113 end if; 13114 13115 return Union_Id (New_L); 13116 end; 13117 13118 -- Anything other than a list or a node is returned unchanged 13119 13120 else 13121 return Field; 13122 end if; 13123 end Copy_Field_With_Replacement; 13124 13125 -- Start of processing for Copy_Node_With_Replacement 13126 13127 begin 13128 if Old_Node <= Empty_Or_Error then 13129 return Old_Node; 13130 13131 elsif Has_Extension (Old_Node) then 13132 return Assoc (Old_Node); 13133 13134 else 13135 New_Node := New_Copy (Old_Node); 13136 13137 -- If the node we are copying is the associated node of a 13138 -- previously copied Itype, then adjust the associated node 13139 -- of the copy of that Itype accordingly. 13140 13141 if Present (Actual_Map) then 13142 declare 13143 E : Elmt_Id; 13144 Ent : Entity_Id; 13145 13146 begin 13147 -- Case of hash table used 13148 13149 if NCT_Hash_Tables_Used then 13150 Ent := NCT_Itype_Assoc.Get (Old_Node); 13151 13152 if Present (Ent) then 13153 Set_Associated_Node_For_Itype (Ent, New_Node); 13154 end if; 13155 13156 -- Case of no hash table used 13157 13158 else 13159 E := First_Elmt (Actual_Map); 13160 while Present (E) loop 13161 if Is_Itype (Node (E)) 13162 and then 13163 Old_Node = Associated_Node_For_Itype (Node (E)) 13164 then 13165 Set_Associated_Node_For_Itype 13166 (Node (Next_Elmt (E)), New_Node); 13167 end if; 13168 13169 E := Next_Elmt (Next_Elmt (E)); 13170 end loop; 13171 end if; 13172 end; 13173 end if; 13174 13175 -- Recursively copy descendents 13176 13177 Set_Field1 13178 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node))); 13179 Set_Field2 13180 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node))); 13181 Set_Field3 13182 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node))); 13183 Set_Field4 13184 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node))); 13185 Set_Field5 13186 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); 13187 13188 -- Adjust Sloc of new node if necessary 13189 13190 if New_Sloc /= No_Location then 13191 Set_Sloc (New_Node, New_Sloc); 13192 13193 -- If we adjust the Sloc, then we are essentially making 13194 -- a completely new node, so the Comes_From_Source flag 13195 -- should be reset to the proper default value. 13196 13197 Nodes.Table (New_Node).Comes_From_Source := 13198 Default_Node.Comes_From_Source; 13199 end if; 13200 13201 -- If the node is call and has named associations, 13202 -- set the corresponding links in the copy. 13203 13204 if (Nkind (Old_Node) = N_Function_Call 13205 or else Nkind (Old_Node) = N_Entry_Call_Statement 13206 or else 13207 Nkind (Old_Node) = N_Procedure_Call_Statement) 13208 and then Present (First_Named_Actual (Old_Node)) 13209 then 13210 Adjust_Named_Associations (Old_Node, New_Node); 13211 end if; 13212 13213 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. 13214 -- The replacement mechanism applies to entities, and is not used 13215 -- here. Eventually we may need a more general graph-copying 13216 -- routine. For now, do a sequential search to find desired node. 13217 13218 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements 13219 and then Present (First_Real_Statement (Old_Node)) 13220 then 13221 declare 13222 Old_F : constant Node_Id := First_Real_Statement (Old_Node); 13223 N1, N2 : Node_Id; 13224 13225 begin 13226 N1 := First (Statements (Old_Node)); 13227 N2 := First (Statements (New_Node)); 13228 13229 while N1 /= Old_F loop 13230 Next (N1); 13231 Next (N2); 13232 end loop; 13233 13234 Set_First_Real_Statement (New_Node, N2); 13235 end; 13236 end if; 13237 end if; 13238 13239 -- All done, return copied node 13240 13241 return New_Node; 13242 end Copy_Node_With_Replacement; 13243 13244 ----------------- 13245 -- Visit_Elist -- 13246 ----------------- 13247 13248 procedure Visit_Elist (E : Elist_Id) is 13249 Elmt : Elmt_Id; 13250 begin 13251 if Present (E) then 13252 Elmt := First_Elmt (E); 13253 13254 while Elmt /= No_Elmt loop 13255 Visit_Node (Node (Elmt)); 13256 Next_Elmt (Elmt); 13257 end loop; 13258 end if; 13259 end Visit_Elist; 13260 13261 ----------------- 13262 -- Visit_Field -- 13263 ----------------- 13264 13265 procedure Visit_Field (F : Union_Id; N : Node_Id) is 13266 begin 13267 if F = Union_Id (Empty) then 13268 return; 13269 13270 elsif F in Node_Range then 13271 13272 -- Copy node if it is syntactic, i.e. its parent pointer is 13273 -- set to point to the field that referenced it (certain 13274 -- Itypes will also meet this criterion, which is fine, since 13275 -- these are clearly Itypes that do need to be copied, since 13276 -- we are copying their parent.) 13277 13278 if Parent (Node_Id (F)) = N then 13279 Visit_Node (Node_Id (F)); 13280 return; 13281 13282 -- Another case, if we are pointing to an Itype, then we want 13283 -- to copy it if its associated node is somewhere in the tree 13284 -- being copied. 13285 13286 -- Note: the exclusion of self-referential copies is just an 13287 -- optimization, since the search of the already copied list 13288 -- would catch it, but it is a common case (Etype pointing 13289 -- to itself for an Itype that is a base type). 13290 13291 elsif Has_Extension (Node_Id (F)) 13292 and then Is_Itype (Entity_Id (F)) 13293 and then Node_Id (F) /= N 13294 then 13295 declare 13296 P : Node_Id; 13297 13298 begin 13299 P := Associated_Node_For_Itype (Node_Id (F)); 13300 while Present (P) loop 13301 if P = Source then 13302 Visit_Node (Node_Id (F)); 13303 return; 13304 else 13305 P := Parent (P); 13306 end if; 13307 end loop; 13308 13309 -- An Itype whose parent is not being copied definitely 13310 -- should NOT be copied, since it does not belong in any 13311 -- sense to the copied subtree. 13312 13313 return; 13314 end; 13315 end if; 13316 13317 elsif F in List_Range 13318 and then Parent (List_Id (F)) = N 13319 then 13320 Visit_List (List_Id (F)); 13321 return; 13322 end if; 13323 end Visit_Field; 13324 13325 ----------------- 13326 -- Visit_Itype -- 13327 ----------------- 13328 13329 procedure Visit_Itype (Old_Itype : Entity_Id) is 13330 New_Itype : Entity_Id; 13331 E : Elmt_Id; 13332 Ent : Entity_Id; 13333 13334 begin 13335 -- Itypes that describe the designated type of access to subprograms 13336 -- have the structure of subprogram declarations, with signatures, 13337 -- etc. Either we duplicate the signatures completely, or choose to 13338 -- share such itypes, which is fine because their elaboration will 13339 -- have no side effects. 13340 13341 if Ekind (Old_Itype) = E_Subprogram_Type then 13342 return; 13343 end if; 13344 13345 New_Itype := New_Copy (Old_Itype); 13346 13347 -- The new Itype has all the attributes of the old one, and 13348 -- we just copy the contents of the entity. However, the back-end 13349 -- needs different names for debugging purposes, so we create a 13350 -- new internal name for it in all cases. 13351 13352 Set_Chars (New_Itype, New_Internal_Name ('T')); 13353 13354 -- If our associated node is an entity that has already been copied, 13355 -- then set the associated node of the copy to point to the right 13356 -- copy. If we have copied an Itype that is itself the associated 13357 -- node of some previously copied Itype, then we set the right 13358 -- pointer in the other direction. 13359 13360 if Present (Actual_Map) then 13361 13362 -- Case of hash tables used 13363 13364 if NCT_Hash_Tables_Used then 13365 13366 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype)); 13367 13368 if Present (Ent) then 13369 Set_Associated_Node_For_Itype (New_Itype, Ent); 13370 end if; 13371 13372 Ent := NCT_Itype_Assoc.Get (Old_Itype); 13373 if Present (Ent) then 13374 Set_Associated_Node_For_Itype (Ent, New_Itype); 13375 13376 -- If the hash table has no association for this Itype and 13377 -- its associated node, enter one now. 13378 13379 else 13380 NCT_Itype_Assoc.Set 13381 (Associated_Node_For_Itype (Old_Itype), New_Itype); 13382 end if; 13383 13384 -- Case of hash tables not used 13385 13386 else 13387 E := First_Elmt (Actual_Map); 13388 while Present (E) loop 13389 if Associated_Node_For_Itype (Old_Itype) = Node (E) then 13390 Set_Associated_Node_For_Itype 13391 (New_Itype, Node (Next_Elmt (E))); 13392 end if; 13393 13394 if Is_Type (Node (E)) 13395 and then 13396 Old_Itype = Associated_Node_For_Itype (Node (E)) 13397 then 13398 Set_Associated_Node_For_Itype 13399 (Node (Next_Elmt (E)), New_Itype); 13400 end if; 13401 13402 E := Next_Elmt (Next_Elmt (E)); 13403 end loop; 13404 end if; 13405 end if; 13406 13407 if Present (Freeze_Node (New_Itype)) then 13408 Set_Is_Frozen (New_Itype, False); 13409 Set_Freeze_Node (New_Itype, Empty); 13410 end if; 13411 13412 -- Add new association to map 13413 13414 if No (Actual_Map) then 13415 Actual_Map := New_Elmt_List; 13416 end if; 13417 13418 Append_Elmt (Old_Itype, Actual_Map); 13419 Append_Elmt (New_Itype, Actual_Map); 13420 13421 if NCT_Hash_Tables_Used then 13422 NCT_Assoc.Set (Old_Itype, New_Itype); 13423 13424 else 13425 NCT_Table_Entries := NCT_Table_Entries + 1; 13426 13427 if NCT_Table_Entries > NCT_Hash_Threshold then 13428 Build_NCT_Hash_Tables; 13429 end if; 13430 end if; 13431 13432 -- If a record subtype is simply copied, the entity list will be 13433 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 13434 13435 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then 13436 Set_Cloned_Subtype (New_Itype, Old_Itype); 13437 end if; 13438 13439 -- Visit descendents that eventually get copied 13440 13441 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype); 13442 13443 if Is_Discrete_Type (Old_Itype) then 13444 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype); 13445 13446 elsif Has_Discriminants (Base_Type (Old_Itype)) then 13447 -- ??? This should involve call to Visit_Field 13448 Visit_Elist (Discriminant_Constraint (Old_Itype)); 13449 13450 elsif Is_Array_Type (Old_Itype) then 13451 if Present (First_Index (Old_Itype)) then 13452 Visit_Field (Union_Id (List_Containing 13453 (First_Index (Old_Itype))), 13454 Old_Itype); 13455 end if; 13456 13457 if Is_Packed (Old_Itype) then 13458 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)), 13459 Old_Itype); 13460 end if; 13461 end if; 13462 end Visit_Itype; 13463 13464 ---------------- 13465 -- Visit_List -- 13466 ---------------- 13467 13468 procedure Visit_List (L : List_Id) is 13469 N : Node_Id; 13470 begin 13471 if L /= No_List then 13472 N := First (L); 13473 13474 while Present (N) loop 13475 Visit_Node (N); 13476 Next (N); 13477 end loop; 13478 end if; 13479 end Visit_List; 13480 13481 ---------------- 13482 -- Visit_Node -- 13483 ---------------- 13484 13485 procedure Visit_Node (N : Node_Or_Entity_Id) is 13486 13487 -- Start of processing for Visit_Node 13488 13489 begin 13490 -- Handle case of an Itype, which must be copied 13491 13492 if Has_Extension (N) 13493 and then Is_Itype (N) 13494 then 13495 -- Nothing to do if already in the list. This can happen with an 13496 -- Itype entity that appears more than once in the tree. 13497 -- Note that we do not want to visit descendents in this case. 13498 13499 -- Test for already in list when hash table is used 13500 13501 if NCT_Hash_Tables_Used then 13502 if Present (NCT_Assoc.Get (Entity_Id (N))) then 13503 return; 13504 end if; 13505 13506 -- Test for already in list when hash table not used 13507 13508 else 13509 declare 13510 E : Elmt_Id; 13511 begin 13512 if Present (Actual_Map) then 13513 E := First_Elmt (Actual_Map); 13514 while Present (E) loop 13515 if Node (E) = N then 13516 return; 13517 else 13518 E := Next_Elmt (Next_Elmt (E)); 13519 end if; 13520 end loop; 13521 end if; 13522 end; 13523 end if; 13524 13525 Visit_Itype (N); 13526 end if; 13527 13528 -- Visit descendents 13529 13530 Visit_Field (Field1 (N), N); 13531 Visit_Field (Field2 (N), N); 13532 Visit_Field (Field3 (N), N); 13533 Visit_Field (Field4 (N), N); 13534 Visit_Field (Field5 (N), N); 13535 end Visit_Node; 13536 13537 -- Start of processing for New_Copy_Tree 13538 13539 begin 13540 Actual_Map := Map; 13541 13542 -- See if we should use hash table 13543 13544 if No (Actual_Map) then 13545 NCT_Hash_Tables_Used := False; 13546 13547 else 13548 declare 13549 Elmt : Elmt_Id; 13550 13551 begin 13552 NCT_Table_Entries := 0; 13553 13554 Elmt := First_Elmt (Actual_Map); 13555 while Present (Elmt) loop 13556 NCT_Table_Entries := NCT_Table_Entries + 1; 13557 Next_Elmt (Elmt); 13558 Next_Elmt (Elmt); 13559 end loop; 13560 13561 if NCT_Table_Entries > NCT_Hash_Threshold then 13562 Build_NCT_Hash_Tables; 13563 else 13564 NCT_Hash_Tables_Used := False; 13565 end if; 13566 end; 13567 end if; 13568 13569 -- Hash table set up if required, now start phase one by visiting 13570 -- top node (we will recursively visit the descendents). 13571 13572 Visit_Node (Source); 13573 13574 -- Now the second phase of the copy can start. First we process 13575 -- all the mapped entities, copying their descendents. 13576 13577 if Present (Actual_Map) then 13578 declare 13579 Elmt : Elmt_Id; 13580 New_Itype : Entity_Id; 13581 begin 13582 Elmt := First_Elmt (Actual_Map); 13583 while Present (Elmt) loop 13584 Next_Elmt (Elmt); 13585 New_Itype := Node (Elmt); 13586 Copy_Itype_With_Replacement (New_Itype); 13587 Next_Elmt (Elmt); 13588 end loop; 13589 end; 13590 end if; 13591 13592 -- Now we can copy the actual tree 13593 13594 return Copy_Node_With_Replacement (Source); 13595 end New_Copy_Tree; 13596 13597 ------------------------- 13598 -- New_External_Entity -- 13599 ------------------------- 13600 13601 function New_External_Entity 13602 (Kind : Entity_Kind; 13603 Scope_Id : Entity_Id; 13604 Sloc_Value : Source_Ptr; 13605 Related_Id : Entity_Id; 13606 Suffix : Character; 13607 Suffix_Index : Nat := 0; 13608 Prefix : Character := ' ') return Entity_Id 13609 is 13610 N : constant Entity_Id := 13611 Make_Defining_Identifier (Sloc_Value, 13612 New_External_Name 13613 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 13614 13615 begin 13616 Set_Ekind (N, Kind); 13617 Set_Is_Internal (N, True); 13618 Append_Entity (N, Scope_Id); 13619 Set_Public_Status (N); 13620 13621 if Kind in Type_Kind then 13622 Init_Size_Align (N); 13623 end if; 13624 13625 return N; 13626 end New_External_Entity; 13627 13628 ------------------------- 13629 -- New_Internal_Entity -- 13630 ------------------------- 13631 13632 function New_Internal_Entity 13633 (Kind : Entity_Kind; 13634 Scope_Id : Entity_Id; 13635 Sloc_Value : Source_Ptr; 13636 Id_Char : Character) return Entity_Id 13637 is 13638 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 13639 13640 begin 13641 Set_Ekind (N, Kind); 13642 Set_Is_Internal (N, True); 13643 Append_Entity (N, Scope_Id); 13644 13645 if Kind in Type_Kind then 13646 Init_Size_Align (N); 13647 end if; 13648 13649 return N; 13650 end New_Internal_Entity; 13651 13652 ----------------- 13653 -- Next_Actual -- 13654 ----------------- 13655 13656 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 13657 N : Node_Id; 13658 13659 begin 13660 -- If we are pointing at a positional parameter, it is a member of a 13661 -- node list (the list of parameters), and the next parameter is the 13662 -- next node on the list, unless we hit a parameter association, then 13663 -- we shift to using the chain whose head is the First_Named_Actual in 13664 -- the parent, and then is threaded using the Next_Named_Actual of the 13665 -- Parameter_Association. All this fiddling is because the original node 13666 -- list is in the textual call order, and what we need is the 13667 -- declaration order. 13668 13669 if Is_List_Member (Actual_Id) then 13670 N := Next (Actual_Id); 13671 13672 if Nkind (N) = N_Parameter_Association then 13673 return First_Named_Actual (Parent (Actual_Id)); 13674 else 13675 return N; 13676 end if; 13677 13678 else 13679 return Next_Named_Actual (Parent (Actual_Id)); 13680 end if; 13681 end Next_Actual; 13682 13683 procedure Next_Actual (Actual_Id : in out Node_Id) is 13684 begin 13685 Actual_Id := Next_Actual (Actual_Id); 13686 end Next_Actual; 13687 13688 --------------------- 13689 -- No_Scalar_Parts -- 13690 --------------------- 13691 13692 function No_Scalar_Parts (T : Entity_Id) return Boolean is 13693 C : Entity_Id; 13694 13695 begin 13696 if Is_Scalar_Type (T) then 13697 return False; 13698 13699 elsif Is_Array_Type (T) then 13700 return No_Scalar_Parts (Component_Type (T)); 13701 13702 elsif Is_Record_Type (T) or else Has_Discriminants (T) then 13703 C := First_Component_Or_Discriminant (T); 13704 while Present (C) loop 13705 if not No_Scalar_Parts (Etype (C)) then 13706 return False; 13707 else 13708 Next_Component_Or_Discriminant (C); 13709 end if; 13710 end loop; 13711 end if; 13712 13713 return True; 13714 end No_Scalar_Parts; 13715 13716 ----------------------- 13717 -- Normalize_Actuals -- 13718 ----------------------- 13719 13720 -- Chain actuals according to formals of subprogram. If there are no named 13721 -- associations, the chain is simply the list of Parameter Associations, 13722 -- since the order is the same as the declaration order. If there are named 13723 -- associations, then the First_Named_Actual field in the N_Function_Call 13724 -- or N_Procedure_Call_Statement node points to the Parameter_Association 13725 -- node for the parameter that comes first in declaration order. The 13726 -- remaining named parameters are then chained in declaration order using 13727 -- Next_Named_Actual. 13728 13729 -- This routine also verifies that the number of actuals is compatible with 13730 -- the number and default values of formals, but performs no type checking 13731 -- (type checking is done by the caller). 13732 13733 -- If the matching succeeds, Success is set to True and the caller proceeds 13734 -- with type-checking. If the match is unsuccessful, then Success is set to 13735 -- False, and the caller attempts a different interpretation, if there is 13736 -- one. 13737 13738 -- If the flag Report is on, the call is not overloaded, and a failure to 13739 -- match can be reported here, rather than in the caller. 13740 13741 procedure Normalize_Actuals 13742 (N : Node_Id; 13743 S : Entity_Id; 13744 Report : Boolean; 13745 Success : out Boolean) 13746 is 13747 Actuals : constant List_Id := Parameter_Associations (N); 13748 Actual : Node_Id := Empty; 13749 Formal : Entity_Id; 13750 Last : Node_Id := Empty; 13751 First_Named : Node_Id := Empty; 13752 Found : Boolean; 13753 13754 Formals_To_Match : Integer := 0; 13755 Actuals_To_Match : Integer := 0; 13756 13757 procedure Chain (A : Node_Id); 13758 -- Add named actual at the proper place in the list, using the 13759 -- Next_Named_Actual link. 13760 13761 function Reporting return Boolean; 13762 -- Determines if an error is to be reported. To report an error, we 13763 -- need Report to be True, and also we do not report errors caused 13764 -- by calls to init procs that occur within other init procs. Such 13765 -- errors must always be cascaded errors, since if all the types are 13766 -- declared correctly, the compiler will certainly build decent calls. 13767 13768 ----------- 13769 -- Chain -- 13770 ----------- 13771 13772 procedure Chain (A : Node_Id) is 13773 begin 13774 if No (Last) then 13775 13776 -- Call node points to first actual in list 13777 13778 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 13779 13780 else 13781 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 13782 end if; 13783 13784 Last := A; 13785 Set_Next_Named_Actual (Last, Empty); 13786 end Chain; 13787 13788 --------------- 13789 -- Reporting -- 13790 --------------- 13791 13792 function Reporting return Boolean is 13793 begin 13794 if not Report then 13795 return False; 13796 13797 elsif not Within_Init_Proc then 13798 return True; 13799 13800 elsif Is_Init_Proc (Entity (Name (N))) then 13801 return False; 13802 13803 else 13804 return True; 13805 end if; 13806 end Reporting; 13807 13808 -- Start of processing for Normalize_Actuals 13809 13810 begin 13811 if Is_Access_Type (S) then 13812 13813 -- The name in the call is a function call that returns an access 13814 -- to subprogram. The designated type has the list of formals. 13815 13816 Formal := First_Formal (Designated_Type (S)); 13817 else 13818 Formal := First_Formal (S); 13819 end if; 13820 13821 while Present (Formal) loop 13822 Formals_To_Match := Formals_To_Match + 1; 13823 Next_Formal (Formal); 13824 end loop; 13825 13826 -- Find if there is a named association, and verify that no positional 13827 -- associations appear after named ones. 13828 13829 if Present (Actuals) then 13830 Actual := First (Actuals); 13831 end if; 13832 13833 while Present (Actual) 13834 and then Nkind (Actual) /= N_Parameter_Association 13835 loop 13836 Actuals_To_Match := Actuals_To_Match + 1; 13837 Next (Actual); 13838 end loop; 13839 13840 if No (Actual) and Actuals_To_Match = Formals_To_Match then 13841 13842 -- Most common case: positional notation, no defaults 13843 13844 Success := True; 13845 return; 13846 13847 elsif Actuals_To_Match > Formals_To_Match then 13848 13849 -- Too many actuals: will not work 13850 13851 if Reporting then 13852 if Is_Entity_Name (Name (N)) then 13853 Error_Msg_N ("too many arguments in call to&", Name (N)); 13854 else 13855 Error_Msg_N ("too many arguments in call", N); 13856 end if; 13857 end if; 13858 13859 Success := False; 13860 return; 13861 end if; 13862 13863 First_Named := Actual; 13864 13865 while Present (Actual) loop 13866 if Nkind (Actual) /= N_Parameter_Association then 13867 Error_Msg_N 13868 ("positional parameters not allowed after named ones", Actual); 13869 Success := False; 13870 return; 13871 13872 else 13873 Actuals_To_Match := Actuals_To_Match + 1; 13874 end if; 13875 13876 Next (Actual); 13877 end loop; 13878 13879 if Present (Actuals) then 13880 Actual := First (Actuals); 13881 end if; 13882 13883 Formal := First_Formal (S); 13884 while Present (Formal) loop 13885 13886 -- Match the formals in order. If the corresponding actual is 13887 -- positional, nothing to do. Else scan the list of named actuals 13888 -- to find the one with the right name. 13889 13890 if Present (Actual) 13891 and then Nkind (Actual) /= N_Parameter_Association 13892 then 13893 Next (Actual); 13894 Actuals_To_Match := Actuals_To_Match - 1; 13895 Formals_To_Match := Formals_To_Match - 1; 13896 13897 else 13898 -- For named parameters, search the list of actuals to find 13899 -- one that matches the next formal name. 13900 13901 Actual := First_Named; 13902 Found := False; 13903 while Present (Actual) loop 13904 if Chars (Selector_Name (Actual)) = Chars (Formal) then 13905 Found := True; 13906 Chain (Actual); 13907 Actuals_To_Match := Actuals_To_Match - 1; 13908 Formals_To_Match := Formals_To_Match - 1; 13909 exit; 13910 end if; 13911 13912 Next (Actual); 13913 end loop; 13914 13915 if not Found then 13916 if Ekind (Formal) /= E_In_Parameter 13917 or else No (Default_Value (Formal)) 13918 then 13919 if Reporting then 13920 if (Comes_From_Source (S) 13921 or else Sloc (S) = Standard_Location) 13922 and then Is_Overloadable (S) 13923 then 13924 if No (Actuals) 13925 and then 13926 (Nkind (Parent (N)) = N_Procedure_Call_Statement 13927 or else 13928 (Nkind (Parent (N)) = N_Function_Call 13929 or else 13930 Nkind (Parent (N)) = N_Parameter_Association)) 13931 and then Ekind (S) /= E_Function 13932 then 13933 Set_Etype (N, Etype (S)); 13934 else 13935 Error_Msg_Name_1 := Chars (S); 13936 Error_Msg_Sloc := Sloc (S); 13937 Error_Msg_NE 13938 ("missing argument for parameter & " & 13939 "in call to % declared #", N, Formal); 13940 end if; 13941 13942 elsif Is_Overloadable (S) then 13943 Error_Msg_Name_1 := Chars (S); 13944 13945 -- Point to type derivation that generated the 13946 -- operation. 13947 13948 Error_Msg_Sloc := Sloc (Parent (S)); 13949 13950 Error_Msg_NE 13951 ("missing argument for parameter & " & 13952 "in call to % (inherited) #", N, Formal); 13953 13954 else 13955 Error_Msg_NE 13956 ("missing argument for parameter &", N, Formal); 13957 end if; 13958 end if; 13959 13960 Success := False; 13961 return; 13962 13963 else 13964 Formals_To_Match := Formals_To_Match - 1; 13965 end if; 13966 end if; 13967 end if; 13968 13969 Next_Formal (Formal); 13970 end loop; 13971 13972 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 13973 Success := True; 13974 return; 13975 13976 else 13977 if Reporting then 13978 13979 -- Find some superfluous named actual that did not get 13980 -- attached to the list of associations. 13981 13982 Actual := First (Actuals); 13983 while Present (Actual) loop 13984 if Nkind (Actual) = N_Parameter_Association 13985 and then Actual /= Last 13986 and then No (Next_Named_Actual (Actual)) 13987 then 13988 Error_Msg_N ("unmatched actual & in call", 13989 Selector_Name (Actual)); 13990 exit; 13991 end if; 13992 13993 Next (Actual); 13994 end loop; 13995 end if; 13996 13997 Success := False; 13998 return; 13999 end if; 14000 end Normalize_Actuals; 14001 14002 -------------------------------- 14003 -- Note_Possible_Modification -- 14004 -------------------------------- 14005 14006 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 14007 Modification_Comes_From_Source : constant Boolean := 14008 Comes_From_Source (Parent (N)); 14009 14010 Ent : Entity_Id; 14011 Exp : Node_Id; 14012 14013 begin 14014 -- Loop to find referenced entity, if there is one 14015 14016 Exp := N; 14017 loop 14018 Ent := Empty; 14019 14020 if Is_Entity_Name (Exp) then 14021 Ent := Entity (Exp); 14022 14023 -- If the entity is missing, it is an undeclared identifier, 14024 -- and there is nothing to annotate. 14025 14026 if No (Ent) then 14027 return; 14028 end if; 14029 14030 elsif Nkind (Exp) = N_Explicit_Dereference then 14031 declare 14032 P : constant Node_Id := Prefix (Exp); 14033 14034 begin 14035 -- In formal verification mode, keep track of all reads and 14036 -- writes through explicit dereferences. 14037 14038 if GNATprove_Mode then 14039 SPARK_Specific.Generate_Dereference (N, 'm'); 14040 end if; 14041 14042 if Nkind (P) = N_Selected_Component 14043 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 14044 then 14045 -- Case of a reference to an entry formal 14046 14047 Ent := Entry_Formal (Entity (Selector_Name (P))); 14048 14049 elsif Nkind (P) = N_Identifier 14050 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 14051 and then Present (Expression (Parent (Entity (P)))) 14052 and then Nkind (Expression (Parent (Entity (P)))) = 14053 N_Reference 14054 then 14055 -- Case of a reference to a value on which side effects have 14056 -- been removed. 14057 14058 Exp := Prefix (Expression (Parent (Entity (P)))); 14059 goto Continue; 14060 14061 else 14062 return; 14063 end if; 14064 end; 14065 14066 elsif Nkind_In (Exp, N_Type_Conversion, 14067 N_Unchecked_Type_Conversion) 14068 then 14069 Exp := Expression (Exp); 14070 goto Continue; 14071 14072 elsif Nkind_In (Exp, N_Slice, 14073 N_Indexed_Component, 14074 N_Selected_Component) 14075 then 14076 -- Special check, if the prefix is an access type, then return 14077 -- since we are modifying the thing pointed to, not the prefix. 14078 -- When we are expanding, most usually the prefix is replaced 14079 -- by an explicit dereference, and this test is not needed, but 14080 -- in some cases (notably -gnatc mode and generics) when we do 14081 -- not do full expansion, we need this special test. 14082 14083 if Is_Access_Type (Etype (Prefix (Exp))) then 14084 return; 14085 14086 -- Otherwise go to prefix and keep going 14087 14088 else 14089 Exp := Prefix (Exp); 14090 goto Continue; 14091 end if; 14092 14093 -- All other cases, not a modification 14094 14095 else 14096 return; 14097 end if; 14098 14099 -- Now look for entity being referenced 14100 14101 if Present (Ent) then 14102 if Is_Object (Ent) then 14103 if Comes_From_Source (Exp) 14104 or else Modification_Comes_From_Source 14105 then 14106 -- Give warning if pragma unmodified given and we are 14107 -- sure this is a modification. 14108 14109 if Has_Pragma_Unmodified (Ent) and then Sure then 14110 Error_Msg_NE 14111 ("??pragma Unmodified given for &!", N, Ent); 14112 end if; 14113 14114 Set_Never_Set_In_Source (Ent, False); 14115 end if; 14116 14117 Set_Is_True_Constant (Ent, False); 14118 Set_Current_Value (Ent, Empty); 14119 Set_Is_Known_Null (Ent, False); 14120 14121 if not Can_Never_Be_Null (Ent) then 14122 Set_Is_Known_Non_Null (Ent, False); 14123 end if; 14124 14125 -- Follow renaming chain 14126 14127 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 14128 and then Present (Renamed_Object (Ent)) 14129 then 14130 Exp := Renamed_Object (Ent); 14131 14132 -- If the entity is the loop variable in an iteration over 14133 -- a container, retrieve container expression to indicate 14134 -- possible modificastion. 14135 14136 if Present (Related_Expression (Ent)) 14137 and then Nkind (Parent (Related_Expression (Ent))) = 14138 N_Iterator_Specification 14139 then 14140 Exp := Original_Node (Related_Expression (Ent)); 14141 end if; 14142 14143 goto Continue; 14144 14145 -- The expression may be the renaming of a subcomponent of an 14146 -- array or container. The assignment to the subcomponent is 14147 -- a modification of the container. 14148 14149 elsif Comes_From_Source (Original_Node (Exp)) 14150 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 14151 N_Indexed_Component) 14152 then 14153 Exp := Prefix (Original_Node (Exp)); 14154 goto Continue; 14155 end if; 14156 14157 -- Generate a reference only if the assignment comes from 14158 -- source. This excludes, for example, calls to a dispatching 14159 -- assignment operation when the left-hand side is tagged. In 14160 -- GNATprove mode, we need those references also on generated 14161 -- code, as these are used to compute the local effects of 14162 -- subprograms. 14163 14164 if Modification_Comes_From_Source or GNATprove_Mode then 14165 Generate_Reference (Ent, Exp, 'm'); 14166 14167 -- If the target of the assignment is the bound variable 14168 -- in an iterator, indicate that the corresponding array 14169 -- or container is also modified. 14170 14171 if Ada_Version >= Ada_2012 14172 and then 14173 Nkind (Parent (Ent)) = N_Iterator_Specification 14174 then 14175 declare 14176 Domain : constant Node_Id := Name (Parent (Ent)); 14177 14178 begin 14179 -- TBD : in the full version of the construct, the 14180 -- domain of iteration can be given by an expression. 14181 14182 if Is_Entity_Name (Domain) then 14183 Generate_Reference (Entity (Domain), Exp, 'm'); 14184 Set_Is_True_Constant (Entity (Domain), False); 14185 Set_Never_Set_In_Source (Entity (Domain), False); 14186 end if; 14187 end; 14188 end if; 14189 end if; 14190 14191 Check_Nested_Access (Ent); 14192 end if; 14193 14194 Kill_Checks (Ent); 14195 14196 -- If we are sure this is a modification from source, and we know 14197 -- this modifies a constant, then give an appropriate warning. 14198 14199 if Overlays_Constant (Ent) 14200 and then Modification_Comes_From_Source 14201 and then Sure 14202 then 14203 declare 14204 A : constant Node_Id := Address_Clause (Ent); 14205 begin 14206 if Present (A) then 14207 declare 14208 Exp : constant Node_Id := Expression (A); 14209 begin 14210 if Nkind (Exp) = N_Attribute_Reference 14211 and then Attribute_Name (Exp) = Name_Address 14212 and then Is_Entity_Name (Prefix (Exp)) 14213 then 14214 Error_Msg_Sloc := Sloc (A); 14215 Error_Msg_NE 14216 ("constant& may be modified via address " 14217 & "clause#??", N, Entity (Prefix (Exp))); 14218 end if; 14219 end; 14220 end if; 14221 end; 14222 end if; 14223 14224 return; 14225 end if; 14226 14227 <<Continue>> 14228 null; 14229 end loop; 14230 end Note_Possible_Modification; 14231 14232 ------------------------- 14233 -- Object_Access_Level -- 14234 ------------------------- 14235 14236 -- Returns the static accessibility level of the view denoted by Obj. Note 14237 -- that the value returned is the result of a call to Scope_Depth. Only 14238 -- scope depths associated with dynamic scopes can actually be returned. 14239 -- Since only relative levels matter for accessibility checking, the fact 14240 -- that the distance between successive levels of accessibility is not 14241 -- always one is immaterial (invariant: if level(E2) is deeper than 14242 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 14243 14244 function Object_Access_Level (Obj : Node_Id) return Uint is 14245 function Is_Interface_Conversion (N : Node_Id) return Boolean; 14246 -- Determine whether N is a construct of the form 14247 -- Some_Type (Operand._tag'Address) 14248 -- This construct appears in the context of dispatching calls. 14249 14250 function Reference_To (Obj : Node_Id) return Node_Id; 14251 -- An explicit dereference is created when removing side-effects from 14252 -- expressions for constraint checking purposes. In this case a local 14253 -- access type is created for it. The correct access level is that of 14254 -- the original source node. We detect this case by noting that the 14255 -- prefix of the dereference is created by an object declaration whose 14256 -- initial expression is a reference. 14257 14258 ----------------------------- 14259 -- Is_Interface_Conversion -- 14260 ----------------------------- 14261 14262 function Is_Interface_Conversion (N : Node_Id) return Boolean is 14263 begin 14264 return 14265 Nkind (N) = N_Unchecked_Type_Conversion 14266 and then Nkind (Expression (N)) = N_Attribute_Reference 14267 and then Attribute_Name (Expression (N)) = Name_Address; 14268 end Is_Interface_Conversion; 14269 14270 ------------------ 14271 -- Reference_To -- 14272 ------------------ 14273 14274 function Reference_To (Obj : Node_Id) return Node_Id is 14275 Pref : constant Node_Id := Prefix (Obj); 14276 begin 14277 if Is_Entity_Name (Pref) 14278 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 14279 and then Present (Expression (Parent (Entity (Pref)))) 14280 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 14281 then 14282 return (Prefix (Expression (Parent (Entity (Pref))))); 14283 else 14284 return Empty; 14285 end if; 14286 end Reference_To; 14287 14288 -- Local variables 14289 14290 E : Entity_Id; 14291 14292 -- Start of processing for Object_Access_Level 14293 14294 begin 14295 if Nkind (Obj) = N_Defining_Identifier 14296 or else Is_Entity_Name (Obj) 14297 then 14298 if Nkind (Obj) = N_Defining_Identifier then 14299 E := Obj; 14300 else 14301 E := Entity (Obj); 14302 end if; 14303 14304 if Is_Prival (E) then 14305 E := Prival_Link (E); 14306 end if; 14307 14308 -- If E is a type then it denotes a current instance. For this case 14309 -- we add one to the normal accessibility level of the type to ensure 14310 -- that current instances are treated as always being deeper than 14311 -- than the level of any visible named access type (see 3.10.2(21)). 14312 14313 if Is_Type (E) then 14314 return Type_Access_Level (E) + 1; 14315 14316 elsif Present (Renamed_Object (E)) then 14317 return Object_Access_Level (Renamed_Object (E)); 14318 14319 -- Similarly, if E is a component of the current instance of a 14320 -- protected type, any instance of it is assumed to be at a deeper 14321 -- level than the type. For a protected object (whose type is an 14322 -- anonymous protected type) its components are at the same level 14323 -- as the type itself. 14324 14325 elsif not Is_Overloadable (E) 14326 and then Ekind (Scope (E)) = E_Protected_Type 14327 and then Comes_From_Source (Scope (E)) 14328 then 14329 return Type_Access_Level (Scope (E)) + 1; 14330 14331 else 14332 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 14333 end if; 14334 14335 elsif Nkind (Obj) = N_Selected_Component then 14336 if Is_Access_Type (Etype (Prefix (Obj))) then 14337 return Type_Access_Level (Etype (Prefix (Obj))); 14338 else 14339 return Object_Access_Level (Prefix (Obj)); 14340 end if; 14341 14342 elsif Nkind (Obj) = N_Indexed_Component then 14343 if Is_Access_Type (Etype (Prefix (Obj))) then 14344 return Type_Access_Level (Etype (Prefix (Obj))); 14345 else 14346 return Object_Access_Level (Prefix (Obj)); 14347 end if; 14348 14349 elsif Nkind (Obj) = N_Explicit_Dereference then 14350 14351 -- If the prefix is a selected access discriminant then we make a 14352 -- recursive call on the prefix, which will in turn check the level 14353 -- of the prefix object of the selected discriminant. 14354 14355 if Nkind (Prefix (Obj)) = N_Selected_Component 14356 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 14357 and then 14358 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 14359 then 14360 return Object_Access_Level (Prefix (Obj)); 14361 14362 -- Detect an interface conversion in the context of a dispatching 14363 -- call. Use the original form of the conversion to find the access 14364 -- level of the operand. 14365 14366 elsif Is_Interface (Etype (Obj)) 14367 and then Is_Interface_Conversion (Prefix (Obj)) 14368 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 14369 then 14370 return Object_Access_Level (Original_Node (Obj)); 14371 14372 elsif not Comes_From_Source (Obj) then 14373 declare 14374 Ref : constant Node_Id := Reference_To (Obj); 14375 begin 14376 if Present (Ref) then 14377 return Object_Access_Level (Ref); 14378 else 14379 return Type_Access_Level (Etype (Prefix (Obj))); 14380 end if; 14381 end; 14382 14383 else 14384 return Type_Access_Level (Etype (Prefix (Obj))); 14385 end if; 14386 14387 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 14388 return Object_Access_Level (Expression (Obj)); 14389 14390 elsif Nkind (Obj) = N_Function_Call then 14391 14392 -- Function results are objects, so we get either the access level of 14393 -- the function or, in the case of an indirect call, the level of the 14394 -- access-to-subprogram type. (This code is used for Ada 95, but it 14395 -- looks wrong, because it seems that we should be checking the level 14396 -- of the call itself, even for Ada 95. However, using the Ada 2005 14397 -- version of the code causes regressions in several tests that are 14398 -- compiled with -gnat95. ???) 14399 14400 if Ada_Version < Ada_2005 then 14401 if Is_Entity_Name (Name (Obj)) then 14402 return Subprogram_Access_Level (Entity (Name (Obj))); 14403 else 14404 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 14405 end if; 14406 14407 -- For Ada 2005, the level of the result object of a function call is 14408 -- defined to be the level of the call's innermost enclosing master. 14409 -- We determine that by querying the depth of the innermost enclosing 14410 -- dynamic scope. 14411 14412 else 14413 Return_Master_Scope_Depth_Of_Call : declare 14414 14415 function Innermost_Master_Scope_Depth 14416 (N : Node_Id) return Uint; 14417 -- Returns the scope depth of the given node's innermost 14418 -- enclosing dynamic scope (effectively the accessibility 14419 -- level of the innermost enclosing master). 14420 14421 ---------------------------------- 14422 -- Innermost_Master_Scope_Depth -- 14423 ---------------------------------- 14424 14425 function Innermost_Master_Scope_Depth 14426 (N : Node_Id) return Uint 14427 is 14428 Node_Par : Node_Id := Parent (N); 14429 14430 begin 14431 -- Locate the nearest enclosing node (by traversing Parents) 14432 -- that Defining_Entity can be applied to, and return the 14433 -- depth of that entity's nearest enclosing dynamic scope. 14434 14435 while Present (Node_Par) loop 14436 case Nkind (Node_Par) is 14437 when N_Component_Declaration | 14438 N_Entry_Declaration | 14439 N_Formal_Object_Declaration | 14440 N_Formal_Type_Declaration | 14441 N_Full_Type_Declaration | 14442 N_Incomplete_Type_Declaration | 14443 N_Loop_Parameter_Specification | 14444 N_Object_Declaration | 14445 N_Protected_Type_Declaration | 14446 N_Private_Extension_Declaration | 14447 N_Private_Type_Declaration | 14448 N_Subtype_Declaration | 14449 N_Function_Specification | 14450 N_Procedure_Specification | 14451 N_Task_Type_Declaration | 14452 N_Body_Stub | 14453 N_Generic_Instantiation | 14454 N_Proper_Body | 14455 N_Implicit_Label_Declaration | 14456 N_Package_Declaration | 14457 N_Single_Task_Declaration | 14458 N_Subprogram_Declaration | 14459 N_Generic_Declaration | 14460 N_Renaming_Declaration | 14461 N_Block_Statement | 14462 N_Formal_Subprogram_Declaration | 14463 N_Abstract_Subprogram_Declaration | 14464 N_Entry_Body | 14465 N_Exception_Declaration | 14466 N_Formal_Package_Declaration | 14467 N_Number_Declaration | 14468 N_Package_Specification | 14469 N_Parameter_Specification | 14470 N_Single_Protected_Declaration | 14471 N_Subunit => 14472 14473 return Scope_Depth 14474 (Nearest_Dynamic_Scope 14475 (Defining_Entity (Node_Par))); 14476 14477 when others => 14478 null; 14479 end case; 14480 14481 Node_Par := Parent (Node_Par); 14482 end loop; 14483 14484 pragma Assert (False); 14485 14486 -- Should never reach the following return 14487 14488 return Scope_Depth (Current_Scope) + 1; 14489 end Innermost_Master_Scope_Depth; 14490 14491 -- Start of processing for Return_Master_Scope_Depth_Of_Call 14492 14493 begin 14494 return Innermost_Master_Scope_Depth (Obj); 14495 end Return_Master_Scope_Depth_Of_Call; 14496 end if; 14497 14498 -- For convenience we handle qualified expressions, even though they 14499 -- aren't technically object names. 14500 14501 elsif Nkind (Obj) = N_Qualified_Expression then 14502 return Object_Access_Level (Expression (Obj)); 14503 14504 -- Otherwise return the scope level of Standard. (If there are cases 14505 -- that fall through to this point they will be treated as having 14506 -- global accessibility for now. ???) 14507 14508 else 14509 return Scope_Depth (Standard_Standard); 14510 end if; 14511 end Object_Access_Level; 14512 14513 -------------------------- 14514 -- Original_Aspect_Name -- 14515 -------------------------- 14516 14517 function Original_Aspect_Name (N : Node_Id) return Name_Id is 14518 Pras : Node_Id; 14519 Name : Name_Id; 14520 14521 begin 14522 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); 14523 Pras := N; 14524 14525 if Is_Rewrite_Substitution (Pras) 14526 and then Nkind (Original_Node (Pras)) = N_Pragma 14527 then 14528 Pras := Original_Node (Pras); 14529 end if; 14530 14531 -- Case where we came from aspect specication 14532 14533 if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then 14534 Pras := Corresponding_Aspect (Pras); 14535 end if; 14536 14537 -- Get name from aspect or pragma 14538 14539 if Nkind (Pras) = N_Pragma then 14540 Name := Pragma_Name (Pras); 14541 else 14542 Name := Chars (Identifier (Pras)); 14543 end if; 14544 14545 -- Deal with 'Class 14546 14547 if Class_Present (Pras) then 14548 case Name is 14549 14550 -- Names that need converting to special _xxx form 14551 14552 when Name_Pre | 14553 Name_Pre_Class => 14554 Name := Name_uPre; 14555 14556 when Name_Post | 14557 Name_Post_Class => 14558 Name := Name_uPost; 14559 14560 when Name_Invariant => 14561 Name := Name_uInvariant; 14562 14563 when Name_Type_Invariant | 14564 Name_Type_Invariant_Class => 14565 Name := Name_uType_Invariant; 14566 14567 -- Nothing to do for other cases (e.g. a Check that derived 14568 -- from Pre_Class and has the flag set). Also we do nothing 14569 -- if the name is already in special _xxx form. 14570 14571 when others => 14572 null; 14573 end case; 14574 end if; 14575 14576 return Name; 14577 end Original_Aspect_Name; 14578 -------------------------------------- 14579 -- Original_Corresponding_Operation -- 14580 -------------------------------------- 14581 14582 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 14583 is 14584 Typ : constant Entity_Id := Find_Dispatching_Type (S); 14585 14586 begin 14587 -- If S is an inherited primitive S2 the original corresponding 14588 -- operation of S is the original corresponding operation of S2 14589 14590 if Present (Alias (S)) 14591 and then Find_Dispatching_Type (Alias (S)) /= Typ 14592 then 14593 return Original_Corresponding_Operation (Alias (S)); 14594 14595 -- If S overrides an inherited subprogram S2 the original corresponding 14596 -- operation of S is the original corresponding operation of S2 14597 14598 elsif Present (Overridden_Operation (S)) then 14599 return Original_Corresponding_Operation (Overridden_Operation (S)); 14600 14601 -- otherwise it is S itself 14602 14603 else 14604 return S; 14605 end if; 14606 end Original_Corresponding_Operation; 14607 14608 ----------------------- 14609 -- Private_Component -- 14610 ----------------------- 14611 14612 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 14613 Ancestor : constant Entity_Id := Base_Type (Type_Id); 14614 14615 function Trace_Components 14616 (T : Entity_Id; 14617 Check : Boolean) return Entity_Id; 14618 -- Recursive function that does the work, and checks against circular 14619 -- definition for each subcomponent type. 14620 14621 ---------------------- 14622 -- Trace_Components -- 14623 ---------------------- 14624 14625 function Trace_Components 14626 (T : Entity_Id; 14627 Check : Boolean) return Entity_Id 14628 is 14629 Btype : constant Entity_Id := Base_Type (T); 14630 Component : Entity_Id; 14631 P : Entity_Id; 14632 Candidate : Entity_Id := Empty; 14633 14634 begin 14635 if Check and then Btype = Ancestor then 14636 Error_Msg_N ("circular type definition", Type_Id); 14637 return Any_Type; 14638 end if; 14639 14640 if Is_Private_Type (Btype) 14641 and then not Is_Generic_Type (Btype) 14642 then 14643 if Present (Full_View (Btype)) 14644 and then Is_Record_Type (Full_View (Btype)) 14645 and then not Is_Frozen (Btype) 14646 then 14647 -- To indicate that the ancestor depends on a private type, the 14648 -- current Btype is sufficient. However, to check for circular 14649 -- definition we must recurse on the full view. 14650 14651 Candidate := Trace_Components (Full_View (Btype), True); 14652 14653 if Candidate = Any_Type then 14654 return Any_Type; 14655 else 14656 return Btype; 14657 end if; 14658 14659 else 14660 return Btype; 14661 end if; 14662 14663 elsif Is_Array_Type (Btype) then 14664 return Trace_Components (Component_Type (Btype), True); 14665 14666 elsif Is_Record_Type (Btype) then 14667 Component := First_Entity (Btype); 14668 while Present (Component) 14669 and then Comes_From_Source (Component) 14670 loop 14671 -- Skip anonymous types generated by constrained components 14672 14673 if not Is_Type (Component) then 14674 P := Trace_Components (Etype (Component), True); 14675 14676 if Present (P) then 14677 if P = Any_Type then 14678 return P; 14679 else 14680 Candidate := P; 14681 end if; 14682 end if; 14683 end if; 14684 14685 Next_Entity (Component); 14686 end loop; 14687 14688 return Candidate; 14689 14690 else 14691 return Empty; 14692 end if; 14693 end Trace_Components; 14694 14695 -- Start of processing for Private_Component 14696 14697 begin 14698 return Trace_Components (Type_Id, False); 14699 end Private_Component; 14700 14701 --------------------------- 14702 -- Primitive_Names_Match -- 14703 --------------------------- 14704 14705 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 14706 14707 function Non_Internal_Name (E : Entity_Id) return Name_Id; 14708 -- Given an internal name, returns the corresponding non-internal name 14709 14710 ------------------------ 14711 -- Non_Internal_Name -- 14712 ------------------------ 14713 14714 function Non_Internal_Name (E : Entity_Id) return Name_Id is 14715 begin 14716 Get_Name_String (Chars (E)); 14717 Name_Len := Name_Len - 1; 14718 return Name_Find; 14719 end Non_Internal_Name; 14720 14721 -- Start of processing for Primitive_Names_Match 14722 14723 begin 14724 pragma Assert (Present (E1) and then Present (E2)); 14725 14726 return Chars (E1) = Chars (E2) 14727 or else 14728 (not Is_Internal_Name (Chars (E1)) 14729 and then Is_Internal_Name (Chars (E2)) 14730 and then Non_Internal_Name (E2) = Chars (E1)) 14731 or else 14732 (not Is_Internal_Name (Chars (E2)) 14733 and then Is_Internal_Name (Chars (E1)) 14734 and then Non_Internal_Name (E1) = Chars (E2)) 14735 or else 14736 (Is_Predefined_Dispatching_Operation (E1) 14737 and then Is_Predefined_Dispatching_Operation (E2) 14738 and then Same_TSS (E1, E2)) 14739 or else 14740 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 14741 end Primitive_Names_Match; 14742 14743 ----------------------- 14744 -- Process_End_Label -- 14745 ----------------------- 14746 14747 procedure Process_End_Label 14748 (N : Node_Id; 14749 Typ : Character; 14750 Ent : Entity_Id) 14751 is 14752 Loc : Source_Ptr; 14753 Nam : Node_Id; 14754 Scop : Entity_Id; 14755 14756 Label_Ref : Boolean; 14757 -- Set True if reference to end label itself is required 14758 14759 Endl : Node_Id; 14760 -- Gets set to the operator symbol or identifier that references the 14761 -- entity Ent. For the child unit case, this is the identifier from the 14762 -- designator. For other cases, this is simply Endl. 14763 14764 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 14765 -- N is an identifier node that appears as a parent unit reference in 14766 -- the case where Ent is a child unit. This procedure generates an 14767 -- appropriate cross-reference entry. E is the corresponding entity. 14768 14769 ------------------------- 14770 -- Generate_Parent_Ref -- 14771 ------------------------- 14772 14773 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 14774 begin 14775 -- If names do not match, something weird, skip reference 14776 14777 if Chars (E) = Chars (N) then 14778 14779 -- Generate the reference. We do NOT consider this as a reference 14780 -- for unreferenced symbol purposes. 14781 14782 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 14783 14784 if Style_Check then 14785 Style.Check_Identifier (N, E); 14786 end if; 14787 end if; 14788 end Generate_Parent_Ref; 14789 14790 -- Start of processing for Process_End_Label 14791 14792 begin 14793 -- If no node, ignore. This happens in some error situations, and 14794 -- also for some internally generated structures where no end label 14795 -- references are required in any case. 14796 14797 if No (N) then 14798 return; 14799 end if; 14800 14801 -- Nothing to do if no End_Label, happens for internally generated 14802 -- constructs where we don't want an end label reference anyway. Also 14803 -- nothing to do if Endl is a string literal, which means there was 14804 -- some prior error (bad operator symbol) 14805 14806 Endl := End_Label (N); 14807 14808 if No (Endl) or else Nkind (Endl) = N_String_Literal then 14809 return; 14810 end if; 14811 14812 -- Reference node is not in extended main source unit 14813 14814 if not In_Extended_Main_Source_Unit (N) then 14815 14816 -- Generally we do not collect references except for the extended 14817 -- main source unit. The one exception is the 'e' entry for a 14818 -- package spec, where it is useful for a client to have the 14819 -- ending information to define scopes. 14820 14821 if Typ /= 'e' then 14822 return; 14823 14824 else 14825 Label_Ref := False; 14826 14827 -- For this case, we can ignore any parent references, but we 14828 -- need the package name itself for the 'e' entry. 14829 14830 if Nkind (Endl) = N_Designator then 14831 Endl := Identifier (Endl); 14832 end if; 14833 end if; 14834 14835 -- Reference is in extended main source unit 14836 14837 else 14838 Label_Ref := True; 14839 14840 -- For designator, generate references for the parent entries 14841 14842 if Nkind (Endl) = N_Designator then 14843 14844 -- Generate references for the prefix if the END line comes from 14845 -- source (otherwise we do not need these references) We climb the 14846 -- scope stack to find the expected entities. 14847 14848 if Comes_From_Source (Endl) then 14849 Nam := Name (Endl); 14850 Scop := Current_Scope; 14851 while Nkind (Nam) = N_Selected_Component loop 14852 Scop := Scope (Scop); 14853 exit when No (Scop); 14854 Generate_Parent_Ref (Selector_Name (Nam), Scop); 14855 Nam := Prefix (Nam); 14856 end loop; 14857 14858 if Present (Scop) then 14859 Generate_Parent_Ref (Nam, Scope (Scop)); 14860 end if; 14861 end if; 14862 14863 Endl := Identifier (Endl); 14864 end if; 14865 end if; 14866 14867 -- If the end label is not for the given entity, then either we have 14868 -- some previous error, or this is a generic instantiation for which 14869 -- we do not need to make a cross-reference in this case anyway. In 14870 -- either case we simply ignore the call. 14871 14872 if Chars (Ent) /= Chars (Endl) then 14873 return; 14874 end if; 14875 14876 -- If label was really there, then generate a normal reference and then 14877 -- adjust the location in the end label to point past the name (which 14878 -- should almost always be the semicolon). 14879 14880 Loc := Sloc (Endl); 14881 14882 if Comes_From_Source (Endl) then 14883 14884 -- If a label reference is required, then do the style check and 14885 -- generate an l-type cross-reference entry for the label 14886 14887 if Label_Ref then 14888 if Style_Check then 14889 Style.Check_Identifier (Endl, Ent); 14890 end if; 14891 14892 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 14893 end if; 14894 14895 -- Set the location to point past the label (normally this will 14896 -- mean the semicolon immediately following the label). This is 14897 -- done for the sake of the 'e' or 't' entry generated below. 14898 14899 Get_Decoded_Name_String (Chars (Endl)); 14900 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 14901 14902 else 14903 -- In SPARK mode, no missing label is allowed for packages and 14904 -- subprogram bodies. Detect those cases by testing whether 14905 -- Process_End_Label was called for a body (Typ = 't') or a package. 14906 14907 if Restriction_Check_Required (SPARK_05) 14908 and then (Typ = 't' or else Ekind (Ent) = E_Package) 14909 then 14910 Error_Msg_Node_1 := Endl; 14911 Check_SPARK_Restriction ("`END &` required", Endl, Force => True); 14912 end if; 14913 end if; 14914 14915 -- Now generate the e/t reference 14916 14917 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 14918 14919 -- Restore Sloc, in case modified above, since we have an identifier 14920 -- and the normal Sloc should be left set in the tree. 14921 14922 Set_Sloc (Endl, Loc); 14923 end Process_End_Label; 14924 14925 ---------------- 14926 -- Referenced -- 14927 ---------------- 14928 14929 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 14930 Seen : Boolean := False; 14931 14932 function Is_Reference (N : Node_Id) return Traverse_Result; 14933 -- Determine whether node N denotes a reference to Id. If this is the 14934 -- case, set global flag Seen to True and stop the traversal. 14935 14936 ------------------ 14937 -- Is_Reference -- 14938 ------------------ 14939 14940 function Is_Reference (N : Node_Id) return Traverse_Result is 14941 begin 14942 if Is_Entity_Name (N) 14943 and then Present (Entity (N)) 14944 and then Entity (N) = Id 14945 then 14946 Seen := True; 14947 return Abandon; 14948 else 14949 return OK; 14950 end if; 14951 end Is_Reference; 14952 14953 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 14954 14955 -- Start of processing for Referenced 14956 14957 begin 14958 Inspect_Expression (Expr); 14959 return Seen; 14960 end Referenced; 14961 14962 ------------------------------------ 14963 -- References_Generic_Formal_Type -- 14964 ------------------------------------ 14965 14966 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 14967 14968 function Process (N : Node_Id) return Traverse_Result; 14969 -- Process one node in search for generic formal type 14970 14971 ------------- 14972 -- Process -- 14973 ------------- 14974 14975 function Process (N : Node_Id) return Traverse_Result is 14976 begin 14977 if Nkind (N) in N_Has_Entity then 14978 declare 14979 E : constant Entity_Id := Entity (N); 14980 begin 14981 if Present (E) then 14982 if Is_Generic_Type (E) then 14983 return Abandon; 14984 elsif Present (Etype (E)) 14985 and then Is_Generic_Type (Etype (E)) 14986 then 14987 return Abandon; 14988 end if; 14989 end if; 14990 end; 14991 end if; 14992 14993 return Atree.OK; 14994 end Process; 14995 14996 function Traverse is new Traverse_Func (Process); 14997 -- Traverse tree to look for generic type 14998 14999 begin 15000 if Inside_A_Generic then 15001 return Traverse (N) = Abandon; 15002 else 15003 return False; 15004 end if; 15005 end References_Generic_Formal_Type; 15006 15007 -------------------- 15008 -- Remove_Homonym -- 15009 -------------------- 15010 15011 procedure Remove_Homonym (E : Entity_Id) is 15012 Prev : Entity_Id := Empty; 15013 H : Entity_Id; 15014 15015 begin 15016 if E = Current_Entity (E) then 15017 if Present (Homonym (E)) then 15018 Set_Current_Entity (Homonym (E)); 15019 else 15020 Set_Name_Entity_Id (Chars (E), Empty); 15021 end if; 15022 15023 else 15024 H := Current_Entity (E); 15025 while Present (H) and then H /= E loop 15026 Prev := H; 15027 H := Homonym (H); 15028 end loop; 15029 15030 -- If E is not on the homonym chain, nothing to do 15031 15032 if Present (H) then 15033 Set_Homonym (Prev, Homonym (E)); 15034 end if; 15035 end if; 15036 end Remove_Homonym; 15037 15038 --------------------- 15039 -- Rep_To_Pos_Flag -- 15040 --------------------- 15041 15042 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 15043 begin 15044 return New_Occurrence_Of 15045 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 15046 end Rep_To_Pos_Flag; 15047 15048 -------------------- 15049 -- Require_Entity -- 15050 -------------------- 15051 15052 procedure Require_Entity (N : Node_Id) is 15053 begin 15054 if Is_Entity_Name (N) and then No (Entity (N)) then 15055 if Total_Errors_Detected /= 0 then 15056 Set_Entity (N, Any_Id); 15057 else 15058 raise Program_Error; 15059 end if; 15060 end if; 15061 end Require_Entity; 15062 15063 ------------------------------- 15064 -- Requires_State_Refinement -- 15065 ------------------------------- 15066 15067 function Requires_State_Refinement 15068 (Spec_Id : Entity_Id; 15069 Body_Id : Entity_Id) return Boolean 15070 is 15071 function Mode_Is_Off (Prag : Node_Id) return Boolean; 15072 -- Given pragma SPARK_Mode, determine whether the mode is Off 15073 15074 ----------------- 15075 -- Mode_Is_Off -- 15076 ----------------- 15077 15078 function Mode_Is_Off (Prag : Node_Id) return Boolean is 15079 Mode : Node_Id; 15080 15081 begin 15082 -- The default SPARK mode is On 15083 15084 if No (Prag) then 15085 return False; 15086 end if; 15087 15088 Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 15089 15090 -- Then the pragma lacks an argument, the default mode is On 15091 15092 if No (Mode) then 15093 return False; 15094 else 15095 return Chars (Mode) = Name_Off; 15096 end if; 15097 end Mode_Is_Off; 15098 15099 -- Start of processing for Requires_State_Refinement 15100 15101 begin 15102 -- A package that does not define at least one abstract state cannot 15103 -- possibly require refinement. 15104 15105 if No (Abstract_States (Spec_Id)) then 15106 return False; 15107 15108 -- The package instroduces a single null state which does not merit 15109 -- refinement. 15110 15111 elsif Has_Null_Abstract_State (Spec_Id) then 15112 return False; 15113 15114 -- Check whether the package body is subject to pragma SPARK_Mode. If 15115 -- it is and the mode is Off, the package body is considered to be in 15116 -- regular Ada and does not require refinement. 15117 15118 elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then 15119 return False; 15120 15121 -- The body's SPARK_Mode may be inherited from a similar pragma that 15122 -- appears in the private declarations of the spec. The pragma we are 15123 -- interested appears as the second entry in SPARK_Pragma. 15124 15125 elsif Present (SPARK_Pragma (Spec_Id)) 15126 and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id))) 15127 then 15128 return False; 15129 15130 -- The spec defines at least one abstract state and the body has no way 15131 -- of circumventing the refinement. 15132 15133 else 15134 return True; 15135 end if; 15136 end Requires_State_Refinement; 15137 15138 ------------------------------ 15139 -- Requires_Transient_Scope -- 15140 ------------------------------ 15141 15142 -- A transient scope is required when variable-sized temporaries are 15143 -- allocated in the primary or secondary stack, or when finalization 15144 -- actions must be generated before the next instruction. 15145 15146 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 15147 Typ : constant Entity_Id := Underlying_Type (Id); 15148 15149 -- Start of processing for Requires_Transient_Scope 15150 15151 begin 15152 -- This is a private type which is not completed yet. This can only 15153 -- happen in a default expression (of a formal parameter or of a 15154 -- record component). Do not expand transient scope in this case 15155 15156 if No (Typ) then 15157 return False; 15158 15159 -- Do not expand transient scope for non-existent procedure return 15160 15161 elsif Typ = Standard_Void_Type then 15162 return False; 15163 15164 -- Elementary types do not require a transient scope 15165 15166 elsif Is_Elementary_Type (Typ) then 15167 return False; 15168 15169 -- Generally, indefinite subtypes require a transient scope, since the 15170 -- back end cannot generate temporaries, since this is not a valid type 15171 -- for declaring an object. It might be possible to relax this in the 15172 -- future, e.g. by declaring the maximum possible space for the type. 15173 15174 elsif Is_Indefinite_Subtype (Typ) then 15175 return True; 15176 15177 -- Functions returning tagged types may dispatch on result so their 15178 -- returned value is allocated on the secondary stack. Controlled 15179 -- type temporaries need finalization. 15180 15181 elsif Is_Tagged_Type (Typ) 15182 or else Has_Controlled_Component (Typ) 15183 then 15184 return not Is_Value_Type (Typ); 15185 15186 -- Record type 15187 15188 elsif Is_Record_Type (Typ) then 15189 declare 15190 Comp : Entity_Id; 15191 begin 15192 Comp := First_Entity (Typ); 15193 while Present (Comp) loop 15194 if Ekind (Comp) = E_Component 15195 and then Requires_Transient_Scope (Etype (Comp)) 15196 then 15197 return True; 15198 else 15199 Next_Entity (Comp); 15200 end if; 15201 end loop; 15202 end; 15203 15204 return False; 15205 15206 -- String literal types never require transient scope 15207 15208 elsif Ekind (Typ) = E_String_Literal_Subtype then 15209 return False; 15210 15211 -- Array type. Note that we already know that this is a constrained 15212 -- array, since unconstrained arrays will fail the indefinite test. 15213 15214 elsif Is_Array_Type (Typ) then 15215 15216 -- If component type requires a transient scope, the array does too 15217 15218 if Requires_Transient_Scope (Component_Type (Typ)) then 15219 return True; 15220 15221 -- Otherwise, we only need a transient scope if the size depends on 15222 -- the value of one or more discriminants. 15223 15224 else 15225 return Size_Depends_On_Discriminant (Typ); 15226 end if; 15227 15228 -- All other cases do not require a transient scope 15229 15230 else 15231 return False; 15232 end if; 15233 end Requires_Transient_Scope; 15234 15235 -------------------------- 15236 -- Reset_Analyzed_Flags -- 15237 -------------------------- 15238 15239 procedure Reset_Analyzed_Flags (N : Node_Id) is 15240 15241 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 15242 -- Function used to reset Analyzed flags in tree. Note that we do 15243 -- not reset Analyzed flags in entities, since there is no need to 15244 -- reanalyze entities, and indeed, it is wrong to do so, since it 15245 -- can result in generating auxiliary stuff more than once. 15246 15247 -------------------- 15248 -- Clear_Analyzed -- 15249 -------------------- 15250 15251 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 15252 begin 15253 if not Has_Extension (N) then 15254 Set_Analyzed (N, False); 15255 end if; 15256 15257 return OK; 15258 end Clear_Analyzed; 15259 15260 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 15261 15262 -- Start of processing for Reset_Analyzed_Flags 15263 15264 begin 15265 Reset_Analyzed (N); 15266 end Reset_Analyzed_Flags; 15267 15268 -------------------------------- 15269 -- Returns_Unconstrained_Type -- 15270 -------------------------------- 15271 15272 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 15273 begin 15274 return Ekind (Subp) = E_Function 15275 and then not Is_Scalar_Type (Etype (Subp)) 15276 and then not Is_Access_Type (Etype (Subp)) 15277 and then not Is_Constrained (Etype (Subp)); 15278 end Returns_Unconstrained_Type; 15279 15280 --------------------------- 15281 -- Safe_To_Capture_Value -- 15282 --------------------------- 15283 15284 function Safe_To_Capture_Value 15285 (N : Node_Id; 15286 Ent : Entity_Id; 15287 Cond : Boolean := False) return Boolean 15288 is 15289 begin 15290 -- The only entities for which we track constant values are variables 15291 -- which are not renamings, constants, out parameters, and in out 15292 -- parameters, so check if we have this case. 15293 15294 -- Note: it may seem odd to track constant values for constants, but in 15295 -- fact this routine is used for other purposes than simply capturing 15296 -- the value. In particular, the setting of Known[_Non]_Null. 15297 15298 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 15299 or else 15300 Ekind (Ent) = E_Constant 15301 or else 15302 Ekind (Ent) = E_Out_Parameter 15303 or else 15304 Ekind (Ent) = E_In_Out_Parameter 15305 then 15306 null; 15307 15308 -- For conditionals, we also allow loop parameters and all formals, 15309 -- including in parameters. 15310 15311 elsif Cond 15312 and then 15313 (Ekind (Ent) = E_Loop_Parameter 15314 or else 15315 Ekind (Ent) = E_In_Parameter) 15316 then 15317 null; 15318 15319 -- For all other cases, not just unsafe, but impossible to capture 15320 -- Current_Value, since the above are the only entities which have 15321 -- Current_Value fields. 15322 15323 else 15324 return False; 15325 end if; 15326 15327 -- Skip if volatile or aliased, since funny things might be going on in 15328 -- these cases which we cannot necessarily track. Also skip any variable 15329 -- for which an address clause is given, or whose address is taken. Also 15330 -- never capture value of library level variables (an attempt to do so 15331 -- can occur in the case of package elaboration code). 15332 15333 if Treat_As_Volatile (Ent) 15334 or else Is_Aliased (Ent) 15335 or else Present (Address_Clause (Ent)) 15336 or else Address_Taken (Ent) 15337 or else (Is_Library_Level_Entity (Ent) 15338 and then Ekind (Ent) = E_Variable) 15339 then 15340 return False; 15341 end if; 15342 15343 -- OK, all above conditions are met. We also require that the scope of 15344 -- the reference be the same as the scope of the entity, not counting 15345 -- packages and blocks and loops. 15346 15347 declare 15348 E_Scope : constant Entity_Id := Scope (Ent); 15349 R_Scope : Entity_Id; 15350 15351 begin 15352 R_Scope := Current_Scope; 15353 while R_Scope /= Standard_Standard loop 15354 exit when R_Scope = E_Scope; 15355 15356 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 15357 return False; 15358 else 15359 R_Scope := Scope (R_Scope); 15360 end if; 15361 end loop; 15362 end; 15363 15364 -- We also require that the reference does not appear in a context 15365 -- where it is not sure to be executed (i.e. a conditional context 15366 -- or an exception handler). We skip this if Cond is True, since the 15367 -- capturing of values from conditional tests handles this ok. 15368 15369 if Cond then 15370 return True; 15371 end if; 15372 15373 declare 15374 Desc : Node_Id; 15375 P : Node_Id; 15376 15377 begin 15378 Desc := N; 15379 15380 -- Seems dubious that case expressions are not handled here ??? 15381 15382 P := Parent (N); 15383 while Present (P) loop 15384 if Nkind (P) = N_If_Statement 15385 or else Nkind (P) = N_Case_Statement 15386 or else (Nkind (P) in N_Short_Circuit 15387 and then Desc = Right_Opnd (P)) 15388 or else (Nkind (P) = N_If_Expression 15389 and then Desc /= First (Expressions (P))) 15390 or else Nkind (P) = N_Exception_Handler 15391 or else Nkind (P) = N_Selective_Accept 15392 or else Nkind (P) = N_Conditional_Entry_Call 15393 or else Nkind (P) = N_Timed_Entry_Call 15394 or else Nkind (P) = N_Asynchronous_Select 15395 then 15396 return False; 15397 else 15398 Desc := P; 15399 P := Parent (P); 15400 15401 -- A special Ada 2012 case: the original node may be part 15402 -- of the else_actions of a conditional expression, in which 15403 -- case it might not have been expanded yet, and appears in 15404 -- a non-syntactic list of actions. In that case it is clearly 15405 -- not safe to save a value. 15406 15407 if No (P) 15408 and then Is_List_Member (Desc) 15409 and then No (Parent (List_Containing (Desc))) 15410 then 15411 return False; 15412 end if; 15413 end if; 15414 end loop; 15415 end; 15416 15417 -- OK, looks safe to set value 15418 15419 return True; 15420 end Safe_To_Capture_Value; 15421 15422 --------------- 15423 -- Same_Name -- 15424 --------------- 15425 15426 function Same_Name (N1, N2 : Node_Id) return Boolean is 15427 K1 : constant Node_Kind := Nkind (N1); 15428 K2 : constant Node_Kind := Nkind (N2); 15429 15430 begin 15431 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 15432 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 15433 then 15434 return Chars (N1) = Chars (N2); 15435 15436 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 15437 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 15438 then 15439 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 15440 and then Same_Name (Prefix (N1), Prefix (N2)); 15441 15442 else 15443 return False; 15444 end if; 15445 end Same_Name; 15446 15447 ----------------- 15448 -- Same_Object -- 15449 ----------------- 15450 15451 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 15452 N1 : constant Node_Id := Original_Node (Node1); 15453 N2 : constant Node_Id := Original_Node (Node2); 15454 -- We do the tests on original nodes, since we are most interested 15455 -- in the original source, not any expansion that got in the way. 15456 15457 K1 : constant Node_Kind := Nkind (N1); 15458 K2 : constant Node_Kind := Nkind (N2); 15459 15460 begin 15461 -- First case, both are entities with same entity 15462 15463 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 15464 declare 15465 EN1 : constant Entity_Id := Entity (N1); 15466 EN2 : constant Entity_Id := Entity (N2); 15467 begin 15468 if Present (EN1) and then Present (EN2) 15469 and then (Ekind_In (EN1, E_Variable, E_Constant) 15470 or else Is_Formal (EN1)) 15471 and then EN1 = EN2 15472 then 15473 return True; 15474 end if; 15475 end; 15476 end if; 15477 15478 -- Second case, selected component with same selector, same record 15479 15480 if K1 = N_Selected_Component 15481 and then K2 = N_Selected_Component 15482 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 15483 then 15484 return Same_Object (Prefix (N1), Prefix (N2)); 15485 15486 -- Third case, indexed component with same subscripts, same array 15487 15488 elsif K1 = N_Indexed_Component 15489 and then K2 = N_Indexed_Component 15490 and then Same_Object (Prefix (N1), Prefix (N2)) 15491 then 15492 declare 15493 E1, E2 : Node_Id; 15494 begin 15495 E1 := First (Expressions (N1)); 15496 E2 := First (Expressions (N2)); 15497 while Present (E1) loop 15498 if not Same_Value (E1, E2) then 15499 return False; 15500 else 15501 Next (E1); 15502 Next (E2); 15503 end if; 15504 end loop; 15505 15506 return True; 15507 end; 15508 15509 -- Fourth case, slice of same array with same bounds 15510 15511 elsif K1 = N_Slice 15512 and then K2 = N_Slice 15513 and then Nkind (Discrete_Range (N1)) = N_Range 15514 and then Nkind (Discrete_Range (N2)) = N_Range 15515 and then Same_Value (Low_Bound (Discrete_Range (N1)), 15516 Low_Bound (Discrete_Range (N2))) 15517 and then Same_Value (High_Bound (Discrete_Range (N1)), 15518 High_Bound (Discrete_Range (N2))) 15519 then 15520 return Same_Name (Prefix (N1), Prefix (N2)); 15521 15522 -- All other cases, not clearly the same object 15523 15524 else 15525 return False; 15526 end if; 15527 end Same_Object; 15528 15529 --------------- 15530 -- Same_Type -- 15531 --------------- 15532 15533 function Same_Type (T1, T2 : Entity_Id) return Boolean is 15534 begin 15535 if T1 = T2 then 15536 return True; 15537 15538 elsif not Is_Constrained (T1) 15539 and then not Is_Constrained (T2) 15540 and then Base_Type (T1) = Base_Type (T2) 15541 then 15542 return True; 15543 15544 -- For now don't bother with case of identical constraints, to be 15545 -- fiddled with later on perhaps (this is only used for optimization 15546 -- purposes, so it is not critical to do a best possible job) 15547 15548 else 15549 return False; 15550 end if; 15551 end Same_Type; 15552 15553 ---------------- 15554 -- Same_Value -- 15555 ---------------- 15556 15557 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 15558 begin 15559 if Compile_Time_Known_Value (Node1) 15560 and then Compile_Time_Known_Value (Node2) 15561 and then Expr_Value (Node1) = Expr_Value (Node2) 15562 then 15563 return True; 15564 elsif Same_Object (Node1, Node2) then 15565 return True; 15566 else 15567 return False; 15568 end if; 15569 end Same_Value; 15570 15571 ------------------------ 15572 -- Scope_Is_Transient -- 15573 ------------------------ 15574 15575 function Scope_Is_Transient return Boolean is 15576 begin 15577 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 15578 end Scope_Is_Transient; 15579 15580 ------------------ 15581 -- Scope_Within -- 15582 ------------------ 15583 15584 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is 15585 Scop : Entity_Id; 15586 15587 begin 15588 Scop := Scope1; 15589 while Scop /= Standard_Standard loop 15590 Scop := Scope (Scop); 15591 15592 if Scop = Scope2 then 15593 return True; 15594 end if; 15595 end loop; 15596 15597 return False; 15598 end Scope_Within; 15599 15600 -------------------------- 15601 -- Scope_Within_Or_Same -- 15602 -------------------------- 15603 15604 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is 15605 Scop : Entity_Id; 15606 15607 begin 15608 Scop := Scope1; 15609 while Scop /= Standard_Standard loop 15610 if Scop = Scope2 then 15611 return True; 15612 else 15613 Scop := Scope (Scop); 15614 end if; 15615 end loop; 15616 15617 return False; 15618 end Scope_Within_Or_Same; 15619 15620 -------------------- 15621 -- Set_Convention -- 15622 -------------------- 15623 15624 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 15625 begin 15626 Basic_Set_Convention (E, Val); 15627 15628 if Is_Type (E) 15629 and then Is_Access_Subprogram_Type (Base_Type (E)) 15630 and then Has_Foreign_Convention (E) 15631 then 15632 Set_Can_Use_Internal_Rep (E, False); 15633 end if; 15634 15635 -- If E is an object or component, and the type of E is an anonymous 15636 -- access type with no convention set, then also set the convention of 15637 -- the anonymous access type. We do not do this for anonymous protected 15638 -- types, since protected types always have the default convention. 15639 15640 if Present (Etype (E)) 15641 and then (Is_Object (E) 15642 or else Ekind (E) = E_Component 15643 15644 -- Allow E_Void (happens for pragma Convention appearing 15645 -- in the middle of a record applying to a component) 15646 15647 or else Ekind (E) = E_Void) 15648 then 15649 declare 15650 Typ : constant Entity_Id := Etype (E); 15651 15652 begin 15653 if Ekind_In (Typ, E_Anonymous_Access_Type, 15654 E_Anonymous_Access_Subprogram_Type) 15655 and then not Has_Convention_Pragma (Typ) 15656 then 15657 Basic_Set_Convention (Typ, Val); 15658 Set_Has_Convention_Pragma (Typ); 15659 15660 -- And for the access subprogram type, deal similarly with the 15661 -- designated E_Subprogram_Type if it is also internal (which 15662 -- it always is?) 15663 15664 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 15665 declare 15666 Dtype : constant Entity_Id := Designated_Type (Typ); 15667 begin 15668 if Ekind (Dtype) = E_Subprogram_Type 15669 and then Is_Itype (Dtype) 15670 and then not Has_Convention_Pragma (Dtype) 15671 then 15672 Basic_Set_Convention (Dtype, Val); 15673 Set_Has_Convention_Pragma (Dtype); 15674 end if; 15675 end; 15676 end if; 15677 end if; 15678 end; 15679 end if; 15680 end Set_Convention; 15681 15682 ------------------------ 15683 -- Set_Current_Entity -- 15684 ------------------------ 15685 15686 -- The given entity is to be set as the currently visible definition of its 15687 -- associated name (i.e. the Node_Id associated with its name). All we have 15688 -- to do is to get the name from the identifier, and then set the 15689 -- associated Node_Id to point to the given entity. 15690 15691 procedure Set_Current_Entity (E : Entity_Id) is 15692 begin 15693 Set_Name_Entity_Id (Chars (E), E); 15694 end Set_Current_Entity; 15695 15696 --------------------------- 15697 -- Set_Debug_Info_Needed -- 15698 --------------------------- 15699 15700 procedure Set_Debug_Info_Needed (T : Entity_Id) is 15701 15702 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 15703 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 15704 -- Used to set debug info in a related node if not set already 15705 15706 -------------------------------------- 15707 -- Set_Debug_Info_Needed_If_Not_Set -- 15708 -------------------------------------- 15709 15710 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 15711 begin 15712 if Present (E) 15713 and then not Needs_Debug_Info (E) 15714 then 15715 Set_Debug_Info_Needed (E); 15716 15717 -- For a private type, indicate that the full view also needs 15718 -- debug information. 15719 15720 if Is_Type (E) 15721 and then Is_Private_Type (E) 15722 and then Present (Full_View (E)) 15723 then 15724 Set_Debug_Info_Needed (Full_View (E)); 15725 end if; 15726 end if; 15727 end Set_Debug_Info_Needed_If_Not_Set; 15728 15729 -- Start of processing for Set_Debug_Info_Needed 15730 15731 begin 15732 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which 15733 -- indicates that Debug_Info_Needed is never required for the entity. 15734 15735 if No (T) 15736 or else Debug_Info_Off (T) 15737 then 15738 return; 15739 end if; 15740 15741 -- Set flag in entity itself. Note that we will go through the following 15742 -- circuitry even if the flag is already set on T. That's intentional, 15743 -- it makes sure that the flag will be set in subsidiary entities. 15744 15745 Set_Needs_Debug_Info (T); 15746 15747 -- Set flag on subsidiary entities if not set already 15748 15749 if Is_Object (T) then 15750 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 15751 15752 elsif Is_Type (T) then 15753 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 15754 15755 if Is_Record_Type (T) then 15756 declare 15757 Ent : Entity_Id := First_Entity (T); 15758 begin 15759 while Present (Ent) loop 15760 Set_Debug_Info_Needed_If_Not_Set (Ent); 15761 Next_Entity (Ent); 15762 end loop; 15763 end; 15764 15765 -- For a class wide subtype, we also need debug information 15766 -- for the equivalent type. 15767 15768 if Ekind (T) = E_Class_Wide_Subtype then 15769 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 15770 end if; 15771 15772 elsif Is_Array_Type (T) then 15773 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 15774 15775 declare 15776 Indx : Node_Id := First_Index (T); 15777 begin 15778 while Present (Indx) loop 15779 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 15780 Indx := Next_Index (Indx); 15781 end loop; 15782 end; 15783 15784 -- For a packed array type, we also need debug information for 15785 -- the type used to represent the packed array. Conversely, we 15786 -- also need it for the former if we need it for the latter. 15787 15788 if Is_Packed (T) then 15789 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); 15790 end if; 15791 15792 if Is_Packed_Array_Type (T) then 15793 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 15794 end if; 15795 15796 elsif Is_Access_Type (T) then 15797 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 15798 15799 elsif Is_Private_Type (T) then 15800 Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); 15801 15802 elsif Is_Protected_Type (T) then 15803 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 15804 end if; 15805 end if; 15806 end Set_Debug_Info_Needed; 15807 15808 ---------------------------- 15809 -- Set_Entity_With_Checks -- 15810 ---------------------------- 15811 15812 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 15813 Val_Actual : Entity_Id; 15814 Nod : Node_Id; 15815 Post_Node : Node_Id; 15816 15817 begin 15818 -- Unconditionally set the entity 15819 15820 Set_Entity (N, Val); 15821 15822 -- Remaining checks are only done on source nodes 15823 15824 if not Comes_From_Source (N) then 15825 return; 15826 end if; 15827 15828 -- The node to post on is the selector in the case of an expanded name, 15829 -- and otherwise the node itself. 15830 15831 if Nkind (N) = N_Expanded_Name then 15832 Post_Node := Selector_Name (N); 15833 else 15834 Post_Node := N; 15835 end if; 15836 15837 -- Check for violation of No_Abort_Statements, which is triggered by 15838 -- call to Ada.Task_Identification.Abort_Task. 15839 15840 if Restriction_Check_Required (No_Abort_Statements) 15841 and then (Is_RTE (Val, RE_Abort_Task)) 15842 then 15843 Check_Restriction (No_Abort_Statements, Post_Node); 15844 end if; 15845 15846 -- Check for violation of No_Dynamic_Attachment 15847 15848 if Restriction_Check_Required (No_Dynamic_Attachment) 15849 and then RTU_Loaded (Ada_Interrupts) 15850 and then (Is_RTE (Val, RE_Is_Reserved) or else 15851 Is_RTE (Val, RE_Is_Attached) or else 15852 Is_RTE (Val, RE_Current_Handler) or else 15853 Is_RTE (Val, RE_Attach_Handler) or else 15854 Is_RTE (Val, RE_Exchange_Handler) or else 15855 Is_RTE (Val, RE_Detach_Handler) or else 15856 Is_RTE (Val, RE_Reference)) 15857 then 15858 Check_Restriction (No_Dynamic_Attachment, Post_Node); 15859 end if; 15860 15861 -- Check for No_Implementation_Identifiers 15862 15863 if Restriction_Check_Required (No_Implementation_Identifiers) then 15864 15865 -- We have an implementation defined entity if it is marked as 15866 -- implementation defined, or is defined in a package marked as 15867 -- implementation defined. However, library packages themselves 15868 -- are excluded (we don't want to flag Interfaces itself, just 15869 -- the entities within it). 15870 15871 if (Is_Implementation_Defined (Val) 15872 or else 15873 Is_Implementation_Defined (Scope (Val))) 15874 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 15875 and then Is_Library_Level_Entity (Val)) 15876 then 15877 Check_Restriction (No_Implementation_Identifiers, Post_Node); 15878 end if; 15879 end if; 15880 15881 -- Do the style check 15882 15883 if Style_Check 15884 and then not Suppress_Style_Checks (Val) 15885 and then not In_Instance 15886 then 15887 if Nkind (N) = N_Identifier then 15888 Nod := N; 15889 elsif Nkind (N) = N_Expanded_Name then 15890 Nod := Selector_Name (N); 15891 else 15892 return; 15893 end if; 15894 15895 -- A special situation arises for derived operations, where we want 15896 -- to do the check against the parent (since the Sloc of the derived 15897 -- operation points to the derived type declaration itself). 15898 15899 Val_Actual := Val; 15900 while not Comes_From_Source (Val_Actual) 15901 and then Nkind (Val_Actual) in N_Entity 15902 and then (Ekind (Val_Actual) = E_Enumeration_Literal 15903 or else Is_Subprogram (Val_Actual) 15904 or else Is_Generic_Subprogram (Val_Actual)) 15905 and then Present (Alias (Val_Actual)) 15906 loop 15907 Val_Actual := Alias (Val_Actual); 15908 end loop; 15909 15910 -- Renaming declarations for generic actuals do not come from source, 15911 -- and have a different name from that of the entity they rename, so 15912 -- there is no style check to perform here. 15913 15914 if Chars (Nod) = Chars (Val_Actual) then 15915 Style.Check_Identifier (Nod, Val_Actual); 15916 end if; 15917 end if; 15918 15919 Set_Entity (N, Val); 15920 end Set_Entity_With_Checks; 15921 15922 ------------------------ 15923 -- Set_Name_Entity_Id -- 15924 ------------------------ 15925 15926 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 15927 begin 15928 Set_Name_Table_Info (Id, Int (Val)); 15929 end Set_Name_Entity_Id; 15930 15931 --------------------- 15932 -- Set_Next_Actual -- 15933 --------------------- 15934 15935 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 15936 begin 15937 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 15938 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 15939 end if; 15940 end Set_Next_Actual; 15941 15942 ---------------------------------- 15943 -- Set_Optimize_Alignment_Flags -- 15944 ---------------------------------- 15945 15946 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 15947 begin 15948 if Optimize_Alignment = 'S' then 15949 Set_Optimize_Alignment_Space (E); 15950 elsif Optimize_Alignment = 'T' then 15951 Set_Optimize_Alignment_Time (E); 15952 end if; 15953 end Set_Optimize_Alignment_Flags; 15954 15955 ----------------------- 15956 -- Set_Public_Status -- 15957 ----------------------- 15958 15959 procedure Set_Public_Status (Id : Entity_Id) is 15960 S : constant Entity_Id := Current_Scope; 15961 15962 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 15963 -- Determines if E is defined within handled statement sequence or 15964 -- an if statement, returns True if so, False otherwise. 15965 15966 ---------------------- 15967 -- Within_HSS_Or_If -- 15968 ---------------------- 15969 15970 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 15971 N : Node_Id; 15972 begin 15973 N := Declaration_Node (E); 15974 loop 15975 N := Parent (N); 15976 15977 if No (N) then 15978 return False; 15979 15980 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 15981 N_If_Statement) 15982 then 15983 return True; 15984 end if; 15985 end loop; 15986 end Within_HSS_Or_If; 15987 15988 -- Start of processing for Set_Public_Status 15989 15990 begin 15991 -- Everything in the scope of Standard is public 15992 15993 if S = Standard_Standard then 15994 Set_Is_Public (Id); 15995 15996 -- Entity is definitely not public if enclosing scope is not public 15997 15998 elsif not Is_Public (S) then 15999 return; 16000 16001 -- An object or function declaration that occurs in a handled sequence 16002 -- of statements or within an if statement is the declaration for a 16003 -- temporary object or local subprogram generated by the expander. It 16004 -- never needs to be made public and furthermore, making it public can 16005 -- cause back end problems. 16006 16007 elsif Nkind_In (Parent (Id), N_Object_Declaration, 16008 N_Function_Specification) 16009 and then Within_HSS_Or_If (Id) 16010 then 16011 return; 16012 16013 -- Entities in public packages or records are public 16014 16015 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 16016 Set_Is_Public (Id); 16017 16018 -- The bounds of an entry family declaration can generate object 16019 -- declarations that are visible to the back-end, e.g. in the 16020 -- the declaration of a composite type that contains tasks. 16021 16022 elsif Is_Concurrent_Type (S) 16023 and then not Has_Completion (S) 16024 and then Nkind (Parent (Id)) = N_Object_Declaration 16025 then 16026 Set_Is_Public (Id); 16027 end if; 16028 end Set_Public_Status; 16029 16030 ----------------------------- 16031 -- Set_Referenced_Modified -- 16032 ----------------------------- 16033 16034 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 16035 Pref : Node_Id; 16036 16037 begin 16038 -- Deal with indexed or selected component where prefix is modified 16039 16040 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 16041 Pref := Prefix (N); 16042 16043 -- If prefix is access type, then it is the designated object that is 16044 -- being modified, which means we have no entity to set the flag on. 16045 16046 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 16047 return; 16048 16049 -- Otherwise chase the prefix 16050 16051 else 16052 Set_Referenced_Modified (Pref, Out_Param); 16053 end if; 16054 16055 -- Otherwise see if we have an entity name (only other case to process) 16056 16057 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 16058 Set_Referenced_As_LHS (Entity (N), not Out_Param); 16059 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 16060 end if; 16061 end Set_Referenced_Modified; 16062 16063 ---------------------------- 16064 -- Set_Scope_Is_Transient -- 16065 ---------------------------- 16066 16067 procedure Set_Scope_Is_Transient (V : Boolean := True) is 16068 begin 16069 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 16070 end Set_Scope_Is_Transient; 16071 16072 ------------------- 16073 -- Set_Size_Info -- 16074 ------------------- 16075 16076 procedure Set_Size_Info (T1, T2 : Entity_Id) is 16077 begin 16078 -- We copy Esize, but not RM_Size, since in general RM_Size is 16079 -- subtype specific and does not get inherited by all subtypes. 16080 16081 Set_Esize (T1, Esize (T2)); 16082 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 16083 16084 if Is_Discrete_Or_Fixed_Point_Type (T1) 16085 and then 16086 Is_Discrete_Or_Fixed_Point_Type (T2) 16087 then 16088 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 16089 end if; 16090 16091 Set_Alignment (T1, Alignment (T2)); 16092 end Set_Size_Info; 16093 16094 -------------------- 16095 -- Static_Boolean -- 16096 -------------------- 16097 16098 function Static_Boolean (N : Node_Id) return Uint is 16099 begin 16100 Analyze_And_Resolve (N, Standard_Boolean); 16101 16102 if N = Error 16103 or else Error_Posted (N) 16104 or else Etype (N) = Any_Type 16105 then 16106 return No_Uint; 16107 end if; 16108 16109 if Is_Static_Expression (N) then 16110 if not Raises_Constraint_Error (N) then 16111 return Expr_Value (N); 16112 else 16113 return No_Uint; 16114 end if; 16115 16116 elsif Etype (N) = Any_Type then 16117 return No_Uint; 16118 16119 else 16120 Flag_Non_Static_Expr 16121 ("static boolean expression required here", N); 16122 return No_Uint; 16123 end if; 16124 end Static_Boolean; 16125 16126 -------------------- 16127 -- Static_Integer -- 16128 -------------------- 16129 16130 function Static_Integer (N : Node_Id) return Uint is 16131 begin 16132 Analyze_And_Resolve (N, Any_Integer); 16133 16134 if N = Error 16135 or else Error_Posted (N) 16136 or else Etype (N) = Any_Type 16137 then 16138 return No_Uint; 16139 end if; 16140 16141 if Is_Static_Expression (N) then 16142 if not Raises_Constraint_Error (N) then 16143 return Expr_Value (N); 16144 else 16145 return No_Uint; 16146 end if; 16147 16148 elsif Etype (N) = Any_Type then 16149 return No_Uint; 16150 16151 else 16152 Flag_Non_Static_Expr 16153 ("static integer expression required here", N); 16154 return No_Uint; 16155 end if; 16156 end Static_Integer; 16157 16158 -------------------------- 16159 -- Statically_Different -- 16160 -------------------------- 16161 16162 function Statically_Different (E1, E2 : Node_Id) return Boolean is 16163 R1 : constant Node_Id := Get_Referenced_Object (E1); 16164 R2 : constant Node_Id := Get_Referenced_Object (E2); 16165 begin 16166 return Is_Entity_Name (R1) 16167 and then Is_Entity_Name (R2) 16168 and then Entity (R1) /= Entity (R2) 16169 and then not Is_Formal (Entity (R1)) 16170 and then not Is_Formal (Entity (R2)); 16171 end Statically_Different; 16172 16173 -------------------------------------- 16174 -- Subject_To_Loop_Entry_Attributes -- 16175 -------------------------------------- 16176 16177 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 16178 Stmt : Node_Id; 16179 16180 begin 16181 Stmt := N; 16182 16183 -- The expansion mechanism transform a loop subject to at least one 16184 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 16185 -- the conditional part. 16186 16187 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) 16188 and then Nkind (Original_Node (N)) = N_Loop_Statement 16189 then 16190 Stmt := Original_Node (N); 16191 end if; 16192 16193 return 16194 Nkind (Stmt) = N_Loop_Statement 16195 and then Present (Identifier (Stmt)) 16196 and then Present (Entity (Identifier (Stmt))) 16197 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 16198 end Subject_To_Loop_Entry_Attributes; 16199 16200 ----------------------------- 16201 -- Subprogram_Access_Level -- 16202 ----------------------------- 16203 16204 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 16205 begin 16206 if Present (Alias (Subp)) then 16207 return Subprogram_Access_Level (Alias (Subp)); 16208 else 16209 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 16210 end if; 16211 end Subprogram_Access_Level; 16212 16213 ------------------------------- 16214 -- Support_Atomic_Primitives -- 16215 ------------------------------- 16216 16217 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 16218 Size : Int; 16219 16220 begin 16221 -- Verify the alignment of Typ is known 16222 16223 if not Known_Alignment (Typ) then 16224 return False; 16225 end if; 16226 16227 if Known_Static_Esize (Typ) then 16228 Size := UI_To_Int (Esize (Typ)); 16229 16230 -- If the Esize (Object_Size) is unknown at compile time, look at the 16231 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 16232 16233 elsif Known_Static_RM_Size (Typ) then 16234 Size := UI_To_Int (RM_Size (Typ)); 16235 16236 -- Otherwise, the size is considered to be unknown. 16237 16238 else 16239 return False; 16240 end if; 16241 16242 -- Check that the size of the component is 8, 16, 32 or 64 bits and that 16243 -- Typ is properly aligned. 16244 16245 case Size is 16246 when 8 | 16 | 32 | 64 => 16247 return Size = UI_To_Int (Alignment (Typ)) * 8; 16248 when others => 16249 return False; 16250 end case; 16251 end Support_Atomic_Primitives; 16252 16253 ----------------- 16254 -- Trace_Scope -- 16255 ----------------- 16256 16257 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 16258 begin 16259 if Debug_Flag_W then 16260 for J in 0 .. Scope_Stack.Last loop 16261 Write_Str (" "); 16262 end loop; 16263 16264 Write_Str (Msg); 16265 Write_Name (Chars (E)); 16266 Write_Str (" from "); 16267 Write_Location (Sloc (N)); 16268 Write_Eol; 16269 end if; 16270 end Trace_Scope; 16271 16272 ----------------------- 16273 -- Transfer_Entities -- 16274 ----------------------- 16275 16276 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 16277 Ent : Entity_Id := First_Entity (From); 16278 16279 begin 16280 if No (Ent) then 16281 return; 16282 end if; 16283 16284 if (Last_Entity (To)) = Empty then 16285 Set_First_Entity (To, Ent); 16286 else 16287 Set_Next_Entity (Last_Entity (To), Ent); 16288 end if; 16289 16290 Set_Last_Entity (To, Last_Entity (From)); 16291 16292 while Present (Ent) loop 16293 Set_Scope (Ent, To); 16294 16295 if not Is_Public (Ent) then 16296 Set_Public_Status (Ent); 16297 16298 if Is_Public (Ent) 16299 and then Ekind (Ent) = E_Record_Subtype 16300 16301 then 16302 -- The components of the propagated Itype must be public 16303 -- as well. 16304 16305 declare 16306 Comp : Entity_Id; 16307 begin 16308 Comp := First_Entity (Ent); 16309 while Present (Comp) loop 16310 Set_Is_Public (Comp); 16311 Next_Entity (Comp); 16312 end loop; 16313 end; 16314 end if; 16315 end if; 16316 16317 Next_Entity (Ent); 16318 end loop; 16319 16320 Set_First_Entity (From, Empty); 16321 Set_Last_Entity (From, Empty); 16322 end Transfer_Entities; 16323 16324 ----------------------- 16325 -- Type_Access_Level -- 16326 ----------------------- 16327 16328 function Type_Access_Level (Typ : Entity_Id) return Uint is 16329 Btyp : Entity_Id; 16330 16331 begin 16332 Btyp := Base_Type (Typ); 16333 16334 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 16335 -- simply use the level where the type is declared. This is true for 16336 -- stand-alone object declarations, and for anonymous access types 16337 -- associated with components the level is the same as that of the 16338 -- enclosing composite type. However, special treatment is needed for 16339 -- the cases of access parameters, return objects of an anonymous access 16340 -- type, and, in Ada 95, access discriminants of limited types. 16341 16342 if Ekind (Btyp) in Access_Kind then 16343 if Ekind (Btyp) = E_Anonymous_Access_Type then 16344 16345 -- If the type is a nonlocal anonymous access type (such as for 16346 -- an access parameter) we treat it as being declared at the 16347 -- library level to ensure that names such as X.all'access don't 16348 -- fail static accessibility checks. 16349 16350 if not Is_Local_Anonymous_Access (Typ) then 16351 return Scope_Depth (Standard_Standard); 16352 16353 -- If this is a return object, the accessibility level is that of 16354 -- the result subtype of the enclosing function. The test here is 16355 -- little complicated, because we have to account for extended 16356 -- return statements that have been rewritten as blocks, in which 16357 -- case we have to find and the Is_Return_Object attribute of the 16358 -- itype's associated object. It would be nice to find a way to 16359 -- simplify this test, but it doesn't seem worthwhile to add a new 16360 -- flag just for purposes of this test. ??? 16361 16362 elsif Ekind (Scope (Btyp)) = E_Return_Statement 16363 or else 16364 (Is_Itype (Btyp) 16365 and then Nkind (Associated_Node_For_Itype (Btyp)) = 16366 N_Object_Declaration 16367 and then Is_Return_Object 16368 (Defining_Identifier 16369 (Associated_Node_For_Itype (Btyp)))) 16370 then 16371 declare 16372 Scop : Entity_Id; 16373 16374 begin 16375 Scop := Scope (Scope (Btyp)); 16376 while Present (Scop) loop 16377 exit when Ekind (Scop) = E_Function; 16378 Scop := Scope (Scop); 16379 end loop; 16380 16381 -- Treat the return object's type as having the level of the 16382 -- function's result subtype (as per RM05-6.5(5.3/2)). 16383 16384 return Type_Access_Level (Etype (Scop)); 16385 end; 16386 end if; 16387 end if; 16388 16389 Btyp := Root_Type (Btyp); 16390 16391 -- The accessibility level of anonymous access types associated with 16392 -- discriminants is that of the current instance of the type, and 16393 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 16394 16395 -- AI-402: access discriminants have accessibility based on the 16396 -- object rather than the type in Ada 2005, so the above paragraph 16397 -- doesn't apply. 16398 16399 -- ??? Needs completion with rules from AI-416 16400 16401 if Ada_Version <= Ada_95 16402 and then Ekind (Typ) = E_Anonymous_Access_Type 16403 and then Present (Associated_Node_For_Itype (Typ)) 16404 and then Nkind (Associated_Node_For_Itype (Typ)) = 16405 N_Discriminant_Specification 16406 then 16407 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 16408 end if; 16409 end if; 16410 16411 -- Return library level for a generic formal type. This is done because 16412 -- RM(10.3.2) says that "The statically deeper relationship does not 16413 -- apply to ... a descendant of a generic formal type". Rather than 16414 -- checking at each point where a static accessibility check is 16415 -- performed to see if we are dealing with a formal type, this rule is 16416 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 16417 -- return extreme values for a formal type; Deepest_Type_Access_Level 16418 -- returns Int'Last. By calling the appropriate function from among the 16419 -- two, we ensure that the static accessibility check will pass if we 16420 -- happen to run into a formal type. More specifically, we should call 16421 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 16422 -- call occurs as part of a static accessibility check and the error 16423 -- case is the case where the type's level is too shallow (as opposed 16424 -- to too deep). 16425 16426 if Is_Generic_Type (Root_Type (Btyp)) then 16427 return Scope_Depth (Standard_Standard); 16428 end if; 16429 16430 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 16431 end Type_Access_Level; 16432 16433 ------------------------------------ 16434 -- Type_Without_Stream_Operation -- 16435 ------------------------------------ 16436 16437 function Type_Without_Stream_Operation 16438 (T : Entity_Id; 16439 Op : TSS_Name_Type := TSS_Null) return Entity_Id 16440 is 16441 BT : constant Entity_Id := Base_Type (T); 16442 Op_Missing : Boolean; 16443 16444 begin 16445 if not Restriction_Active (No_Default_Stream_Attributes) then 16446 return Empty; 16447 end if; 16448 16449 if Is_Elementary_Type (T) then 16450 if Op = TSS_Null then 16451 Op_Missing := 16452 No (TSS (BT, TSS_Stream_Read)) 16453 or else No (TSS (BT, TSS_Stream_Write)); 16454 16455 else 16456 Op_Missing := No (TSS (BT, Op)); 16457 end if; 16458 16459 if Op_Missing then 16460 return T; 16461 else 16462 return Empty; 16463 end if; 16464 16465 elsif Is_Array_Type (T) then 16466 return Type_Without_Stream_Operation (Component_Type (T), Op); 16467 16468 elsif Is_Record_Type (T) then 16469 declare 16470 Comp : Entity_Id; 16471 C_Typ : Entity_Id; 16472 16473 begin 16474 Comp := First_Component (T); 16475 while Present (Comp) loop 16476 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 16477 16478 if Present (C_Typ) then 16479 return C_Typ; 16480 end if; 16481 16482 Next_Component (Comp); 16483 end loop; 16484 16485 return Empty; 16486 end; 16487 16488 elsif Is_Private_Type (T) 16489 and then Present (Full_View (T)) 16490 then 16491 return Type_Without_Stream_Operation (Full_View (T), Op); 16492 else 16493 return Empty; 16494 end if; 16495 end Type_Without_Stream_Operation; 16496 16497 ---------------------------- 16498 -- Unique_Defining_Entity -- 16499 ---------------------------- 16500 16501 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 16502 begin 16503 return Unique_Entity (Defining_Entity (N)); 16504 end Unique_Defining_Entity; 16505 16506 ------------------- 16507 -- Unique_Entity -- 16508 ------------------- 16509 16510 function Unique_Entity (E : Entity_Id) return Entity_Id is 16511 U : Entity_Id := E; 16512 P : Node_Id; 16513 16514 begin 16515 case Ekind (E) is 16516 when E_Constant => 16517 if Present (Full_View (E)) then 16518 U := Full_View (E); 16519 end if; 16520 16521 when Type_Kind => 16522 if Present (Full_View (E)) then 16523 U := Full_View (E); 16524 end if; 16525 16526 when E_Package_Body => 16527 P := Parent (E); 16528 16529 if Nkind (P) = N_Defining_Program_Unit_Name then 16530 P := Parent (P); 16531 end if; 16532 16533 U := Corresponding_Spec (P); 16534 16535 when E_Subprogram_Body => 16536 P := Parent (E); 16537 16538 if Nkind (P) = N_Defining_Program_Unit_Name then 16539 P := Parent (P); 16540 end if; 16541 16542 P := Parent (P); 16543 16544 if Nkind (P) = N_Subprogram_Body_Stub then 16545 if Present (Library_Unit (P)) then 16546 16547 -- Get to the function or procedure (generic) entity through 16548 -- the body entity. 16549 16550 U := 16551 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P))); 16552 end if; 16553 else 16554 U := Corresponding_Spec (P); 16555 end if; 16556 16557 when Formal_Kind => 16558 if Present (Spec_Entity (E)) then 16559 U := Spec_Entity (E); 16560 end if; 16561 16562 when others => 16563 null; 16564 end case; 16565 16566 return U; 16567 end Unique_Entity; 16568 16569 ----------------- 16570 -- Unique_Name -- 16571 ----------------- 16572 16573 function Unique_Name (E : Entity_Id) return String is 16574 16575 -- Names of E_Subprogram_Body or E_Package_Body entities are not 16576 -- reliable, as they may not include the overloading suffix. Instead, 16577 -- when looking for the name of E or one of its enclosing scope, we get 16578 -- the name of the corresponding Unique_Entity. 16579 16580 function Get_Scoped_Name (E : Entity_Id) return String; 16581 -- Return the name of E prefixed by all the names of the scopes to which 16582 -- E belongs, except for Standard. 16583 16584 --------------------- 16585 -- Get_Scoped_Name -- 16586 --------------------- 16587 16588 function Get_Scoped_Name (E : Entity_Id) return String is 16589 Name : constant String := Get_Name_String (Chars (E)); 16590 begin 16591 if Has_Fully_Qualified_Name (E) 16592 or else Scope (E) = Standard_Standard 16593 then 16594 return Name; 16595 else 16596 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name; 16597 end if; 16598 end Get_Scoped_Name; 16599 16600 -- Start of processing for Unique_Name 16601 16602 begin 16603 if E = Standard_Standard then 16604 return Get_Name_String (Name_Standard); 16605 16606 elsif Scope (E) = Standard_Standard 16607 and then not (Ekind (E) = E_Package or else Is_Subprogram (E)) 16608 then 16609 return Get_Name_String (Name_Standard) & "__" & 16610 Get_Name_String (Chars (E)); 16611 16612 elsif Ekind (E) = E_Enumeration_Literal then 16613 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); 16614 16615 else 16616 return Get_Scoped_Name (Unique_Entity (E)); 16617 end if; 16618 end Unique_Name; 16619 16620 --------------------- 16621 -- Unit_Is_Visible -- 16622 --------------------- 16623 16624 function Unit_Is_Visible (U : Entity_Id) return Boolean is 16625 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 16626 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 16627 16628 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 16629 -- For a child unit, check whether unit appears in a with_clause 16630 -- of a parent. 16631 16632 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 16633 -- Scan the context clause of one compilation unit looking for a 16634 -- with_clause for the unit in question. 16635 16636 ---------------------------- 16637 -- Unit_In_Parent_Context -- 16638 ---------------------------- 16639 16640 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 16641 begin 16642 if Unit_In_Context (Par_Unit) then 16643 return True; 16644 16645 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 16646 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 16647 16648 else 16649 return False; 16650 end if; 16651 end Unit_In_Parent_Context; 16652 16653 --------------------- 16654 -- Unit_In_Context -- 16655 --------------------- 16656 16657 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 16658 Clause : Node_Id; 16659 16660 begin 16661 Clause := First (Context_Items (Comp_Unit)); 16662 while Present (Clause) loop 16663 if Nkind (Clause) = N_With_Clause then 16664 if Library_Unit (Clause) = U then 16665 return True; 16666 16667 -- The with_clause may denote a renaming of the unit we are 16668 -- looking for, eg. Text_IO which renames Ada.Text_IO. 16669 16670 elsif 16671 Renamed_Entity (Entity (Name (Clause))) = 16672 Defining_Entity (Unit (U)) 16673 then 16674 return True; 16675 end if; 16676 end if; 16677 16678 Next (Clause); 16679 end loop; 16680 16681 return False; 16682 end Unit_In_Context; 16683 16684 -- Start of processing for Unit_Is_Visible 16685 16686 begin 16687 -- The currrent unit is directly visible 16688 16689 if Curr = U then 16690 return True; 16691 16692 elsif Unit_In_Context (Curr) then 16693 return True; 16694 16695 -- If the current unit is a body, check the context of the spec 16696 16697 elsif Nkind (Unit (Curr)) = N_Package_Body 16698 or else 16699 (Nkind (Unit (Curr)) = N_Subprogram_Body 16700 and then not Acts_As_Spec (Unit (Curr))) 16701 then 16702 if Unit_In_Context (Library_Unit (Curr)) then 16703 return True; 16704 end if; 16705 end if; 16706 16707 -- If the spec is a child unit, examine the parents 16708 16709 if Is_Child_Unit (Curr_Entity) then 16710 if Nkind (Unit (Curr)) in N_Unit_Body then 16711 return 16712 Unit_In_Parent_Context 16713 (Parent_Spec (Unit (Library_Unit (Curr)))); 16714 else 16715 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 16716 end if; 16717 16718 else 16719 return False; 16720 end if; 16721 end Unit_Is_Visible; 16722 16723 ------------------------------ 16724 -- Universal_Interpretation -- 16725 ------------------------------ 16726 16727 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 16728 Index : Interp_Index; 16729 It : Interp; 16730 16731 begin 16732 -- The argument may be a formal parameter of an operator or subprogram 16733 -- with multiple interpretations, or else an expression for an actual. 16734 16735 if Nkind (Opnd) = N_Defining_Identifier 16736 or else not Is_Overloaded (Opnd) 16737 then 16738 if Etype (Opnd) = Universal_Integer 16739 or else Etype (Opnd) = Universal_Real 16740 then 16741 return Etype (Opnd); 16742 else 16743 return Empty; 16744 end if; 16745 16746 else 16747 Get_First_Interp (Opnd, Index, It); 16748 while Present (It.Typ) loop 16749 if It.Typ = Universal_Integer 16750 or else It.Typ = Universal_Real 16751 then 16752 return It.Typ; 16753 end if; 16754 16755 Get_Next_Interp (Index, It); 16756 end loop; 16757 16758 return Empty; 16759 end if; 16760 end Universal_Interpretation; 16761 16762 --------------- 16763 -- Unqualify -- 16764 --------------- 16765 16766 function Unqualify (Expr : Node_Id) return Node_Id is 16767 begin 16768 -- Recurse to handle unlikely case of multiple levels of qualification 16769 16770 if Nkind (Expr) = N_Qualified_Expression then 16771 return Unqualify (Expression (Expr)); 16772 16773 -- Normal case, not a qualified expression 16774 16775 else 16776 return Expr; 16777 end if; 16778 end Unqualify; 16779 16780 ----------------------- 16781 -- Visible_Ancestors -- 16782 ----------------------- 16783 16784 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 16785 List_1 : Elist_Id; 16786 List_2 : Elist_Id; 16787 Elmt : Elmt_Id; 16788 16789 begin 16790 pragma Assert (Is_Record_Type (Typ) 16791 and then Is_Tagged_Type (Typ)); 16792 16793 -- Collect all the parents and progenitors of Typ. If the full-view of 16794 -- private parents and progenitors is available then it is used to 16795 -- generate the list of visible ancestors; otherwise their partial 16796 -- view is added to the resulting list. 16797 16798 Collect_Parents 16799 (T => Typ, 16800 List => List_1, 16801 Use_Full_View => True); 16802 16803 Collect_Interfaces 16804 (T => Typ, 16805 Ifaces_List => List_2, 16806 Exclude_Parents => True, 16807 Use_Full_View => True); 16808 16809 -- Join the two lists. Avoid duplications because an interface may 16810 -- simultaneously be parent and progenitor of a type. 16811 16812 Elmt := First_Elmt (List_2); 16813 while Present (Elmt) loop 16814 Append_Unique_Elmt (Node (Elmt), List_1); 16815 Next_Elmt (Elmt); 16816 end loop; 16817 16818 return List_1; 16819 end Visible_Ancestors; 16820 16821 ---------------------- 16822 -- Within_Init_Proc -- 16823 ---------------------- 16824 16825 function Within_Init_Proc return Boolean is 16826 S : Entity_Id; 16827 16828 begin 16829 S := Current_Scope; 16830 while not Is_Overloadable (S) loop 16831 if S = Standard_Standard then 16832 return False; 16833 else 16834 S := Scope (S); 16835 end if; 16836 end loop; 16837 16838 return Is_Init_Proc (S); 16839 end Within_Init_Proc; 16840 16841 ------------------ 16842 -- Within_Scope -- 16843 ------------------ 16844 16845 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 16846 SE : Entity_Id; 16847 begin 16848 SE := Scope (E); 16849 loop 16850 if SE = S then 16851 return True; 16852 elsif SE = Standard_Standard then 16853 return False; 16854 else 16855 SE := Scope (SE); 16856 end if; 16857 end loop; 16858 end Within_Scope; 16859 16860 ---------------- 16861 -- Wrong_Type -- 16862 ---------------- 16863 16864 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 16865 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 16866 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 16867 16868 Matching_Field : Entity_Id; 16869 -- Entity to give a more precise suggestion on how to write a one- 16870 -- element positional aggregate. 16871 16872 function Has_One_Matching_Field return Boolean; 16873 -- Determines if Expec_Type is a record type with a single component or 16874 -- discriminant whose type matches the found type or is one dimensional 16875 -- array whose component type matches the found type. In the case of 16876 -- one discriminant, we ignore the variant parts. That's not accurate, 16877 -- but good enough for the warning. 16878 16879 ---------------------------- 16880 -- Has_One_Matching_Field -- 16881 ---------------------------- 16882 16883 function Has_One_Matching_Field return Boolean is 16884 E : Entity_Id; 16885 16886 begin 16887 Matching_Field := Empty; 16888 16889 if Is_Array_Type (Expec_Type) 16890 and then Number_Dimensions (Expec_Type) = 1 16891 and then 16892 Covers (Etype (Component_Type (Expec_Type)), Found_Type) 16893 then 16894 -- Use type name if available. This excludes multidimensional 16895 -- arrays and anonymous arrays. 16896 16897 if Comes_From_Source (Expec_Type) then 16898 Matching_Field := Expec_Type; 16899 16900 -- For an assignment, use name of target 16901 16902 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 16903 and then Is_Entity_Name (Name (Parent (Expr))) 16904 then 16905 Matching_Field := Entity (Name (Parent (Expr))); 16906 end if; 16907 16908 return True; 16909 16910 elsif not Is_Record_Type (Expec_Type) then 16911 return False; 16912 16913 else 16914 E := First_Entity (Expec_Type); 16915 loop 16916 if No (E) then 16917 return False; 16918 16919 elsif not Ekind_In (E, E_Discriminant, E_Component) 16920 or else Nam_In (Chars (E), Name_uTag, Name_uParent) 16921 then 16922 Next_Entity (E); 16923 16924 else 16925 exit; 16926 end if; 16927 end loop; 16928 16929 if not Covers (Etype (E), Found_Type) then 16930 return False; 16931 16932 elsif Present (Next_Entity (E)) 16933 and then (Ekind (E) = E_Component 16934 or else Ekind (Next_Entity (E)) = E_Discriminant) 16935 then 16936 return False; 16937 16938 else 16939 Matching_Field := E; 16940 return True; 16941 end if; 16942 end if; 16943 end Has_One_Matching_Field; 16944 16945 -- Start of processing for Wrong_Type 16946 16947 begin 16948 -- Don't output message if either type is Any_Type, or if a message 16949 -- has already been posted for this node. We need to do the latter 16950 -- check explicitly (it is ordinarily done in Errout), because we 16951 -- are using ! to force the output of the error messages. 16952 16953 if Expec_Type = Any_Type 16954 or else Found_Type = Any_Type 16955 or else Error_Posted (Expr) 16956 then 16957 return; 16958 16959 -- If one of the types is a Taft-Amendment type and the other it its 16960 -- completion, it must be an illegal use of a TAT in the spec, for 16961 -- which an error was already emitted. Avoid cascaded errors. 16962 16963 elsif Is_Incomplete_Type (Expec_Type) 16964 and then Has_Completion_In_Body (Expec_Type) 16965 and then Full_View (Expec_Type) = Etype (Expr) 16966 then 16967 return; 16968 16969 elsif Is_Incomplete_Type (Etype (Expr)) 16970 and then Has_Completion_In_Body (Etype (Expr)) 16971 and then Full_View (Etype (Expr)) = Expec_Type 16972 then 16973 return; 16974 16975 -- In an instance, there is an ongoing problem with completion of 16976 -- type derived from private types. Their structure is what Gigi 16977 -- expects, but the Etype is the parent type rather than the 16978 -- derived private type itself. Do not flag error in this case. The 16979 -- private completion is an entity without a parent, like an Itype. 16980 -- Similarly, full and partial views may be incorrect in the instance. 16981 -- There is no simple way to insure that it is consistent ??? 16982 16983 elsif In_Instance then 16984 if Etype (Etype (Expr)) = Etype (Expected_Type) 16985 and then 16986 (Has_Private_Declaration (Expected_Type) 16987 or else Has_Private_Declaration (Etype (Expr))) 16988 and then No (Parent (Expected_Type)) 16989 then 16990 return; 16991 end if; 16992 end if; 16993 16994 -- An interesting special check. If the expression is parenthesized 16995 -- and its type corresponds to the type of the sole component of the 16996 -- expected record type, or to the component type of the expected one 16997 -- dimensional array type, then assume we have a bad aggregate attempt. 16998 16999 if Nkind (Expr) in N_Subexpr 17000 and then Paren_Count (Expr) /= 0 17001 and then Has_One_Matching_Field 17002 then 17003 Error_Msg_N ("positional aggregate cannot have one component", Expr); 17004 if Present (Matching_Field) then 17005 if Is_Array_Type (Expec_Type) then 17006 Error_Msg_NE 17007 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 17008 17009 else 17010 Error_Msg_NE 17011 ("\write instead `& ='> ...`", Expr, Matching_Field); 17012 end if; 17013 end if; 17014 17015 -- Another special check, if we are looking for a pool-specific access 17016 -- type and we found an E_Access_Attribute_Type, then we have the case 17017 -- of an Access attribute being used in a context which needs a pool- 17018 -- specific type, which is never allowed. The one extra check we make 17019 -- is that the expected designated type covers the Found_Type. 17020 17021 elsif Is_Access_Type (Expec_Type) 17022 and then Ekind (Found_Type) = E_Access_Attribute_Type 17023 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 17024 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 17025 and then Covers 17026 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 17027 then 17028 Error_Msg_N -- CODEFIX 17029 ("result must be general access type!", Expr); 17030 Error_Msg_NE -- CODEFIX 17031 ("add ALL to }!", Expr, Expec_Type); 17032 17033 -- Another special check, if the expected type is an integer type, 17034 -- but the expression is of type System.Address, and the parent is 17035 -- an addition or subtraction operation whose left operand is the 17036 -- expression in question and whose right operand is of an integral 17037 -- type, then this is an attempt at address arithmetic, so give 17038 -- appropriate message. 17039 17040 elsif Is_Integer_Type (Expec_Type) 17041 and then Is_RTE (Found_Type, RE_Address) 17042 and then (Nkind (Parent (Expr)) = N_Op_Add 17043 or else 17044 Nkind (Parent (Expr)) = N_Op_Subtract) 17045 and then Expr = Left_Opnd (Parent (Expr)) 17046 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 17047 then 17048 Error_Msg_N 17049 ("address arithmetic not predefined in package System", 17050 Parent (Expr)); 17051 Error_Msg_N 17052 ("\possible missing with/use of System.Storage_Elements", 17053 Parent (Expr)); 17054 return; 17055 17056 -- If the expected type is an anonymous access type, as for access 17057 -- parameters and discriminants, the error is on the designated types. 17058 17059 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 17060 if Comes_From_Source (Expec_Type) then 17061 Error_Msg_NE ("expected}!", Expr, Expec_Type); 17062 else 17063 Error_Msg_NE 17064 ("expected an access type with designated}", 17065 Expr, Designated_Type (Expec_Type)); 17066 end if; 17067 17068 if Is_Access_Type (Found_Type) 17069 and then not Comes_From_Source (Found_Type) 17070 then 17071 Error_Msg_NE 17072 ("\\found an access type with designated}!", 17073 Expr, Designated_Type (Found_Type)); 17074 else 17075 if From_Limited_With (Found_Type) then 17076 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 17077 Error_Msg_Qual_Level := 99; 17078 Error_Msg_NE -- CODEFIX 17079 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 17080 Error_Msg_Qual_Level := 0; 17081 else 17082 Error_Msg_NE ("found}!", Expr, Found_Type); 17083 end if; 17084 end if; 17085 17086 -- Normal case of one type found, some other type expected 17087 17088 else 17089 -- If the names of the two types are the same, see if some number 17090 -- of levels of qualification will help. Don't try more than three 17091 -- levels, and if we get to standard, it's no use (and probably 17092 -- represents an error in the compiler) Also do not bother with 17093 -- internal scope names. 17094 17095 declare 17096 Expec_Scope : Entity_Id; 17097 Found_Scope : Entity_Id; 17098 17099 begin 17100 Expec_Scope := Expec_Type; 17101 Found_Scope := Found_Type; 17102 17103 for Levels in Int range 0 .. 3 loop 17104 if Chars (Expec_Scope) /= Chars (Found_Scope) then 17105 Error_Msg_Qual_Level := Levels; 17106 exit; 17107 end if; 17108 17109 Expec_Scope := Scope (Expec_Scope); 17110 Found_Scope := Scope (Found_Scope); 17111 17112 exit when Expec_Scope = Standard_Standard 17113 or else Found_Scope = Standard_Standard 17114 or else not Comes_From_Source (Expec_Scope) 17115 or else not Comes_From_Source (Found_Scope); 17116 end loop; 17117 end; 17118 17119 if Is_Record_Type (Expec_Type) 17120 and then Present (Corresponding_Remote_Type (Expec_Type)) 17121 then 17122 Error_Msg_NE ("expected}!", Expr, 17123 Corresponding_Remote_Type (Expec_Type)); 17124 else 17125 Error_Msg_NE ("expected}!", Expr, Expec_Type); 17126 end if; 17127 17128 if Is_Entity_Name (Expr) 17129 and then Is_Package_Or_Generic_Package (Entity (Expr)) 17130 then 17131 Error_Msg_N ("\\found package name!", Expr); 17132 17133 elsif Is_Entity_Name (Expr) 17134 and then 17135 (Ekind (Entity (Expr)) = E_Procedure 17136 or else 17137 Ekind (Entity (Expr)) = E_Generic_Procedure) 17138 then 17139 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 17140 Error_Msg_N 17141 ("found procedure name, possibly missing Access attribute!", 17142 Expr); 17143 else 17144 Error_Msg_N 17145 ("\\found procedure name instead of function!", Expr); 17146 end if; 17147 17148 elsif Nkind (Expr) = N_Function_Call 17149 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 17150 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 17151 and then No (Parameter_Associations (Expr)) 17152 then 17153 Error_Msg_N 17154 ("found function name, possibly missing Access attribute!", 17155 Expr); 17156 17157 -- Catch common error: a prefix or infix operator which is not 17158 -- directly visible because the type isn't. 17159 17160 elsif Nkind (Expr) in N_Op 17161 and then Is_Overloaded (Expr) 17162 and then not Is_Immediately_Visible (Expec_Type) 17163 and then not Is_Potentially_Use_Visible (Expec_Type) 17164 and then not In_Use (Expec_Type) 17165 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 17166 then 17167 Error_Msg_N 17168 ("operator of the type is not directly visible!", Expr); 17169 17170 elsif Ekind (Found_Type) = E_Void 17171 and then Present (Parent (Found_Type)) 17172 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 17173 then 17174 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 17175 17176 else 17177 Error_Msg_NE ("\\found}!", Expr, Found_Type); 17178 end if; 17179 17180 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 17181 -- of the same modular type, and (M1 and M2) = 0 was intended. 17182 17183 if Expec_Type = Standard_Boolean 17184 and then Is_Modular_Integer_Type (Found_Type) 17185 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 17186 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 17187 then 17188 declare 17189 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 17190 L : constant Node_Id := Left_Opnd (Op); 17191 R : constant Node_Id := Right_Opnd (Op); 17192 begin 17193 -- The case for the message is when the left operand of the 17194 -- comparison is the same modular type, or when it is an 17195 -- integer literal (or other universal integer expression), 17196 -- which would have been typed as the modular type if the 17197 -- parens had been there. 17198 17199 if (Etype (L) = Found_Type 17200 or else 17201 Etype (L) = Universal_Integer) 17202 and then Is_Integer_Type (Etype (R)) 17203 then 17204 Error_Msg_N 17205 ("\\possible missing parens for modular operation", Expr); 17206 end if; 17207 end; 17208 end if; 17209 17210 -- Reset error message qualification indication 17211 17212 Error_Msg_Qual_Level := 0; 17213 end if; 17214 end Wrong_Type; 17215 17216end Sem_Util; 17217