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-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Casing; use Casing; 29with Checks; use Checks; 30with Debug; use Debug; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Disp; use Exp_Disp; 35with Exp_Unst; use Exp_Unst; 36with Exp_Util; use Exp_Util; 37with Fname; use Fname; 38with Freeze; use Freeze; 39with Lib; use Lib; 40with Lib.Xref; use Lib.Xref; 41with Namet.Sp; use Namet.Sp; 42with Nlists; use Nlists; 43with Nmake; use Nmake; 44with Output; use Output; 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_Ch6; use Sem_Ch6; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Ch13; use Sem_Ch13; 54with Sem_Disp; use Sem_Disp; 55with Sem_Eval; use Sem_Eval; 56with Sem_Prag; use Sem_Prag; 57with Sem_Res; use Sem_Res; 58with Sem_Warn; use Sem_Warn; 59with Sem_Type; use Sem_Type; 60with Sinfo; use Sinfo; 61with Sinput; use Sinput; 62with Stand; use Stand; 63with Style; 64with Stringt; use Stringt; 65with Targparm; use Targparm; 66with Tbuild; use Tbuild; 67with Ttypes; use Ttypes; 68with Uname; use Uname; 69 70with GNAT.HTable; use GNAT.HTable; 71 72package body Sem_Util is 73 74 ---------------------------------------- 75 -- Global Variables for New_Copy_Tree -- 76 ---------------------------------------- 77 78 -- These global variables are used by New_Copy_Tree. See description of the 79 -- body of this subprogram for details. Global variables can be safely used 80 -- by New_Copy_Tree, since there is no case of a recursive call from the 81 -- processing inside New_Copy_Tree. 82 83 NCT_Hash_Threshold : constant := 20; 84 -- If there are more than this number of pairs of entries in the map, then 85 -- Hash_Tables_Used will be set, and the hash tables will be initialized 86 -- and used for the searches. 87 88 NCT_Hash_Tables_Used : Boolean := False; 89 -- Set to True if hash tables are in use 90 91 NCT_Table_Entries : Nat := 0; 92 -- Count entries in table to see if threshold is reached 93 94 NCT_Hash_Table_Setup : Boolean := False; 95 -- Set to True if hash table contains data. We set this True if we setup 96 -- the hash table with data, and leave it set permanently from then on, 97 -- this is a signal that second and subsequent users of the hash table 98 -- must clear the old entries before reuse. 99 100 subtype NCT_Header_Num is Int range 0 .. 511; 101 -- Defines range of headers in hash tables (512 headers) 102 103 ----------------------- 104 -- Local Subprograms -- 105 ----------------------- 106 107 function Build_Component_Subtype 108 (C : List_Id; 109 Loc : Source_Ptr; 110 T : Entity_Id) return Node_Id; 111 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 112 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 113 -- Loc is the source location, T is the original subtype. 114 115 function Has_Enabled_Property 116 (Item_Id : Entity_Id; 117 Property : Name_Id) return Boolean; 118 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 119 -- Determine whether an abstract state or a variable denoted by entity 120 -- Item_Id has enabled property Property. 121 122 function Has_Null_Extension (T : Entity_Id) return Boolean; 123 -- T is a derived tagged type. Check whether the type extension is null. 124 -- If the parent type is fully initialized, T can be treated as such. 125 126 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 127 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 128 -- with discriminants whose default values are static, examine only the 129 -- components in the selected variant to determine whether all of them 130 -- have a default. 131 132 ------------------------------ 133 -- Abstract_Interface_List -- 134 ------------------------------ 135 136 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 137 Nod : Node_Id; 138 139 begin 140 if Is_Concurrent_Type (Typ) then 141 142 -- If we are dealing with a synchronized subtype, go to the base 143 -- type, whose declaration has the interface list. 144 145 -- Shouldn't this be Declaration_Node??? 146 147 Nod := Parent (Base_Type (Typ)); 148 149 if Nkind (Nod) = N_Full_Type_Declaration then 150 return Empty_List; 151 end if; 152 153 elsif Ekind (Typ) = E_Record_Type_With_Private then 154 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 155 Nod := Type_Definition (Parent (Typ)); 156 157 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 158 if Present (Full_View (Typ)) 159 and then 160 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration 161 then 162 Nod := Type_Definition (Parent (Full_View (Typ))); 163 164 -- If the full-view is not available we cannot do anything else 165 -- here (the source has errors). 166 167 else 168 return Empty_List; 169 end if; 170 171 -- Support for generic formals with interfaces is still missing ??? 172 173 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 174 return Empty_List; 175 176 else 177 pragma Assert 178 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 179 Nod := Parent (Typ); 180 end if; 181 182 elsif Ekind (Typ) = E_Record_Subtype then 183 Nod := Type_Definition (Parent (Etype (Typ))); 184 185 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 186 187 -- Recurse, because parent may still be a private extension. Also 188 -- note that the full view of the subtype or the full view of its 189 -- base type may (both) be unavailable. 190 191 return Abstract_Interface_List (Etype (Typ)); 192 193 else pragma Assert ((Ekind (Typ)) = E_Record_Type); 194 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 195 Nod := Formal_Type_Definition (Parent (Typ)); 196 else 197 Nod := Type_Definition (Parent (Typ)); 198 end if; 199 end if; 200 201 return Interface_List (Nod); 202 end Abstract_Interface_List; 203 204 -------------------------------- 205 -- Add_Access_Type_To_Process -- 206 -------------------------------- 207 208 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 209 L : Elist_Id; 210 211 begin 212 Ensure_Freeze_Node (E); 213 L := Access_Types_To_Process (Freeze_Node (E)); 214 215 if No (L) then 216 L := New_Elmt_List; 217 Set_Access_Types_To_Process (Freeze_Node (E), L); 218 end if; 219 220 Append_Elmt (A, L); 221 end Add_Access_Type_To_Process; 222 223 -------------------------- 224 -- Add_Block_Identifier -- 225 -------------------------- 226 227 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 228 Loc : constant Source_Ptr := Sloc (N); 229 230 begin 231 pragma Assert (Nkind (N) = N_Block_Statement); 232 233 -- The block already has a label, return its entity 234 235 if Present (Identifier (N)) then 236 Id := Entity (Identifier (N)); 237 238 -- Create a new block label and set its attributes 239 240 else 241 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 242 Set_Etype (Id, Standard_Void_Type); 243 Set_Parent (Id, N); 244 245 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 246 Set_Block_Node (Id, Identifier (N)); 247 end if; 248 end Add_Block_Identifier; 249 250 ----------------------- 251 -- Add_Contract_Item -- 252 ----------------------- 253 254 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is 255 Items : Node_Id := Contract (Id); 256 257 procedure Add_Classification; 258 -- Prepend Prag to the list of classifications 259 260 procedure Add_Contract_Test_Case; 261 -- Prepend Prag to the list of contract and test cases 262 263 procedure Add_Pre_Post_Condition; 264 -- Prepend Prag to the list of pre- and postconditions 265 266 ------------------------ 267 -- Add_Classification -- 268 ------------------------ 269 270 procedure Add_Classification is 271 begin 272 Set_Next_Pragma (Prag, Classifications (Items)); 273 Set_Classifications (Items, Prag); 274 end Add_Classification; 275 276 ---------------------------- 277 -- Add_Contract_Test_Case -- 278 ---------------------------- 279 280 procedure Add_Contract_Test_Case is 281 begin 282 Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); 283 Set_Contract_Test_Cases (Items, Prag); 284 end Add_Contract_Test_Case; 285 286 ---------------------------- 287 -- Add_Pre_Post_Condition -- 288 ---------------------------- 289 290 procedure Add_Pre_Post_Condition is 291 begin 292 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); 293 Set_Pre_Post_Conditions (Items, Prag); 294 end Add_Pre_Post_Condition; 295 296 -- Local variables 297 298 Prag_Nam : Name_Id; 299 300 -- Start of processing for Add_Contract_Item 301 302 begin 303 -- A contract must contain only pragmas 304 305 pragma Assert (Nkind (Prag) = N_Pragma); 306 Prag_Nam := Pragma_Name (Prag); 307 308 -- Create a new contract when adding the first item 309 310 if No (Items) then 311 Items := Make_Contract (Sloc (Id)); 312 Set_Contract (Id, Items); 313 end if; 314 315 -- Contract items related to [generic] packages or instantiations. The 316 -- applicable pragmas are: 317 -- Abstract_States 318 -- Initial_Condition 319 -- Initializes 320 -- Part_Of (instantiation only) 321 322 if Ekind_In (Id, E_Generic_Package, E_Package) then 323 if Nam_In (Prag_Nam, Name_Abstract_State, 324 Name_Initial_Condition, 325 Name_Initializes) 326 then 327 Add_Classification; 328 329 -- Indicator Part_Of must be associated with a package instantiation 330 331 elsif Prag_Nam = Name_Part_Of and then Is_Generic_Instance (Id) then 332 Add_Classification; 333 334 -- The pragma is not a proper contract item 335 336 else 337 raise Program_Error; 338 end if; 339 340 -- Contract items related to package bodies. The applicable pragmas are: 341 -- Refined_States 342 343 elsif Ekind (Id) = E_Package_Body then 344 if Prag_Nam = Name_Refined_State then 345 Add_Classification; 346 347 -- The pragma is not a proper contract item 348 349 else 350 raise Program_Error; 351 end if; 352 353 -- Contract items related to subprogram or entry declarations. The 354 -- applicable pragmas are: 355 -- Contract_Cases 356 -- Depends 357 -- Extensions_Visible 358 -- Global 359 -- Postcondition 360 -- Precondition 361 -- Test_Case 362 363 elsif Ekind_In (Id, E_Entry, E_Entry_Family) 364 or else Is_Generic_Subprogram (Id) 365 or else Is_Subprogram (Id) 366 then 367 if Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then 368 Add_Pre_Post_Condition; 369 370 elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then 371 Add_Contract_Test_Case; 372 373 elsif Nam_In (Prag_Nam, Name_Depends, 374 Name_Extensions_Visible, 375 Name_Global) 376 then 377 Add_Classification; 378 379 -- The pragma is not a proper contract item 380 381 else 382 raise Program_Error; 383 end if; 384 385 -- Contract items related to subprogram bodies. Applicable pragmas are: 386 -- Postcondition 387 -- Precondition 388 -- Refined_Depends 389 -- Refined_Global 390 -- Refined_Post 391 392 elsif Ekind (Id) = E_Subprogram_Body then 393 if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then 394 Add_Classification; 395 396 elsif Nam_In (Prag_Nam, Name_Postcondition, 397 Name_Precondition, 398 Name_Refined_Post) 399 then 400 Add_Pre_Post_Condition; 401 402 -- The pragma is not a proper contract item 403 404 else 405 raise Program_Error; 406 end if; 407 408 -- Contract items related to variables. Applicable pragmas are: 409 -- Async_Readers 410 -- Async_Writers 411 -- Effective_Reads 412 -- Effective_Writes 413 -- Part_Of 414 415 elsif Ekind (Id) = E_Variable then 416 if Nam_In (Prag_Nam, Name_Async_Readers, 417 Name_Async_Writers, 418 Name_Effective_Reads, 419 Name_Effective_Writes, 420 Name_Part_Of) 421 then 422 Add_Classification; 423 424 -- The pragma is not a proper contract item 425 426 else 427 raise Program_Error; 428 end if; 429 end if; 430 end Add_Contract_Item; 431 432 ---------------------------- 433 -- Add_Global_Declaration -- 434 ---------------------------- 435 436 procedure Add_Global_Declaration (N : Node_Id) is 437 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 438 439 begin 440 if No (Declarations (Aux_Node)) then 441 Set_Declarations (Aux_Node, New_List); 442 end if; 443 444 Append_To (Declarations (Aux_Node), N); 445 Analyze (N); 446 end Add_Global_Declaration; 447 448 -------------------------------- 449 -- Address_Integer_Convert_OK -- 450 -------------------------------- 451 452 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 453 begin 454 if Allow_Integer_Address 455 and then ((Is_Descendent_Of_Address (T1) 456 and then Is_Private_Type (T1) 457 and then Is_Integer_Type (T2)) 458 or else 459 (Is_Descendent_Of_Address (T2) 460 and then Is_Private_Type (T2) 461 and then Is_Integer_Type (T1))) 462 then 463 return True; 464 else 465 return False; 466 end if; 467 end Address_Integer_Convert_OK; 468 469 ----------------- 470 -- Addressable -- 471 ----------------- 472 473 -- For now, just 8/16/32/64. but analyze later if AAMP is special??? 474 475 function Addressable (V : Uint) return Boolean is 476 begin 477 return V = Uint_8 or else 478 V = Uint_16 or else 479 V = Uint_32 or else 480 V = Uint_64; 481 end Addressable; 482 483 function Addressable (V : Int) return Boolean is 484 begin 485 return V = 8 or else 486 V = 16 or else 487 V = 32 or else 488 V = 64; 489 end Addressable; 490 491 --------------------------------- 492 -- Aggregate_Constraint_Checks -- 493 --------------------------------- 494 495 procedure Aggregate_Constraint_Checks 496 (Exp : Node_Id; 497 Check_Typ : Entity_Id) 498 is 499 Exp_Typ : constant Entity_Id := Etype (Exp); 500 501 begin 502 if Raises_Constraint_Error (Exp) then 503 return; 504 end if; 505 506 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access 507 -- component's type to force the appropriate accessibility checks. 508 509 -- Ada 2005 (AI-231): Generate conversion to the null-excluding 510 -- type to force the corresponding run-time check 511 512 if Is_Access_Type (Check_Typ) 513 and then ((Is_Local_Anonymous_Access (Check_Typ)) 514 or else (Can_Never_Be_Null (Check_Typ) 515 and then not Can_Never_Be_Null (Exp_Typ))) 516 then 517 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 518 Analyze_And_Resolve (Exp, Check_Typ); 519 Check_Unset_Reference (Exp); 520 end if; 521 522 -- This is really expansion activity, so make sure that expansion is 523 -- on and is allowed. In GNATprove mode, we also want check flags to 524 -- be added in the tree, so that the formal verification can rely on 525 -- those to be present. In GNATprove mode for formal verification, some 526 -- treatment typically only done during expansion needs to be performed 527 -- on the tree, but it should not be applied inside generics. Otherwise, 528 -- this breaks the name resolution mechanism for generic instances. 529 530 if not Expander_Active 531 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 532 then 533 return; 534 end if; 535 536 -- First check if we have to insert discriminant checks 537 538 if Has_Discriminants (Exp_Typ) then 539 Apply_Discriminant_Check (Exp, Check_Typ); 540 541 -- Next emit length checks for array aggregates 542 543 elsif Is_Array_Type (Exp_Typ) then 544 Apply_Length_Check (Exp, Check_Typ); 545 546 -- Finally emit scalar and string checks. If we are dealing with a 547 -- scalar literal we need to check by hand because the Etype of 548 -- literals is not necessarily correct. 549 550 elsif Is_Scalar_Type (Exp_Typ) 551 and then Compile_Time_Known_Value (Exp) 552 then 553 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then 554 Apply_Compile_Time_Constraint_Error 555 (Exp, "value not in range of}??", CE_Range_Check_Failed, 556 Ent => Base_Type (Check_Typ), 557 Typ => Base_Type (Check_Typ)); 558 559 elsif Is_Out_Of_Range (Exp, Check_Typ) then 560 Apply_Compile_Time_Constraint_Error 561 (Exp, "value not in range of}??", CE_Range_Check_Failed, 562 Ent => Check_Typ, 563 Typ => Check_Typ); 564 565 elsif not Range_Checks_Suppressed (Check_Typ) then 566 Apply_Scalar_Range_Check (Exp, Check_Typ); 567 end if; 568 569 -- Verify that target type is also scalar, to prevent view anomalies 570 -- in instantiations. 571 572 elsif (Is_Scalar_Type (Exp_Typ) 573 or else Nkind (Exp) = N_String_Literal) 574 and then Is_Scalar_Type (Check_Typ) 575 and then Exp_Typ /= Check_Typ 576 then 577 if Is_Entity_Name (Exp) 578 and then Ekind (Entity (Exp)) = E_Constant 579 then 580 -- If expression is a constant, it is worthwhile checking whether 581 -- it is a bound of the type. 582 583 if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) 584 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) 585 or else 586 (Is_Entity_Name (Type_High_Bound (Check_Typ)) 587 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) 588 then 589 return; 590 591 else 592 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 593 Analyze_And_Resolve (Exp, Check_Typ); 594 Check_Unset_Reference (Exp); 595 end if; 596 597 -- Could use a comment on this case ??? 598 599 else 600 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 601 Analyze_And_Resolve (Exp, Check_Typ); 602 Check_Unset_Reference (Exp); 603 end if; 604 605 end if; 606 end Aggregate_Constraint_Checks; 607 608 ----------------------- 609 -- Alignment_In_Bits -- 610 ----------------------- 611 612 function Alignment_In_Bits (E : Entity_Id) return Uint is 613 begin 614 return Alignment (E) * System_Storage_Unit; 615 end Alignment_In_Bits; 616 617 --------------------------------- 618 -- Append_Inherited_Subprogram -- 619 --------------------------------- 620 621 procedure Append_Inherited_Subprogram (S : Entity_Id) is 622 Par : constant Entity_Id := Alias (S); 623 -- The parent subprogram 624 625 Scop : constant Entity_Id := Scope (Par); 626 -- The scope of definition of the parent subprogram 627 628 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 629 -- The derived type of which S is a primitive operation 630 631 Decl : Node_Id; 632 Next_E : Entity_Id; 633 634 begin 635 if Ekind (Current_Scope) = E_Package 636 and then In_Private_Part (Current_Scope) 637 and then Has_Private_Declaration (Typ) 638 and then Is_Tagged_Type (Typ) 639 and then Scop = Current_Scope 640 then 641 -- The inherited operation is available at the earliest place after 642 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only 643 -- relevant for type extensions. If the parent operation appears 644 -- after the type extension, the operation is not visible. 645 646 Decl := First 647 (Visible_Declarations 648 (Package_Specification (Current_Scope))); 649 while Present (Decl) loop 650 if Nkind (Decl) = N_Private_Extension_Declaration 651 and then Defining_Entity (Decl) = Typ 652 then 653 if Sloc (Decl) > Sloc (Par) then 654 Next_E := Next_Entity (Par); 655 Set_Next_Entity (Par, S); 656 Set_Next_Entity (S, Next_E); 657 return; 658 659 else 660 exit; 661 end if; 662 end if; 663 664 Next (Decl); 665 end loop; 666 end if; 667 668 -- If partial view is not a type extension, or it appears before the 669 -- subprogram declaration, insert normally at end of entity list. 670 671 Append_Entity (S, Current_Scope); 672 end Append_Inherited_Subprogram; 673 674 ----------------------------------------- 675 -- Apply_Compile_Time_Constraint_Error -- 676 ----------------------------------------- 677 678 procedure Apply_Compile_Time_Constraint_Error 679 (N : Node_Id; 680 Msg : String; 681 Reason : RT_Exception_Code; 682 Ent : Entity_Id := Empty; 683 Typ : Entity_Id := Empty; 684 Loc : Source_Ptr := No_Location; 685 Rep : Boolean := True; 686 Warn : Boolean := False) 687 is 688 Stat : constant Boolean := Is_Static_Expression (N); 689 R_Stat : constant Node_Id := 690 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 691 Rtyp : Entity_Id; 692 693 begin 694 if No (Typ) then 695 Rtyp := Etype (N); 696 else 697 Rtyp := Typ; 698 end if; 699 700 Discard_Node 701 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 702 703 if not Rep then 704 return; 705 end if; 706 707 -- Now we replace the node by an N_Raise_Constraint_Error node 708 -- This does not need reanalyzing, so set it as analyzed now. 709 710 Rewrite (N, R_Stat); 711 Set_Analyzed (N, True); 712 713 Set_Etype (N, Rtyp); 714 Set_Raises_Constraint_Error (N); 715 716 -- Now deal with possible local raise handling 717 718 Possible_Local_Raise (N, Standard_Constraint_Error); 719 720 -- If the original expression was marked as static, the result is 721 -- still marked as static, but the Raises_Constraint_Error flag is 722 -- always set so that further static evaluation is not attempted. 723 724 if Stat then 725 Set_Is_Static_Expression (N); 726 end if; 727 end Apply_Compile_Time_Constraint_Error; 728 729 --------------------------- 730 -- Async_Readers_Enabled -- 731 --------------------------- 732 733 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 734 begin 735 return Has_Enabled_Property (Id, Name_Async_Readers); 736 end Async_Readers_Enabled; 737 738 --------------------------- 739 -- Async_Writers_Enabled -- 740 --------------------------- 741 742 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 743 begin 744 return Has_Enabled_Property (Id, Name_Async_Writers); 745 end Async_Writers_Enabled; 746 747 -------------------------------------- 748 -- Available_Full_View_Of_Component -- 749 -------------------------------------- 750 751 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 752 ST : constant Entity_Id := Scope (T); 753 SCT : constant Entity_Id := Scope (Component_Type (T)); 754 begin 755 return In_Open_Scopes (ST) 756 and then In_Open_Scopes (SCT) 757 and then Scope_Depth (ST) >= Scope_Depth (SCT); 758 end Available_Full_View_Of_Component; 759 760 ------------------- 761 -- Bad_Attribute -- 762 ------------------- 763 764 procedure Bad_Attribute 765 (N : Node_Id; 766 Nam : Name_Id; 767 Warn : Boolean := False) 768 is 769 begin 770 Error_Msg_Warn := Warn; 771 Error_Msg_N ("unrecognized attribute&<<", N); 772 773 -- Check for possible misspelling 774 775 Error_Msg_Name_1 := First_Attribute_Name; 776 while Error_Msg_Name_1 <= Last_Attribute_Name loop 777 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 778 Error_Msg_N -- CODEFIX 779 ("\possible misspelling of %<<", N); 780 exit; 781 end if; 782 783 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 784 end loop; 785 end Bad_Attribute; 786 787 -------------------------------- 788 -- Bad_Predicated_Subtype_Use -- 789 -------------------------------- 790 791 procedure Bad_Predicated_Subtype_Use 792 (Msg : String; 793 N : Node_Id; 794 Typ : Entity_Id; 795 Suggest_Static : Boolean := False) 796 is 797 Gen : Entity_Id; 798 799 begin 800 -- Avoid cascaded errors 801 802 if Error_Posted (N) then 803 return; 804 end if; 805 806 if Inside_A_Generic then 807 Gen := Current_Scope; 808 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop 809 Gen := Scope (Gen); 810 end loop; 811 812 if No (Gen) then 813 return; 814 end if; 815 816 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then 817 Set_No_Predicate_On_Actual (Typ); 818 end if; 819 820 elsif Has_Predicates (Typ) then 821 if Is_Generic_Actual_Type (Typ) then 822 823 -- The restriction on loop parameters is only that the type 824 -- should have no dynamic predicates. 825 826 if Nkind (Parent (N)) = N_Loop_Parameter_Specification 827 and then not Has_Dynamic_Predicate_Aspect (Typ) 828 and then Is_OK_Static_Subtype (Typ) 829 then 830 return; 831 end if; 832 833 Gen := Current_Scope; 834 while not Is_Generic_Instance (Gen) loop 835 Gen := Scope (Gen); 836 end loop; 837 838 pragma Assert (Present (Gen)); 839 840 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then 841 Error_Msg_Warn := SPARK_Mode /= On; 842 Error_Msg_FE (Msg & "<<", N, Typ); 843 Error_Msg_F ("\Program_Error [<<", N); 844 845 Insert_Action (N, 846 Make_Raise_Program_Error (Sloc (N), 847 Reason => PE_Bad_Predicated_Generic_Type)); 848 849 else 850 Error_Msg_FE (Msg & "<<", N, Typ); 851 end if; 852 853 else 854 Error_Msg_FE (Msg, N, Typ); 855 end if; 856 857 -- Emit an optional suggestion on how to remedy the error if the 858 -- context warrants it. 859 860 if Suggest_Static and then Has_Static_Predicate (Typ) then 861 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 862 end if; 863 end if; 864 end Bad_Predicated_Subtype_Use; 865 866 ----------------------------------------- 867 -- Bad_Unordered_Enumeration_Reference -- 868 ----------------------------------------- 869 870 function Bad_Unordered_Enumeration_Reference 871 (N : Node_Id; 872 T : Entity_Id) return Boolean 873 is 874 begin 875 return Is_Enumeration_Type (T) 876 and then Warn_On_Unordered_Enumeration_Type 877 and then not Is_Generic_Type (T) 878 and then Comes_From_Source (N) 879 and then not Has_Pragma_Ordered (T) 880 and then not In_Same_Extended_Unit (N, T); 881 end Bad_Unordered_Enumeration_Reference; 882 883 -------------------------- 884 -- Build_Actual_Subtype -- 885 -------------------------- 886 887 function Build_Actual_Subtype 888 (T : Entity_Id; 889 N : Node_Or_Entity_Id) return Node_Id 890 is 891 Loc : Source_Ptr; 892 -- Normally Sloc (N), but may point to corresponding body in some cases 893 894 Constraints : List_Id; 895 Decl : Node_Id; 896 Discr : Entity_Id; 897 Hi : Node_Id; 898 Lo : Node_Id; 899 Subt : Entity_Id; 900 Disc_Type : Entity_Id; 901 Obj : Node_Id; 902 903 begin 904 Loc := Sloc (N); 905 906 if Nkind (N) = N_Defining_Identifier then 907 Obj := New_Occurrence_Of (N, Loc); 908 909 -- If this is a formal parameter of a subprogram declaration, and 910 -- we are compiling the body, we want the declaration for the 911 -- actual subtype to carry the source position of the body, to 912 -- prevent anomalies in gdb when stepping through the code. 913 914 if Is_Formal (N) then 915 declare 916 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 917 begin 918 if Nkind (Decl) = N_Subprogram_Declaration 919 and then Present (Corresponding_Body (Decl)) 920 then 921 Loc := Sloc (Corresponding_Body (Decl)); 922 end if; 923 end; 924 end if; 925 926 else 927 Obj := N; 928 end if; 929 930 if Is_Array_Type (T) then 931 Constraints := New_List; 932 for J in 1 .. Number_Dimensions (T) loop 933 934 -- Build an array subtype declaration with the nominal subtype and 935 -- the bounds of the actual. Add the declaration in front of the 936 -- local declarations for the subprogram, for analysis before any 937 -- reference to the formal in the body. 938 939 Lo := 940 Make_Attribute_Reference (Loc, 941 Prefix => 942 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 943 Attribute_Name => Name_First, 944 Expressions => New_List ( 945 Make_Integer_Literal (Loc, J))); 946 947 Hi := 948 Make_Attribute_Reference (Loc, 949 Prefix => 950 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 951 Attribute_Name => Name_Last, 952 Expressions => New_List ( 953 Make_Integer_Literal (Loc, J))); 954 955 Append (Make_Range (Loc, Lo, Hi), Constraints); 956 end loop; 957 958 -- If the type has unknown discriminants there is no constrained 959 -- subtype to build. This is never called for a formal or for a 960 -- lhs, so returning the type is ok ??? 961 962 elsif Has_Unknown_Discriminants (T) then 963 return T; 964 965 else 966 Constraints := New_List; 967 968 -- Type T is a generic derived type, inherit the discriminants from 969 -- the parent type. 970 971 if Is_Private_Type (T) 972 and then No (Full_View (T)) 973 974 -- T was flagged as an error if it was declared as a formal 975 -- derived type with known discriminants. In this case there 976 -- is no need to look at the parent type since T already carries 977 -- its own discriminants. 978 979 and then not Error_Posted (T) 980 then 981 Disc_Type := Etype (Base_Type (T)); 982 else 983 Disc_Type := T; 984 end if; 985 986 Discr := First_Discriminant (Disc_Type); 987 while Present (Discr) loop 988 Append_To (Constraints, 989 Make_Selected_Component (Loc, 990 Prefix => 991 Duplicate_Subexpr_No_Checks (Obj), 992 Selector_Name => New_Occurrence_Of (Discr, Loc))); 993 Next_Discriminant (Discr); 994 end loop; 995 end if; 996 997 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 998 Set_Is_Internal (Subt); 999 1000 Decl := 1001 Make_Subtype_Declaration (Loc, 1002 Defining_Identifier => Subt, 1003 Subtype_Indication => 1004 Make_Subtype_Indication (Loc, 1005 Subtype_Mark => New_Occurrence_Of (T, Loc), 1006 Constraint => 1007 Make_Index_Or_Discriminant_Constraint (Loc, 1008 Constraints => Constraints))); 1009 1010 Mark_Rewrite_Insertion (Decl); 1011 return Decl; 1012 end Build_Actual_Subtype; 1013 1014 --------------------------------------- 1015 -- Build_Actual_Subtype_Of_Component -- 1016 --------------------------------------- 1017 1018 function Build_Actual_Subtype_Of_Component 1019 (T : Entity_Id; 1020 N : Node_Id) return Node_Id 1021 is 1022 Loc : constant Source_Ptr := Sloc (N); 1023 P : constant Node_Id := Prefix (N); 1024 D : Elmt_Id; 1025 Id : Node_Id; 1026 Index_Typ : Entity_Id; 1027 1028 Desig_Typ : Entity_Id; 1029 -- This is either a copy of T, or if T is an access type, then it is 1030 -- the directly designated type of this access type. 1031 1032 function Build_Actual_Array_Constraint return List_Id; 1033 -- If one or more of the bounds of the component depends on 1034 -- discriminants, build actual constraint using the discriminants 1035 -- of the prefix. 1036 1037 function Build_Actual_Record_Constraint return List_Id; 1038 -- Similar to previous one, for discriminated components constrained 1039 -- by the discriminant of the enclosing object. 1040 1041 ----------------------------------- 1042 -- Build_Actual_Array_Constraint -- 1043 ----------------------------------- 1044 1045 function Build_Actual_Array_Constraint return List_Id is 1046 Constraints : constant List_Id := New_List; 1047 Indx : Node_Id; 1048 Hi : Node_Id; 1049 Lo : Node_Id; 1050 Old_Hi : Node_Id; 1051 Old_Lo : Node_Id; 1052 1053 begin 1054 Indx := First_Index (Desig_Typ); 1055 while Present (Indx) loop 1056 Old_Lo := Type_Low_Bound (Etype (Indx)); 1057 Old_Hi := Type_High_Bound (Etype (Indx)); 1058 1059 if Denotes_Discriminant (Old_Lo) then 1060 Lo := 1061 Make_Selected_Component (Loc, 1062 Prefix => New_Copy_Tree (P), 1063 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 1064 1065 else 1066 Lo := New_Copy_Tree (Old_Lo); 1067 1068 -- The new bound will be reanalyzed in the enclosing 1069 -- declaration. For literal bounds that come from a type 1070 -- declaration, the type of the context must be imposed, so 1071 -- insure that analysis will take place. For non-universal 1072 -- types this is not strictly necessary. 1073 1074 Set_Analyzed (Lo, False); 1075 end if; 1076 1077 if Denotes_Discriminant (Old_Hi) then 1078 Hi := 1079 Make_Selected_Component (Loc, 1080 Prefix => New_Copy_Tree (P), 1081 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 1082 1083 else 1084 Hi := New_Copy_Tree (Old_Hi); 1085 Set_Analyzed (Hi, False); 1086 end if; 1087 1088 Append (Make_Range (Loc, Lo, Hi), Constraints); 1089 Next_Index (Indx); 1090 end loop; 1091 1092 return Constraints; 1093 end Build_Actual_Array_Constraint; 1094 1095 ------------------------------------ 1096 -- Build_Actual_Record_Constraint -- 1097 ------------------------------------ 1098 1099 function Build_Actual_Record_Constraint return List_Id is 1100 Constraints : constant List_Id := New_List; 1101 D : Elmt_Id; 1102 D_Val : Node_Id; 1103 1104 begin 1105 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1106 while Present (D) loop 1107 if Denotes_Discriminant (Node (D)) then 1108 D_Val := Make_Selected_Component (Loc, 1109 Prefix => New_Copy_Tree (P), 1110 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 1111 1112 else 1113 D_Val := New_Copy_Tree (Node (D)); 1114 end if; 1115 1116 Append (D_Val, Constraints); 1117 Next_Elmt (D); 1118 end loop; 1119 1120 return Constraints; 1121 end Build_Actual_Record_Constraint; 1122 1123 -- Start of processing for Build_Actual_Subtype_Of_Component 1124 1125 begin 1126 -- Why the test for Spec_Expression mode here??? 1127 1128 if In_Spec_Expression then 1129 return Empty; 1130 1131 -- More comments for the rest of this body would be good ??? 1132 1133 elsif Nkind (N) = N_Explicit_Dereference then 1134 if Is_Composite_Type (T) 1135 and then not Is_Constrained (T) 1136 and then not (Is_Class_Wide_Type (T) 1137 and then Is_Constrained (Root_Type (T))) 1138 and then not Has_Unknown_Discriminants (T) 1139 then 1140 -- If the type of the dereference is already constrained, it is an 1141 -- actual subtype. 1142 1143 if Is_Array_Type (Etype (N)) 1144 and then Is_Constrained (Etype (N)) 1145 then 1146 return Empty; 1147 else 1148 Remove_Side_Effects (P); 1149 return Build_Actual_Subtype (T, N); 1150 end if; 1151 else 1152 return Empty; 1153 end if; 1154 end if; 1155 1156 if Ekind (T) = E_Access_Subtype then 1157 Desig_Typ := Designated_Type (T); 1158 else 1159 Desig_Typ := T; 1160 end if; 1161 1162 if Ekind (Desig_Typ) = E_Array_Subtype then 1163 Id := First_Index (Desig_Typ); 1164 while Present (Id) loop 1165 Index_Typ := Underlying_Type (Etype (Id)); 1166 1167 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 1168 or else 1169 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 1170 then 1171 Remove_Side_Effects (P); 1172 return 1173 Build_Component_Subtype 1174 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 1175 end if; 1176 1177 Next_Index (Id); 1178 end loop; 1179 1180 elsif Is_Composite_Type (Desig_Typ) 1181 and then Has_Discriminants (Desig_Typ) 1182 and then not Has_Unknown_Discriminants (Desig_Typ) 1183 then 1184 if Is_Private_Type (Desig_Typ) 1185 and then No (Discriminant_Constraint (Desig_Typ)) 1186 then 1187 Desig_Typ := Full_View (Desig_Typ); 1188 end if; 1189 1190 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1191 while Present (D) loop 1192 if Denotes_Discriminant (Node (D)) then 1193 Remove_Side_Effects (P); 1194 return 1195 Build_Component_Subtype ( 1196 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 1197 end if; 1198 1199 Next_Elmt (D); 1200 end loop; 1201 end if; 1202 1203 -- If none of the above, the actual and nominal subtypes are the same 1204 1205 return Empty; 1206 end Build_Actual_Subtype_Of_Component; 1207 1208 ----------------------------- 1209 -- Build_Component_Subtype -- 1210 ----------------------------- 1211 1212 function Build_Component_Subtype 1213 (C : List_Id; 1214 Loc : Source_Ptr; 1215 T : Entity_Id) return Node_Id 1216 is 1217 Subt : Entity_Id; 1218 Decl : Node_Id; 1219 1220 begin 1221 -- Unchecked_Union components do not require component subtypes 1222 1223 if Is_Unchecked_Union (T) then 1224 return Empty; 1225 end if; 1226 1227 Subt := Make_Temporary (Loc, 'S'); 1228 Set_Is_Internal (Subt); 1229 1230 Decl := 1231 Make_Subtype_Declaration (Loc, 1232 Defining_Identifier => Subt, 1233 Subtype_Indication => 1234 Make_Subtype_Indication (Loc, 1235 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 1236 Constraint => 1237 Make_Index_Or_Discriminant_Constraint (Loc, 1238 Constraints => C))); 1239 1240 Mark_Rewrite_Insertion (Decl); 1241 return Decl; 1242 end Build_Component_Subtype; 1243 1244 ---------------------------------- 1245 -- Build_Default_Init_Cond_Call -- 1246 ---------------------------------- 1247 1248 function Build_Default_Init_Cond_Call 1249 (Loc : Source_Ptr; 1250 Obj_Id : Entity_Id; 1251 Typ : Entity_Id) return Node_Id 1252 is 1253 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); 1254 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id)); 1255 1256 begin 1257 return 1258 Make_Procedure_Call_Statement (Loc, 1259 Name => New_Occurrence_Of (Proc_Id, Loc), 1260 Parameter_Associations => New_List ( 1261 Make_Unchecked_Type_Conversion (Loc, 1262 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc), 1263 Expression => New_Occurrence_Of (Obj_Id, Loc)))); 1264 end Build_Default_Init_Cond_Call; 1265 1266 ---------------------------------------------- 1267 -- Build_Default_Init_Cond_Procedure_Bodies -- 1268 ---------------------------------------------- 1269 1270 procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is 1271 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id); 1272 -- If type Typ is subject to pragma Default_Initial_Condition, build the 1273 -- body of the procedure which verifies the assumption of the pragma at 1274 -- run time. The generated body is added after the type declaration. 1275 1276 -------------------------------------------- 1277 -- Build_Default_Init_Cond_Procedure_Body -- 1278 -------------------------------------------- 1279 1280 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is 1281 Param_Id : Entity_Id; 1282 -- The entity of the sole formal parameter of the default initial 1283 -- condition procedure. 1284 1285 procedure Replace_Type_Reference (N : Node_Id); 1286 -- Replace a single reference to type Typ with a reference to formal 1287 -- parameter Param_Id. 1288 1289 ---------------------------- 1290 -- Replace_Type_Reference -- 1291 ---------------------------- 1292 1293 procedure Replace_Type_Reference (N : Node_Id) is 1294 begin 1295 Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N))); 1296 end Replace_Type_Reference; 1297 1298 procedure Replace_Type_References is 1299 new Replace_Type_References_Generic (Replace_Type_Reference); 1300 1301 -- Local variables 1302 1303 Loc : constant Source_Ptr := Sloc (Typ); 1304 Prag : constant Node_Id := 1305 Get_Pragma (Typ, Pragma_Default_Initial_Condition); 1306 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); 1307 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id); 1308 Body_Decl : Node_Id; 1309 Expr : Node_Id; 1310 Stmt : Node_Id; 1311 1312 -- Start of processing for Build_Default_Init_Cond_Procedure_Body 1313 1314 begin 1315 -- The procedure should be generated only for [sub]types subject to 1316 -- pragma Default_Initial_Condition. Types that inherit the pragma do 1317 -- not get this specialized procedure. 1318 1319 pragma Assert (Has_Default_Init_Cond (Typ)); 1320 pragma Assert (Present (Prag)); 1321 pragma Assert (Present (Proc_Id)); 1322 1323 -- Nothing to do if the body was already built 1324 1325 if Present (Corresponding_Body (Spec_Decl)) then 1326 return; 1327 end if; 1328 1329 Param_Id := First_Formal (Proc_Id); 1330 1331 -- The pragma has an argument. Note that the argument is analyzed 1332 -- after all references to the current instance of the type are 1333 -- replaced. 1334 1335 if Present (Pragma_Argument_Associations (Prag)) then 1336 Expr := 1337 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 1338 1339 if Nkind (Expr) = N_Null then 1340 Stmt := Make_Null_Statement (Loc); 1341 1342 -- Preserve the original argument of the pragma by replicating it. 1343 -- Replace all references to the current instance of the type with 1344 -- references to the formal parameter. 1345 1346 else 1347 Expr := New_Copy_Tree (Expr); 1348 Replace_Type_References (Expr, Typ); 1349 1350 -- Generate: 1351 -- pragma Check (Default_Initial_Condition, <Expr>); 1352 1353 Stmt := 1354 Make_Pragma (Loc, 1355 Pragma_Identifier => 1356 Make_Identifier (Loc, Name_Check), 1357 1358 Pragma_Argument_Associations => New_List ( 1359 Make_Pragma_Argument_Association (Loc, 1360 Expression => 1361 Make_Identifier (Loc, 1362 Chars => Name_Default_Initial_Condition)), 1363 Make_Pragma_Argument_Association (Loc, 1364 Expression => Expr))); 1365 end if; 1366 1367 -- Otherwise the pragma appears without an argument 1368 1369 else 1370 Stmt := Make_Null_Statement (Loc); 1371 end if; 1372 1373 -- Generate: 1374 -- procedure <Typ>Default_Init_Cond (I : <Typ>) is 1375 -- begin 1376 -- <Stmt>; 1377 -- end <Typ>Default_Init_Cond; 1378 1379 Body_Decl := 1380 Make_Subprogram_Body (Loc, 1381 Specification => 1382 Copy_Separate_Tree (Specification (Spec_Decl)), 1383 Declarations => Empty_List, 1384 Handled_Statement_Sequence => 1385 Make_Handled_Sequence_Of_Statements (Loc, 1386 Statements => New_List (Stmt))); 1387 1388 -- Link the spec and body of the default initial condition procedure 1389 -- to prevent the generation of a duplicate body. 1390 1391 Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); 1392 Set_Corresponding_Spec (Body_Decl, Proc_Id); 1393 1394 Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl); 1395 end Build_Default_Init_Cond_Procedure_Body; 1396 1397 -- Local variables 1398 1399 Decl : Node_Id; 1400 Typ : Entity_Id; 1401 1402 -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies 1403 1404 begin 1405 -- Inspect the private declarations looking for [sub]type declarations 1406 1407 Decl := First (Priv_Decls); 1408 while Present (Decl) loop 1409 if Nkind_In (Decl, N_Full_Type_Declaration, 1410 N_Subtype_Declaration) 1411 then 1412 Typ := Defining_Entity (Decl); 1413 1414 -- Guard against partially decorate types due to previous errors 1415 1416 if Is_Type (Typ) then 1417 1418 -- If the type is subject to pragma Default_Initial_Condition, 1419 -- generate the body of the internal procedure which verifies 1420 -- the assertion of the pragma at run time. 1421 1422 if Has_Default_Init_Cond (Typ) then 1423 Build_Default_Init_Cond_Procedure_Body (Typ); 1424 1425 -- A derived type inherits the default initial condition 1426 -- procedure from its parent type. 1427 1428 elsif Has_Inherited_Default_Init_Cond (Typ) then 1429 Inherit_Default_Init_Cond_Procedure (Typ); 1430 end if; 1431 end if; 1432 end if; 1433 1434 Next (Decl); 1435 end loop; 1436 end Build_Default_Init_Cond_Procedure_Bodies; 1437 1438 --------------------------------------------------- 1439 -- Build_Default_Init_Cond_Procedure_Declaration -- 1440 --------------------------------------------------- 1441 1442 procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is 1443 Loc : constant Source_Ptr := Sloc (Typ); 1444 Prag : constant Node_Id := 1445 Get_Pragma (Typ, Pragma_Default_Initial_Condition); 1446 Proc_Id : Entity_Id; 1447 1448 begin 1449 -- The procedure should be generated only for types subject to pragma 1450 -- Default_Initial_Condition. Types that inherit the pragma do not get 1451 -- this specialized procedure. 1452 1453 pragma Assert (Has_Default_Init_Cond (Typ)); 1454 pragma Assert (Present (Prag)); 1455 1456 -- Nothing to do if default initial condition procedure already built 1457 1458 if Present (Default_Init_Cond_Procedure (Typ)) then 1459 return; 1460 end if; 1461 1462 Proc_Id := 1463 Make_Defining_Identifier (Loc, 1464 Chars => New_External_Name (Chars (Typ), "Default_Init_Cond")); 1465 1466 -- Associate default initial condition procedure with the private type 1467 1468 Set_Ekind (Proc_Id, E_Procedure); 1469 Set_Is_Default_Init_Cond_Procedure (Proc_Id); 1470 Set_Default_Init_Cond_Procedure (Typ, Proc_Id); 1471 1472 -- Generate: 1473 -- procedure <Typ>Default_Init_Cond (Inn : <Typ>); 1474 1475 Insert_After_And_Analyze (Prag, 1476 Make_Subprogram_Declaration (Loc, 1477 Specification => 1478 Make_Procedure_Specification (Loc, 1479 Defining_Unit_Name => Proc_Id, 1480 Parameter_Specifications => New_List ( 1481 Make_Parameter_Specification (Loc, 1482 Defining_Identifier => Make_Temporary (Loc, 'I'), 1483 Parameter_Type => New_Occurrence_Of (Typ, Loc)))))); 1484 end Build_Default_Init_Cond_Procedure_Declaration; 1485 1486 --------------------------- 1487 -- Build_Default_Subtype -- 1488 --------------------------- 1489 1490 function Build_Default_Subtype 1491 (T : Entity_Id; 1492 N : Node_Id) return Entity_Id 1493 is 1494 Loc : constant Source_Ptr := Sloc (N); 1495 Disc : Entity_Id; 1496 1497 Bas : Entity_Id; 1498 -- The base type that is to be constrained by the defaults 1499 1500 begin 1501 if not Has_Discriminants (T) or else Is_Constrained (T) then 1502 return T; 1503 end if; 1504 1505 Bas := Base_Type (T); 1506 1507 -- If T is non-private but its base type is private, this is the 1508 -- completion of a subtype declaration whose parent type is private 1509 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 1510 -- are to be found in the full view of the base. Check that the private 1511 -- status of T and its base differ. 1512 1513 if Is_Private_Type (Bas) 1514 and then not Is_Private_Type (T) 1515 and then Present (Full_View (Bas)) 1516 then 1517 Bas := Full_View (Bas); 1518 end if; 1519 1520 Disc := First_Discriminant (T); 1521 1522 if No (Discriminant_Default_Value (Disc)) then 1523 return T; 1524 end if; 1525 1526 declare 1527 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 1528 Constraints : constant List_Id := New_List; 1529 Decl : Node_Id; 1530 1531 begin 1532 while Present (Disc) loop 1533 Append_To (Constraints, 1534 New_Copy_Tree (Discriminant_Default_Value (Disc))); 1535 Next_Discriminant (Disc); 1536 end loop; 1537 1538 Decl := 1539 Make_Subtype_Declaration (Loc, 1540 Defining_Identifier => Act, 1541 Subtype_Indication => 1542 Make_Subtype_Indication (Loc, 1543 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 1544 Constraint => 1545 Make_Index_Or_Discriminant_Constraint (Loc, 1546 Constraints => Constraints))); 1547 1548 Insert_Action (N, Decl); 1549 Analyze (Decl); 1550 return Act; 1551 end; 1552 end Build_Default_Subtype; 1553 1554 -------------------------------------------- 1555 -- Build_Discriminal_Subtype_Of_Component -- 1556 -------------------------------------------- 1557 1558 function Build_Discriminal_Subtype_Of_Component 1559 (T : Entity_Id) return Node_Id 1560 is 1561 Loc : constant Source_Ptr := Sloc (T); 1562 D : Elmt_Id; 1563 Id : Node_Id; 1564 1565 function Build_Discriminal_Array_Constraint return List_Id; 1566 -- If one or more of the bounds of the component depends on 1567 -- discriminants, build actual constraint using the discriminants 1568 -- of the prefix. 1569 1570 function Build_Discriminal_Record_Constraint return List_Id; 1571 -- Similar to previous one, for discriminated components constrained by 1572 -- the discriminant of the enclosing object. 1573 1574 ---------------------------------------- 1575 -- Build_Discriminal_Array_Constraint -- 1576 ---------------------------------------- 1577 1578 function Build_Discriminal_Array_Constraint return List_Id is 1579 Constraints : constant List_Id := New_List; 1580 Indx : Node_Id; 1581 Hi : Node_Id; 1582 Lo : Node_Id; 1583 Old_Hi : Node_Id; 1584 Old_Lo : Node_Id; 1585 1586 begin 1587 Indx := First_Index (T); 1588 while Present (Indx) loop 1589 Old_Lo := Type_Low_Bound (Etype (Indx)); 1590 Old_Hi := Type_High_Bound (Etype (Indx)); 1591 1592 if Denotes_Discriminant (Old_Lo) then 1593 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 1594 1595 else 1596 Lo := New_Copy_Tree (Old_Lo); 1597 end if; 1598 1599 if Denotes_Discriminant (Old_Hi) then 1600 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 1601 1602 else 1603 Hi := New_Copy_Tree (Old_Hi); 1604 end if; 1605 1606 Append (Make_Range (Loc, Lo, Hi), Constraints); 1607 Next_Index (Indx); 1608 end loop; 1609 1610 return Constraints; 1611 end Build_Discriminal_Array_Constraint; 1612 1613 ----------------------------------------- 1614 -- Build_Discriminal_Record_Constraint -- 1615 ----------------------------------------- 1616 1617 function Build_Discriminal_Record_Constraint return List_Id is 1618 Constraints : constant List_Id := New_List; 1619 D : Elmt_Id; 1620 D_Val : Node_Id; 1621 1622 begin 1623 D := First_Elmt (Discriminant_Constraint (T)); 1624 while Present (D) loop 1625 if Denotes_Discriminant (Node (D)) then 1626 D_Val := 1627 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 1628 else 1629 D_Val := New_Copy_Tree (Node (D)); 1630 end if; 1631 1632 Append (D_Val, Constraints); 1633 Next_Elmt (D); 1634 end loop; 1635 1636 return Constraints; 1637 end Build_Discriminal_Record_Constraint; 1638 1639 -- Start of processing for Build_Discriminal_Subtype_Of_Component 1640 1641 begin 1642 if Ekind (T) = E_Array_Subtype then 1643 Id := First_Index (T); 1644 while Present (Id) loop 1645 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) 1646 or else 1647 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 1648 then 1649 return Build_Component_Subtype 1650 (Build_Discriminal_Array_Constraint, Loc, T); 1651 end if; 1652 1653 Next_Index (Id); 1654 end loop; 1655 1656 elsif Ekind (T) = E_Record_Subtype 1657 and then Has_Discriminants (T) 1658 and then not Has_Unknown_Discriminants (T) 1659 then 1660 D := First_Elmt (Discriminant_Constraint (T)); 1661 while Present (D) loop 1662 if Denotes_Discriminant (Node (D)) then 1663 return Build_Component_Subtype 1664 (Build_Discriminal_Record_Constraint, Loc, T); 1665 end if; 1666 1667 Next_Elmt (D); 1668 end loop; 1669 end if; 1670 1671 -- If none of the above, the actual and nominal subtypes are the same 1672 1673 return Empty; 1674 end Build_Discriminal_Subtype_Of_Component; 1675 1676 ------------------------------ 1677 -- Build_Elaboration_Entity -- 1678 ------------------------------ 1679 1680 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 1681 Loc : constant Source_Ptr := Sloc (N); 1682 Decl : Node_Id; 1683 Elab_Ent : Entity_Id; 1684 1685 procedure Set_Package_Name (Ent : Entity_Id); 1686 -- Given an entity, sets the fully qualified name of the entity in 1687 -- Name_Buffer, with components separated by double underscores. This 1688 -- is a recursive routine that climbs the scope chain to Standard. 1689 1690 ---------------------- 1691 -- Set_Package_Name -- 1692 ---------------------- 1693 1694 procedure Set_Package_Name (Ent : Entity_Id) is 1695 begin 1696 if Scope (Ent) /= Standard_Standard then 1697 Set_Package_Name (Scope (Ent)); 1698 1699 declare 1700 Nam : constant String := Get_Name_String (Chars (Ent)); 1701 begin 1702 Name_Buffer (Name_Len + 1) := '_'; 1703 Name_Buffer (Name_Len + 2) := '_'; 1704 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 1705 Name_Len := Name_Len + Nam'Length + 2; 1706 end; 1707 1708 else 1709 Get_Name_String (Chars (Ent)); 1710 end if; 1711 end Set_Package_Name; 1712 1713 -- Start of processing for Build_Elaboration_Entity 1714 1715 begin 1716 -- Ignore call if already constructed 1717 1718 if Present (Elaboration_Entity (Spec_Id)) then 1719 return; 1720 1721 -- Ignore in ASIS mode, elaboration entity is not in source and plays 1722 -- no role in analysis. 1723 1724 elsif ASIS_Mode then 1725 return; 1726 1727 -- See if we need elaboration entity. We always need it for the dynamic 1728 -- elaboration model, since it is needed to properly generate the PE 1729 -- exception for access before elaboration. 1730 1731 elsif Dynamic_Elaboration_Checks then 1732 null; 1733 1734 -- For the static model, we don't need the elaboration counter if this 1735 -- unit is sure to have no elaboration code, since that means there 1736 -- is no elaboration unit to be called. Note that we can't just decide 1737 -- after the fact by looking to see whether there was elaboration code, 1738 -- because that's too late to make this decision. 1739 1740 elsif Restriction_Active (No_Elaboration_Code) then 1741 return; 1742 1743 -- Similarly, for the static model, we can skip the elaboration counter 1744 -- if we have the No_Multiple_Elaboration restriction, since for the 1745 -- static model, that's the only purpose of the counter (to avoid 1746 -- multiple elaboration). 1747 1748 elsif Restriction_Active (No_Multiple_Elaboration) then 1749 return; 1750 end if; 1751 1752 -- Here we need the elaboration entity 1753 1754 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 1755 -- name with dots replaced by double underscore. We have to manually 1756 -- construct this name, since it will be elaborated in the outer scope, 1757 -- and thus will not have the unit name automatically prepended. 1758 1759 Set_Package_Name (Spec_Id); 1760 Add_Str_To_Name_Buffer ("_E"); 1761 1762 -- Create elaboration counter 1763 1764 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 1765 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 1766 1767 Decl := 1768 Make_Object_Declaration (Loc, 1769 Defining_Identifier => Elab_Ent, 1770 Object_Definition => 1771 New_Occurrence_Of (Standard_Short_Integer, Loc), 1772 Expression => Make_Integer_Literal (Loc, Uint_0)); 1773 1774 Push_Scope (Standard_Standard); 1775 Add_Global_Declaration (Decl); 1776 Pop_Scope; 1777 1778 -- Reset True_Constant indication, since we will indeed assign a value 1779 -- to the variable in the binder main. We also kill the Current_Value 1780 -- and Last_Assignment fields for the same reason. 1781 1782 Set_Is_True_Constant (Elab_Ent, False); 1783 Set_Current_Value (Elab_Ent, Empty); 1784 Set_Last_Assignment (Elab_Ent, Empty); 1785 1786 -- We do not want any further qualification of the name (if we did not 1787 -- do this, we would pick up the name of the generic package in the case 1788 -- of a library level generic instantiation). 1789 1790 Set_Has_Qualified_Name (Elab_Ent); 1791 Set_Has_Fully_Qualified_Name (Elab_Ent); 1792 end Build_Elaboration_Entity; 1793 1794 -------------------------------- 1795 -- Build_Explicit_Dereference -- 1796 -------------------------------- 1797 1798 procedure Build_Explicit_Dereference 1799 (Expr : Node_Id; 1800 Disc : Entity_Id) 1801 is 1802 Loc : constant Source_Ptr := Sloc (Expr); 1803 1804 begin 1805 -- An entity of a type with a reference aspect is overloaded with 1806 -- both interpretations: with and without the dereference. Now that 1807 -- the dereference is made explicit, set the type of the node properly, 1808 -- to prevent anomalies in the backend. Same if the expression is an 1809 -- overloaded function call whose return type has a reference aspect. 1810 1811 if Is_Entity_Name (Expr) then 1812 Set_Etype (Expr, Etype (Entity (Expr))); 1813 1814 elsif Nkind (Expr) = N_Function_Call then 1815 Set_Etype (Expr, Etype (Name (Expr))); 1816 end if; 1817 1818 Set_Is_Overloaded (Expr, False); 1819 1820 -- The expression will often be a generalized indexing that yields a 1821 -- container element that is then dereferenced, in which case the 1822 -- generalized indexing call is also non-overloaded. 1823 1824 if Nkind (Expr) = N_Indexed_Component 1825 and then Present (Generalized_Indexing (Expr)) 1826 then 1827 Set_Is_Overloaded (Generalized_Indexing (Expr), False); 1828 end if; 1829 1830 Rewrite (Expr, 1831 Make_Explicit_Dereference (Loc, 1832 Prefix => 1833 Make_Selected_Component (Loc, 1834 Prefix => Relocate_Node (Expr), 1835 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 1836 Set_Etype (Prefix (Expr), Etype (Disc)); 1837 Set_Etype (Expr, Designated_Type (Etype (Disc))); 1838 end Build_Explicit_Dereference; 1839 1840 ----------------------------------- 1841 -- Cannot_Raise_Constraint_Error -- 1842 ----------------------------------- 1843 1844 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 1845 begin 1846 if Compile_Time_Known_Value (Expr) then 1847 return True; 1848 1849 elsif Do_Range_Check (Expr) then 1850 return False; 1851 1852 elsif Raises_Constraint_Error (Expr) then 1853 return False; 1854 1855 else 1856 case Nkind (Expr) is 1857 when N_Identifier => 1858 return True; 1859 1860 when N_Expanded_Name => 1861 return True; 1862 1863 when N_Selected_Component => 1864 return not Do_Discriminant_Check (Expr); 1865 1866 when N_Attribute_Reference => 1867 if Do_Overflow_Check (Expr) then 1868 return False; 1869 1870 elsif No (Expressions (Expr)) then 1871 return True; 1872 1873 else 1874 declare 1875 N : Node_Id; 1876 1877 begin 1878 N := First (Expressions (Expr)); 1879 while Present (N) loop 1880 if Cannot_Raise_Constraint_Error (N) then 1881 Next (N); 1882 else 1883 return False; 1884 end if; 1885 end loop; 1886 1887 return True; 1888 end; 1889 end if; 1890 1891 when N_Type_Conversion => 1892 if Do_Overflow_Check (Expr) 1893 or else Do_Length_Check (Expr) 1894 or else Do_Tag_Check (Expr) 1895 then 1896 return False; 1897 else 1898 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1899 end if; 1900 1901 when N_Unchecked_Type_Conversion => 1902 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1903 1904 when N_Unary_Op => 1905 if Do_Overflow_Check (Expr) then 1906 return False; 1907 else 1908 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1909 end if; 1910 1911 when N_Op_Divide | 1912 N_Op_Mod | 1913 N_Op_Rem 1914 => 1915 if Do_Division_Check (Expr) 1916 or else 1917 Do_Overflow_Check (Expr) 1918 then 1919 return False; 1920 else 1921 return 1922 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1923 and then 1924 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1925 end if; 1926 1927 when N_Op_Add | 1928 N_Op_And | 1929 N_Op_Concat | 1930 N_Op_Eq | 1931 N_Op_Expon | 1932 N_Op_Ge | 1933 N_Op_Gt | 1934 N_Op_Le | 1935 N_Op_Lt | 1936 N_Op_Multiply | 1937 N_Op_Ne | 1938 N_Op_Or | 1939 N_Op_Rotate_Left | 1940 N_Op_Rotate_Right | 1941 N_Op_Shift_Left | 1942 N_Op_Shift_Right | 1943 N_Op_Shift_Right_Arithmetic | 1944 N_Op_Subtract | 1945 N_Op_Xor 1946 => 1947 if Do_Overflow_Check (Expr) then 1948 return False; 1949 else 1950 return 1951 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1952 and then 1953 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1954 end if; 1955 1956 when others => 1957 return False; 1958 end case; 1959 end if; 1960 end Cannot_Raise_Constraint_Error; 1961 1962 ----------------------------------------- 1963 -- Check_Dynamically_Tagged_Expression -- 1964 ----------------------------------------- 1965 1966 procedure Check_Dynamically_Tagged_Expression 1967 (Expr : Node_Id; 1968 Typ : Entity_Id; 1969 Related_Nod : Node_Id) 1970 is 1971 begin 1972 pragma Assert (Is_Tagged_Type (Typ)); 1973 1974 -- In order to avoid spurious errors when analyzing the expanded code, 1975 -- this check is done only for nodes that come from source and for 1976 -- actuals of generic instantiations. 1977 1978 if (Comes_From_Source (Related_Nod) 1979 or else In_Generic_Actual (Expr)) 1980 and then (Is_Class_Wide_Type (Etype (Expr)) 1981 or else Is_Dynamically_Tagged (Expr)) 1982 and then Is_Tagged_Type (Typ) 1983 and then not Is_Class_Wide_Type (Typ) 1984 then 1985 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 1986 end if; 1987 end Check_Dynamically_Tagged_Expression; 1988 1989 -------------------------- 1990 -- Check_Fully_Declared -- 1991 -------------------------- 1992 1993 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 1994 begin 1995 if Ekind (T) = E_Incomplete_Type then 1996 1997 -- Ada 2005 (AI-50217): If the type is available through a limited 1998 -- with_clause, verify that its full view has been analyzed. 1999 2000 if From_Limited_With (T) 2001 and then Present (Non_Limited_View (T)) 2002 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 2003 then 2004 -- The non-limited view is fully declared 2005 2006 null; 2007 2008 else 2009 Error_Msg_NE 2010 ("premature usage of incomplete}", N, First_Subtype (T)); 2011 end if; 2012 2013 -- Need comments for these tests ??? 2014 2015 elsif Has_Private_Component (T) 2016 and then not Is_Generic_Type (Root_Type (T)) 2017 and then not In_Spec_Expression 2018 then 2019 -- Special case: if T is the anonymous type created for a single 2020 -- task or protected object, use the name of the source object. 2021 2022 if Is_Concurrent_Type (T) 2023 and then not Comes_From_Source (T) 2024 and then Nkind (N) = N_Object_Declaration 2025 then 2026 Error_Msg_NE 2027 ("type of& has incomplete component", 2028 N, Defining_Identifier (N)); 2029 else 2030 Error_Msg_NE 2031 ("premature usage of incomplete}", 2032 N, First_Subtype (T)); 2033 end if; 2034 end if; 2035 end Check_Fully_Declared; 2036 2037 ------------------------------------- 2038 -- Check_Function_Writable_Actuals -- 2039 ------------------------------------- 2040 2041 procedure Check_Function_Writable_Actuals (N : Node_Id) is 2042 Writable_Actuals_List : Elist_Id := No_Elist; 2043 Identifiers_List : Elist_Id := No_Elist; 2044 Error_Node : Node_Id := Empty; 2045 2046 procedure Collect_Identifiers (N : Node_Id); 2047 -- In a single traversal of subtree N collect in Writable_Actuals_List 2048 -- all the actuals of functions with writable actuals, and in the list 2049 -- Identifiers_List collect all the identifiers that are not actuals of 2050 -- functions with writable actuals. If a writable actual is referenced 2051 -- twice as writable actual then Error_Node is set to reference its 2052 -- second occurrence, the error is reported, and the tree traversal 2053 -- is abandoned. 2054 2055 function Get_Function_Id (Call : Node_Id) return Entity_Id; 2056 -- Return the entity associated with the function call 2057 2058 procedure Preanalyze_Without_Errors (N : Node_Id); 2059 -- Preanalyze N without reporting errors. Very dubious, you can't just 2060 -- go analyzing things more than once??? 2061 2062 ------------------------- 2063 -- Collect_Identifiers -- 2064 ------------------------- 2065 2066 procedure Collect_Identifiers (N : Node_Id) is 2067 2068 function Check_Node (N : Node_Id) return Traverse_Result; 2069 -- Process a single node during the tree traversal to collect the 2070 -- writable actuals of functions and all the identifiers which are 2071 -- not writable actuals of functions. 2072 2073 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 2074 -- Returns True if List has a node whose Entity is Entity (N) 2075 2076 ------------------------- 2077 -- Check_Function_Call -- 2078 ------------------------- 2079 2080 function Check_Node (N : Node_Id) return Traverse_Result is 2081 Is_Writable_Actual : Boolean := False; 2082 Id : Entity_Id; 2083 2084 begin 2085 if Nkind (N) = N_Identifier then 2086 2087 -- No analysis possible if the entity is not decorated 2088 2089 if No (Entity (N)) then 2090 return Skip; 2091 2092 -- Don't collect identifiers of packages, called functions, etc 2093 2094 elsif Ekind_In (Entity (N), E_Package, 2095 E_Function, 2096 E_Procedure, 2097 E_Entry) 2098 then 2099 return Skip; 2100 2101 -- Analyze if N is a writable actual of a function 2102 2103 elsif Nkind (Parent (N)) = N_Function_Call then 2104 declare 2105 Call : constant Node_Id := Parent (N); 2106 Actual : Node_Id; 2107 Formal : Node_Id; 2108 2109 begin 2110 Id := Get_Function_Id (Call); 2111 2112 -- In case of previous error, no check is possible 2113 2114 if No (Id) then 2115 return Abandon; 2116 end if; 2117 2118 Formal := First_Formal (Id); 2119 Actual := First_Actual (Call); 2120 while Present (Actual) and then Present (Formal) loop 2121 if Actual = N then 2122 if Ekind_In (Formal, E_Out_Parameter, 2123 E_In_Out_Parameter) 2124 then 2125 Is_Writable_Actual := True; 2126 end if; 2127 2128 exit; 2129 end if; 2130 2131 Next_Formal (Formal); 2132 Next_Actual (Actual); 2133 end loop; 2134 end; 2135 end if; 2136 2137 if Is_Writable_Actual then 2138 if Contains (Writable_Actuals_List, N) then 2139 Error_Msg_NE 2140 ("value may be affected by call to& " 2141 & "because order of evaluation is arbitrary", N, Id); 2142 Error_Node := N; 2143 return Abandon; 2144 end if; 2145 2146 Append_New_Elmt (N, To => Writable_Actuals_List); 2147 2148 else 2149 if Identifiers_List = No_Elist then 2150 Identifiers_List := New_Elmt_List; 2151 end if; 2152 2153 Append_Unique_Elmt (N, Identifiers_List); 2154 end if; 2155 end if; 2156 2157 return OK; 2158 end Check_Node; 2159 2160 -------------- 2161 -- Contains -- 2162 -------------- 2163 2164 function Contains 2165 (List : Elist_Id; 2166 N : Node_Id) return Boolean 2167 is 2168 pragma Assert (Nkind (N) in N_Has_Entity); 2169 2170 Elmt : Elmt_Id; 2171 2172 begin 2173 if List = No_Elist then 2174 return False; 2175 end if; 2176 2177 Elmt := First_Elmt (List); 2178 while Present (Elmt) loop 2179 if Entity (Node (Elmt)) = Entity (N) then 2180 return True; 2181 else 2182 Next_Elmt (Elmt); 2183 end if; 2184 end loop; 2185 2186 return False; 2187 end Contains; 2188 2189 ------------------ 2190 -- Do_Traversal -- 2191 ------------------ 2192 2193 procedure Do_Traversal is new Traverse_Proc (Check_Node); 2194 -- The traversal procedure 2195 2196 -- Start of processing for Collect_Identifiers 2197 2198 begin 2199 if Present (Error_Node) then 2200 return; 2201 end if; 2202 2203 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 2204 return; 2205 end if; 2206 2207 Do_Traversal (N); 2208 end Collect_Identifiers; 2209 2210 --------------------- 2211 -- Get_Function_Id -- 2212 --------------------- 2213 2214 function Get_Function_Id (Call : Node_Id) return Entity_Id is 2215 Nam : constant Node_Id := Name (Call); 2216 Id : Entity_Id; 2217 2218 begin 2219 if Nkind (Nam) = N_Explicit_Dereference then 2220 Id := Etype (Nam); 2221 pragma Assert (Ekind (Id) = E_Subprogram_Type); 2222 2223 elsif Nkind (Nam) = N_Selected_Component then 2224 Id := Entity (Selector_Name (Nam)); 2225 2226 elsif Nkind (Nam) = N_Indexed_Component then 2227 Id := Entity (Selector_Name (Prefix (Nam))); 2228 2229 else 2230 Id := Entity (Nam); 2231 end if; 2232 2233 return Id; 2234 end Get_Function_Id; 2235 2236 --------------------------- 2237 -- Preanalyze_Expression -- 2238 --------------------------- 2239 2240 procedure Preanalyze_Without_Errors (N : Node_Id) is 2241 Status : constant Boolean := Get_Ignore_Errors; 2242 begin 2243 Set_Ignore_Errors (True); 2244 Preanalyze (N); 2245 Set_Ignore_Errors (Status); 2246 end Preanalyze_Without_Errors; 2247 2248 -- Start of processing for Check_Function_Writable_Actuals 2249 2250 begin 2251 -- The check only applies to Ada 2012 code, and only to constructs that 2252 -- have multiple constituents whose order of evaluation is not specified 2253 -- by the language. 2254 2255 if Ada_Version < Ada_2012 2256 or else (not (Nkind (N) in N_Op) 2257 and then not (Nkind (N) in N_Membership_Test) 2258 and then not Nkind_In (N, N_Range, 2259 N_Aggregate, 2260 N_Extension_Aggregate, 2261 N_Full_Type_Declaration, 2262 N_Function_Call, 2263 N_Procedure_Call_Statement, 2264 N_Entry_Call_Statement)) 2265 or else (Nkind (N) = N_Full_Type_Declaration 2266 and then not Is_Record_Type (Defining_Identifier (N))) 2267 2268 -- In addition, this check only applies to source code, not to code 2269 -- generated by constraint checks. 2270 2271 or else not Comes_From_Source (N) 2272 then 2273 return; 2274 end if; 2275 2276 -- If a construct C has two or more direct constituents that are names 2277 -- or expressions whose evaluation may occur in an arbitrary order, at 2278 -- least one of which contains a function call with an in out or out 2279 -- parameter, then the construct is legal only if: for each name N that 2280 -- is passed as a parameter of mode in out or out to some inner function 2281 -- call C2 (not including the construct C itself), there is no other 2282 -- name anywhere within a direct constituent of the construct C other 2283 -- than the one containing C2, that is known to refer to the same 2284 -- object (RM 6.4.1(6.17/3)). 2285 2286 case Nkind (N) is 2287 when N_Range => 2288 Collect_Identifiers (Low_Bound (N)); 2289 Collect_Identifiers (High_Bound (N)); 2290 2291 when N_Op | N_Membership_Test => 2292 declare 2293 Expr : Node_Id; 2294 2295 begin 2296 Collect_Identifiers (Left_Opnd (N)); 2297 2298 if Present (Right_Opnd (N)) then 2299 Collect_Identifiers (Right_Opnd (N)); 2300 end if; 2301 2302 if Nkind_In (N, N_In, N_Not_In) 2303 and then Present (Alternatives (N)) 2304 then 2305 Expr := First (Alternatives (N)); 2306 while Present (Expr) loop 2307 Collect_Identifiers (Expr); 2308 2309 Next (Expr); 2310 end loop; 2311 end if; 2312 end; 2313 2314 when N_Full_Type_Declaration => 2315 declare 2316 function Get_Record_Part (N : Node_Id) return Node_Id; 2317 -- Return the record part of this record type definition 2318 2319 function Get_Record_Part (N : Node_Id) return Node_Id is 2320 Type_Def : constant Node_Id := Type_Definition (N); 2321 begin 2322 if Nkind (Type_Def) = N_Derived_Type_Definition then 2323 return Record_Extension_Part (Type_Def); 2324 else 2325 return Type_Def; 2326 end if; 2327 end Get_Record_Part; 2328 2329 Comp : Node_Id; 2330 Def_Id : Entity_Id := Defining_Identifier (N); 2331 Rec : Node_Id := Get_Record_Part (N); 2332 2333 begin 2334 -- No need to perform any analysis if the record has no 2335 -- components 2336 2337 if No (Rec) or else No (Component_List (Rec)) then 2338 return; 2339 end if; 2340 2341 -- Collect the identifiers starting from the deepest 2342 -- derivation. Done to report the error in the deepest 2343 -- derivation. 2344 2345 loop 2346 if Present (Component_List (Rec)) then 2347 Comp := First (Component_Items (Component_List (Rec))); 2348 while Present (Comp) loop 2349 if Nkind (Comp) = N_Component_Declaration 2350 and then Present (Expression (Comp)) 2351 then 2352 Collect_Identifiers (Expression (Comp)); 2353 end if; 2354 2355 Next (Comp); 2356 end loop; 2357 end if; 2358 2359 exit when No (Underlying_Type (Etype (Def_Id))) 2360 or else Base_Type (Underlying_Type (Etype (Def_Id))) 2361 = Def_Id; 2362 2363 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 2364 Rec := Get_Record_Part (Parent (Def_Id)); 2365 end loop; 2366 end; 2367 2368 when N_Subprogram_Call | 2369 N_Entry_Call_Statement => 2370 declare 2371 Id : constant Entity_Id := Get_Function_Id (N); 2372 Formal : Node_Id; 2373 Actual : Node_Id; 2374 2375 begin 2376 Formal := First_Formal (Id); 2377 Actual := First_Actual (N); 2378 while Present (Actual) and then Present (Formal) loop 2379 if Ekind_In (Formal, E_Out_Parameter, 2380 E_In_Out_Parameter) 2381 then 2382 Collect_Identifiers (Actual); 2383 end if; 2384 2385 Next_Formal (Formal); 2386 Next_Actual (Actual); 2387 end loop; 2388 end; 2389 2390 when N_Aggregate | 2391 N_Extension_Aggregate => 2392 declare 2393 Assoc : Node_Id; 2394 Choice : Node_Id; 2395 Comp_Expr : Node_Id; 2396 2397 begin 2398 -- Handle the N_Others_Choice of array aggregates with static 2399 -- bounds. There is no need to perform this analysis in 2400 -- aggregates without static bounds since we cannot evaluate 2401 -- if the N_Others_Choice covers several elements. There is 2402 -- no need to handle the N_Others choice of record aggregates 2403 -- since at this stage it has been already expanded by 2404 -- Resolve_Record_Aggregate. 2405 2406 if Is_Array_Type (Etype (N)) 2407 and then Nkind (N) = N_Aggregate 2408 and then Present (Aggregate_Bounds (N)) 2409 and then Compile_Time_Known_Bounds (Etype (N)) 2410 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 2411 > 2412 Expr_Value (Low_Bound (Aggregate_Bounds (N))) 2413 then 2414 declare 2415 Count_Components : Uint := Uint_0; 2416 Num_Components : Uint; 2417 Others_Assoc : Node_Id; 2418 Others_Choice : Node_Id := Empty; 2419 Others_Box_Present : Boolean := False; 2420 2421 begin 2422 -- Count positional associations 2423 2424 if Present (Expressions (N)) then 2425 Comp_Expr := First (Expressions (N)); 2426 while Present (Comp_Expr) loop 2427 Count_Components := Count_Components + 1; 2428 Next (Comp_Expr); 2429 end loop; 2430 end if; 2431 2432 -- Count the rest of elements and locate the N_Others 2433 -- choice (if any) 2434 2435 Assoc := First (Component_Associations (N)); 2436 while Present (Assoc) loop 2437 Choice := First (Choices (Assoc)); 2438 while Present (Choice) loop 2439 if Nkind (Choice) = N_Others_Choice then 2440 Others_Assoc := Assoc; 2441 Others_Choice := Choice; 2442 Others_Box_Present := Box_Present (Assoc); 2443 2444 -- Count several components 2445 2446 elsif Nkind_In (Choice, N_Range, 2447 N_Subtype_Indication) 2448 or else (Is_Entity_Name (Choice) 2449 and then Is_Type (Entity (Choice))) 2450 then 2451 declare 2452 L, H : Node_Id; 2453 begin 2454 Get_Index_Bounds (Choice, L, H); 2455 pragma Assert 2456 (Compile_Time_Known_Value (L) 2457 and then Compile_Time_Known_Value (H)); 2458 Count_Components := 2459 Count_Components 2460 + Expr_Value (H) - Expr_Value (L) + 1; 2461 end; 2462 2463 -- Count single component. No other case available 2464 -- since we are handling an aggregate with static 2465 -- bounds. 2466 2467 else 2468 pragma Assert (Is_OK_Static_Expression (Choice) 2469 or else Nkind (Choice) = N_Identifier 2470 or else Nkind (Choice) = N_Integer_Literal); 2471 2472 Count_Components := Count_Components + 1; 2473 end if; 2474 2475 Next (Choice); 2476 end loop; 2477 2478 Next (Assoc); 2479 end loop; 2480 2481 Num_Components := 2482 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 2483 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 2484 2485 pragma Assert (Count_Components <= Num_Components); 2486 2487 -- Handle the N_Others choice if it covers several 2488 -- components 2489 2490 if Present (Others_Choice) 2491 and then (Num_Components - Count_Components) > 1 2492 then 2493 if not Others_Box_Present then 2494 2495 -- At this stage, if expansion is active, the 2496 -- expression of the others choice has not been 2497 -- analyzed. Hence we generate a duplicate and 2498 -- we analyze it silently to have available the 2499 -- minimum decoration required to collect the 2500 -- identifiers. 2501 2502 if not Expander_Active then 2503 Comp_Expr := Expression (Others_Assoc); 2504 else 2505 Comp_Expr := 2506 New_Copy_Tree (Expression (Others_Assoc)); 2507 Preanalyze_Without_Errors (Comp_Expr); 2508 end if; 2509 2510 Collect_Identifiers (Comp_Expr); 2511 2512 if Writable_Actuals_List /= No_Elist then 2513 2514 -- As suggested by Robert, at current stage we 2515 -- report occurrences of this case as warnings. 2516 2517 Error_Msg_N 2518 ("writable function parameter may affect " 2519 & "value in other component because order " 2520 & "of evaluation is unspecified??", 2521 Node (First_Elmt (Writable_Actuals_List))); 2522 end if; 2523 end if; 2524 end if; 2525 end; 2526 end if; 2527 2528 -- Handle ancestor part of extension aggregates 2529 2530 if Nkind (N) = N_Extension_Aggregate then 2531 Collect_Identifiers (Ancestor_Part (N)); 2532 end if; 2533 2534 -- Handle positional associations 2535 2536 if Present (Expressions (N)) then 2537 Comp_Expr := First (Expressions (N)); 2538 while Present (Comp_Expr) loop 2539 if not Is_OK_Static_Expression (Comp_Expr) then 2540 Collect_Identifiers (Comp_Expr); 2541 end if; 2542 2543 Next (Comp_Expr); 2544 end loop; 2545 end if; 2546 2547 -- Handle discrete associations 2548 2549 if Present (Component_Associations (N)) then 2550 Assoc := First (Component_Associations (N)); 2551 while Present (Assoc) loop 2552 2553 if not Box_Present (Assoc) then 2554 Choice := First (Choices (Assoc)); 2555 while Present (Choice) loop 2556 2557 -- For now we skip discriminants since it requires 2558 -- performing the analysis in two phases: first one 2559 -- analyzing discriminants and second one analyzing 2560 -- the rest of components since discriminants are 2561 -- evaluated prior to components: too much extra 2562 -- work to detect a corner case??? 2563 2564 if Nkind (Choice) in N_Has_Entity 2565 and then Present (Entity (Choice)) 2566 and then Ekind (Entity (Choice)) = E_Discriminant 2567 then 2568 null; 2569 2570 elsif Box_Present (Assoc) then 2571 null; 2572 2573 else 2574 if not Analyzed (Expression (Assoc)) then 2575 Comp_Expr := 2576 New_Copy_Tree (Expression (Assoc)); 2577 Set_Parent (Comp_Expr, Parent (N)); 2578 Preanalyze_Without_Errors (Comp_Expr); 2579 else 2580 Comp_Expr := Expression (Assoc); 2581 end if; 2582 2583 Collect_Identifiers (Comp_Expr); 2584 end if; 2585 2586 Next (Choice); 2587 end loop; 2588 end if; 2589 2590 Next (Assoc); 2591 end loop; 2592 end if; 2593 end; 2594 2595 when others => 2596 return; 2597 end case; 2598 2599 -- No further action needed if we already reported an error 2600 2601 if Present (Error_Node) then 2602 return; 2603 end if; 2604 2605 -- Check if some writable argument of a function is referenced 2606 2607 if Writable_Actuals_List /= No_Elist 2608 and then Identifiers_List /= No_Elist 2609 then 2610 declare 2611 Elmt_1 : Elmt_Id; 2612 Elmt_2 : Elmt_Id; 2613 2614 begin 2615 Elmt_1 := First_Elmt (Writable_Actuals_List); 2616 while Present (Elmt_1) loop 2617 Elmt_2 := First_Elmt (Identifiers_List); 2618 while Present (Elmt_2) loop 2619 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 2620 case Nkind (Parent (Node (Elmt_2))) is 2621 when N_Aggregate | 2622 N_Component_Association | 2623 N_Component_Declaration => 2624 Error_Msg_N 2625 ("value may be affected by call in other " 2626 & "component because they are evaluated " 2627 & "in unspecified order", 2628 Node (Elmt_2)); 2629 2630 when N_In | N_Not_In => 2631 Error_Msg_N 2632 ("value may be affected by call in other " 2633 & "alternative because they are evaluated " 2634 & "in unspecified order", 2635 Node (Elmt_2)); 2636 2637 when others => 2638 Error_Msg_N 2639 ("value of actual may be affected by call in " 2640 & "other actual because they are evaluated " 2641 & "in unspecified order", 2642 Node (Elmt_2)); 2643 end case; 2644 end if; 2645 2646 Next_Elmt (Elmt_2); 2647 end loop; 2648 2649 Next_Elmt (Elmt_1); 2650 end loop; 2651 end; 2652 end if; 2653 end Check_Function_Writable_Actuals; 2654 2655 -------------------------------- 2656 -- Check_Implicit_Dereference -- 2657 -------------------------------- 2658 2659 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is 2660 Disc : Entity_Id; 2661 Desig : Entity_Id; 2662 Nam : Node_Id; 2663 2664 begin 2665 if Nkind (N) = N_Indexed_Component 2666 and then Present (Generalized_Indexing (N)) 2667 then 2668 Nam := Generalized_Indexing (N); 2669 else 2670 Nam := N; 2671 end if; 2672 2673 if Ada_Version < Ada_2012 2674 or else not Has_Implicit_Dereference (Base_Type (Typ)) 2675 then 2676 return; 2677 2678 elsif not Comes_From_Source (N) 2679 and then Nkind (N) /= N_Indexed_Component 2680 then 2681 return; 2682 2683 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then 2684 null; 2685 2686 else 2687 Disc := First_Discriminant (Typ); 2688 while Present (Disc) loop 2689 if Has_Implicit_Dereference (Disc) then 2690 Desig := Designated_Type (Etype (Disc)); 2691 Add_One_Interp (Nam, Disc, Desig); 2692 2693 -- If the node is a generalized indexing, add interpretation 2694 -- to that node as well, for subsequent resolution. 2695 2696 if Nkind (N) = N_Indexed_Component then 2697 Add_One_Interp (N, Disc, Desig); 2698 end if; 2699 2700 -- If the operation comes from a generic unit and the context 2701 -- is a selected component, the selector name may be global 2702 -- and set in the instance already. Remove the entity to 2703 -- force resolution of the selected component, and the 2704 -- generation of an explicit dereference if needed. 2705 2706 if In_Instance 2707 and then Nkind (Parent (Nam)) = N_Selected_Component 2708 then 2709 Set_Entity (Selector_Name (Parent (Nam)), Empty); 2710 end if; 2711 2712 exit; 2713 end if; 2714 2715 Next_Discriminant (Disc); 2716 end loop; 2717 end if; 2718 end Check_Implicit_Dereference; 2719 2720 ---------------------------------- 2721 -- Check_Internal_Protected_Use -- 2722 ---------------------------------- 2723 2724 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 2725 S : Entity_Id; 2726 Prot : Entity_Id; 2727 2728 begin 2729 S := Current_Scope; 2730 while Present (S) loop 2731 if S = Standard_Standard then 2732 return; 2733 2734 elsif Ekind (S) = E_Function 2735 and then Ekind (Scope (S)) = E_Protected_Type 2736 then 2737 Prot := Scope (S); 2738 exit; 2739 end if; 2740 2741 S := Scope (S); 2742 end loop; 2743 2744 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then 2745 2746 -- An indirect function call (e.g. a callback within a protected 2747 -- function body) is not statically illegal. If the access type is 2748 -- anonymous and is the type of an access parameter, the scope of Nam 2749 -- will be the protected type, but it is not a protected operation. 2750 2751 if Ekind (Nam) = E_Subprogram_Type 2752 and then 2753 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification 2754 then 2755 null; 2756 2757 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 2758 Error_Msg_N 2759 ("within protected function cannot use protected " 2760 & "procedure in renaming or as generic actual", N); 2761 2762 elsif Nkind (N) = N_Attribute_Reference then 2763 Error_Msg_N 2764 ("within protected function cannot take access of " 2765 & " protected procedure", N); 2766 2767 else 2768 Error_Msg_N 2769 ("within protected function, protected object is constant", N); 2770 Error_Msg_N 2771 ("\cannot call operation that may modify it", N); 2772 end if; 2773 end if; 2774 end Check_Internal_Protected_Use; 2775 2776 --------------------------------------- 2777 -- Check_Later_Vs_Basic_Declarations -- 2778 --------------------------------------- 2779 2780 procedure Check_Later_Vs_Basic_Declarations 2781 (Decls : List_Id; 2782 During_Parsing : Boolean) 2783 is 2784 Body_Sloc : Source_Ptr; 2785 Decl : Node_Id; 2786 2787 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 2788 -- Return whether Decl is considered as a declarative item. 2789 -- When During_Parsing is True, the semantics of Ada 83 is followed. 2790 -- When During_Parsing is False, the semantics of SPARK is followed. 2791 2792 ------------------------------- 2793 -- Is_Later_Declarative_Item -- 2794 ------------------------------- 2795 2796 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 2797 begin 2798 if Nkind (Decl) in N_Later_Decl_Item then 2799 return True; 2800 2801 elsif Nkind (Decl) = N_Pragma then 2802 return True; 2803 2804 elsif During_Parsing then 2805 return False; 2806 2807 -- In SPARK, a package declaration is not considered as a later 2808 -- declarative item. 2809 2810 elsif Nkind (Decl) = N_Package_Declaration then 2811 return False; 2812 2813 -- In SPARK, a renaming is considered as a later declarative item 2814 2815 elsif Nkind (Decl) in N_Renaming_Declaration then 2816 return True; 2817 2818 else 2819 return False; 2820 end if; 2821 end Is_Later_Declarative_Item; 2822 2823 -- Start of Check_Later_Vs_Basic_Declarations 2824 2825 begin 2826 Decl := First (Decls); 2827 2828 -- Loop through sequence of basic declarative items 2829 2830 Outer : while Present (Decl) loop 2831 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 2832 and then Nkind (Decl) not in N_Body_Stub 2833 then 2834 Next (Decl); 2835 2836 -- Once a body is encountered, we only allow later declarative 2837 -- items. The inner loop checks the rest of the list. 2838 2839 else 2840 Body_Sloc := Sloc (Decl); 2841 2842 Inner : while Present (Decl) loop 2843 if not Is_Later_Declarative_Item (Decl) then 2844 if During_Parsing then 2845 if Ada_Version = Ada_83 then 2846 Error_Msg_Sloc := Body_Sloc; 2847 Error_Msg_N 2848 ("(Ada 83) decl cannot appear after body#", Decl); 2849 end if; 2850 else 2851 Error_Msg_Sloc := Body_Sloc; 2852 Check_SPARK_05_Restriction 2853 ("decl cannot appear after body#", Decl); 2854 end if; 2855 end if; 2856 2857 Next (Decl); 2858 end loop Inner; 2859 end if; 2860 end loop Outer; 2861 end Check_Later_Vs_Basic_Declarations; 2862 2863 ------------------------- 2864 -- Check_Nested_Access -- 2865 ------------------------- 2866 2867 procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id) is 2868 Scop : constant Entity_Id := Current_Scope; 2869 Current_Subp : Entity_Id; 2870 Enclosing : Entity_Id; 2871 2872 begin 2873 -- Currently only enabled for VM back-ends for efficiency, should we 2874 -- enable it more systematically? Probably not unless someone actually 2875 -- needs it. It will be needed for C generation and is activated if the 2876 -- Opt.Unnest_Subprogram_Mode flag is set True. 2877 2878 if (VM_Target /= No_VM or else Unnest_Subprogram_Mode) 2879 and then Scope (Ent) /= Empty 2880 and then not Is_Library_Level_Entity (Ent) 2881 2882 -- Comment the exclusion of imported entities ??? 2883 2884 and then not Is_Imported (Ent) 2885 then 2886 -- In both the VM case and in Unnest_Subprogram_Mode, we mark 2887 -- variables, constants, and loop parameters. 2888 2889 if Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) then 2890 null; 2891 2892 -- In Unnest_Subprogram_Mode, we also mark types and formals 2893 2894 elsif Unnest_Subprogram_Mode 2895 and then (Is_Type (Ent) or else Is_Formal (Ent)) 2896 then 2897 null; 2898 2899 -- All other cases, do not mark 2900 2901 else 2902 return; 2903 end if; 2904 2905 -- Get current subprogram that is relevant 2906 2907 if Is_Subprogram (Scop) 2908 or else Is_Generic_Subprogram (Scop) 2909 or else Is_Entry (Scop) 2910 then 2911 Current_Subp := Scop; 2912 else 2913 Current_Subp := Current_Subprogram; 2914 end if; 2915 2916 Enclosing := Enclosing_Subprogram (Ent); 2917 2918 -- Set flag if uplevel reference 2919 2920 if Enclosing /= Empty and then Enclosing /= Current_Subp then 2921 if Is_Type (Ent) then 2922 Check_Uplevel_Reference_To_Type (Ent); 2923 else 2924 Set_Has_Uplevel_Reference (Ent, True); 2925 2926 if Unnest_Subprogram_Mode then 2927 Set_Has_Uplevel_Reference (Current_Subp, True); 2928 Note_Uplevel_Reference (N, Enclosing); 2929 end if; 2930 end if; 2931 end if; 2932 end if; 2933 end Check_Nested_Access; 2934 2935 --------------------------- 2936 -- Check_No_Hidden_State -- 2937 --------------------------- 2938 2939 procedure Check_No_Hidden_State (Id : Entity_Id) is 2940 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean; 2941 -- Determine whether the entity of a package denoted by Pkg has a null 2942 -- abstract state. 2943 2944 ----------------------------- 2945 -- Has_Null_Abstract_State -- 2946 ----------------------------- 2947 2948 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is 2949 States : constant Elist_Id := Abstract_States (Pkg); 2950 2951 begin 2952 -- Check first available state of related package. A null abstract 2953 -- state always appears as the sole element of the state list. 2954 2955 return 2956 Present (States) 2957 and then Is_Null_State (Node (First_Elmt (States))); 2958 end Has_Null_Abstract_State; 2959 2960 -- Local variables 2961 2962 Context : Entity_Id := Empty; 2963 Not_Visible : Boolean := False; 2964 Scop : Entity_Id; 2965 2966 -- Start of processing for Check_No_Hidden_State 2967 2968 begin 2969 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); 2970 2971 -- Find the proper context where the object or state appears 2972 2973 Scop := Scope (Id); 2974 while Present (Scop) loop 2975 Context := Scop; 2976 2977 -- Keep track of the context's visibility 2978 2979 Not_Visible := Not_Visible or else In_Private_Part (Context); 2980 2981 -- Prevent the search from going too far 2982 2983 if Context = Standard_Standard then 2984 return; 2985 2986 -- Objects and states that appear immediately within a subprogram or 2987 -- inside a construct nested within a subprogram do not introduce a 2988 -- hidden state. They behave as local variable declarations. 2989 2990 elsif Is_Subprogram (Context) then 2991 return; 2992 2993 -- When examining a package body, use the entity of the spec as it 2994 -- carries the abstract state declarations. 2995 2996 elsif Ekind (Context) = E_Package_Body then 2997 Context := Spec_Entity (Context); 2998 end if; 2999 3000 -- Stop the traversal when a package subject to a null abstract state 3001 -- has been found. 3002 3003 if Ekind_In (Context, E_Generic_Package, E_Package) 3004 and then Has_Null_Abstract_State (Context) 3005 then 3006 exit; 3007 end if; 3008 3009 Scop := Scope (Scop); 3010 end loop; 3011 3012 -- At this point we know that there is at least one package with a null 3013 -- abstract state in visibility. Emit an error message unconditionally 3014 -- if the entity being processed is a state because the placement of the 3015 -- related package is irrelevant. This is not the case for objects as 3016 -- the intermediate context matters. 3017 3018 if Present (Context) 3019 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 3020 then 3021 Error_Msg_N ("cannot introduce hidden state &", Id); 3022 Error_Msg_NE ("\package & has null abstract state", Id, Context); 3023 end if; 3024 end Check_No_Hidden_State; 3025 3026 ------------------------------------------ 3027 -- Check_Potentially_Blocking_Operation -- 3028 ------------------------------------------ 3029 3030 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 3031 S : Entity_Id; 3032 3033 begin 3034 -- N is one of the potentially blocking operations listed in 9.5.1(8). 3035 -- When pragma Detect_Blocking is active, the run time will raise 3036 -- Program_Error. Here we only issue a warning, since we generally 3037 -- support the use of potentially blocking operations in the absence 3038 -- of the pragma. 3039 3040 -- Indirect blocking through a subprogram call cannot be diagnosed 3041 -- statically without interprocedural analysis, so we do not attempt 3042 -- to do it here. 3043 3044 S := Scope (Current_Scope); 3045 while Present (S) and then S /= Standard_Standard loop 3046 if Is_Protected_Type (S) then 3047 Error_Msg_N 3048 ("potentially blocking operation in protected operation??", N); 3049 return; 3050 end if; 3051 3052 S := Scope (S); 3053 end loop; 3054 end Check_Potentially_Blocking_Operation; 3055 3056 --------------------------------- 3057 -- Check_Result_And_Post_State -- 3058 --------------------------------- 3059 3060 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is 3061 procedure Check_Result_And_Post_State_In_Pragma 3062 (Prag : Node_Id; 3063 Result_Seen : in out Boolean); 3064 -- Determine whether pragma Prag mentions attribute 'Result and whether 3065 -- the pragma contains an expression that evaluates differently in pre- 3066 -- and post-state. Prag is a [refined] postcondition or a contract-cases 3067 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result 3068 3069 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; 3070 -- Determine whether subprogram Subp_Id contains at least one IN OUT 3071 -- formal parameter. 3072 3073 ------------------------------------------- 3074 -- Check_Result_And_Post_State_In_Pragma -- 3075 ------------------------------------------- 3076 3077 procedure Check_Result_And_Post_State_In_Pragma 3078 (Prag : Node_Id; 3079 Result_Seen : in out Boolean) 3080 is 3081 procedure Check_Expression (Expr : Node_Id); 3082 -- Perform the 'Result and post-state checks on a given expression 3083 3084 function Is_Function_Result (N : Node_Id) return Traverse_Result; 3085 -- Attempt to find attribute 'Result in a subtree denoted by N 3086 3087 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 3088 -- Determine whether source node N denotes "True" or "False" 3089 3090 function Mentions_Post_State (N : Node_Id) return Boolean; 3091 -- Determine whether a subtree denoted by N mentions any construct 3092 -- that denotes a post-state. 3093 3094 procedure Check_Function_Result is 3095 new Traverse_Proc (Is_Function_Result); 3096 3097 ---------------------- 3098 -- Check_Expression -- 3099 ---------------------- 3100 3101 procedure Check_Expression (Expr : Node_Id) is 3102 begin 3103 if not Is_Trivial_Boolean (Expr) then 3104 Check_Function_Result (Expr); 3105 3106 if not Mentions_Post_State (Expr) then 3107 if Pragma_Name (Prag) = Name_Contract_Cases then 3108 Error_Msg_NE 3109 ("contract case does not check the outcome of calling " 3110 & "&?T?", Expr, Subp_Id); 3111 3112 elsif Pragma_Name (Prag) = Name_Refined_Post then 3113 Error_Msg_NE 3114 ("refined postcondition does not check the outcome of " 3115 & "calling &?T?", Prag, Subp_Id); 3116 3117 else 3118 Error_Msg_NE 3119 ("postcondition does not check the outcome of calling " 3120 & "&?T?", Prag, Subp_Id); 3121 end if; 3122 end if; 3123 end if; 3124 end Check_Expression; 3125 3126 ------------------------ 3127 -- Is_Function_Result -- 3128 ------------------------ 3129 3130 function Is_Function_Result (N : Node_Id) return Traverse_Result is 3131 begin 3132 if Is_Attribute_Result (N) then 3133 Result_Seen := True; 3134 return Abandon; 3135 3136 -- Continue the traversal 3137 3138 else 3139 return OK; 3140 end if; 3141 end Is_Function_Result; 3142 3143 ------------------------ 3144 -- Is_Trivial_Boolean -- 3145 ------------------------ 3146 3147 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 3148 begin 3149 return 3150 Comes_From_Source (N) 3151 and then Is_Entity_Name (N) 3152 and then (Entity (N) = Standard_True 3153 or else 3154 Entity (N) = Standard_False); 3155 end Is_Trivial_Boolean; 3156 3157 ------------------------- 3158 -- Mentions_Post_State -- 3159 ------------------------- 3160 3161 function Mentions_Post_State (N : Node_Id) return Boolean is 3162 Post_State_Seen : Boolean := False; 3163 3164 function Is_Post_State (N : Node_Id) return Traverse_Result; 3165 -- Attempt to find a construct that denotes a post-state. If this 3166 -- is the case, set flag Post_State_Seen. 3167 3168 ------------------- 3169 -- Is_Post_State -- 3170 ------------------- 3171 3172 function Is_Post_State (N : Node_Id) return Traverse_Result is 3173 Ent : Entity_Id; 3174 3175 begin 3176 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then 3177 Post_State_Seen := True; 3178 return Abandon; 3179 3180 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then 3181 Ent := Entity (N); 3182 3183 -- The entity may be modifiable through an implicit 3184 -- dereference. 3185 3186 if No (Ent) 3187 or else Ekind (Ent) in Assignable_Kind 3188 or else (Is_Access_Type (Etype (Ent)) 3189 and then Nkind (Parent (N)) = 3190 N_Selected_Component) 3191 then 3192 Post_State_Seen := True; 3193 return Abandon; 3194 end if; 3195 3196 elsif Nkind (N) = N_Attribute_Reference then 3197 if Attribute_Name (N) = Name_Old then 3198 return Skip; 3199 3200 elsif Attribute_Name (N) = Name_Result then 3201 Post_State_Seen := True; 3202 return Abandon; 3203 end if; 3204 end if; 3205 3206 return OK; 3207 end Is_Post_State; 3208 3209 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 3210 3211 -- Start of processing for Mentions_Post_State 3212 3213 begin 3214 Find_Post_State (N); 3215 3216 return Post_State_Seen; 3217 end Mentions_Post_State; 3218 3219 -- Local variables 3220 3221 Expr : constant Node_Id := 3222 Get_Pragma_Arg 3223 (First (Pragma_Argument_Associations (Prag))); 3224 Nam : constant Name_Id := Pragma_Name (Prag); 3225 CCase : Node_Id; 3226 3227 -- Start of processing for Check_Result_And_Post_State_In_Pragma 3228 3229 begin 3230 -- Examine all consequences 3231 3232 if Nam = Name_Contract_Cases then 3233 CCase := First (Component_Associations (Expr)); 3234 while Present (CCase) loop 3235 Check_Expression (Expression (CCase)); 3236 3237 Next (CCase); 3238 end loop; 3239 3240 -- Examine the expression of a postcondition 3241 3242 else pragma Assert (Nam_In (Nam, Name_Postcondition, 3243 Name_Refined_Post)); 3244 Check_Expression (Expr); 3245 end if; 3246 end Check_Result_And_Post_State_In_Pragma; 3247 3248 -------------------------- 3249 -- Has_In_Out_Parameter -- 3250 -------------------------- 3251 3252 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is 3253 Formal : Entity_Id; 3254 3255 begin 3256 -- Traverse the formals looking for an IN OUT parameter 3257 3258 Formal := First_Formal (Subp_Id); 3259 while Present (Formal) loop 3260 if Ekind (Formal) = E_In_Out_Parameter then 3261 return True; 3262 end if; 3263 3264 Next_Formal (Formal); 3265 end loop; 3266 3267 return False; 3268 end Has_In_Out_Parameter; 3269 3270 -- Local variables 3271 3272 Items : constant Node_Id := Contract (Subp_Id); 3273 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 3274 Case_Prag : Node_Id := Empty; 3275 Post_Prag : Node_Id := Empty; 3276 Prag : Node_Id; 3277 Seen_In_Case : Boolean := False; 3278 Seen_In_Post : Boolean := False; 3279 Spec_Id : Entity_Id; 3280 3281 -- Start of processing for Check_Result_And_Post_State 3282 3283 begin 3284 -- The lack of attribute 'Result or a post-state is classified as a 3285 -- suspicious contract. Do not perform the check if the corresponding 3286 -- swich is not set. 3287 3288 if not Warn_On_Suspicious_Contract then 3289 return; 3290 3291 -- Nothing to do if there is no contract 3292 3293 elsif No (Items) then 3294 return; 3295 end if; 3296 3297 -- Retrieve the entity of the subprogram spec (if any) 3298 3299 if Nkind (Subp_Decl) = N_Subprogram_Body 3300 and then Present (Corresponding_Spec (Subp_Decl)) 3301 then 3302 Spec_Id := Corresponding_Spec (Subp_Decl); 3303 3304 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 3305 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 3306 then 3307 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 3308 3309 else 3310 Spec_Id := Subp_Id; 3311 end if; 3312 3313 -- Examine all postconditions for attribute 'Result and a post-state 3314 3315 Prag := Pre_Post_Conditions (Items); 3316 while Present (Prag) loop 3317 if Nam_In (Pragma_Name (Prag), Name_Postcondition, 3318 Name_Refined_Post) 3319 and then not Error_Posted (Prag) 3320 then 3321 Post_Prag := Prag; 3322 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); 3323 end if; 3324 3325 Prag := Next_Pragma (Prag); 3326 end loop; 3327 3328 -- Examine the contract cases of the subprogram for attribute 'Result 3329 -- and a post-state. 3330 3331 Prag := Contract_Test_Cases (Items); 3332 while Present (Prag) loop 3333 if Pragma_Name (Prag) = Name_Contract_Cases 3334 and then not Error_Posted (Prag) 3335 then 3336 Case_Prag := Prag; 3337 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); 3338 end if; 3339 3340 Prag := Next_Pragma (Prag); 3341 end loop; 3342 3343 -- Do not emit any errors if the subprogram is not a function 3344 3345 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 3346 null; 3347 3348 -- Regardless of whether the function has postconditions or contract 3349 -- cases, or whether they mention attribute 'Result, an IN OUT formal 3350 -- parameter is always treated as a result. 3351 3352 elsif Has_In_Out_Parameter (Spec_Id) then 3353 null; 3354 3355 -- The function has both a postcondition and contract cases and they do 3356 -- not mention attribute 'Result. 3357 3358 elsif Present (Case_Prag) 3359 and then not Seen_In_Case 3360 and then Present (Post_Prag) 3361 and then not Seen_In_Post 3362 then 3363 Error_Msg_N 3364 ("neither postcondition nor contract cases mention function " 3365 & "result?T?", Post_Prag); 3366 3367 -- The function has contract cases only and they do not mention 3368 -- attribute 'Result. 3369 3370 elsif Present (Case_Prag) and then not Seen_In_Case then 3371 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); 3372 3373 -- The function has postconditions only and they do not mention 3374 -- attribute 'Result. 3375 3376 elsif Present (Post_Prag) and then not Seen_In_Post then 3377 Error_Msg_N 3378 ("postcondition does not mention function result?T?", Post_Prag); 3379 end if; 3380 end Check_Result_And_Post_State; 3381 3382 ------------------------------ 3383 -- Check_Unprotected_Access -- 3384 ------------------------------ 3385 3386 procedure Check_Unprotected_Access 3387 (Context : Node_Id; 3388 Expr : Node_Id) 3389 is 3390 Cont_Encl_Typ : Entity_Id; 3391 Pref_Encl_Typ : Entity_Id; 3392 3393 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 3394 -- Check whether Obj is a private component of a protected object. 3395 -- Return the protected type where the component resides, Empty 3396 -- otherwise. 3397 3398 function Is_Public_Operation return Boolean; 3399 -- Verify that the enclosing operation is callable from outside the 3400 -- protected object, to minimize false positives. 3401 3402 ------------------------------ 3403 -- Enclosing_Protected_Type -- 3404 ------------------------------ 3405 3406 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 3407 begin 3408 if Is_Entity_Name (Obj) then 3409 declare 3410 Ent : Entity_Id := Entity (Obj); 3411 3412 begin 3413 -- The object can be a renaming of a private component, use 3414 -- the original record component. 3415 3416 if Is_Prival (Ent) then 3417 Ent := Prival_Link (Ent); 3418 end if; 3419 3420 if Is_Protected_Type (Scope (Ent)) then 3421 return Scope (Ent); 3422 end if; 3423 end; 3424 end if; 3425 3426 -- For indexed and selected components, recursively check the prefix 3427 3428 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 3429 return Enclosing_Protected_Type (Prefix (Obj)); 3430 3431 -- The object does not denote a protected component 3432 3433 else 3434 return Empty; 3435 end if; 3436 end Enclosing_Protected_Type; 3437 3438 ------------------------- 3439 -- Is_Public_Operation -- 3440 ------------------------- 3441 3442 function Is_Public_Operation return Boolean is 3443 S : Entity_Id; 3444 E : Entity_Id; 3445 3446 begin 3447 S := Current_Scope; 3448 while Present (S) and then S /= Pref_Encl_Typ loop 3449 if Scope (S) = Pref_Encl_Typ then 3450 E := First_Entity (Pref_Encl_Typ); 3451 while Present (E) 3452 and then E /= First_Private_Entity (Pref_Encl_Typ) 3453 loop 3454 if E = S then 3455 return True; 3456 end if; 3457 3458 Next_Entity (E); 3459 end loop; 3460 end if; 3461 3462 S := Scope (S); 3463 end loop; 3464 3465 return False; 3466 end Is_Public_Operation; 3467 3468 -- Start of processing for Check_Unprotected_Access 3469 3470 begin 3471 if Nkind (Expr) = N_Attribute_Reference 3472 and then Attribute_Name (Expr) = Name_Unchecked_Access 3473 then 3474 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 3475 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 3476 3477 -- Check whether we are trying to export a protected component to a 3478 -- context with an equal or lower access level. 3479 3480 if Present (Pref_Encl_Typ) 3481 and then No (Cont_Encl_Typ) 3482 and then Is_Public_Operation 3483 and then Scope_Depth (Pref_Encl_Typ) >= 3484 Object_Access_Level (Context) 3485 then 3486 Error_Msg_N 3487 ("??possible unprotected access to protected data", Expr); 3488 end if; 3489 end if; 3490 end Check_Unprotected_Access; 3491 3492 ------------------------ 3493 -- Collect_Interfaces -- 3494 ------------------------ 3495 3496 procedure Collect_Interfaces 3497 (T : Entity_Id; 3498 Ifaces_List : out Elist_Id; 3499 Exclude_Parents : Boolean := False; 3500 Use_Full_View : Boolean := True) 3501 is 3502 procedure Collect (Typ : Entity_Id); 3503 -- Subsidiary subprogram used to traverse the whole list 3504 -- of directly and indirectly implemented interfaces 3505 3506 ------------- 3507 -- Collect -- 3508 ------------- 3509 3510 procedure Collect (Typ : Entity_Id) is 3511 Ancestor : Entity_Id; 3512 Full_T : Entity_Id; 3513 Id : Node_Id; 3514 Iface : Entity_Id; 3515 3516 begin 3517 Full_T := Typ; 3518 3519 -- Handle private types and subtypes 3520 3521 if Use_Full_View 3522 and then Is_Private_Type (Typ) 3523 and then Present (Full_View (Typ)) 3524 then 3525 Full_T := Full_View (Typ); 3526 3527 if Ekind (Full_T) = E_Record_Subtype then 3528 Full_T := Full_View (Etype (Typ)); 3529 end if; 3530 end if; 3531 3532 -- Include the ancestor if we are generating the whole list of 3533 -- abstract interfaces. 3534 3535 if Etype (Full_T) /= Typ 3536 3537 -- Protect the frontend against wrong sources. For example: 3538 3539 -- package P is 3540 -- type A is tagged null record; 3541 -- type B is new A with private; 3542 -- type C is new A with private; 3543 -- private 3544 -- type B is new C with null record; 3545 -- type C is new B with null record; 3546 -- end P; 3547 3548 and then Etype (Full_T) /= T 3549 then 3550 Ancestor := Etype (Full_T); 3551 Collect (Ancestor); 3552 3553 if Is_Interface (Ancestor) and then not Exclude_Parents then 3554 Append_Unique_Elmt (Ancestor, Ifaces_List); 3555 end if; 3556 end if; 3557 3558 -- Traverse the graph of ancestor interfaces 3559 3560 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 3561 Id := First (Abstract_Interface_List (Full_T)); 3562 while Present (Id) loop 3563 Iface := Etype (Id); 3564 3565 -- Protect against wrong uses. For example: 3566 -- type I is interface; 3567 -- type O is tagged null record; 3568 -- type Wrong is new I and O with null record; -- ERROR 3569 3570 if Is_Interface (Iface) then 3571 if Exclude_Parents 3572 and then Etype (T) /= T 3573 and then Interface_Present_In_Ancestor (Etype (T), Iface) 3574 then 3575 null; 3576 else 3577 Collect (Iface); 3578 Append_Unique_Elmt (Iface, Ifaces_List); 3579 end if; 3580 end if; 3581 3582 Next (Id); 3583 end loop; 3584 end if; 3585 end Collect; 3586 3587 -- Start of processing for Collect_Interfaces 3588 3589 begin 3590 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 3591 Ifaces_List := New_Elmt_List; 3592 Collect (T); 3593 end Collect_Interfaces; 3594 3595 ---------------------------------- 3596 -- Collect_Interface_Components -- 3597 ---------------------------------- 3598 3599 procedure Collect_Interface_Components 3600 (Tagged_Type : Entity_Id; 3601 Components_List : out Elist_Id) 3602 is 3603 procedure Collect (Typ : Entity_Id); 3604 -- Subsidiary subprogram used to climb to the parents 3605 3606 ------------- 3607 -- Collect -- 3608 ------------- 3609 3610 procedure Collect (Typ : Entity_Id) is 3611 Tag_Comp : Entity_Id; 3612 Parent_Typ : Entity_Id; 3613 3614 begin 3615 -- Handle private types 3616 3617 if Present (Full_View (Etype (Typ))) then 3618 Parent_Typ := Full_View (Etype (Typ)); 3619 else 3620 Parent_Typ := Etype (Typ); 3621 end if; 3622 3623 if Parent_Typ /= Typ 3624 3625 -- Protect the frontend against wrong sources. For example: 3626 3627 -- package P is 3628 -- type A is tagged null record; 3629 -- type B is new A with private; 3630 -- type C is new A with private; 3631 -- private 3632 -- type B is new C with null record; 3633 -- type C is new B with null record; 3634 -- end P; 3635 3636 and then Parent_Typ /= Tagged_Type 3637 then 3638 Collect (Parent_Typ); 3639 end if; 3640 3641 -- Collect the components containing tags of secondary dispatch 3642 -- tables. 3643 3644 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 3645 while Present (Tag_Comp) loop 3646 pragma Assert (Present (Related_Type (Tag_Comp))); 3647 Append_Elmt (Tag_Comp, Components_List); 3648 3649 Tag_Comp := Next_Tag_Component (Tag_Comp); 3650 end loop; 3651 end Collect; 3652 3653 -- Start of processing for Collect_Interface_Components 3654 3655 begin 3656 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 3657 and then Is_Tagged_Type (Tagged_Type)); 3658 3659 Components_List := New_Elmt_List; 3660 Collect (Tagged_Type); 3661 end Collect_Interface_Components; 3662 3663 ----------------------------- 3664 -- Collect_Interfaces_Info -- 3665 ----------------------------- 3666 3667 procedure Collect_Interfaces_Info 3668 (T : Entity_Id; 3669 Ifaces_List : out Elist_Id; 3670 Components_List : out Elist_Id; 3671 Tags_List : out Elist_Id) 3672 is 3673 Comps_List : Elist_Id; 3674 Comp_Elmt : Elmt_Id; 3675 Comp_Iface : Entity_Id; 3676 Iface_Elmt : Elmt_Id; 3677 Iface : Entity_Id; 3678 3679 function Search_Tag (Iface : Entity_Id) return Entity_Id; 3680 -- Search for the secondary tag associated with the interface type 3681 -- Iface that is implemented by T. 3682 3683 ---------------- 3684 -- Search_Tag -- 3685 ---------------- 3686 3687 function Search_Tag (Iface : Entity_Id) return Entity_Id is 3688 ADT : Elmt_Id; 3689 begin 3690 if not Is_CPP_Class (T) then 3691 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 3692 else 3693 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 3694 end if; 3695 3696 while Present (ADT) 3697 and then Is_Tag (Node (ADT)) 3698 and then Related_Type (Node (ADT)) /= Iface 3699 loop 3700 -- Skip secondary dispatch table referencing thunks to user 3701 -- defined primitives covered by this interface. 3702 3703 pragma Assert (Has_Suffix (Node (ADT), 'P')); 3704 Next_Elmt (ADT); 3705 3706 -- Skip secondary dispatch tables of Ada types 3707 3708 if not Is_CPP_Class (T) then 3709 3710 -- Skip secondary dispatch table referencing thunks to 3711 -- predefined primitives. 3712 3713 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 3714 Next_Elmt (ADT); 3715 3716 -- Skip secondary dispatch table referencing user-defined 3717 -- primitives covered by this interface. 3718 3719 pragma Assert (Has_Suffix (Node (ADT), 'D')); 3720 Next_Elmt (ADT); 3721 3722 -- Skip secondary dispatch table referencing predefined 3723 -- primitives. 3724 3725 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 3726 Next_Elmt (ADT); 3727 end if; 3728 end loop; 3729 3730 pragma Assert (Is_Tag (Node (ADT))); 3731 return Node (ADT); 3732 end Search_Tag; 3733 3734 -- Start of processing for Collect_Interfaces_Info 3735 3736 begin 3737 Collect_Interfaces (T, Ifaces_List); 3738 Collect_Interface_Components (T, Comps_List); 3739 3740 -- Search for the record component and tag associated with each 3741 -- interface type of T. 3742 3743 Components_List := New_Elmt_List; 3744 Tags_List := New_Elmt_List; 3745 3746 Iface_Elmt := First_Elmt (Ifaces_List); 3747 while Present (Iface_Elmt) loop 3748 Iface := Node (Iface_Elmt); 3749 3750 -- Associate the primary tag component and the primary dispatch table 3751 -- with all the interfaces that are parents of T 3752 3753 if Is_Ancestor (Iface, T, Use_Full_View => True) then 3754 Append_Elmt (First_Tag_Component (T), Components_List); 3755 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 3756 3757 -- Otherwise search for the tag component and secondary dispatch 3758 -- table of Iface 3759 3760 else 3761 Comp_Elmt := First_Elmt (Comps_List); 3762 while Present (Comp_Elmt) loop 3763 Comp_Iface := Related_Type (Node (Comp_Elmt)); 3764 3765 if Comp_Iface = Iface 3766 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 3767 then 3768 Append_Elmt (Node (Comp_Elmt), Components_List); 3769 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 3770 exit; 3771 end if; 3772 3773 Next_Elmt (Comp_Elmt); 3774 end loop; 3775 pragma Assert (Present (Comp_Elmt)); 3776 end if; 3777 3778 Next_Elmt (Iface_Elmt); 3779 end loop; 3780 end Collect_Interfaces_Info; 3781 3782 --------------------- 3783 -- Collect_Parents -- 3784 --------------------- 3785 3786 procedure Collect_Parents 3787 (T : Entity_Id; 3788 List : out Elist_Id; 3789 Use_Full_View : Boolean := True) 3790 is 3791 Current_Typ : Entity_Id := T; 3792 Parent_Typ : Entity_Id; 3793 3794 begin 3795 List := New_Elmt_List; 3796 3797 -- No action if the if the type has no parents 3798 3799 if T = Etype (T) then 3800 return; 3801 end if; 3802 3803 loop 3804 Parent_Typ := Etype (Current_Typ); 3805 3806 if Is_Private_Type (Parent_Typ) 3807 and then Present (Full_View (Parent_Typ)) 3808 and then Use_Full_View 3809 then 3810 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 3811 end if; 3812 3813 Append_Elmt (Parent_Typ, List); 3814 3815 exit when Parent_Typ = Current_Typ; 3816 Current_Typ := Parent_Typ; 3817 end loop; 3818 end Collect_Parents; 3819 3820 ---------------------------------- 3821 -- Collect_Primitive_Operations -- 3822 ---------------------------------- 3823 3824 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 3825 B_Type : constant Entity_Id := Base_Type (T); 3826 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 3827 B_Scope : Entity_Id := Scope (B_Type); 3828 Op_List : Elist_Id; 3829 Formal : Entity_Id; 3830 Is_Prim : Boolean; 3831 Is_Type_In_Pkg : Boolean; 3832 Formal_Derived : Boolean := False; 3833 Id : Entity_Id; 3834 3835 function Match (E : Entity_Id) return Boolean; 3836 -- True if E's base type is B_Type, or E is of an anonymous access type 3837 -- and the base type of its designated type is B_Type. 3838 3839 ----------- 3840 -- Match -- 3841 ----------- 3842 3843 function Match (E : Entity_Id) return Boolean is 3844 Etyp : Entity_Id := Etype (E); 3845 3846 begin 3847 if Ekind (Etyp) = E_Anonymous_Access_Type then 3848 Etyp := Designated_Type (Etyp); 3849 end if; 3850 3851 -- In Ada 2012 a primitive operation may have a formal of an 3852 -- incomplete view of the parent type. 3853 3854 return Base_Type (Etyp) = B_Type 3855 or else 3856 (Ada_Version >= Ada_2012 3857 and then Ekind (Etyp) = E_Incomplete_Type 3858 and then Full_View (Etyp) = B_Type); 3859 end Match; 3860 3861 -- Start of processing for Collect_Primitive_Operations 3862 3863 begin 3864 -- For tagged types, the primitive operations are collected as they 3865 -- are declared, and held in an explicit list which is simply returned. 3866 3867 if Is_Tagged_Type (B_Type) then 3868 return Primitive_Operations (B_Type); 3869 3870 -- An untagged generic type that is a derived type inherits the 3871 -- primitive operations of its parent type. Other formal types only 3872 -- have predefined operators, which are not explicitly represented. 3873 3874 elsif Is_Generic_Type (B_Type) then 3875 if Nkind (B_Decl) = N_Formal_Type_Declaration 3876 and then Nkind (Formal_Type_Definition (B_Decl)) = 3877 N_Formal_Derived_Type_Definition 3878 then 3879 Formal_Derived := True; 3880 else 3881 return New_Elmt_List; 3882 end if; 3883 end if; 3884 3885 Op_List := New_Elmt_List; 3886 3887 if B_Scope = Standard_Standard then 3888 if B_Type = Standard_String then 3889 Append_Elmt (Standard_Op_Concat, Op_List); 3890 3891 elsif B_Type = Standard_Wide_String then 3892 Append_Elmt (Standard_Op_Concatw, Op_List); 3893 3894 else 3895 null; 3896 end if; 3897 3898 -- Locate the primitive subprograms of the type 3899 3900 else 3901 -- The primitive operations appear after the base type, except 3902 -- if the derivation happens within the private part of B_Scope 3903 -- and the type is a private type, in which case both the type 3904 -- and some primitive operations may appear before the base 3905 -- type, and the list of candidates starts after the type. 3906 3907 if In_Open_Scopes (B_Scope) 3908 and then Scope (T) = B_Scope 3909 and then In_Private_Part (B_Scope) 3910 then 3911 Id := Next_Entity (T); 3912 3913 -- In Ada 2012, If the type has an incomplete partial view, there 3914 -- may be primitive operations declared before the full view, so 3915 -- we need to start scanning from the incomplete view, which is 3916 -- earlier on the entity chain. 3917 3918 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration 3919 and then Present (Incomplete_View (Parent (B_Type))) 3920 then 3921 Id := Defining_Entity (Incomplete_View (Parent (B_Type))); 3922 3923 else 3924 Id := Next_Entity (B_Type); 3925 end if; 3926 3927 -- Set flag if this is a type in a package spec 3928 3929 Is_Type_In_Pkg := 3930 Is_Package_Or_Generic_Package (B_Scope) 3931 and then 3932 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 3933 N_Package_Body; 3934 3935 while Present (Id) loop 3936 3937 -- Test whether the result type or any of the parameter types of 3938 -- each subprogram following the type match that type when the 3939 -- type is declared in a package spec, is a derived type, or the 3940 -- subprogram is marked as primitive. (The Is_Primitive test is 3941 -- needed to find primitives of nonderived types in declarative 3942 -- parts that happen to override the predefined "=" operator.) 3943 3944 -- Note that generic formal subprograms are not considered to be 3945 -- primitive operations and thus are never inherited. 3946 3947 if Is_Overloadable (Id) 3948 and then (Is_Type_In_Pkg 3949 or else Is_Derived_Type (B_Type) 3950 or else Is_Primitive (Id)) 3951 and then Nkind (Parent (Parent (Id))) 3952 not in N_Formal_Subprogram_Declaration 3953 then 3954 Is_Prim := False; 3955 3956 if Match (Id) then 3957 Is_Prim := True; 3958 3959 else 3960 Formal := First_Formal (Id); 3961 while Present (Formal) loop 3962 if Match (Formal) then 3963 Is_Prim := True; 3964 exit; 3965 end if; 3966 3967 Next_Formal (Formal); 3968 end loop; 3969 end if; 3970 3971 -- For a formal derived type, the only primitives are the ones 3972 -- inherited from the parent type. Operations appearing in the 3973 -- package declaration are not primitive for it. 3974 3975 if Is_Prim 3976 and then (not Formal_Derived or else Present (Alias (Id))) 3977 then 3978 -- In the special case of an equality operator aliased to 3979 -- an overriding dispatching equality belonging to the same 3980 -- type, we don't include it in the list of primitives. 3981 -- This avoids inheriting multiple equality operators when 3982 -- deriving from untagged private types whose full type is 3983 -- tagged, which can otherwise cause ambiguities. Note that 3984 -- this should only happen for this kind of untagged parent 3985 -- type, since normally dispatching operations are inherited 3986 -- using the type's Primitive_Operations list. 3987 3988 if Chars (Id) = Name_Op_Eq 3989 and then Is_Dispatching_Operation (Id) 3990 and then Present (Alias (Id)) 3991 and then Present (Overridden_Operation (Alias (Id))) 3992 and then Base_Type (Etype (First_Entity (Id))) = 3993 Base_Type (Etype (First_Entity (Alias (Id)))) 3994 then 3995 null; 3996 3997 -- Include the subprogram in the list of primitives 3998 3999 else 4000 Append_Elmt (Id, Op_List); 4001 end if; 4002 end if; 4003 end if; 4004 4005 Next_Entity (Id); 4006 4007 -- For a type declared in System, some of its operations may 4008 -- appear in the target-specific extension to System. 4009 4010 if No (Id) 4011 and then B_Scope = RTU_Entity (System) 4012 and then Present_System_Aux 4013 then 4014 B_Scope := System_Aux_Id; 4015 Id := First_Entity (System_Aux_Id); 4016 end if; 4017 end loop; 4018 end if; 4019 4020 return Op_List; 4021 end Collect_Primitive_Operations; 4022 4023 ----------------------------------- 4024 -- Compile_Time_Constraint_Error -- 4025 ----------------------------------- 4026 4027 function Compile_Time_Constraint_Error 4028 (N : Node_Id; 4029 Msg : String; 4030 Ent : Entity_Id := Empty; 4031 Loc : Source_Ptr := No_Location; 4032 Warn : Boolean := False) return Node_Id 4033 is 4034 Msgc : String (1 .. Msg'Length + 3); 4035 -- Copy of message, with room for possible ?? or << and ! at end 4036 4037 Msgl : Natural; 4038 Wmsg : Boolean; 4039 Eloc : Source_Ptr; 4040 4041 -- Start of processing for Compile_Time_Constraint_Error 4042 4043 begin 4044 -- If this is a warning, convert it into an error if we are in code 4045 -- subject to SPARK_Mode being set ON. 4046 4047 Error_Msg_Warn := SPARK_Mode /= On; 4048 4049 -- A static constraint error in an instance body is not a fatal error. 4050 -- we choose to inhibit the message altogether, because there is no 4051 -- obvious node (for now) on which to post it. On the other hand the 4052 -- offending node must be replaced with a constraint_error in any case. 4053 4054 -- No messages are generated if we already posted an error on this node 4055 4056 if not Error_Posted (N) then 4057 if Loc /= No_Location then 4058 Eloc := Loc; 4059 else 4060 Eloc := Sloc (N); 4061 end if; 4062 4063 -- Copy message to Msgc, converting any ? in the message into 4064 -- < instead, so that we have an error in GNATprove mode. 4065 4066 Msgl := Msg'Length; 4067 4068 for J in 1 .. Msgl loop 4069 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then 4070 Msgc (J) := '<'; 4071 else 4072 Msgc (J) := Msg (J); 4073 end if; 4074 end loop; 4075 4076 -- Message is a warning, even in Ada 95 case 4077 4078 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 4079 Wmsg := True; 4080 4081 -- In Ada 83, all messages are warnings. In the private part and 4082 -- the body of an instance, constraint_checks are only warnings. 4083 -- We also make this a warning if the Warn parameter is set. 4084 4085 elsif Warn 4086 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 4087 then 4088 Msgl := Msgl + 1; 4089 Msgc (Msgl) := '<'; 4090 Msgl := Msgl + 1; 4091 Msgc (Msgl) := '<'; 4092 Wmsg := True; 4093 4094 elsif In_Instance_Not_Visible then 4095 Msgl := Msgl + 1; 4096 Msgc (Msgl) := '<'; 4097 Msgl := Msgl + 1; 4098 Msgc (Msgl) := '<'; 4099 Wmsg := True; 4100 4101 -- Otherwise we have a real error message (Ada 95 static case) 4102 -- and we make this an unconditional message. Note that in the 4103 -- warning case we do not make the message unconditional, it seems 4104 -- quite reasonable to delete messages like this (about exceptions 4105 -- that will be raised) in dead code. 4106 4107 else 4108 Wmsg := False; 4109 Msgl := Msgl + 1; 4110 Msgc (Msgl) := '!'; 4111 end if; 4112 4113 -- One more test, skip the warning if the related expression is 4114 -- statically unevaluated, since we don't want to warn about what 4115 -- will happen when something is evaluated if it never will be 4116 -- evaluated. 4117 4118 if not Is_Statically_Unevaluated (N) then 4119 Error_Msg_Warn := SPARK_Mode /= On; 4120 4121 if Present (Ent) then 4122 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 4123 else 4124 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 4125 end if; 4126 4127 if Wmsg then 4128 4129 -- Check whether the context is an Init_Proc 4130 4131 if Inside_Init_Proc then 4132 declare 4133 Conc_Typ : constant Entity_Id := 4134 Corresponding_Concurrent_Type 4135 (Entity (Parameter_Type (First 4136 (Parameter_Specifications 4137 (Parent (Current_Scope)))))); 4138 4139 begin 4140 -- Don't complain if the corresponding concurrent type 4141 -- doesn't come from source (i.e. a single task/protected 4142 -- object). 4143 4144 if Present (Conc_Typ) 4145 and then not Comes_From_Source (Conc_Typ) 4146 then 4147 Error_Msg_NEL 4148 ("\& [<<", N, Standard_Constraint_Error, Eloc); 4149 4150 else 4151 if GNATprove_Mode then 4152 Error_Msg_NEL 4153 ("\& would have been raised for objects of this " 4154 & "type", N, Standard_Constraint_Error, Eloc); 4155 else 4156 Error_Msg_NEL 4157 ("\& will be raised for objects of this type??", 4158 N, Standard_Constraint_Error, Eloc); 4159 end if; 4160 end if; 4161 end; 4162 4163 else 4164 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 4165 end if; 4166 4167 else 4168 Error_Msg ("\static expression fails Constraint_Check", Eloc); 4169 Set_Error_Posted (N); 4170 end if; 4171 end if; 4172 end if; 4173 4174 return N; 4175 end Compile_Time_Constraint_Error; 4176 4177 ----------------------- 4178 -- Conditional_Delay -- 4179 ----------------------- 4180 4181 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 4182 begin 4183 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 4184 Set_Has_Delayed_Freeze (New_Ent); 4185 end if; 4186 end Conditional_Delay; 4187 4188 ---------------------------- 4189 -- Contains_Refined_State -- 4190 ---------------------------- 4191 4192 function Contains_Refined_State (Prag : Node_Id) return Boolean is 4193 function Has_State_In_Dependency (List : Node_Id) return Boolean; 4194 -- Determine whether a dependency list mentions a state with a visible 4195 -- refinement. 4196 4197 function Has_State_In_Global (List : Node_Id) return Boolean; 4198 -- Determine whether a global list mentions a state with a visible 4199 -- refinement. 4200 4201 function Is_Refined_State (Item : Node_Id) return Boolean; 4202 -- Determine whether Item is a reference to an abstract state with a 4203 -- visible refinement. 4204 4205 ----------------------------- 4206 -- Has_State_In_Dependency -- 4207 ----------------------------- 4208 4209 function Has_State_In_Dependency (List : Node_Id) return Boolean is 4210 Clause : Node_Id; 4211 Output : Node_Id; 4212 4213 begin 4214 -- A null dependency list does not mention any states 4215 4216 if Nkind (List) = N_Null then 4217 return False; 4218 4219 -- Dependency clauses appear as component associations of an 4220 -- aggregate. 4221 4222 elsif Nkind (List) = N_Aggregate 4223 and then Present (Component_Associations (List)) 4224 then 4225 Clause := First (Component_Associations (List)); 4226 while Present (Clause) loop 4227 4228 -- Inspect the outputs of a dependency clause 4229 4230 Output := First (Choices (Clause)); 4231 while Present (Output) loop 4232 if Is_Refined_State (Output) then 4233 return True; 4234 end if; 4235 4236 Next (Output); 4237 end loop; 4238 4239 -- Inspect the outputs of a dependency clause 4240 4241 if Is_Refined_State (Expression (Clause)) then 4242 return True; 4243 end if; 4244 4245 Next (Clause); 4246 end loop; 4247 4248 -- If we get here, then none of the dependency clauses mention a 4249 -- state with visible refinement. 4250 4251 return False; 4252 4253 -- An illegal pragma managed to sneak in 4254 4255 else 4256 raise Program_Error; 4257 end if; 4258 end Has_State_In_Dependency; 4259 4260 ------------------------- 4261 -- Has_State_In_Global -- 4262 ------------------------- 4263 4264 function Has_State_In_Global (List : Node_Id) return Boolean is 4265 Item : Node_Id; 4266 4267 begin 4268 -- A null global list does not mention any states 4269 4270 if Nkind (List) = N_Null then 4271 return False; 4272 4273 -- Simple global list or moded global list declaration 4274 4275 elsif Nkind (List) = N_Aggregate then 4276 4277 -- The declaration of a simple global list appear as a collection 4278 -- of expressions. 4279 4280 if Present (Expressions (List)) then 4281 Item := First (Expressions (List)); 4282 while Present (Item) loop 4283 if Is_Refined_State (Item) then 4284 return True; 4285 end if; 4286 4287 Next (Item); 4288 end loop; 4289 4290 -- The declaration of a moded global list appears as a collection 4291 -- of component associations where individual choices denote 4292 -- modes. 4293 4294 else 4295 Item := First (Component_Associations (List)); 4296 while Present (Item) loop 4297 if Has_State_In_Global (Expression (Item)) then 4298 return True; 4299 end if; 4300 4301 Next (Item); 4302 end loop; 4303 end if; 4304 4305 -- If we get here, then the simple/moded global list did not 4306 -- mention any states with a visible refinement. 4307 4308 return False; 4309 4310 -- Single global item declaration 4311 4312 elsif Is_Entity_Name (List) then 4313 return Is_Refined_State (List); 4314 4315 -- An illegal pragma managed to sneak in 4316 4317 else 4318 raise Program_Error; 4319 end if; 4320 end Has_State_In_Global; 4321 4322 ---------------------- 4323 -- Is_Refined_State -- 4324 ---------------------- 4325 4326 function Is_Refined_State (Item : Node_Id) return Boolean is 4327 Elmt : Node_Id; 4328 Item_Id : Entity_Id; 4329 4330 begin 4331 if Nkind (Item) = N_Null then 4332 return False; 4333 4334 -- States cannot be subject to attribute 'Result. This case arises 4335 -- in dependency relations. 4336 4337 elsif Nkind (Item) = N_Attribute_Reference 4338 and then Attribute_Name (Item) = Name_Result 4339 then 4340 return False; 4341 4342 -- Multiple items appear as an aggregate. This case arises in 4343 -- dependency relations. 4344 4345 elsif Nkind (Item) = N_Aggregate 4346 and then Present (Expressions (Item)) 4347 then 4348 Elmt := First (Expressions (Item)); 4349 while Present (Elmt) loop 4350 if Is_Refined_State (Elmt) then 4351 return True; 4352 end if; 4353 4354 Next (Elmt); 4355 end loop; 4356 4357 -- If we get here, then none of the inputs or outputs reference a 4358 -- state with visible refinement. 4359 4360 return False; 4361 4362 -- Single item 4363 4364 else 4365 Item_Id := Entity_Of (Item); 4366 4367 return 4368 Present (Item_Id) 4369 and then Ekind (Item_Id) = E_Abstract_State 4370 and then Has_Visible_Refinement (Item_Id); 4371 end if; 4372 end Is_Refined_State; 4373 4374 -- Local variables 4375 4376 Arg : constant Node_Id := 4377 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 4378 Nam : constant Name_Id := Pragma_Name (Prag); 4379 4380 -- Start of processing for Contains_Refined_State 4381 4382 begin 4383 if Nam = Name_Depends then 4384 return Has_State_In_Dependency (Arg); 4385 4386 else pragma Assert (Nam = Name_Global); 4387 return Has_State_In_Global (Arg); 4388 end if; 4389 end Contains_Refined_State; 4390 4391 ------------------------- 4392 -- Copy_Component_List -- 4393 ------------------------- 4394 4395 function Copy_Component_List 4396 (R_Typ : Entity_Id; 4397 Loc : Source_Ptr) return List_Id 4398 is 4399 Comp : Node_Id; 4400 Comps : constant List_Id := New_List; 4401 4402 begin 4403 Comp := First_Component (Underlying_Type (R_Typ)); 4404 while Present (Comp) loop 4405 if Comes_From_Source (Comp) then 4406 declare 4407 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 4408 begin 4409 Append_To (Comps, 4410 Make_Component_Declaration (Loc, 4411 Defining_Identifier => 4412 Make_Defining_Identifier (Loc, Chars (Comp)), 4413 Component_Definition => 4414 New_Copy_Tree 4415 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 4416 end; 4417 end if; 4418 4419 Next_Component (Comp); 4420 end loop; 4421 4422 return Comps; 4423 end Copy_Component_List; 4424 4425 ------------------------- 4426 -- Copy_Parameter_List -- 4427 ------------------------- 4428 4429 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 4430 Loc : constant Source_Ptr := Sloc (Subp_Id); 4431 Plist : List_Id; 4432 Formal : Entity_Id; 4433 4434 begin 4435 if No (First_Formal (Subp_Id)) then 4436 return No_List; 4437 else 4438 Plist := New_List; 4439 Formal := First_Formal (Subp_Id); 4440 while Present (Formal) loop 4441 Append 4442 (Make_Parameter_Specification (Loc, 4443 Defining_Identifier => 4444 Make_Defining_Identifier (Sloc (Formal), 4445 Chars => Chars (Formal)), 4446 In_Present => In_Present (Parent (Formal)), 4447 Out_Present => Out_Present (Parent (Formal)), 4448 Parameter_Type => 4449 New_Occurrence_Of (Etype (Formal), Loc), 4450 Expression => 4451 New_Copy_Tree (Expression (Parent (Formal)))), 4452 Plist); 4453 4454 Next_Formal (Formal); 4455 end loop; 4456 end if; 4457 4458 return Plist; 4459 end Copy_Parameter_List; 4460 4461 -------------------------------- 4462 -- Corresponding_Generic_Type -- 4463 -------------------------------- 4464 4465 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 4466 Inst : Entity_Id; 4467 Gen : Entity_Id; 4468 Typ : Entity_Id; 4469 4470 begin 4471 if not Is_Generic_Actual_Type (T) then 4472 return Any_Type; 4473 4474 -- If the actual is the actual of an enclosing instance, resolution 4475 -- was correct in the generic. 4476 4477 elsif Nkind (Parent (T)) = N_Subtype_Declaration 4478 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 4479 and then 4480 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 4481 then 4482 return Any_Type; 4483 4484 else 4485 Inst := Scope (T); 4486 4487 if Is_Wrapper_Package (Inst) then 4488 Inst := Related_Instance (Inst); 4489 end if; 4490 4491 Gen := 4492 Generic_Parent 4493 (Specification (Unit_Declaration_Node (Inst))); 4494 4495 -- Generic actual has the same name as the corresponding formal 4496 4497 Typ := First_Entity (Gen); 4498 while Present (Typ) loop 4499 if Chars (Typ) = Chars (T) then 4500 return Typ; 4501 end if; 4502 4503 Next_Entity (Typ); 4504 end loop; 4505 4506 return Any_Type; 4507 end if; 4508 end Corresponding_Generic_Type; 4509 4510 --------------------------- 4511 -- Corresponding_Spec_Of -- 4512 --------------------------- 4513 4514 function Corresponding_Spec_Of (Subp_Decl : Node_Id) return Entity_Id is 4515 begin 4516 if Nkind (Subp_Decl) = N_Subprogram_Body 4517 and then Present (Corresponding_Spec (Subp_Decl)) 4518 then 4519 return Corresponding_Spec (Subp_Decl); 4520 4521 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4522 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 4523 then 4524 return Corresponding_Spec_Of_Stub (Subp_Decl); 4525 4526 else 4527 return Defining_Entity (Subp_Decl); 4528 end if; 4529 end Corresponding_Spec_Of; 4530 4531 -------------------- 4532 -- Current_Entity -- 4533 -------------------- 4534 4535 -- The currently visible definition for a given identifier is the 4536 -- one most chained at the start of the visibility chain, i.e. the 4537 -- one that is referenced by the Node_Id value of the name of the 4538 -- given identifier. 4539 4540 function Current_Entity (N : Node_Id) return Entity_Id is 4541 begin 4542 return Get_Name_Entity_Id (Chars (N)); 4543 end Current_Entity; 4544 4545 ----------------------------- 4546 -- Current_Entity_In_Scope -- 4547 ----------------------------- 4548 4549 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 4550 E : Entity_Id; 4551 CS : constant Entity_Id := Current_Scope; 4552 4553 Transient_Case : constant Boolean := Scope_Is_Transient; 4554 4555 begin 4556 E := Get_Name_Entity_Id (Chars (N)); 4557 while Present (E) 4558 and then Scope (E) /= CS 4559 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 4560 loop 4561 E := Homonym (E); 4562 end loop; 4563 4564 return E; 4565 end Current_Entity_In_Scope; 4566 4567 ------------------- 4568 -- Current_Scope -- 4569 ------------------- 4570 4571 function Current_Scope return Entity_Id is 4572 begin 4573 if Scope_Stack.Last = -1 then 4574 return Standard_Standard; 4575 else 4576 declare 4577 C : constant Entity_Id := 4578 Scope_Stack.Table (Scope_Stack.Last).Entity; 4579 begin 4580 if Present (C) then 4581 return C; 4582 else 4583 return Standard_Standard; 4584 end if; 4585 end; 4586 end if; 4587 end Current_Scope; 4588 4589 ------------------------ 4590 -- Current_Subprogram -- 4591 ------------------------ 4592 4593 function Current_Subprogram return Entity_Id is 4594 Scop : constant Entity_Id := Current_Scope; 4595 begin 4596 if Is_Subprogram_Or_Generic_Subprogram (Scop) then 4597 return Scop; 4598 else 4599 return Enclosing_Subprogram (Scop); 4600 end if; 4601 end Current_Subprogram; 4602 4603 ---------------------------------- 4604 -- Deepest_Type_Access_Level -- 4605 ---------------------------------- 4606 4607 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 4608 begin 4609 if Ekind (Typ) = E_Anonymous_Access_Type 4610 and then not Is_Local_Anonymous_Access (Typ) 4611 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 4612 then 4613 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 4614 -- access type. 4615 4616 return 4617 Scope_Depth (Enclosing_Dynamic_Scope 4618 (Defining_Identifier 4619 (Associated_Node_For_Itype (Typ)))); 4620 4621 -- For generic formal type, return Int'Last (infinite). 4622 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 4623 4624 elsif Is_Generic_Type (Root_Type (Typ)) then 4625 return UI_From_Int (Int'Last); 4626 4627 else 4628 return Type_Access_Level (Typ); 4629 end if; 4630 end Deepest_Type_Access_Level; 4631 4632 --------------------- 4633 -- Defining_Entity -- 4634 --------------------- 4635 4636 function Defining_Entity (N : Node_Id) return Entity_Id is 4637 K : constant Node_Kind := Nkind (N); 4638 Err : Entity_Id := Empty; 4639 4640 begin 4641 case K is 4642 when 4643 N_Subprogram_Declaration | 4644 N_Abstract_Subprogram_Declaration | 4645 N_Subprogram_Body | 4646 N_Package_Declaration | 4647 N_Subprogram_Renaming_Declaration | 4648 N_Subprogram_Body_Stub | 4649 N_Generic_Subprogram_Declaration | 4650 N_Generic_Package_Declaration | 4651 N_Formal_Subprogram_Declaration | 4652 N_Expression_Function 4653 => 4654 return Defining_Entity (Specification (N)); 4655 4656 when 4657 N_Component_Declaration | 4658 N_Defining_Program_Unit_Name | 4659 N_Discriminant_Specification | 4660 N_Entry_Body | 4661 N_Entry_Declaration | 4662 N_Entry_Index_Specification | 4663 N_Exception_Declaration | 4664 N_Exception_Renaming_Declaration | 4665 N_Formal_Object_Declaration | 4666 N_Formal_Package_Declaration | 4667 N_Formal_Type_Declaration | 4668 N_Full_Type_Declaration | 4669 N_Implicit_Label_Declaration | 4670 N_Incomplete_Type_Declaration | 4671 N_Loop_Parameter_Specification | 4672 N_Number_Declaration | 4673 N_Object_Declaration | 4674 N_Object_Renaming_Declaration | 4675 N_Package_Body_Stub | 4676 N_Parameter_Specification | 4677 N_Private_Extension_Declaration | 4678 N_Private_Type_Declaration | 4679 N_Protected_Body | 4680 N_Protected_Body_Stub | 4681 N_Protected_Type_Declaration | 4682 N_Single_Protected_Declaration | 4683 N_Single_Task_Declaration | 4684 N_Subtype_Declaration | 4685 N_Task_Body | 4686 N_Task_Body_Stub | 4687 N_Task_Type_Declaration 4688 => 4689 return Defining_Identifier (N); 4690 4691 when N_Subunit => 4692 return Defining_Entity (Proper_Body (N)); 4693 4694 when 4695 N_Function_Instantiation | 4696 N_Function_Specification | 4697 N_Generic_Function_Renaming_Declaration | 4698 N_Generic_Package_Renaming_Declaration | 4699 N_Generic_Procedure_Renaming_Declaration | 4700 N_Package_Body | 4701 N_Package_Instantiation | 4702 N_Package_Renaming_Declaration | 4703 N_Package_Specification | 4704 N_Procedure_Instantiation | 4705 N_Procedure_Specification 4706 => 4707 declare 4708 Nam : constant Node_Id := Defining_Unit_Name (N); 4709 4710 begin 4711 if Nkind (Nam) in N_Entity then 4712 return Nam; 4713 4714 -- For Error, make up a name and attach to declaration 4715 -- so we can continue semantic analysis 4716 4717 elsif Nam = Error then 4718 Err := Make_Temporary (Sloc (N), 'T'); 4719 Set_Defining_Unit_Name (N, Err); 4720 4721 return Err; 4722 4723 -- If not an entity, get defining identifier 4724 4725 else 4726 return Defining_Identifier (Nam); 4727 end if; 4728 end; 4729 4730 when 4731 N_Block_Statement | 4732 N_Loop_Statement 4733 => 4734 return Entity (Identifier (N)); 4735 4736 when others => 4737 raise Program_Error; 4738 4739 end case; 4740 end Defining_Entity; 4741 4742 -------------------------- 4743 -- Denotes_Discriminant -- 4744 -------------------------- 4745 4746 function Denotes_Discriminant 4747 (N : Node_Id; 4748 Check_Concurrent : Boolean := False) return Boolean 4749 is 4750 E : Entity_Id; 4751 4752 begin 4753 if not Is_Entity_Name (N) or else No (Entity (N)) then 4754 return False; 4755 else 4756 E := Entity (N); 4757 end if; 4758 4759 -- If we are checking for a protected type, the discriminant may have 4760 -- been rewritten as the corresponding discriminal of the original type 4761 -- or of the corresponding concurrent record, depending on whether we 4762 -- are in the spec or body of the protected type. 4763 4764 return Ekind (E) = E_Discriminant 4765 or else 4766 (Check_Concurrent 4767 and then Ekind (E) = E_In_Parameter 4768 and then Present (Discriminal_Link (E)) 4769 and then 4770 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 4771 or else 4772 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 4773 4774 end Denotes_Discriminant; 4775 4776 ------------------------- 4777 -- Denotes_Same_Object -- 4778 ------------------------- 4779 4780 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 4781 Obj1 : Node_Id := A1; 4782 Obj2 : Node_Id := A2; 4783 4784 function Has_Prefix (N : Node_Id) return Boolean; 4785 -- Return True if N has attribute Prefix 4786 4787 function Is_Renaming (N : Node_Id) return Boolean; 4788 -- Return true if N names a renaming entity 4789 4790 function Is_Valid_Renaming (N : Node_Id) return Boolean; 4791 -- For renamings, return False if the prefix of any dereference within 4792 -- the renamed object_name is a variable, or any expression within the 4793 -- renamed object_name contains references to variables or calls on 4794 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 4795 4796 ---------------- 4797 -- Has_Prefix -- 4798 ---------------- 4799 4800 function Has_Prefix (N : Node_Id) return Boolean is 4801 begin 4802 return 4803 Nkind_In (N, 4804 N_Attribute_Reference, 4805 N_Expanded_Name, 4806 N_Explicit_Dereference, 4807 N_Indexed_Component, 4808 N_Reference, 4809 N_Selected_Component, 4810 N_Slice); 4811 end Has_Prefix; 4812 4813 ----------------- 4814 -- Is_Renaming -- 4815 ----------------- 4816 4817 function Is_Renaming (N : Node_Id) return Boolean is 4818 begin 4819 return Is_Entity_Name (N) 4820 and then Present (Renamed_Entity (Entity (N))); 4821 end Is_Renaming; 4822 4823 ----------------------- 4824 -- Is_Valid_Renaming -- 4825 ----------------------- 4826 4827 function Is_Valid_Renaming (N : Node_Id) return Boolean is 4828 4829 function Check_Renaming (N : Node_Id) return Boolean; 4830 -- Recursive function used to traverse all the prefixes of N 4831 4832 function Check_Renaming (N : Node_Id) return Boolean is 4833 begin 4834 if Is_Renaming (N) 4835 and then not Check_Renaming (Renamed_Entity (Entity (N))) 4836 then 4837 return False; 4838 end if; 4839 4840 if Nkind (N) = N_Indexed_Component then 4841 declare 4842 Indx : Node_Id; 4843 4844 begin 4845 Indx := First (Expressions (N)); 4846 while Present (Indx) loop 4847 if not Is_OK_Static_Expression (Indx) then 4848 return False; 4849 end if; 4850 4851 Next_Index (Indx); 4852 end loop; 4853 end; 4854 end if; 4855 4856 if Has_Prefix (N) then 4857 declare 4858 P : constant Node_Id := Prefix (N); 4859 4860 begin 4861 if Nkind (N) = N_Explicit_Dereference 4862 and then Is_Variable (P) 4863 then 4864 return False; 4865 4866 elsif Is_Entity_Name (P) 4867 and then Ekind (Entity (P)) = E_Function 4868 then 4869 return False; 4870 4871 elsif Nkind (P) = N_Function_Call then 4872 return False; 4873 end if; 4874 4875 -- Recursion to continue traversing the prefix of the 4876 -- renaming expression 4877 4878 return Check_Renaming (P); 4879 end; 4880 end if; 4881 4882 return True; 4883 end Check_Renaming; 4884 4885 -- Start of processing for Is_Valid_Renaming 4886 4887 begin 4888 return Check_Renaming (N); 4889 end Is_Valid_Renaming; 4890 4891 -- Start of processing for Denotes_Same_Object 4892 4893 begin 4894 -- Both names statically denote the same stand-alone object or parameter 4895 -- (RM 6.4.1(6.5/3)) 4896 4897 if Is_Entity_Name (Obj1) 4898 and then Is_Entity_Name (Obj2) 4899 and then Entity (Obj1) = Entity (Obj2) 4900 then 4901 return True; 4902 end if; 4903 4904 -- For renamings, the prefix of any dereference within the renamed 4905 -- object_name is not a variable, and any expression within the 4906 -- renamed object_name contains no references to variables nor 4907 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 4908 4909 if Is_Renaming (Obj1) then 4910 if Is_Valid_Renaming (Obj1) then 4911 Obj1 := Renamed_Entity (Entity (Obj1)); 4912 else 4913 return False; 4914 end if; 4915 end if; 4916 4917 if Is_Renaming (Obj2) then 4918 if Is_Valid_Renaming (Obj2) then 4919 Obj2 := Renamed_Entity (Entity (Obj2)); 4920 else 4921 return False; 4922 end if; 4923 end if; 4924 4925 -- No match if not same node kind (such cases are handled by 4926 -- Denotes_Same_Prefix) 4927 4928 if Nkind (Obj1) /= Nkind (Obj2) then 4929 return False; 4930 4931 -- After handling valid renamings, one of the two names statically 4932 -- denoted a renaming declaration whose renamed object_name is known 4933 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 4934 4935 elsif Is_Entity_Name (Obj1) then 4936 if Is_Entity_Name (Obj2) then 4937 return Entity (Obj1) = Entity (Obj2); 4938 else 4939 return False; 4940 end if; 4941 4942 -- Both names are selected_components, their prefixes are known to 4943 -- denote the same object, and their selector_names denote the same 4944 -- component (RM 6.4.1(6.6/3) 4945 4946 elsif Nkind (Obj1) = N_Selected_Component then 4947 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 4948 and then 4949 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 4950 4951 -- Both names are dereferences and the dereferenced names are known to 4952 -- denote the same object (RM 6.4.1(6.7/3)) 4953 4954 elsif Nkind (Obj1) = N_Explicit_Dereference then 4955 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 4956 4957 -- Both names are indexed_components, their prefixes are known to denote 4958 -- the same object, and each of the pairs of corresponding index values 4959 -- are either both static expressions with the same static value or both 4960 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 4961 4962 elsif Nkind (Obj1) = N_Indexed_Component then 4963 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 4964 return False; 4965 else 4966 declare 4967 Indx1 : Node_Id; 4968 Indx2 : Node_Id; 4969 4970 begin 4971 Indx1 := First (Expressions (Obj1)); 4972 Indx2 := First (Expressions (Obj2)); 4973 while Present (Indx1) loop 4974 4975 -- Indexes must denote the same static value or same object 4976 4977 if Is_OK_Static_Expression (Indx1) then 4978 if not Is_OK_Static_Expression (Indx2) then 4979 return False; 4980 4981 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 4982 return False; 4983 end if; 4984 4985 elsif not Denotes_Same_Object (Indx1, Indx2) then 4986 return False; 4987 end if; 4988 4989 Next (Indx1); 4990 Next (Indx2); 4991 end loop; 4992 4993 return True; 4994 end; 4995 end if; 4996 4997 -- Both names are slices, their prefixes are known to denote the same 4998 -- object, and the two slices have statically matching index constraints 4999 -- (RM 6.4.1(6.9/3)) 5000 5001 elsif Nkind (Obj1) = N_Slice 5002 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 5003 then 5004 declare 5005 Lo1, Lo2, Hi1, Hi2 : Node_Id; 5006 5007 begin 5008 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 5009 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 5010 5011 -- Check whether bounds are statically identical. There is no 5012 -- attempt to detect partial overlap of slices. 5013 5014 return Denotes_Same_Object (Lo1, Lo2) 5015 and then 5016 Denotes_Same_Object (Hi1, Hi2); 5017 end; 5018 5019 -- In the recursion, literals appear as indexes 5020 5021 elsif Nkind (Obj1) = N_Integer_Literal 5022 and then 5023 Nkind (Obj2) = N_Integer_Literal 5024 then 5025 return Intval (Obj1) = Intval (Obj2); 5026 5027 else 5028 return False; 5029 end if; 5030 end Denotes_Same_Object; 5031 5032 ------------------------- 5033 -- Denotes_Same_Prefix -- 5034 ------------------------- 5035 5036 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 5037 5038 begin 5039 if Is_Entity_Name (A1) then 5040 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 5041 and then not Is_Access_Type (Etype (A1)) 5042 then 5043 return Denotes_Same_Object (A1, Prefix (A2)) 5044 or else Denotes_Same_Prefix (A1, Prefix (A2)); 5045 else 5046 return False; 5047 end if; 5048 5049 elsif Is_Entity_Name (A2) then 5050 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 5051 5052 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 5053 and then 5054 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 5055 then 5056 declare 5057 Root1, Root2 : Node_Id; 5058 Depth1, Depth2 : Int := 0; 5059 5060 begin 5061 Root1 := Prefix (A1); 5062 while not Is_Entity_Name (Root1) loop 5063 if not Nkind_In 5064 (Root1, N_Selected_Component, N_Indexed_Component) 5065 then 5066 return False; 5067 else 5068 Root1 := Prefix (Root1); 5069 end if; 5070 5071 Depth1 := Depth1 + 1; 5072 end loop; 5073 5074 Root2 := Prefix (A2); 5075 while not Is_Entity_Name (Root2) loop 5076 if not Nkind_In (Root2, N_Selected_Component, 5077 N_Indexed_Component) 5078 then 5079 return False; 5080 else 5081 Root2 := Prefix (Root2); 5082 end if; 5083 5084 Depth2 := Depth2 + 1; 5085 end loop; 5086 5087 -- If both have the same depth and they do not denote the same 5088 -- object, they are disjoint and no warning is needed. 5089 5090 if Depth1 = Depth2 then 5091 return False; 5092 5093 elsif Depth1 > Depth2 then 5094 Root1 := Prefix (A1); 5095 for J in 1 .. Depth1 - Depth2 - 1 loop 5096 Root1 := Prefix (Root1); 5097 end loop; 5098 5099 return Denotes_Same_Object (Root1, A2); 5100 5101 else 5102 Root2 := Prefix (A2); 5103 for J in 1 .. Depth2 - Depth1 - 1 loop 5104 Root2 := Prefix (Root2); 5105 end loop; 5106 5107 return Denotes_Same_Object (A1, Root2); 5108 end if; 5109 end; 5110 5111 else 5112 return False; 5113 end if; 5114 end Denotes_Same_Prefix; 5115 5116 ---------------------- 5117 -- Denotes_Variable -- 5118 ---------------------- 5119 5120 function Denotes_Variable (N : Node_Id) return Boolean is 5121 begin 5122 return Is_Variable (N) and then Paren_Count (N) = 0; 5123 end Denotes_Variable; 5124 5125 ----------------------------- 5126 -- Depends_On_Discriminant -- 5127 ----------------------------- 5128 5129 function Depends_On_Discriminant (N : Node_Id) return Boolean is 5130 L : Node_Id; 5131 H : Node_Id; 5132 5133 begin 5134 Get_Index_Bounds (N, L, H); 5135 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 5136 end Depends_On_Discriminant; 5137 5138 ------------------------- 5139 -- Designate_Same_Unit -- 5140 ------------------------- 5141 5142 function Designate_Same_Unit 5143 (Name1 : Node_Id; 5144 Name2 : Node_Id) return Boolean 5145 is 5146 K1 : constant Node_Kind := Nkind (Name1); 5147 K2 : constant Node_Kind := Nkind (Name2); 5148 5149 function Prefix_Node (N : Node_Id) return Node_Id; 5150 -- Returns the parent unit name node of a defining program unit name 5151 -- or the prefix if N is a selected component or an expanded name. 5152 5153 function Select_Node (N : Node_Id) return Node_Id; 5154 -- Returns the defining identifier node of a defining program unit 5155 -- name or the selector node if N is a selected component or an 5156 -- expanded name. 5157 5158 ----------------- 5159 -- Prefix_Node -- 5160 ----------------- 5161 5162 function Prefix_Node (N : Node_Id) return Node_Id is 5163 begin 5164 if Nkind (N) = N_Defining_Program_Unit_Name then 5165 return Name (N); 5166 else 5167 return Prefix (N); 5168 end if; 5169 end Prefix_Node; 5170 5171 ----------------- 5172 -- Select_Node -- 5173 ----------------- 5174 5175 function Select_Node (N : Node_Id) return Node_Id is 5176 begin 5177 if Nkind (N) = N_Defining_Program_Unit_Name then 5178 return Defining_Identifier (N); 5179 else 5180 return Selector_Name (N); 5181 end if; 5182 end Select_Node; 5183 5184 -- Start of processing for Designate_Same_Unit 5185 5186 begin 5187 if Nkind_In (K1, N_Identifier, N_Defining_Identifier) 5188 and then 5189 Nkind_In (K2, N_Identifier, N_Defining_Identifier) 5190 then 5191 return Chars (Name1) = Chars (Name2); 5192 5193 elsif Nkind_In (K1, N_Expanded_Name, 5194 N_Selected_Component, 5195 N_Defining_Program_Unit_Name) 5196 and then 5197 Nkind_In (K2, N_Expanded_Name, 5198 N_Selected_Component, 5199 N_Defining_Program_Unit_Name) 5200 then 5201 return 5202 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 5203 and then 5204 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 5205 5206 else 5207 return False; 5208 end if; 5209 end Designate_Same_Unit; 5210 5211 ------------------------------------------ 5212 -- function Dynamic_Accessibility_Level -- 5213 ------------------------------------------ 5214 5215 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 5216 E : Entity_Id; 5217 Loc : constant Source_Ptr := Sloc (Expr); 5218 5219 function Make_Level_Literal (Level : Uint) return Node_Id; 5220 -- Construct an integer literal representing an accessibility level 5221 -- with its type set to Natural. 5222 5223 ------------------------ 5224 -- Make_Level_Literal -- 5225 ------------------------ 5226 5227 function Make_Level_Literal (Level : Uint) return Node_Id is 5228 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 5229 begin 5230 Set_Etype (Result, Standard_Natural); 5231 return Result; 5232 end Make_Level_Literal; 5233 5234 -- Start of processing for Dynamic_Accessibility_Level 5235 5236 begin 5237 if Is_Entity_Name (Expr) then 5238 E := Entity (Expr); 5239 5240 if Present (Renamed_Object (E)) then 5241 return Dynamic_Accessibility_Level (Renamed_Object (E)); 5242 end if; 5243 5244 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 5245 if Present (Extra_Accessibility (E)) then 5246 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 5247 end if; 5248 end if; 5249 end if; 5250 5251 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 5252 5253 case Nkind (Expr) is 5254 5255 -- For access discriminant, the level of the enclosing object 5256 5257 when N_Selected_Component => 5258 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 5259 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 5260 E_Anonymous_Access_Type 5261 then 5262 return Make_Level_Literal (Object_Access_Level (Expr)); 5263 end if; 5264 5265 when N_Attribute_Reference => 5266 case Get_Attribute_Id (Attribute_Name (Expr)) is 5267 5268 -- For X'Access, the level of the prefix X 5269 5270 when Attribute_Access => 5271 return Make_Level_Literal 5272 (Object_Access_Level (Prefix (Expr))); 5273 5274 -- Treat the unchecked attributes as library-level 5275 5276 when Attribute_Unchecked_Access | 5277 Attribute_Unrestricted_Access => 5278 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 5279 5280 -- No other access-valued attributes 5281 5282 when others => 5283 raise Program_Error; 5284 end case; 5285 5286 when N_Allocator => 5287 5288 -- Unimplemented: depends on context. As an actual parameter where 5289 -- formal type is anonymous, use 5290 -- Scope_Depth (Current_Scope) + 1. 5291 -- For other cases, see 3.10.2(14/3) and following. ??? 5292 5293 null; 5294 5295 when N_Type_Conversion => 5296 if not Is_Local_Anonymous_Access (Etype (Expr)) then 5297 5298 -- Handle type conversions introduced for a rename of an 5299 -- Ada 2012 stand-alone object of an anonymous access type. 5300 5301 return Dynamic_Accessibility_Level (Expression (Expr)); 5302 end if; 5303 5304 when others => 5305 null; 5306 end case; 5307 5308 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 5309 end Dynamic_Accessibility_Level; 5310 5311 ----------------------------------- 5312 -- Effective_Extra_Accessibility -- 5313 ----------------------------------- 5314 5315 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 5316 begin 5317 if Present (Renamed_Object (Id)) 5318 and then Is_Entity_Name (Renamed_Object (Id)) 5319 then 5320 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 5321 else 5322 return Extra_Accessibility (Id); 5323 end if; 5324 end Effective_Extra_Accessibility; 5325 5326 ----------------------------- 5327 -- Effective_Reads_Enabled -- 5328 ----------------------------- 5329 5330 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 5331 begin 5332 return Has_Enabled_Property (Id, Name_Effective_Reads); 5333 end Effective_Reads_Enabled; 5334 5335 ------------------------------ 5336 -- Effective_Writes_Enabled -- 5337 ------------------------------ 5338 5339 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 5340 begin 5341 return Has_Enabled_Property (Id, Name_Effective_Writes); 5342 end Effective_Writes_Enabled; 5343 5344 ------------------------------ 5345 -- Enclosing_Comp_Unit_Node -- 5346 ------------------------------ 5347 5348 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 5349 Current_Node : Node_Id; 5350 5351 begin 5352 Current_Node := N; 5353 while Present (Current_Node) 5354 and then Nkind (Current_Node) /= N_Compilation_Unit 5355 loop 5356 Current_Node := Parent (Current_Node); 5357 end loop; 5358 5359 if Nkind (Current_Node) /= N_Compilation_Unit then 5360 return Empty; 5361 else 5362 return Current_Node; 5363 end if; 5364 end Enclosing_Comp_Unit_Node; 5365 5366 -------------------------- 5367 -- Enclosing_CPP_Parent -- 5368 -------------------------- 5369 5370 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 5371 Parent_Typ : Entity_Id := Typ; 5372 5373 begin 5374 while not Is_CPP_Class (Parent_Typ) 5375 and then Etype (Parent_Typ) /= Parent_Typ 5376 loop 5377 Parent_Typ := Etype (Parent_Typ); 5378 5379 if Is_Private_Type (Parent_Typ) then 5380 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5381 end if; 5382 end loop; 5383 5384 pragma Assert (Is_CPP_Class (Parent_Typ)); 5385 return Parent_Typ; 5386 end Enclosing_CPP_Parent; 5387 5388 ---------------------------- 5389 -- Enclosing_Generic_Body -- 5390 ---------------------------- 5391 5392 function Enclosing_Generic_Body 5393 (N : Node_Id) return Node_Id 5394 is 5395 P : Node_Id; 5396 Decl : Node_Id; 5397 Spec : Node_Id; 5398 5399 begin 5400 P := Parent (N); 5401 while Present (P) loop 5402 if Nkind (P) = N_Package_Body 5403 or else Nkind (P) = N_Subprogram_Body 5404 then 5405 Spec := Corresponding_Spec (P); 5406 5407 if Present (Spec) then 5408 Decl := Unit_Declaration_Node (Spec); 5409 5410 if Nkind (Decl) = N_Generic_Package_Declaration 5411 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 5412 then 5413 return P; 5414 end if; 5415 end if; 5416 end if; 5417 5418 P := Parent (P); 5419 end loop; 5420 5421 return Empty; 5422 end Enclosing_Generic_Body; 5423 5424 ---------------------------- 5425 -- Enclosing_Generic_Unit -- 5426 ---------------------------- 5427 5428 function Enclosing_Generic_Unit 5429 (N : Node_Id) return Node_Id 5430 is 5431 P : Node_Id; 5432 Decl : Node_Id; 5433 Spec : Node_Id; 5434 5435 begin 5436 P := Parent (N); 5437 while Present (P) loop 5438 if Nkind (P) = N_Generic_Package_Declaration 5439 or else Nkind (P) = N_Generic_Subprogram_Declaration 5440 then 5441 return P; 5442 5443 elsif Nkind (P) = N_Package_Body 5444 or else Nkind (P) = N_Subprogram_Body 5445 then 5446 Spec := Corresponding_Spec (P); 5447 5448 if Present (Spec) then 5449 Decl := Unit_Declaration_Node (Spec); 5450 5451 if Nkind (Decl) = N_Generic_Package_Declaration 5452 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 5453 then 5454 return Decl; 5455 end if; 5456 end if; 5457 end if; 5458 5459 P := Parent (P); 5460 end loop; 5461 5462 return Empty; 5463 end Enclosing_Generic_Unit; 5464 5465 ------------------------------- 5466 -- Enclosing_Lib_Unit_Entity -- 5467 ------------------------------- 5468 5469 function Enclosing_Lib_Unit_Entity 5470 (E : Entity_Id := Current_Scope) return Entity_Id 5471 is 5472 Unit_Entity : Entity_Id; 5473 5474 begin 5475 -- Look for enclosing library unit entity by following scope links. 5476 -- Equivalent to, but faster than indexing through the scope stack. 5477 5478 Unit_Entity := E; 5479 while (Present (Scope (Unit_Entity)) 5480 and then Scope (Unit_Entity) /= Standard_Standard) 5481 and not Is_Child_Unit (Unit_Entity) 5482 loop 5483 Unit_Entity := Scope (Unit_Entity); 5484 end loop; 5485 5486 return Unit_Entity; 5487 end Enclosing_Lib_Unit_Entity; 5488 5489 ----------------------- 5490 -- Enclosing_Package -- 5491 ----------------------- 5492 5493 function Enclosing_Package (E : Entity_Id) return Entity_Id is 5494 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 5495 5496 begin 5497 if Dynamic_Scope = Standard_Standard then 5498 return Standard_Standard; 5499 5500 elsif Dynamic_Scope = Empty then 5501 return Empty; 5502 5503 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 5504 E_Generic_Package) 5505 then 5506 return Dynamic_Scope; 5507 5508 else 5509 return Enclosing_Package (Dynamic_Scope); 5510 end if; 5511 end Enclosing_Package; 5512 5513 -------------------------- 5514 -- Enclosing_Subprogram -- 5515 -------------------------- 5516 5517 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 5518 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 5519 5520 begin 5521 if Dynamic_Scope = Standard_Standard then 5522 return Empty; 5523 5524 elsif Dynamic_Scope = Empty then 5525 return Empty; 5526 5527 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then 5528 return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); 5529 5530 elsif Ekind (Dynamic_Scope) = E_Block 5531 or else Ekind (Dynamic_Scope) = E_Return_Statement 5532 then 5533 return Enclosing_Subprogram (Dynamic_Scope); 5534 5535 elsif Ekind (Dynamic_Scope) = E_Task_Type then 5536 return Get_Task_Body_Procedure (Dynamic_Scope); 5537 5538 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type 5539 and then Present (Full_View (Dynamic_Scope)) 5540 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type 5541 then 5542 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); 5543 5544 -- No body is generated if the protected operation is eliminated 5545 5546 elsif Convention (Dynamic_Scope) = Convention_Protected 5547 and then not Is_Eliminated (Dynamic_Scope) 5548 and then Present (Protected_Body_Subprogram (Dynamic_Scope)) 5549 then 5550 return Protected_Body_Subprogram (Dynamic_Scope); 5551 5552 else 5553 return Dynamic_Scope; 5554 end if; 5555 end Enclosing_Subprogram; 5556 5557 ------------------------ 5558 -- Ensure_Freeze_Node -- 5559 ------------------------ 5560 5561 procedure Ensure_Freeze_Node (E : Entity_Id) is 5562 FN : Node_Id; 5563 begin 5564 if No (Freeze_Node (E)) then 5565 FN := Make_Freeze_Entity (Sloc (E)); 5566 Set_Has_Delayed_Freeze (E); 5567 Set_Freeze_Node (E, FN); 5568 Set_Access_Types_To_Process (FN, No_Elist); 5569 Set_TSS_Elist (FN, No_Elist); 5570 Set_Entity (FN, E); 5571 end if; 5572 end Ensure_Freeze_Node; 5573 5574 ---------------- 5575 -- Enter_Name -- 5576 ---------------- 5577 5578 procedure Enter_Name (Def_Id : Entity_Id) is 5579 C : constant Entity_Id := Current_Entity (Def_Id); 5580 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 5581 S : constant Entity_Id := Current_Scope; 5582 5583 begin 5584 Generate_Definition (Def_Id); 5585 5586 -- Add new name to current scope declarations. Check for duplicate 5587 -- declaration, which may or may not be a genuine error. 5588 5589 if Present (E) then 5590 5591 -- Case of previous entity entered because of a missing declaration 5592 -- or else a bad subtype indication. Best is to use the new entity, 5593 -- and make the previous one invisible. 5594 5595 if Etype (E) = Any_Type then 5596 Set_Is_Immediately_Visible (E, False); 5597 5598 -- Case of renaming declaration constructed for package instances. 5599 -- if there is an explicit declaration with the same identifier, 5600 -- the renaming is not immediately visible any longer, but remains 5601 -- visible through selected component notation. 5602 5603 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 5604 and then not Comes_From_Source (E) 5605 then 5606 Set_Is_Immediately_Visible (E, False); 5607 5608 -- The new entity may be the package renaming, which has the same 5609 -- same name as a generic formal which has been seen already. 5610 5611 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 5612 and then not Comes_From_Source (Def_Id) 5613 then 5614 Set_Is_Immediately_Visible (E, False); 5615 5616 -- For a fat pointer corresponding to a remote access to subprogram, 5617 -- we use the same identifier as the RAS type, so that the proper 5618 -- name appears in the stub. This type is only retrieved through 5619 -- the RAS type and never by visibility, and is not added to the 5620 -- visibility list (see below). 5621 5622 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 5623 and then Ekind (Def_Id) = E_Record_Type 5624 and then Present (Corresponding_Remote_Type (Def_Id)) 5625 then 5626 null; 5627 5628 -- Case of an implicit operation or derived literal. The new entity 5629 -- hides the implicit one, which is removed from all visibility, 5630 -- i.e. the entity list of its scope, and homonym chain of its name. 5631 5632 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 5633 or else Is_Internal (E) 5634 then 5635 declare 5636 Prev : Entity_Id; 5637 Prev_Vis : Entity_Id; 5638 Decl : constant Node_Id := Parent (E); 5639 5640 begin 5641 -- If E is an implicit declaration, it cannot be the first 5642 -- entity in the scope. 5643 5644 Prev := First_Entity (Current_Scope); 5645 while Present (Prev) and then Next_Entity (Prev) /= E loop 5646 Next_Entity (Prev); 5647 end loop; 5648 5649 if No (Prev) then 5650 5651 -- If E is not on the entity chain of the current scope, 5652 -- it is an implicit declaration in the generic formal 5653 -- part of a generic subprogram. When analyzing the body, 5654 -- the generic formals are visible but not on the entity 5655 -- chain of the subprogram. The new entity will become 5656 -- the visible one in the body. 5657 5658 pragma Assert 5659 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 5660 null; 5661 5662 else 5663 Set_Next_Entity (Prev, Next_Entity (E)); 5664 5665 if No (Next_Entity (Prev)) then 5666 Set_Last_Entity (Current_Scope, Prev); 5667 end if; 5668 5669 if E = Current_Entity (E) then 5670 Prev_Vis := Empty; 5671 5672 else 5673 Prev_Vis := Current_Entity (E); 5674 while Homonym (Prev_Vis) /= E loop 5675 Prev_Vis := Homonym (Prev_Vis); 5676 end loop; 5677 end if; 5678 5679 if Present (Prev_Vis) then 5680 5681 -- Skip E in the visibility chain 5682 5683 Set_Homonym (Prev_Vis, Homonym (E)); 5684 5685 else 5686 Set_Name_Entity_Id (Chars (E), Homonym (E)); 5687 end if; 5688 end if; 5689 end; 5690 5691 -- This section of code could use a comment ??? 5692 5693 elsif Present (Etype (E)) 5694 and then Is_Concurrent_Type (Etype (E)) 5695 and then E = Def_Id 5696 then 5697 return; 5698 5699 -- If the homograph is a protected component renaming, it should not 5700 -- be hiding the current entity. Such renamings are treated as weak 5701 -- declarations. 5702 5703 elsif Is_Prival (E) then 5704 Set_Is_Immediately_Visible (E, False); 5705 5706 -- In this case the current entity is a protected component renaming. 5707 -- Perform minimal decoration by setting the scope and return since 5708 -- the prival should not be hiding other visible entities. 5709 5710 elsif Is_Prival (Def_Id) then 5711 Set_Scope (Def_Id, Current_Scope); 5712 return; 5713 5714 -- Analogous to privals, the discriminal generated for an entry index 5715 -- parameter acts as a weak declaration. Perform minimal decoration 5716 -- to avoid bogus errors. 5717 5718 elsif Is_Discriminal (Def_Id) 5719 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 5720 then 5721 Set_Scope (Def_Id, Current_Scope); 5722 return; 5723 5724 -- In the body or private part of an instance, a type extension may 5725 -- introduce a component with the same name as that of an actual. The 5726 -- legality rule is not enforced, but the semantics of the full type 5727 -- with two components of same name are not clear at this point??? 5728 5729 elsif In_Instance_Not_Visible then 5730 null; 5731 5732 -- When compiling a package body, some child units may have become 5733 -- visible. They cannot conflict with local entities that hide them. 5734 5735 elsif Is_Child_Unit (E) 5736 and then In_Open_Scopes (Scope (E)) 5737 and then not Is_Immediately_Visible (E) 5738 then 5739 null; 5740 5741 -- Conversely, with front-end inlining we may compile the parent body 5742 -- first, and a child unit subsequently. The context is now the 5743 -- parent spec, and body entities are not visible. 5744 5745 elsif Is_Child_Unit (Def_Id) 5746 and then Is_Package_Body_Entity (E) 5747 and then not In_Package_Body (Current_Scope) 5748 then 5749 null; 5750 5751 -- Case of genuine duplicate declaration 5752 5753 else 5754 Error_Msg_Sloc := Sloc (E); 5755 5756 -- If the previous declaration is an incomplete type declaration 5757 -- this may be an attempt to complete it with a private type. The 5758 -- following avoids confusing cascaded errors. 5759 5760 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 5761 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 5762 then 5763 Error_Msg_N 5764 ("incomplete type cannot be completed with a private " & 5765 "declaration", Parent (Def_Id)); 5766 Set_Is_Immediately_Visible (E, False); 5767 Set_Full_View (E, Def_Id); 5768 5769 -- An inherited component of a record conflicts with a new 5770 -- discriminant. The discriminant is inserted first in the scope, 5771 -- but the error should be posted on it, not on the component. 5772 5773 elsif Ekind (E) = E_Discriminant 5774 and then Present (Scope (Def_Id)) 5775 and then Scope (Def_Id) /= Current_Scope 5776 then 5777 Error_Msg_Sloc := Sloc (Def_Id); 5778 Error_Msg_N ("& conflicts with declaration#", E); 5779 return; 5780 5781 -- If the name of the unit appears in its own context clause, a 5782 -- dummy package with the name has already been created, and the 5783 -- error emitted. Try to continue quietly. 5784 5785 elsif Error_Posted (E) 5786 and then Sloc (E) = No_Location 5787 and then Nkind (Parent (E)) = N_Package_Specification 5788 and then Current_Scope = Standard_Standard 5789 then 5790 Set_Scope (Def_Id, Current_Scope); 5791 return; 5792 5793 else 5794 Error_Msg_N ("& conflicts with declaration#", Def_Id); 5795 5796 -- Avoid cascaded messages with duplicate components in 5797 -- derived types. 5798 5799 if Ekind_In (E, E_Component, E_Discriminant) then 5800 return; 5801 end if; 5802 end if; 5803 5804 if Nkind (Parent (Parent (Def_Id))) = 5805 N_Generic_Subprogram_Declaration 5806 and then Def_Id = 5807 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 5808 then 5809 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 5810 end if; 5811 5812 -- If entity is in standard, then we are in trouble, because it 5813 -- means that we have a library package with a duplicated name. 5814 -- That's hard to recover from, so abort. 5815 5816 if S = Standard_Standard then 5817 raise Unrecoverable_Error; 5818 5819 -- Otherwise we continue with the declaration. Having two 5820 -- identical declarations should not cause us too much trouble. 5821 5822 else 5823 null; 5824 end if; 5825 end if; 5826 end if; 5827 5828 -- If we fall through, declaration is OK, at least OK enough to continue 5829 5830 -- If Def_Id is a discriminant or a record component we are in the midst 5831 -- of inheriting components in a derived record definition. Preserve 5832 -- their Ekind and Etype. 5833 5834 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 5835 null; 5836 5837 -- If a type is already set, leave it alone (happens when a type 5838 -- declaration is reanalyzed following a call to the optimizer). 5839 5840 elsif Present (Etype (Def_Id)) then 5841 null; 5842 5843 -- Otherwise, the kind E_Void insures that premature uses of the entity 5844 -- will be detected. Any_Type insures that no cascaded errors will occur 5845 5846 else 5847 Set_Ekind (Def_Id, E_Void); 5848 Set_Etype (Def_Id, Any_Type); 5849 end if; 5850 5851 -- Inherited discriminants and components in derived record types are 5852 -- immediately visible. Itypes are not. 5853 5854 -- Unless the Itype is for a record type with a corresponding remote 5855 -- type (what is that about, it was not commented ???) 5856 5857 if Ekind_In (Def_Id, E_Discriminant, E_Component) 5858 or else 5859 ((not Is_Record_Type (Def_Id) 5860 or else No (Corresponding_Remote_Type (Def_Id))) 5861 and then not Is_Itype (Def_Id)) 5862 then 5863 Set_Is_Immediately_Visible (Def_Id); 5864 Set_Current_Entity (Def_Id); 5865 end if; 5866 5867 Set_Homonym (Def_Id, C); 5868 Append_Entity (Def_Id, S); 5869 Set_Public_Status (Def_Id); 5870 5871 -- Declaring a homonym is not allowed in SPARK ... 5872 5873 if Present (C) and then Restriction_Check_Required (SPARK_05) then 5874 declare 5875 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 5876 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 5877 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 5878 5879 begin 5880 -- ... unless the new declaration is in a subprogram, and the 5881 -- visible declaration is a variable declaration or a parameter 5882 -- specification outside that subprogram. 5883 5884 if Present (Enclosing_Subp) 5885 and then Nkind_In (Parent (C), N_Object_Declaration, 5886 N_Parameter_Specification) 5887 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 5888 then 5889 null; 5890 5891 -- ... or the new declaration is in a package, and the visible 5892 -- declaration occurs outside that package. 5893 5894 elsif Present (Enclosing_Pack) 5895 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 5896 then 5897 null; 5898 5899 -- ... or the new declaration is a component declaration in a 5900 -- record type definition. 5901 5902 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 5903 null; 5904 5905 -- Don't issue error for non-source entities 5906 5907 elsif Comes_From_Source (Def_Id) 5908 and then Comes_From_Source (C) 5909 then 5910 Error_Msg_Sloc := Sloc (C); 5911 Check_SPARK_05_Restriction 5912 ("redeclaration of identifier &#", Def_Id); 5913 end if; 5914 end; 5915 end if; 5916 5917 -- Warn if new entity hides an old one 5918 5919 if Warn_On_Hiding and then Present (C) 5920 5921 -- Don't warn for record components since they always have a well 5922 -- defined scope which does not confuse other uses. Note that in 5923 -- some cases, Ekind has not been set yet. 5924 5925 and then Ekind (C) /= E_Component 5926 and then Ekind (C) /= E_Discriminant 5927 and then Nkind (Parent (C)) /= N_Component_Declaration 5928 and then Ekind (Def_Id) /= E_Component 5929 and then Ekind (Def_Id) /= E_Discriminant 5930 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 5931 5932 -- Don't warn for one character variables. It is too common to use 5933 -- such variables as locals and will just cause too many false hits. 5934 5935 and then Length_Of_Name (Chars (C)) /= 1 5936 5937 -- Don't warn for non-source entities 5938 5939 and then Comes_From_Source (C) 5940 and then Comes_From_Source (Def_Id) 5941 5942 -- Don't warn unless entity in question is in extended main source 5943 5944 and then In_Extended_Main_Source_Unit (Def_Id) 5945 5946 -- Finally, the hidden entity must be either immediately visible or 5947 -- use visible (i.e. from a used package). 5948 5949 and then 5950 (Is_Immediately_Visible (C) 5951 or else 5952 Is_Potentially_Use_Visible (C)) 5953 then 5954 Error_Msg_Sloc := Sloc (C); 5955 Error_Msg_N ("declaration hides &#?h?", Def_Id); 5956 end if; 5957 end Enter_Name; 5958 5959 --------------- 5960 -- Entity_Of -- 5961 --------------- 5962 5963 function Entity_Of (N : Node_Id) return Entity_Id is 5964 Id : Entity_Id; 5965 5966 begin 5967 Id := Empty; 5968 5969 if Is_Entity_Name (N) then 5970 Id := Entity (N); 5971 5972 -- Follow a possible chain of renamings to reach the root renamed 5973 -- object. 5974 5975 while Present (Id) and then Present (Renamed_Object (Id)) loop 5976 if Is_Entity_Name (Renamed_Object (Id)) then 5977 Id := Entity (Renamed_Object (Id)); 5978 else 5979 Id := Empty; 5980 exit; 5981 end if; 5982 end loop; 5983 end if; 5984 5985 return Id; 5986 end Entity_Of; 5987 5988 -------------------------- 5989 -- Explain_Limited_Type -- 5990 -------------------------- 5991 5992 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 5993 C : Entity_Id; 5994 5995 begin 5996 -- For array, component type must be limited 5997 5998 if Is_Array_Type (T) then 5999 Error_Msg_Node_2 := T; 6000 Error_Msg_NE 6001 ("\component type& of type& is limited", N, Component_Type (T)); 6002 Explain_Limited_Type (Component_Type (T), N); 6003 6004 elsif Is_Record_Type (T) then 6005 6006 -- No need for extra messages if explicit limited record 6007 6008 if Is_Limited_Record (Base_Type (T)) then 6009 return; 6010 end if; 6011 6012 -- Otherwise find a limited component. Check only components that 6013 -- come from source, or inherited components that appear in the 6014 -- source of the ancestor. 6015 6016 C := First_Component (T); 6017 while Present (C) loop 6018 if Is_Limited_Type (Etype (C)) 6019 and then 6020 (Comes_From_Source (C) 6021 or else 6022 (Present (Original_Record_Component (C)) 6023 and then 6024 Comes_From_Source (Original_Record_Component (C)))) 6025 then 6026 Error_Msg_Node_2 := T; 6027 Error_Msg_NE ("\component& of type& has limited type", N, C); 6028 Explain_Limited_Type (Etype (C), N); 6029 return; 6030 end if; 6031 6032 Next_Component (C); 6033 end loop; 6034 6035 -- The type may be declared explicitly limited, even if no component 6036 -- of it is limited, in which case we fall out of the loop. 6037 return; 6038 end if; 6039 end Explain_Limited_Type; 6040 6041 ------------------------------- 6042 -- Extensions_Visible_Status -- 6043 ------------------------------- 6044 6045 function Extensions_Visible_Status 6046 (Id : Entity_Id) return Extensions_Visible_Mode 6047 is 6048 Arg : Node_Id; 6049 Decl : Node_Id; 6050 Expr : Node_Id; 6051 Prag : Node_Id; 6052 Subp : Entity_Id; 6053 6054 begin 6055 -- When a formal parameter is subject to Extensions_Visible, the pragma 6056 -- is stored in the contract of related subprogram. 6057 6058 if Is_Formal (Id) then 6059 Subp := Scope (Id); 6060 6061 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 6062 Subp := Id; 6063 6064 -- No other construct carries this pragma 6065 6066 else 6067 return Extensions_Visible_None; 6068 end if; 6069 6070 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 6071 6072 -- In certain cases analysis may request the Extensions_Visible status 6073 -- of an expression function before the pragma has been analyzed yet. 6074 -- Inspect the declarative items after the expression function looking 6075 -- for the pragma (if any). 6076 6077 if No (Prag) and then Is_Expression_Function (Subp) then 6078 Decl := Next (Unit_Declaration_Node (Subp)); 6079 while Present (Decl) loop 6080 if Nkind (Decl) = N_Pragma 6081 and then Pragma_Name (Decl) = Name_Extensions_Visible 6082 then 6083 Prag := Decl; 6084 exit; 6085 6086 -- A source construct ends the region where Extensions_Visible may 6087 -- appear, stop the traversal. An expanded expression function is 6088 -- no longer a source construct, but it must still be recognized. 6089 6090 elsif Comes_From_Source (Decl) 6091 or else 6092 (Nkind_In (Decl, N_Subprogram_Body, 6093 N_Subprogram_Declaration) 6094 and then Is_Expression_Function (Defining_Entity (Decl))) 6095 then 6096 exit; 6097 end if; 6098 6099 Next (Decl); 6100 end loop; 6101 end if; 6102 6103 -- Extract the value from the Boolean expression (if any) 6104 6105 if Present (Prag) then 6106 Arg := First (Pragma_Argument_Associations (Prag)); 6107 6108 if Present (Arg) then 6109 Expr := Get_Pragma_Arg (Arg); 6110 6111 -- When the associated subprogram is an expression function, the 6112 -- argument of the pragma may not have been analyzed. 6113 6114 if not Analyzed (Expr) then 6115 Preanalyze_And_Resolve (Expr, Standard_Boolean); 6116 end if; 6117 6118 -- Guard against cascading errors when the argument of pragma 6119 -- Extensions_Visible is not a valid static Boolean expression. 6120 6121 if Error_Posted (Expr) then 6122 return Extensions_Visible_None; 6123 6124 elsif Is_True (Expr_Value (Expr)) then 6125 return Extensions_Visible_True; 6126 6127 else 6128 return Extensions_Visible_False; 6129 end if; 6130 6131 -- Otherwise the aspect or pragma defaults to True 6132 6133 else 6134 return Extensions_Visible_True; 6135 end if; 6136 6137 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 6138 -- directly specified. In SPARK code, its value defaults to "False". 6139 6140 elsif SPARK_Mode = On then 6141 return Extensions_Visible_False; 6142 6143 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 6144 -- "True". 6145 6146 else 6147 return Extensions_Visible_True; 6148 end if; 6149 end Extensions_Visible_Status; 6150 6151 ----------------- 6152 -- Find_Actual -- 6153 ----------------- 6154 6155 procedure Find_Actual 6156 (N : Node_Id; 6157 Formal : out Entity_Id; 6158 Call : out Node_Id) 6159 is 6160 Parnt : constant Node_Id := Parent (N); 6161 Actual : Node_Id; 6162 6163 begin 6164 if Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component) 6165 and then N = Prefix (Parnt) 6166 then 6167 Find_Actual (Parnt, Formal, Call); 6168 return; 6169 6170 elsif Nkind (Parnt) = N_Parameter_Association 6171 and then N = Explicit_Actual_Parameter (Parnt) 6172 then 6173 Call := Parent (Parnt); 6174 6175 elsif Nkind (Parnt) in N_Subprogram_Call then 6176 Call := Parnt; 6177 6178 else 6179 Formal := Empty; 6180 Call := Empty; 6181 return; 6182 end if; 6183 6184 -- If we have a call to a subprogram look for the parameter. Note that 6185 -- we exclude overloaded calls, since we don't know enough to be sure 6186 -- of giving the right answer in this case. 6187 6188 if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) 6189 and then Is_Entity_Name (Name (Call)) 6190 and then Present (Entity (Name (Call))) 6191 and then Is_Overloadable (Entity (Name (Call))) 6192 and then not Is_Overloaded (Name (Call)) 6193 then 6194 -- If node is name in call it is not an actual 6195 6196 if N = Name (Call) then 6197 Call := Empty; 6198 Formal := Empty; 6199 return; 6200 end if; 6201 6202 -- Fall here if we are definitely a parameter 6203 6204 Actual := First_Actual (Call); 6205 Formal := First_Formal (Entity (Name (Call))); 6206 while Present (Formal) and then Present (Actual) loop 6207 if Actual = N then 6208 return; 6209 6210 -- An actual that is the prefix in a prefixed call may have 6211 -- been rewritten in the call, after the deferred reference 6212 -- was collected. Check if sloc and kinds and names match. 6213 6214 elsif Sloc (Actual) = Sloc (N) 6215 and then Nkind (Actual) = N_Identifier 6216 and then Nkind (Actual) = Nkind (N) 6217 and then Chars (Actual) = Chars (N) 6218 then 6219 return; 6220 6221 else 6222 Actual := Next_Actual (Actual); 6223 Formal := Next_Formal (Formal); 6224 end if; 6225 end loop; 6226 end if; 6227 6228 -- Fall through here if we did not find matching actual 6229 6230 Formal := Empty; 6231 Call := Empty; 6232 end Find_Actual; 6233 6234 --------------------------- 6235 -- Find_Body_Discriminal -- 6236 --------------------------- 6237 6238 function Find_Body_Discriminal 6239 (Spec_Discriminant : Entity_Id) return Entity_Id 6240 is 6241 Tsk : Entity_Id; 6242 Disc : Entity_Id; 6243 6244 begin 6245 -- If expansion is suppressed, then the scope can be the concurrent type 6246 -- itself rather than a corresponding concurrent record type. 6247 6248 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 6249 Tsk := Scope (Spec_Discriminant); 6250 6251 else 6252 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 6253 6254 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 6255 end if; 6256 6257 -- Find discriminant of original concurrent type, and use its current 6258 -- discriminal, which is the renaming within the task/protected body. 6259 6260 Disc := First_Discriminant (Tsk); 6261 while Present (Disc) loop 6262 if Chars (Disc) = Chars (Spec_Discriminant) then 6263 return Discriminal (Disc); 6264 end if; 6265 6266 Next_Discriminant (Disc); 6267 end loop; 6268 6269 -- That loop should always succeed in finding a matching entry and 6270 -- returning. Fatal error if not. 6271 6272 raise Program_Error; 6273 end Find_Body_Discriminal; 6274 6275 ------------------------------------- 6276 -- Find_Corresponding_Discriminant -- 6277 ------------------------------------- 6278 6279 function Find_Corresponding_Discriminant 6280 (Id : Node_Id; 6281 Typ : Entity_Id) return Entity_Id 6282 is 6283 Par_Disc : Entity_Id; 6284 Old_Disc : Entity_Id; 6285 New_Disc : Entity_Id; 6286 6287 begin 6288 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 6289 6290 -- The original type may currently be private, and the discriminant 6291 -- only appear on its full view. 6292 6293 if Is_Private_Type (Scope (Par_Disc)) 6294 and then not Has_Discriminants (Scope (Par_Disc)) 6295 and then Present (Full_View (Scope (Par_Disc))) 6296 then 6297 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 6298 else 6299 Old_Disc := First_Discriminant (Scope (Par_Disc)); 6300 end if; 6301 6302 if Is_Class_Wide_Type (Typ) then 6303 New_Disc := First_Discriminant (Root_Type (Typ)); 6304 else 6305 New_Disc := First_Discriminant (Typ); 6306 end if; 6307 6308 while Present (Old_Disc) and then Present (New_Disc) loop 6309 if Old_Disc = Par_Disc then 6310 return New_Disc; 6311 end if; 6312 6313 Next_Discriminant (Old_Disc); 6314 Next_Discriminant (New_Disc); 6315 end loop; 6316 6317 -- Should always find it 6318 6319 raise Program_Error; 6320 end Find_Corresponding_Discriminant; 6321 6322 ---------------------------------- 6323 -- Find_Enclosing_Iterator_Loop -- 6324 ---------------------------------- 6325 6326 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 6327 Constr : Node_Id; 6328 S : Entity_Id; 6329 6330 begin 6331 -- Traverse the scope chain looking for an iterator loop. Such loops are 6332 -- usually transformed into blocks, hence the use of Original_Node. 6333 6334 S := Id; 6335 while Present (S) and then S /= Standard_Standard loop 6336 if Ekind (S) = E_Loop 6337 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 6338 then 6339 Constr := Original_Node (Label_Construct (Parent (S))); 6340 6341 if Nkind (Constr) = N_Loop_Statement 6342 and then Present (Iteration_Scheme (Constr)) 6343 and then Nkind (Iterator_Specification 6344 (Iteration_Scheme (Constr))) = 6345 N_Iterator_Specification 6346 then 6347 return S; 6348 end if; 6349 end if; 6350 6351 S := Scope (S); 6352 end loop; 6353 6354 return Empty; 6355 end Find_Enclosing_Iterator_Loop; 6356 6357 ------------------------------------ 6358 -- Find_Loop_In_Conditional_Block -- 6359 ------------------------------------ 6360 6361 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 6362 Stmt : Node_Id; 6363 6364 begin 6365 Stmt := N; 6366 6367 if Nkind (Stmt) = N_If_Statement then 6368 Stmt := First (Then_Statements (Stmt)); 6369 end if; 6370 6371 pragma Assert (Nkind (Stmt) = N_Block_Statement); 6372 6373 -- Inspect the statements of the conditional block. In general the loop 6374 -- should be the first statement in the statement sequence of the block, 6375 -- but the finalization machinery may have introduced extra object 6376 -- declarations. 6377 6378 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 6379 while Present (Stmt) loop 6380 if Nkind (Stmt) = N_Loop_Statement then 6381 return Stmt; 6382 end if; 6383 6384 Next (Stmt); 6385 end loop; 6386 6387 -- The expansion of attribute 'Loop_Entry produced a malformed block 6388 6389 raise Program_Error; 6390 end Find_Loop_In_Conditional_Block; 6391 6392 -------------------------- 6393 -- Find_Overlaid_Entity -- 6394 -------------------------- 6395 6396 procedure Find_Overlaid_Entity 6397 (N : Node_Id; 6398 Ent : out Entity_Id; 6399 Off : out Boolean) 6400 is 6401 Expr : Node_Id; 6402 6403 begin 6404 -- We are looking for one of the two following forms: 6405 6406 -- for X'Address use Y'Address 6407 6408 -- or 6409 6410 -- Const : constant Address := expr; 6411 -- ... 6412 -- for X'Address use Const; 6413 6414 -- In the second case, the expr is either Y'Address, or recursively a 6415 -- constant that eventually references Y'Address. 6416 6417 Ent := Empty; 6418 Off := False; 6419 6420 if Nkind (N) = N_Attribute_Definition_Clause 6421 and then Chars (N) = Name_Address 6422 then 6423 Expr := Expression (N); 6424 6425 -- This loop checks the form of the expression for Y'Address, 6426 -- using recursion to deal with intermediate constants. 6427 6428 loop 6429 -- Check for Y'Address 6430 6431 if Nkind (Expr) = N_Attribute_Reference 6432 and then Attribute_Name (Expr) = Name_Address 6433 then 6434 Expr := Prefix (Expr); 6435 exit; 6436 6437 -- Check for Const where Const is a constant entity 6438 6439 elsif Is_Entity_Name (Expr) 6440 and then Ekind (Entity (Expr)) = E_Constant 6441 then 6442 Expr := Constant_Value (Entity (Expr)); 6443 6444 -- Anything else does not need checking 6445 6446 else 6447 return; 6448 end if; 6449 end loop; 6450 6451 -- This loop checks the form of the prefix for an entity, using 6452 -- recursion to deal with intermediate components. 6453 6454 loop 6455 -- Check for Y where Y is an entity 6456 6457 if Is_Entity_Name (Expr) then 6458 Ent := Entity (Expr); 6459 return; 6460 6461 -- Check for components 6462 6463 elsif 6464 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 6465 then 6466 Expr := Prefix (Expr); 6467 Off := True; 6468 6469 -- Anything else does not need checking 6470 6471 else 6472 return; 6473 end if; 6474 end loop; 6475 end if; 6476 end Find_Overlaid_Entity; 6477 6478 ------------------------- 6479 -- Find_Parameter_Type -- 6480 ------------------------- 6481 6482 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 6483 begin 6484 if Nkind (Param) /= N_Parameter_Specification then 6485 return Empty; 6486 6487 -- For an access parameter, obtain the type from the formal entity 6488 -- itself, because access to subprogram nodes do not carry a type. 6489 -- Shouldn't we always use the formal entity ??? 6490 6491 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 6492 return Etype (Defining_Identifier (Param)); 6493 6494 else 6495 return Etype (Parameter_Type (Param)); 6496 end if; 6497 end Find_Parameter_Type; 6498 6499 ----------------------------------- 6500 -- Find_Placement_In_State_Space -- 6501 ----------------------------------- 6502 6503 procedure Find_Placement_In_State_Space 6504 (Item_Id : Entity_Id; 6505 Placement : out State_Space_Kind; 6506 Pack_Id : out Entity_Id) 6507 is 6508 Context : Entity_Id; 6509 6510 begin 6511 -- Assume that the item does not appear in the state space of a package 6512 6513 Placement := Not_In_Package; 6514 Pack_Id := Empty; 6515 6516 -- Climb the scope stack and examine the enclosing context 6517 6518 Context := Scope (Item_Id); 6519 while Present (Context) and then Context /= Standard_Standard loop 6520 if Ekind (Context) = E_Package then 6521 Pack_Id := Context; 6522 6523 -- A package body is a cut off point for the traversal as the item 6524 -- cannot be visible to the outside from this point on. Note that 6525 -- this test must be done first as a body is also classified as a 6526 -- private part. 6527 6528 if In_Package_Body (Context) then 6529 Placement := Body_State_Space; 6530 return; 6531 6532 -- The private part of a package is a cut off point for the 6533 -- traversal as the item cannot be visible to the outside from 6534 -- this point on. 6535 6536 elsif In_Private_Part (Context) then 6537 Placement := Private_State_Space; 6538 return; 6539 6540 -- When the item appears in the visible state space of a package, 6541 -- continue to climb the scope stack as this may not be the final 6542 -- state space. 6543 6544 else 6545 Placement := Visible_State_Space; 6546 6547 -- The visible state space of a child unit acts as the proper 6548 -- placement of an item. 6549 6550 if Is_Child_Unit (Context) then 6551 return; 6552 end if; 6553 end if; 6554 6555 -- The item or its enclosing package appear in a construct that has 6556 -- no state space. 6557 6558 else 6559 Placement := Not_In_Package; 6560 return; 6561 end if; 6562 6563 Context := Scope (Context); 6564 end loop; 6565 end Find_Placement_In_State_Space; 6566 6567 ------------------------ 6568 -- Find_Specific_Type -- 6569 ------------------------ 6570 6571 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 6572 Typ : Entity_Id := Root_Type (CW); 6573 6574 begin 6575 if Ekind (Typ) = E_Incomplete_Type then 6576 if From_Limited_With (Typ) then 6577 Typ := Non_Limited_View (Typ); 6578 else 6579 Typ := Full_View (Typ); 6580 end if; 6581 end if; 6582 6583 if Is_Private_Type (Typ) 6584 and then not Is_Tagged_Type (Typ) 6585 and then Present (Full_View (Typ)) 6586 then 6587 return Full_View (Typ); 6588 else 6589 return Typ; 6590 end if; 6591 end Find_Specific_Type; 6592 6593 ----------------------------- 6594 -- Find_Static_Alternative -- 6595 ----------------------------- 6596 6597 function Find_Static_Alternative (N : Node_Id) return Node_Id is 6598 Expr : constant Node_Id := Expression (N); 6599 Val : constant Uint := Expr_Value (Expr); 6600 Alt : Node_Id; 6601 Choice : Node_Id; 6602 6603 begin 6604 Alt := First (Alternatives (N)); 6605 6606 Search : loop 6607 if Nkind (Alt) /= N_Pragma then 6608 Choice := First (Discrete_Choices (Alt)); 6609 while Present (Choice) loop 6610 6611 -- Others choice, always matches 6612 6613 if Nkind (Choice) = N_Others_Choice then 6614 exit Search; 6615 6616 -- Range, check if value is in the range 6617 6618 elsif Nkind (Choice) = N_Range then 6619 exit Search when 6620 Val >= Expr_Value (Low_Bound (Choice)) 6621 and then 6622 Val <= Expr_Value (High_Bound (Choice)); 6623 6624 -- Choice is a subtype name. Note that we know it must 6625 -- be a static subtype, since otherwise it would have 6626 -- been diagnosed as illegal. 6627 6628 elsif Is_Entity_Name (Choice) 6629 and then Is_Type (Entity (Choice)) 6630 then 6631 exit Search when Is_In_Range (Expr, Etype (Choice), 6632 Assume_Valid => False); 6633 6634 -- Choice is a subtype indication 6635 6636 elsif Nkind (Choice) = N_Subtype_Indication then 6637 declare 6638 C : constant Node_Id := Constraint (Choice); 6639 R : constant Node_Id := Range_Expression (C); 6640 6641 begin 6642 exit Search when 6643 Val >= Expr_Value (Low_Bound (R)) 6644 and then 6645 Val <= Expr_Value (High_Bound (R)); 6646 end; 6647 6648 -- Choice is a simple expression 6649 6650 else 6651 exit Search when Val = Expr_Value (Choice); 6652 end if; 6653 6654 Next (Choice); 6655 end loop; 6656 end if; 6657 6658 Next (Alt); 6659 pragma Assert (Present (Alt)); 6660 end loop Search; 6661 6662 -- The above loop *must* terminate by finding a match, since 6663 -- we know the case statement is valid, and the value of the 6664 -- expression is known at compile time. When we fall out of 6665 -- the loop, Alt points to the alternative that we know will 6666 -- be selected at run time. 6667 6668 return Alt; 6669 end Find_Static_Alternative; 6670 6671 ------------------ 6672 -- First_Actual -- 6673 ------------------ 6674 6675 function First_Actual (Node : Node_Id) return Node_Id is 6676 N : Node_Id; 6677 6678 begin 6679 if No (Parameter_Associations (Node)) then 6680 return Empty; 6681 end if; 6682 6683 N := First (Parameter_Associations (Node)); 6684 6685 if Nkind (N) = N_Parameter_Association then 6686 return First_Named_Actual (Node); 6687 else 6688 return N; 6689 end if; 6690 end First_Actual; 6691 6692 ----------------------- 6693 -- Gather_Components -- 6694 ----------------------- 6695 6696 procedure Gather_Components 6697 (Typ : Entity_Id; 6698 Comp_List : Node_Id; 6699 Governed_By : List_Id; 6700 Into : Elist_Id; 6701 Report_Errors : out Boolean) 6702 is 6703 Assoc : Node_Id; 6704 Variant : Node_Id; 6705 Discrete_Choice : Node_Id; 6706 Comp_Item : Node_Id; 6707 6708 Discrim : Entity_Id; 6709 Discrim_Name : Node_Id; 6710 Discrim_Value : Node_Id; 6711 6712 begin 6713 Report_Errors := False; 6714 6715 if No (Comp_List) or else Null_Present (Comp_List) then 6716 return; 6717 6718 elsif Present (Component_Items (Comp_List)) then 6719 Comp_Item := First (Component_Items (Comp_List)); 6720 6721 else 6722 Comp_Item := Empty; 6723 end if; 6724 6725 while Present (Comp_Item) loop 6726 6727 -- Skip the tag of a tagged record, the interface tags, as well 6728 -- as all items that are not user components (anonymous types, 6729 -- rep clauses, Parent field, controller field). 6730 6731 if Nkind (Comp_Item) = N_Component_Declaration then 6732 declare 6733 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 6734 begin 6735 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then 6736 Append_Elmt (Comp, Into); 6737 end if; 6738 end; 6739 end if; 6740 6741 Next (Comp_Item); 6742 end loop; 6743 6744 if No (Variant_Part (Comp_List)) then 6745 return; 6746 else 6747 Discrim_Name := Name (Variant_Part (Comp_List)); 6748 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 6749 end if; 6750 6751 -- Look for the discriminant that governs this variant part. 6752 -- The discriminant *must* be in the Governed_By List 6753 6754 Assoc := First (Governed_By); 6755 Find_Constraint : loop 6756 Discrim := First (Choices (Assoc)); 6757 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) 6758 or else (Present (Corresponding_Discriminant (Entity (Discrim))) 6759 and then 6760 Chars (Corresponding_Discriminant (Entity (Discrim))) = 6761 Chars (Discrim_Name)) 6762 or else Chars (Original_Record_Component (Entity (Discrim))) 6763 = Chars (Discrim_Name); 6764 6765 if No (Next (Assoc)) then 6766 if not Is_Constrained (Typ) 6767 and then Is_Derived_Type (Typ) 6768 and then Present (Stored_Constraint (Typ)) 6769 then 6770 -- If the type is a tagged type with inherited discriminants, 6771 -- use the stored constraint on the parent in order to find 6772 -- the values of discriminants that are otherwise hidden by an 6773 -- explicit constraint. Renamed discriminants are handled in 6774 -- the code above. 6775 6776 -- If several parent discriminants are renamed by a single 6777 -- discriminant of the derived type, the call to obtain the 6778 -- Corresponding_Discriminant field only retrieves the last 6779 -- of them. We recover the constraint on the others from the 6780 -- Stored_Constraint as well. 6781 6782 declare 6783 D : Entity_Id; 6784 C : Elmt_Id; 6785 6786 begin 6787 D := First_Discriminant (Etype (Typ)); 6788 C := First_Elmt (Stored_Constraint (Typ)); 6789 while Present (D) and then Present (C) loop 6790 if Chars (Discrim_Name) = Chars (D) then 6791 if Is_Entity_Name (Node (C)) 6792 and then Entity (Node (C)) = Entity (Discrim) 6793 then 6794 -- D is renamed by Discrim, whose value is given in 6795 -- Assoc. 6796 6797 null; 6798 6799 else 6800 Assoc := 6801 Make_Component_Association (Sloc (Typ), 6802 New_List 6803 (New_Occurrence_Of (D, Sloc (Typ))), 6804 Duplicate_Subexpr_No_Checks (Node (C))); 6805 end if; 6806 exit Find_Constraint; 6807 end if; 6808 6809 Next_Discriminant (D); 6810 Next_Elmt (C); 6811 end loop; 6812 end; 6813 end if; 6814 end if; 6815 6816 if No (Next (Assoc)) then 6817 Error_Msg_NE (" missing value for discriminant&", 6818 First (Governed_By), Discrim_Name); 6819 Report_Errors := True; 6820 return; 6821 end if; 6822 6823 Next (Assoc); 6824 end loop Find_Constraint; 6825 6826 Discrim_Value := Expression (Assoc); 6827 6828 if not Is_OK_Static_Expression (Discrim_Value) then 6829 6830 -- If the variant part is governed by a discriminant of the type 6831 -- this is an error. If the variant part and the discriminant are 6832 -- inherited from an ancestor this is legal (AI05-120) unless the 6833 -- components are being gathered for an aggregate, in which case 6834 -- the caller must check Report_Errors. 6835 6836 if Scope (Original_Record_Component 6837 ((Entity (First (Choices (Assoc)))))) = Typ 6838 then 6839 Error_Msg_FE 6840 ("value for discriminant & must be static!", 6841 Discrim_Value, Discrim); 6842 Why_Not_Static (Discrim_Value); 6843 end if; 6844 6845 Report_Errors := True; 6846 return; 6847 end if; 6848 6849 Search_For_Discriminant_Value : declare 6850 Low : Node_Id; 6851 High : Node_Id; 6852 6853 UI_High : Uint; 6854 UI_Low : Uint; 6855 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 6856 6857 begin 6858 Find_Discrete_Value : while Present (Variant) loop 6859 Discrete_Choice := First (Discrete_Choices (Variant)); 6860 while Present (Discrete_Choice) loop 6861 exit Find_Discrete_Value when 6862 Nkind (Discrete_Choice) = N_Others_Choice; 6863 6864 Get_Index_Bounds (Discrete_Choice, Low, High); 6865 6866 UI_Low := Expr_Value (Low); 6867 UI_High := Expr_Value (High); 6868 6869 exit Find_Discrete_Value when 6870 UI_Low <= UI_Discrim_Value 6871 and then 6872 UI_High >= UI_Discrim_Value; 6873 6874 Next (Discrete_Choice); 6875 end loop; 6876 6877 Next_Non_Pragma (Variant); 6878 end loop Find_Discrete_Value; 6879 end Search_For_Discriminant_Value; 6880 6881 if No (Variant) then 6882 Error_Msg_NE 6883 ("value of discriminant & is out of range", Discrim_Value, Discrim); 6884 Report_Errors := True; 6885 return; 6886 end if; 6887 6888 -- If we have found the corresponding choice, recursively add its 6889 -- components to the Into list. 6890 6891 Gather_Components 6892 (Empty, Component_List (Variant), Governed_By, Into, Report_Errors); 6893 end Gather_Components; 6894 6895 ------------------------ 6896 -- Get_Actual_Subtype -- 6897 ------------------------ 6898 6899 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 6900 Typ : constant Entity_Id := Etype (N); 6901 Utyp : Entity_Id := Underlying_Type (Typ); 6902 Decl : Node_Id; 6903 Atyp : Entity_Id; 6904 6905 begin 6906 if No (Utyp) then 6907 Utyp := Typ; 6908 end if; 6909 6910 -- If what we have is an identifier that references a subprogram 6911 -- formal, or a variable or constant object, then we get the actual 6912 -- subtype from the referenced entity if one has been built. 6913 6914 if Nkind (N) = N_Identifier 6915 and then 6916 (Is_Formal (Entity (N)) 6917 or else Ekind (Entity (N)) = E_Constant 6918 or else Ekind (Entity (N)) = E_Variable) 6919 and then Present (Actual_Subtype (Entity (N))) 6920 then 6921 return Actual_Subtype (Entity (N)); 6922 6923 -- Actual subtype of unchecked union is always itself. We never need 6924 -- the "real" actual subtype. If we did, we couldn't get it anyway 6925 -- because the discriminant is not available. The restrictions on 6926 -- Unchecked_Union are designed to make sure that this is OK. 6927 6928 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 6929 return Typ; 6930 6931 -- Here for the unconstrained case, we must find actual subtype 6932 -- No actual subtype is available, so we must build it on the fly. 6933 6934 -- Checking the type, not the underlying type, for constrainedness 6935 -- seems to be necessary. Maybe all the tests should be on the type??? 6936 6937 elsif (not Is_Constrained (Typ)) 6938 and then (Is_Array_Type (Utyp) 6939 or else (Is_Record_Type (Utyp) 6940 and then Has_Discriminants (Utyp))) 6941 and then not Has_Unknown_Discriminants (Utyp) 6942 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 6943 then 6944 -- Nothing to do if in spec expression (why not???) 6945 6946 if In_Spec_Expression then 6947 return Typ; 6948 6949 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 6950 6951 -- If the type has no discriminants, there is no subtype to 6952 -- build, even if the underlying type is discriminated. 6953 6954 return Typ; 6955 6956 -- Else build the actual subtype 6957 6958 else 6959 Decl := Build_Actual_Subtype (Typ, N); 6960 Atyp := Defining_Identifier (Decl); 6961 6962 -- If Build_Actual_Subtype generated a new declaration then use it 6963 6964 if Atyp /= Typ then 6965 6966 -- The actual subtype is an Itype, so analyze the declaration, 6967 -- but do not attach it to the tree, to get the type defined. 6968 6969 Set_Parent (Decl, N); 6970 Set_Is_Itype (Atyp); 6971 Analyze (Decl, Suppress => All_Checks); 6972 Set_Associated_Node_For_Itype (Atyp, N); 6973 Set_Has_Delayed_Freeze (Atyp, False); 6974 6975 -- We need to freeze the actual subtype immediately. This is 6976 -- needed, because otherwise this Itype will not get frozen 6977 -- at all, and it is always safe to freeze on creation because 6978 -- any associated types must be frozen at this point. 6979 6980 Freeze_Itype (Atyp, N); 6981 return Atyp; 6982 6983 -- Otherwise we did not build a declaration, so return original 6984 6985 else 6986 return Typ; 6987 end if; 6988 end if; 6989 6990 -- For all remaining cases, the actual subtype is the same as 6991 -- the nominal type. 6992 6993 else 6994 return Typ; 6995 end if; 6996 end Get_Actual_Subtype; 6997 6998 ------------------------------------- 6999 -- Get_Actual_Subtype_If_Available -- 7000 ------------------------------------- 7001 7002 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 7003 Typ : constant Entity_Id := Etype (N); 7004 7005 begin 7006 -- If what we have is an identifier that references a subprogram 7007 -- formal, or a variable or constant object, then we get the actual 7008 -- subtype from the referenced entity if one has been built. 7009 7010 if Nkind (N) = N_Identifier 7011 and then 7012 (Is_Formal (Entity (N)) 7013 or else Ekind (Entity (N)) = E_Constant 7014 or else Ekind (Entity (N)) = E_Variable) 7015 and then Present (Actual_Subtype (Entity (N))) 7016 then 7017 return Actual_Subtype (Entity (N)); 7018 7019 -- Otherwise the Etype of N is returned unchanged 7020 7021 else 7022 return Typ; 7023 end if; 7024 end Get_Actual_Subtype_If_Available; 7025 7026 ------------------------ 7027 -- Get_Body_From_Stub -- 7028 ------------------------ 7029 7030 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 7031 begin 7032 return Proper_Body (Unit (Library_Unit (N))); 7033 end Get_Body_From_Stub; 7034 7035 --------------------- 7036 -- Get_Cursor_Type -- 7037 --------------------- 7038 7039 function Get_Cursor_Type 7040 (Aspect : Node_Id; 7041 Typ : Entity_Id) return Entity_Id 7042 is 7043 Assoc : Node_Id; 7044 Func : Entity_Id; 7045 First_Op : Entity_Id; 7046 Cursor : Entity_Id; 7047 7048 begin 7049 -- If error already detected, return 7050 7051 if Error_Posted (Aspect) then 7052 return Any_Type; 7053 end if; 7054 7055 -- The cursor type for an Iterable aspect is the return type of a 7056 -- non-overloaded First primitive operation. Locate association for 7057 -- First. 7058 7059 Assoc := First (Component_Associations (Expression (Aspect))); 7060 First_Op := Any_Id; 7061 while Present (Assoc) loop 7062 if Chars (First (Choices (Assoc))) = Name_First then 7063 First_Op := Expression (Assoc); 7064 exit; 7065 end if; 7066 7067 Next (Assoc); 7068 end loop; 7069 7070 if First_Op = Any_Id then 7071 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 7072 return Any_Type; 7073 end if; 7074 7075 Cursor := Any_Type; 7076 7077 -- Locate function with desired name and profile in scope of type 7078 7079 Func := First_Entity (Scope (Typ)); 7080 while Present (Func) loop 7081 if Chars (Func) = Chars (First_Op) 7082 and then Ekind (Func) = E_Function 7083 and then Present (First_Formal (Func)) 7084 and then Etype (First_Formal (Func)) = Typ 7085 and then No (Next_Formal (First_Formal (Func))) 7086 then 7087 if Cursor /= Any_Type then 7088 Error_Msg_N 7089 ("Operation First for iterable type must be unique", Aspect); 7090 return Any_Type; 7091 else 7092 Cursor := Etype (Func); 7093 end if; 7094 end if; 7095 7096 Next_Entity (Func); 7097 end loop; 7098 7099 -- If not found, no way to resolve remaining primitives. 7100 7101 if Cursor = Any_Type then 7102 Error_Msg_N 7103 ("No legal primitive operation First for Iterable type", Aspect); 7104 end if; 7105 7106 return Cursor; 7107 end Get_Cursor_Type; 7108 7109 ------------------------------- 7110 -- Get_Default_External_Name -- 7111 ------------------------------- 7112 7113 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 7114 begin 7115 Get_Decoded_Name_String (Chars (E)); 7116 7117 if Opt.External_Name_Imp_Casing = Uppercase then 7118 Set_Casing (All_Upper_Case); 7119 else 7120 Set_Casing (All_Lower_Case); 7121 end if; 7122 7123 return 7124 Make_String_Literal (Sloc (E), 7125 Strval => String_From_Name_Buffer); 7126 end Get_Default_External_Name; 7127 7128 -------------------------- 7129 -- Get_Enclosing_Object -- 7130 -------------------------- 7131 7132 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 7133 begin 7134 if Is_Entity_Name (N) then 7135 return Entity (N); 7136 else 7137 case Nkind (N) is 7138 when N_Indexed_Component | 7139 N_Slice | 7140 N_Selected_Component => 7141 7142 -- If not generating code, a dereference may be left implicit. 7143 -- In thoses cases, return Empty. 7144 7145 if Is_Access_Type (Etype (Prefix (N))) then 7146 return Empty; 7147 else 7148 return Get_Enclosing_Object (Prefix (N)); 7149 end if; 7150 7151 when N_Type_Conversion => 7152 return Get_Enclosing_Object (Expression (N)); 7153 7154 when others => 7155 return Empty; 7156 end case; 7157 end if; 7158 end Get_Enclosing_Object; 7159 7160 --------------------------- 7161 -- Get_Enum_Lit_From_Pos -- 7162 --------------------------- 7163 7164 function Get_Enum_Lit_From_Pos 7165 (T : Entity_Id; 7166 Pos : Uint; 7167 Loc : Source_Ptr) return Node_Id 7168 is 7169 Btyp : Entity_Id := Base_Type (T); 7170 Lit : Node_Id; 7171 7172 begin 7173 -- In the case where the literal is of type Character, Wide_Character 7174 -- or Wide_Wide_Character or of a type derived from them, there needs 7175 -- to be some special handling since there is no explicit chain of 7176 -- literals to search. Instead, an N_Character_Literal node is created 7177 -- with the appropriate Char_Code and Chars fields. 7178 7179 if Is_Standard_Character_Type (T) then 7180 Set_Character_Literal_Name (UI_To_CC (Pos)); 7181 return 7182 Make_Character_Literal (Loc, 7183 Chars => Name_Find, 7184 Char_Literal_Value => Pos); 7185 7186 -- For all other cases, we have a complete table of literals, and 7187 -- we simply iterate through the chain of literal until the one 7188 -- with the desired position value is found. 7189 7190 else 7191 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 7192 Btyp := Full_View (Btyp); 7193 end if; 7194 7195 Lit := First_Literal (Btyp); 7196 for J in 1 .. UI_To_Int (Pos) loop 7197 Next_Literal (Lit); 7198 end loop; 7199 7200 return New_Occurrence_Of (Lit, Loc); 7201 end if; 7202 end Get_Enum_Lit_From_Pos; 7203 7204 ------------------------ 7205 -- Get_Generic_Entity -- 7206 ------------------------ 7207 7208 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 7209 Ent : constant Entity_Id := Entity (Name (N)); 7210 begin 7211 if Present (Renamed_Object (Ent)) then 7212 return Renamed_Object (Ent); 7213 else 7214 return Ent; 7215 end if; 7216 end Get_Generic_Entity; 7217 7218 ------------------------------------- 7219 -- Get_Incomplete_View_Of_Ancestor -- 7220 ------------------------------------- 7221 7222 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 7223 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 7224 Par_Scope : Entity_Id; 7225 Par_Type : Entity_Id; 7226 7227 begin 7228 -- The incomplete view of an ancestor is only relevant for private 7229 -- derived types in child units. 7230 7231 if not Is_Derived_Type (E) 7232 or else not Is_Child_Unit (Cur_Unit) 7233 then 7234 return Empty; 7235 7236 else 7237 Par_Scope := Scope (Cur_Unit); 7238 if No (Par_Scope) then 7239 return Empty; 7240 end if; 7241 7242 Par_Type := Etype (Base_Type (E)); 7243 7244 -- Traverse list of ancestor types until we find one declared in 7245 -- a parent or grandparent unit (two levels seem sufficient). 7246 7247 while Present (Par_Type) loop 7248 if Scope (Par_Type) = Par_Scope 7249 or else Scope (Par_Type) = Scope (Par_Scope) 7250 then 7251 return Par_Type; 7252 7253 elsif not Is_Derived_Type (Par_Type) then 7254 return Empty; 7255 7256 else 7257 Par_Type := Etype (Base_Type (Par_Type)); 7258 end if; 7259 end loop; 7260 7261 -- If none found, there is no relevant ancestor type. 7262 7263 return Empty; 7264 end if; 7265 end Get_Incomplete_View_Of_Ancestor; 7266 7267 ---------------------- 7268 -- Get_Index_Bounds -- 7269 ---------------------- 7270 7271 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is 7272 Kind : constant Node_Kind := Nkind (N); 7273 R : Node_Id; 7274 7275 begin 7276 if Kind = N_Range then 7277 L := Low_Bound (N); 7278 H := High_Bound (N); 7279 7280 elsif Kind = N_Subtype_Indication then 7281 R := Range_Expression (Constraint (N)); 7282 7283 if R = Error then 7284 L := Error; 7285 H := Error; 7286 return; 7287 7288 else 7289 L := Low_Bound (Range_Expression (Constraint (N))); 7290 H := High_Bound (Range_Expression (Constraint (N))); 7291 end if; 7292 7293 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 7294 if Error_Posted (Scalar_Range (Entity (N))) then 7295 L := Error; 7296 H := Error; 7297 7298 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then 7299 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H); 7300 7301 else 7302 L := Low_Bound (Scalar_Range (Entity (N))); 7303 H := High_Bound (Scalar_Range (Entity (N))); 7304 end if; 7305 7306 else 7307 -- N is an expression, indicating a range with one value 7308 7309 L := N; 7310 H := N; 7311 end if; 7312 end Get_Index_Bounds; 7313 7314 --------------------------------- 7315 -- Get_Iterable_Type_Primitive -- 7316 --------------------------------- 7317 7318 function Get_Iterable_Type_Primitive 7319 (Typ : Entity_Id; 7320 Nam : Name_Id) return Entity_Id 7321 is 7322 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 7323 Assoc : Node_Id; 7324 7325 begin 7326 if No (Funcs) then 7327 return Empty; 7328 7329 else 7330 Assoc := First (Component_Associations (Funcs)); 7331 while Present (Assoc) loop 7332 if Chars (First (Choices (Assoc))) = Nam then 7333 return Entity (Expression (Assoc)); 7334 end if; 7335 7336 Assoc := Next (Assoc); 7337 end loop; 7338 7339 return Empty; 7340 end if; 7341 end Get_Iterable_Type_Primitive; 7342 7343 ---------------------------------- 7344 -- Get_Library_Unit_Name_string -- 7345 ---------------------------------- 7346 7347 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 7348 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 7349 7350 begin 7351 Get_Unit_Name_String (Unit_Name_Id); 7352 7353 -- Remove seven last character (" (spec)" or " (body)") 7354 7355 Name_Len := Name_Len - 7; 7356 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 7357 end Get_Library_Unit_Name_String; 7358 7359 ------------------------ 7360 -- Get_Name_Entity_Id -- 7361 ------------------------ 7362 7363 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 7364 begin 7365 return Entity_Id (Get_Name_Table_Int (Id)); 7366 end Get_Name_Entity_Id; 7367 7368 ------------------------------ 7369 -- Get_Name_From_CTC_Pragma -- 7370 ------------------------------ 7371 7372 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 7373 Arg : constant Node_Id := 7374 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 7375 begin 7376 return Strval (Expr_Value_S (Arg)); 7377 end Get_Name_From_CTC_Pragma; 7378 7379 ----------------------- 7380 -- Get_Parent_Entity -- 7381 ----------------------- 7382 7383 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 7384 begin 7385 if Nkind (Unit) = N_Package_Body 7386 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 7387 then 7388 return Defining_Entity 7389 (Specification (Instance_Spec (Original_Node (Unit)))); 7390 elsif Nkind (Unit) = N_Package_Instantiation then 7391 return Defining_Entity (Specification (Instance_Spec (Unit))); 7392 else 7393 return Defining_Entity (Unit); 7394 end if; 7395 end Get_Parent_Entity; 7396 ------------------- 7397 -- Get_Pragma_Id -- 7398 ------------------- 7399 7400 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 7401 begin 7402 return Get_Pragma_Id (Pragma_Name (N)); 7403 end Get_Pragma_Id; 7404 7405 ----------------------- 7406 -- Get_Reason_String -- 7407 ----------------------- 7408 7409 procedure Get_Reason_String (N : Node_Id) is 7410 begin 7411 if Nkind (N) = N_String_Literal then 7412 Store_String_Chars (Strval (N)); 7413 7414 elsif Nkind (N) = N_Op_Concat then 7415 Get_Reason_String (Left_Opnd (N)); 7416 Get_Reason_String (Right_Opnd (N)); 7417 7418 -- If not of required form, error 7419 7420 else 7421 Error_Msg_N 7422 ("Reason for pragma Warnings has wrong form", N); 7423 Error_Msg_N 7424 ("\must be string literal or concatenation of string literals", N); 7425 return; 7426 end if; 7427 end Get_Reason_String; 7428 7429 --------------------------- 7430 -- Get_Referenced_Object -- 7431 --------------------------- 7432 7433 function Get_Referenced_Object (N : Node_Id) return Node_Id is 7434 R : Node_Id; 7435 7436 begin 7437 R := N; 7438 while Is_Entity_Name (R) 7439 and then Present (Renamed_Object (Entity (R))) 7440 loop 7441 R := Renamed_Object (Entity (R)); 7442 end loop; 7443 7444 return R; 7445 end Get_Referenced_Object; 7446 7447 ------------------------ 7448 -- Get_Renamed_Entity -- 7449 ------------------------ 7450 7451 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 7452 R : Entity_Id; 7453 7454 begin 7455 R := E; 7456 while Present (Renamed_Entity (R)) loop 7457 R := Renamed_Entity (R); 7458 end loop; 7459 7460 return R; 7461 end Get_Renamed_Entity; 7462 7463 ------------------------- 7464 -- Get_Subprogram_Body -- 7465 ------------------------- 7466 7467 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is 7468 Decl : Node_Id; 7469 7470 begin 7471 Decl := Unit_Declaration_Node (E); 7472 7473 if Nkind (Decl) = N_Subprogram_Body then 7474 return Decl; 7475 7476 -- The below comment is bad, because it is possible for 7477 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ??? 7478 7479 else -- Nkind (Decl) = N_Subprogram_Declaration 7480 7481 if Present (Corresponding_Body (Decl)) then 7482 return Unit_Declaration_Node (Corresponding_Body (Decl)); 7483 7484 -- Imported subprogram case 7485 7486 else 7487 return Empty; 7488 end if; 7489 end if; 7490 end Get_Subprogram_Body; 7491 7492 --------------------------- 7493 -- Get_Subprogram_Entity -- 7494 --------------------------- 7495 7496 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 7497 Subp : Node_Id; 7498 Subp_Id : Entity_Id; 7499 7500 begin 7501 if Nkind (Nod) = N_Accept_Statement then 7502 Subp := Entry_Direct_Name (Nod); 7503 7504 elsif Nkind (Nod) = N_Slice then 7505 Subp := Prefix (Nod); 7506 7507 else 7508 Subp := Name (Nod); 7509 end if; 7510 7511 -- Strip the subprogram call 7512 7513 loop 7514 if Nkind_In (Subp, N_Explicit_Dereference, 7515 N_Indexed_Component, 7516 N_Selected_Component) 7517 then 7518 Subp := Prefix (Subp); 7519 7520 elsif Nkind_In (Subp, N_Type_Conversion, 7521 N_Unchecked_Type_Conversion) 7522 then 7523 Subp := Expression (Subp); 7524 7525 else 7526 exit; 7527 end if; 7528 end loop; 7529 7530 -- Extract the entity of the subprogram call 7531 7532 if Is_Entity_Name (Subp) then 7533 Subp_Id := Entity (Subp); 7534 7535 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 7536 Subp_Id := Directly_Designated_Type (Subp_Id); 7537 end if; 7538 7539 if Is_Subprogram (Subp_Id) then 7540 return Subp_Id; 7541 else 7542 return Empty; 7543 end if; 7544 7545 -- The search did not find a construct that denotes a subprogram 7546 7547 else 7548 return Empty; 7549 end if; 7550 end Get_Subprogram_Entity; 7551 7552 ----------------------------- 7553 -- Get_Task_Body_Procedure -- 7554 ----------------------------- 7555 7556 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is 7557 begin 7558 -- Note: A task type may be the completion of a private type with 7559 -- discriminants. When performing elaboration checks on a task 7560 -- declaration, the current view of the type may be the private one, 7561 -- and the procedure that holds the body of the task is held in its 7562 -- underlying type. 7563 7564 -- This is an odd function, why not have Task_Body_Procedure do 7565 -- the following digging??? 7566 7567 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 7568 end Get_Task_Body_Procedure; 7569 7570 ----------------------- 7571 -- Has_Access_Values -- 7572 ----------------------- 7573 7574 function Has_Access_Values (T : Entity_Id) return Boolean is 7575 Typ : constant Entity_Id := Underlying_Type (T); 7576 7577 begin 7578 -- Case of a private type which is not completed yet. This can only 7579 -- happen in the case of a generic format type appearing directly, or 7580 -- as a component of the type to which this function is being applied 7581 -- at the top level. Return False in this case, since we certainly do 7582 -- not know that the type contains access types. 7583 7584 if No (Typ) then 7585 return False; 7586 7587 elsif Is_Access_Type (Typ) then 7588 return True; 7589 7590 elsif Is_Array_Type (Typ) then 7591 return Has_Access_Values (Component_Type (Typ)); 7592 7593 elsif Is_Record_Type (Typ) then 7594 declare 7595 Comp : Entity_Id; 7596 7597 begin 7598 -- Loop to Check components 7599 7600 Comp := First_Component_Or_Discriminant (Typ); 7601 while Present (Comp) loop 7602 7603 -- Check for access component, tag field does not count, even 7604 -- though it is implemented internally using an access type. 7605 7606 if Has_Access_Values (Etype (Comp)) 7607 and then Chars (Comp) /= Name_uTag 7608 then 7609 return True; 7610 end if; 7611 7612 Next_Component_Or_Discriminant (Comp); 7613 end loop; 7614 end; 7615 7616 return False; 7617 7618 else 7619 return False; 7620 end if; 7621 end Has_Access_Values; 7622 7623 ------------------------------ 7624 -- Has_Compatible_Alignment -- 7625 ------------------------------ 7626 7627 function Has_Compatible_Alignment 7628 (Obj : Entity_Id; 7629 Expr : Node_Id) return Alignment_Result 7630 is 7631 function Has_Compatible_Alignment_Internal 7632 (Obj : Entity_Id; 7633 Expr : Node_Id; 7634 Default : Alignment_Result) return Alignment_Result; 7635 -- This is the internal recursive function that actually does the work. 7636 -- There is one additional parameter, which says what the result should 7637 -- be if no alignment information is found, and there is no definite 7638 -- indication of compatible alignments. At the outer level, this is set 7639 -- to Unknown, but for internal recursive calls in the case where types 7640 -- are known to be correct, it is set to Known_Compatible. 7641 7642 --------------------------------------- 7643 -- Has_Compatible_Alignment_Internal -- 7644 --------------------------------------- 7645 7646 function Has_Compatible_Alignment_Internal 7647 (Obj : Entity_Id; 7648 Expr : Node_Id; 7649 Default : Alignment_Result) return Alignment_Result 7650 is 7651 Result : Alignment_Result := Known_Compatible; 7652 -- Holds the current status of the result. Note that once a value of 7653 -- Known_Incompatible is set, it is sticky and does not get changed 7654 -- to Unknown (the value in Result only gets worse as we go along, 7655 -- never better). 7656 7657 Offs : Uint := No_Uint; 7658 -- Set to a factor of the offset from the base object when Expr is a 7659 -- selected or indexed component, based on Component_Bit_Offset and 7660 -- Component_Size respectively. A negative value is used to represent 7661 -- a value which is not known at compile time. 7662 7663 procedure Check_Prefix; 7664 -- Checks the prefix recursively in the case where the expression 7665 -- is an indexed or selected component. 7666 7667 procedure Set_Result (R : Alignment_Result); 7668 -- If R represents a worse outcome (unknown instead of known 7669 -- compatible, or known incompatible), then set Result to R. 7670 7671 ------------------ 7672 -- Check_Prefix -- 7673 ------------------ 7674 7675 procedure Check_Prefix is 7676 begin 7677 -- The subtlety here is that in doing a recursive call to check 7678 -- the prefix, we have to decide what to do in the case where we 7679 -- don't find any specific indication of an alignment problem. 7680 7681 -- At the outer level, we normally set Unknown as the result in 7682 -- this case, since we can only set Known_Compatible if we really 7683 -- know that the alignment value is OK, but for the recursive 7684 -- call, in the case where the types match, and we have not 7685 -- specified a peculiar alignment for the object, we are only 7686 -- concerned about suspicious rep clauses, the default case does 7687 -- not affect us, since the compiler will, in the absence of such 7688 -- rep clauses, ensure that the alignment is correct. 7689 7690 if Default = Known_Compatible 7691 or else 7692 (Etype (Obj) = Etype (Expr) 7693 and then (Unknown_Alignment (Obj) 7694 or else 7695 Alignment (Obj) = Alignment (Etype (Obj)))) 7696 then 7697 Set_Result 7698 (Has_Compatible_Alignment_Internal 7699 (Obj, Prefix (Expr), Known_Compatible)); 7700 7701 -- In all other cases, we need a full check on the prefix 7702 7703 else 7704 Set_Result 7705 (Has_Compatible_Alignment_Internal 7706 (Obj, Prefix (Expr), Unknown)); 7707 end if; 7708 end Check_Prefix; 7709 7710 ---------------- 7711 -- Set_Result -- 7712 ---------------- 7713 7714 procedure Set_Result (R : Alignment_Result) is 7715 begin 7716 if R > Result then 7717 Result := R; 7718 end if; 7719 end Set_Result; 7720 7721 -- Start of processing for Has_Compatible_Alignment_Internal 7722 7723 begin 7724 -- If Expr is a selected component, we must make sure there is no 7725 -- potentially troublesome component clause, and that the record is 7726 -- not packed. 7727 7728 if Nkind (Expr) = N_Selected_Component then 7729 7730 -- Packed record always generate unknown alignment 7731 7732 if Is_Packed (Etype (Prefix (Expr))) then 7733 Set_Result (Unknown); 7734 end if; 7735 7736 -- Check prefix and component offset 7737 7738 Check_Prefix; 7739 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 7740 7741 -- If Expr is an indexed component, we must make sure there is no 7742 -- potentially troublesome Component_Size clause and that the array 7743 -- is not bit-packed. 7744 7745 elsif Nkind (Expr) = N_Indexed_Component then 7746 declare 7747 Typ : constant Entity_Id := Etype (Prefix (Expr)); 7748 Ind : constant Node_Id := First_Index (Typ); 7749 7750 begin 7751 -- Bit packed array always generates unknown alignment 7752 7753 if Is_Bit_Packed_Array (Typ) then 7754 Set_Result (Unknown); 7755 end if; 7756 7757 -- Check prefix and component offset 7758 7759 Check_Prefix; 7760 Offs := Component_Size (Typ); 7761 7762 -- Small optimization: compute the full offset when possible 7763 7764 if Offs /= No_Uint 7765 and then Offs > Uint_0 7766 and then Present (Ind) 7767 and then Nkind (Ind) = N_Range 7768 and then Compile_Time_Known_Value (Low_Bound (Ind)) 7769 and then Compile_Time_Known_Value (First (Expressions (Expr))) 7770 then 7771 Offs := Offs * (Expr_Value (First (Expressions (Expr))) 7772 - Expr_Value (Low_Bound ((Ind)))); 7773 end if; 7774 end; 7775 end if; 7776 7777 -- If we have a null offset, the result is entirely determined by 7778 -- the base object and has already been computed recursively. 7779 7780 if Offs = Uint_0 then 7781 null; 7782 7783 -- Case where we know the alignment of the object 7784 7785 elsif Known_Alignment (Obj) then 7786 declare 7787 ObjA : constant Uint := Alignment (Obj); 7788 ExpA : Uint := No_Uint; 7789 SizA : Uint := No_Uint; 7790 7791 begin 7792 -- If alignment of Obj is 1, then we are always OK 7793 7794 if ObjA = 1 then 7795 Set_Result (Known_Compatible); 7796 7797 -- Alignment of Obj is greater than 1, so we need to check 7798 7799 else 7800 -- If we have an offset, see if it is compatible 7801 7802 if Offs /= No_Uint and Offs > Uint_0 then 7803 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 7804 Set_Result (Known_Incompatible); 7805 end if; 7806 7807 -- See if Expr is an object with known alignment 7808 7809 elsif Is_Entity_Name (Expr) 7810 and then Known_Alignment (Entity (Expr)) 7811 then 7812 ExpA := Alignment (Entity (Expr)); 7813 7814 -- Otherwise, we can use the alignment of the type of 7815 -- Expr given that we already checked for 7816 -- discombobulating rep clauses for the cases of indexed 7817 -- and selected components above. 7818 7819 elsif Known_Alignment (Etype (Expr)) then 7820 ExpA := Alignment (Etype (Expr)); 7821 7822 -- Otherwise the alignment is unknown 7823 7824 else 7825 Set_Result (Default); 7826 end if; 7827 7828 -- If we got an alignment, see if it is acceptable 7829 7830 if ExpA /= No_Uint and then ExpA < ObjA then 7831 Set_Result (Known_Incompatible); 7832 end if; 7833 7834 -- If Expr is not a piece of a larger object, see if size 7835 -- is given. If so, check that it is not too small for the 7836 -- required alignment. 7837 7838 if Offs /= No_Uint then 7839 null; 7840 7841 -- See if Expr is an object with known size 7842 7843 elsif Is_Entity_Name (Expr) 7844 and then Known_Static_Esize (Entity (Expr)) 7845 then 7846 SizA := Esize (Entity (Expr)); 7847 7848 -- Otherwise, we check the object size of the Expr type 7849 7850 elsif Known_Static_Esize (Etype (Expr)) then 7851 SizA := Esize (Etype (Expr)); 7852 end if; 7853 7854 -- If we got a size, see if it is a multiple of the Obj 7855 -- alignment, if not, then the alignment cannot be 7856 -- acceptable, since the size is always a multiple of the 7857 -- alignment. 7858 7859 if SizA /= No_Uint then 7860 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 7861 Set_Result (Known_Incompatible); 7862 end if; 7863 end if; 7864 end if; 7865 end; 7866 7867 -- If we do not know required alignment, any non-zero offset is a 7868 -- potential problem (but certainly may be OK, so result is unknown). 7869 7870 elsif Offs /= No_Uint then 7871 Set_Result (Unknown); 7872 7873 -- If we can't find the result by direct comparison of alignment 7874 -- values, then there is still one case that we can determine known 7875 -- result, and that is when we can determine that the types are the 7876 -- same, and no alignments are specified. Then we known that the 7877 -- alignments are compatible, even if we don't know the alignment 7878 -- value in the front end. 7879 7880 elsif Etype (Obj) = Etype (Expr) then 7881 7882 -- Types are the same, but we have to check for possible size 7883 -- and alignments on the Expr object that may make the alignment 7884 -- different, even though the types are the same. 7885 7886 if Is_Entity_Name (Expr) then 7887 7888 -- First check alignment of the Expr object. Any alignment less 7889 -- than Maximum_Alignment is worrisome since this is the case 7890 -- where we do not know the alignment of Obj. 7891 7892 if Known_Alignment (Entity (Expr)) 7893 and then UI_To_Int (Alignment (Entity (Expr))) < 7894 Ttypes.Maximum_Alignment 7895 then 7896 Set_Result (Unknown); 7897 7898 -- Now check size of Expr object. Any size that is not an 7899 -- even multiple of Maximum_Alignment is also worrisome 7900 -- since it may cause the alignment of the object to be less 7901 -- than the alignment of the type. 7902 7903 elsif Known_Static_Esize (Entity (Expr)) 7904 and then 7905 (UI_To_Int (Esize (Entity (Expr))) mod 7906 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 7907 /= 0 7908 then 7909 Set_Result (Unknown); 7910 7911 -- Otherwise same type is decisive 7912 7913 else 7914 Set_Result (Known_Compatible); 7915 end if; 7916 end if; 7917 7918 -- Another case to deal with is when there is an explicit size or 7919 -- alignment clause when the types are not the same. If so, then the 7920 -- result is Unknown. We don't need to do this test if the Default is 7921 -- Unknown, since that result will be set in any case. 7922 7923 elsif Default /= Unknown 7924 and then (Has_Size_Clause (Etype (Expr)) 7925 or else 7926 Has_Alignment_Clause (Etype (Expr))) 7927 then 7928 Set_Result (Unknown); 7929 7930 -- If no indication found, set default 7931 7932 else 7933 Set_Result (Default); 7934 end if; 7935 7936 -- Return worst result found 7937 7938 return Result; 7939 end Has_Compatible_Alignment_Internal; 7940 7941 -- Start of processing for Has_Compatible_Alignment 7942 7943 begin 7944 -- If Obj has no specified alignment, then set alignment from the type 7945 -- alignment. Perhaps we should always do this, but for sure we should 7946 -- do it when there is an address clause since we can do more if the 7947 -- alignment is known. 7948 7949 if Unknown_Alignment (Obj) then 7950 Set_Alignment (Obj, Alignment (Etype (Obj))); 7951 end if; 7952 7953 -- Now do the internal call that does all the work 7954 7955 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown); 7956 end Has_Compatible_Alignment; 7957 7958 ---------------------- 7959 -- Has_Declarations -- 7960 ---------------------- 7961 7962 function Has_Declarations (N : Node_Id) return Boolean is 7963 begin 7964 return Nkind_In (Nkind (N), N_Accept_Statement, 7965 N_Block_Statement, 7966 N_Compilation_Unit_Aux, 7967 N_Entry_Body, 7968 N_Package_Body, 7969 N_Protected_Body, 7970 N_Subprogram_Body, 7971 N_Task_Body, 7972 N_Package_Specification); 7973 end Has_Declarations; 7974 7975 --------------------------------- 7976 -- Has_Defaulted_Discriminants -- 7977 --------------------------------- 7978 7979 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 7980 begin 7981 return Has_Discriminants (Typ) 7982 and then Present (First_Discriminant (Typ)) 7983 and then Present (Discriminant_Default_Value 7984 (First_Discriminant (Typ))); 7985 end Has_Defaulted_Discriminants; 7986 7987 ------------------- 7988 -- Has_Denormals -- 7989 ------------------- 7990 7991 function Has_Denormals (E : Entity_Id) return Boolean is 7992 begin 7993 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 7994 end Has_Denormals; 7995 7996 ------------------------------------------- 7997 -- Has_Discriminant_Dependent_Constraint -- 7998 ------------------------------------------- 7999 8000 function Has_Discriminant_Dependent_Constraint 8001 (Comp : Entity_Id) return Boolean 8002 is 8003 Comp_Decl : constant Node_Id := Parent (Comp); 8004 Subt_Indic : Node_Id; 8005 Constr : Node_Id; 8006 Assn : Node_Id; 8007 8008 begin 8009 -- Discriminants can't depend on discriminants 8010 8011 if Ekind (Comp) = E_Discriminant then 8012 return False; 8013 8014 else 8015 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 8016 8017 if Nkind (Subt_Indic) = N_Subtype_Indication then 8018 Constr := Constraint (Subt_Indic); 8019 8020 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 8021 Assn := First (Constraints (Constr)); 8022 while Present (Assn) loop 8023 case Nkind (Assn) is 8024 when N_Subtype_Indication | 8025 N_Range | 8026 N_Identifier 8027 => 8028 if Depends_On_Discriminant (Assn) then 8029 return True; 8030 end if; 8031 8032 when N_Discriminant_Association => 8033 if Depends_On_Discriminant (Expression (Assn)) then 8034 return True; 8035 end if; 8036 8037 when others => 8038 null; 8039 end case; 8040 8041 Next (Assn); 8042 end loop; 8043 end if; 8044 end if; 8045 end if; 8046 8047 return False; 8048 end Has_Discriminant_Dependent_Constraint; 8049 8050 -------------------------- 8051 -- Has_Enabled_Property -- 8052 -------------------------- 8053 8054 function Has_Enabled_Property 8055 (Item_Id : Entity_Id; 8056 Property : Name_Id) return Boolean 8057 is 8058 function State_Has_Enabled_Property return Boolean; 8059 -- Determine whether a state denoted by Item_Id has the property enabled 8060 8061 function Variable_Has_Enabled_Property return Boolean; 8062 -- Determine whether a variable denoted by Item_Id has the property 8063 -- enabled. 8064 8065 -------------------------------- 8066 -- State_Has_Enabled_Property -- 8067 -------------------------------- 8068 8069 function State_Has_Enabled_Property return Boolean is 8070 Decl : constant Node_Id := Parent (Item_Id); 8071 Opt : Node_Id; 8072 Opt_Nam : Node_Id; 8073 Prop : Node_Id; 8074 Prop_Nam : Node_Id; 8075 Props : Node_Id; 8076 8077 begin 8078 -- The declaration of an external abstract state appears as an 8079 -- extension aggregate. If this is not the case, properties can never 8080 -- be set. 8081 8082 if Nkind (Decl) /= N_Extension_Aggregate then 8083 return False; 8084 end if; 8085 8086 -- When External appears as a simple option, it automatically enables 8087 -- all properties. 8088 8089 Opt := First (Expressions (Decl)); 8090 while Present (Opt) loop 8091 if Nkind (Opt) = N_Identifier 8092 and then Chars (Opt) = Name_External 8093 then 8094 return True; 8095 end if; 8096 8097 Next (Opt); 8098 end loop; 8099 8100 -- When External specifies particular properties, inspect those and 8101 -- find the desired one (if any). 8102 8103 Opt := First (Component_Associations (Decl)); 8104 while Present (Opt) loop 8105 Opt_Nam := First (Choices (Opt)); 8106 8107 if Nkind (Opt_Nam) = N_Identifier 8108 and then Chars (Opt_Nam) = Name_External 8109 then 8110 Props := Expression (Opt); 8111 8112 -- Multiple properties appear as an aggregate 8113 8114 if Nkind (Props) = N_Aggregate then 8115 8116 -- Simple property form 8117 8118 Prop := First (Expressions (Props)); 8119 while Present (Prop) loop 8120 if Chars (Prop) = Property then 8121 return True; 8122 end if; 8123 8124 Next (Prop); 8125 end loop; 8126 8127 -- Property with expression form 8128 8129 Prop := First (Component_Associations (Props)); 8130 while Present (Prop) loop 8131 Prop_Nam := First (Choices (Prop)); 8132 8133 -- The property can be represented in two ways: 8134 -- others => <value> 8135 -- <property> => <value> 8136 8137 if Nkind (Prop_Nam) = N_Others_Choice 8138 or else (Nkind (Prop_Nam) = N_Identifier 8139 and then Chars (Prop_Nam) = Property) 8140 then 8141 return Is_True (Expr_Value (Expression (Prop))); 8142 end if; 8143 8144 Next (Prop); 8145 end loop; 8146 8147 -- Single property 8148 8149 else 8150 return Chars (Props) = Property; 8151 end if; 8152 end if; 8153 8154 Next (Opt); 8155 end loop; 8156 8157 return False; 8158 end State_Has_Enabled_Property; 8159 8160 ----------------------------------- 8161 -- Variable_Has_Enabled_Property -- 8162 ----------------------------------- 8163 8164 function Variable_Has_Enabled_Property return Boolean is 8165 function Is_Enabled (Prag : Node_Id) return Boolean; 8166 -- Determine whether property pragma Prag (if present) denotes an 8167 -- enabled property. 8168 8169 ---------------- 8170 -- Is_Enabled -- 8171 ---------------- 8172 8173 function Is_Enabled (Prag : Node_Id) return Boolean is 8174 Arg2 : Node_Id; 8175 8176 begin 8177 if Present (Prag) then 8178 Arg2 := Next (First (Pragma_Argument_Associations (Prag))); 8179 8180 -- The pragma has an optional Boolean expression, the related 8181 -- property is enabled only when the expression evaluates to 8182 -- True. 8183 8184 if Present (Arg2) then 8185 return Is_True (Expr_Value (Get_Pragma_Arg (Arg2))); 8186 8187 -- Otherwise the lack of expression enables the property by 8188 -- default. 8189 8190 else 8191 return True; 8192 end if; 8193 8194 -- The property was never set in the first place 8195 8196 else 8197 return False; 8198 end if; 8199 end Is_Enabled; 8200 8201 -- Local variables 8202 8203 AR : constant Node_Id := 8204 Get_Pragma (Item_Id, Pragma_Async_Readers); 8205 AW : constant Node_Id := 8206 Get_Pragma (Item_Id, Pragma_Async_Writers); 8207 ER : constant Node_Id := 8208 Get_Pragma (Item_Id, Pragma_Effective_Reads); 8209 EW : constant Node_Id := 8210 Get_Pragma (Item_Id, Pragma_Effective_Writes); 8211 8212 -- Start of processing for Variable_Has_Enabled_Property 8213 8214 begin 8215 -- A non-effectively volatile object can never possess external 8216 -- properties. 8217 8218 if not Is_Effectively_Volatile (Item_Id) then 8219 return False; 8220 8221 -- External properties related to variables come in two flavors - 8222 -- explicit and implicit. The explicit case is characterized by the 8223 -- presence of a property pragma with an optional Boolean flag. The 8224 -- property is enabled when the flag evaluates to True or the flag is 8225 -- missing altogether. 8226 8227 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then 8228 return True; 8229 8230 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then 8231 return True; 8232 8233 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then 8234 return True; 8235 8236 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then 8237 return True; 8238 8239 -- The implicit case lacks all property pragmas 8240 8241 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 8242 return True; 8243 8244 else 8245 return False; 8246 end if; 8247 end Variable_Has_Enabled_Property; 8248 8249 -- Start of processing for Has_Enabled_Property 8250 8251 begin 8252 -- Abstract states and variables have a flexible scheme of specifying 8253 -- external properties. 8254 8255 if Ekind (Item_Id) = E_Abstract_State then 8256 return State_Has_Enabled_Property; 8257 8258 elsif Ekind (Item_Id) = E_Variable then 8259 return Variable_Has_Enabled_Property; 8260 8261 -- Otherwise a property is enabled when the related item is effectively 8262 -- volatile. 8263 8264 else 8265 return Is_Effectively_Volatile (Item_Id); 8266 end if; 8267 end Has_Enabled_Property; 8268 8269 -------------------- 8270 -- Has_Infinities -- 8271 -------------------- 8272 8273 function Has_Infinities (E : Entity_Id) return Boolean is 8274 begin 8275 return 8276 Is_Floating_Point_Type (E) 8277 and then Nkind (Scalar_Range (E)) = N_Range 8278 and then Includes_Infinities (Scalar_Range (E)); 8279 end Has_Infinities; 8280 8281 -------------------- 8282 -- Has_Interfaces -- 8283 -------------------- 8284 8285 function Has_Interfaces 8286 (T : Entity_Id; 8287 Use_Full_View : Boolean := True) return Boolean 8288 is 8289 Typ : Entity_Id := Base_Type (T); 8290 8291 begin 8292 -- Handle concurrent types 8293 8294 if Is_Concurrent_Type (Typ) then 8295 Typ := Corresponding_Record_Type (Typ); 8296 end if; 8297 8298 if not Present (Typ) 8299 or else not Is_Record_Type (Typ) 8300 or else not Is_Tagged_Type (Typ) 8301 then 8302 return False; 8303 end if; 8304 8305 -- Handle private types 8306 8307 if Use_Full_View and then Present (Full_View (Typ)) then 8308 Typ := Full_View (Typ); 8309 end if; 8310 8311 -- Handle concurrent record types 8312 8313 if Is_Concurrent_Record_Type (Typ) 8314 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 8315 then 8316 return True; 8317 end if; 8318 8319 loop 8320 if Is_Interface (Typ) 8321 or else 8322 (Is_Record_Type (Typ) 8323 and then Present (Interfaces (Typ)) 8324 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 8325 then 8326 return True; 8327 end if; 8328 8329 exit when Etype (Typ) = Typ 8330 8331 -- Handle private types 8332 8333 or else (Present (Full_View (Etype (Typ))) 8334 and then Full_View (Etype (Typ)) = Typ) 8335 8336 -- Protect frontend against wrong sources with cyclic derivations 8337 8338 or else Etype (Typ) = T; 8339 8340 -- Climb to the ancestor type handling private types 8341 8342 if Present (Full_View (Etype (Typ))) then 8343 Typ := Full_View (Etype (Typ)); 8344 else 8345 Typ := Etype (Typ); 8346 end if; 8347 end loop; 8348 8349 return False; 8350 end Has_Interfaces; 8351 8352 --------------------------------- 8353 -- Has_No_Obvious_Side_Effects -- 8354 --------------------------------- 8355 8356 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 8357 begin 8358 -- For now, just handle literals, constants, and non-volatile 8359 -- variables and expressions combining these with operators or 8360 -- short circuit forms. 8361 8362 if Nkind (N) in N_Numeric_Or_String_Literal then 8363 return True; 8364 8365 elsif Nkind (N) = N_Character_Literal then 8366 return True; 8367 8368 elsif Nkind (N) in N_Unary_Op then 8369 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 8370 8371 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 8372 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 8373 and then 8374 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 8375 8376 elsif Nkind (N) = N_Expression_With_Actions 8377 and then Is_Empty_List (Actions (N)) 8378 then 8379 return Has_No_Obvious_Side_Effects (Expression (N)); 8380 8381 elsif Nkind (N) in N_Has_Entity then 8382 return Present (Entity (N)) 8383 and then Ekind_In (Entity (N), E_Variable, 8384 E_Constant, 8385 E_Enumeration_Literal, 8386 E_In_Parameter, 8387 E_Out_Parameter, 8388 E_In_Out_Parameter) 8389 and then not Is_Volatile (Entity (N)); 8390 8391 else 8392 return False; 8393 end if; 8394 end Has_No_Obvious_Side_Effects; 8395 8396 ------------------------ 8397 -- Has_Null_Exclusion -- 8398 ------------------------ 8399 8400 function Has_Null_Exclusion (N : Node_Id) return Boolean is 8401 begin 8402 case Nkind (N) is 8403 when N_Access_Definition | 8404 N_Access_Function_Definition | 8405 N_Access_Procedure_Definition | 8406 N_Access_To_Object_Definition | 8407 N_Allocator | 8408 N_Derived_Type_Definition | 8409 N_Function_Specification | 8410 N_Subtype_Declaration => 8411 return Null_Exclusion_Present (N); 8412 8413 when N_Component_Definition | 8414 N_Formal_Object_Declaration | 8415 N_Object_Renaming_Declaration => 8416 if Present (Subtype_Mark (N)) then 8417 return Null_Exclusion_Present (N); 8418 else pragma Assert (Present (Access_Definition (N))); 8419 return Null_Exclusion_Present (Access_Definition (N)); 8420 end if; 8421 8422 when N_Discriminant_Specification => 8423 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 8424 return Null_Exclusion_Present (Discriminant_Type (N)); 8425 else 8426 return Null_Exclusion_Present (N); 8427 end if; 8428 8429 when N_Object_Declaration => 8430 if Nkind (Object_Definition (N)) = N_Access_Definition then 8431 return Null_Exclusion_Present (Object_Definition (N)); 8432 else 8433 return Null_Exclusion_Present (N); 8434 end if; 8435 8436 when N_Parameter_Specification => 8437 if Nkind (Parameter_Type (N)) = N_Access_Definition then 8438 return Null_Exclusion_Present (Parameter_Type (N)); 8439 else 8440 return Null_Exclusion_Present (N); 8441 end if; 8442 8443 when others => 8444 return False; 8445 8446 end case; 8447 end Has_Null_Exclusion; 8448 8449 ------------------------ 8450 -- Has_Null_Extension -- 8451 ------------------------ 8452 8453 function Has_Null_Extension (T : Entity_Id) return Boolean is 8454 B : constant Entity_Id := Base_Type (T); 8455 Comps : Node_Id; 8456 Ext : Node_Id; 8457 8458 begin 8459 if Nkind (Parent (B)) = N_Full_Type_Declaration 8460 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 8461 then 8462 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 8463 8464 if Present (Ext) then 8465 if Null_Present (Ext) then 8466 return True; 8467 else 8468 Comps := Component_List (Ext); 8469 8470 -- The null component list is rewritten during analysis to 8471 -- include the parent component. Any other component indicates 8472 -- that the extension was not originally null. 8473 8474 return Null_Present (Comps) 8475 or else No (Next (First (Component_Items (Comps)))); 8476 end if; 8477 else 8478 return False; 8479 end if; 8480 8481 else 8482 return False; 8483 end if; 8484 end Has_Null_Extension; 8485 8486 ------------------------------- 8487 -- Has_Overriding_Initialize -- 8488 ------------------------------- 8489 8490 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 8491 BT : constant Entity_Id := Base_Type (T); 8492 P : Elmt_Id; 8493 8494 begin 8495 if Is_Controlled (BT) then 8496 if Is_RTU (Scope (BT), Ada_Finalization) then 8497 return False; 8498 8499 elsif Present (Primitive_Operations (BT)) then 8500 P := First_Elmt (Primitive_Operations (BT)); 8501 while Present (P) loop 8502 declare 8503 Init : constant Entity_Id := Node (P); 8504 Formal : constant Entity_Id := First_Formal (Init); 8505 begin 8506 if Ekind (Init) = E_Procedure 8507 and then Chars (Init) = Name_Initialize 8508 and then Comes_From_Source (Init) 8509 and then Present (Formal) 8510 and then Etype (Formal) = BT 8511 and then No (Next_Formal (Formal)) 8512 and then (Ada_Version < Ada_2012 8513 or else not Null_Present (Parent (Init))) 8514 then 8515 return True; 8516 end if; 8517 end; 8518 8519 Next_Elmt (P); 8520 end loop; 8521 end if; 8522 8523 -- Here if type itself does not have a non-null Initialize operation: 8524 -- check immediate ancestor. 8525 8526 if Is_Derived_Type (BT) 8527 and then Has_Overriding_Initialize (Etype (BT)) 8528 then 8529 return True; 8530 end if; 8531 end if; 8532 8533 return False; 8534 end Has_Overriding_Initialize; 8535 8536 -------------------------------------- 8537 -- Has_Preelaborable_Initialization -- 8538 -------------------------------------- 8539 8540 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 8541 Has_PE : Boolean; 8542 8543 procedure Check_Components (E : Entity_Id); 8544 -- Check component/discriminant chain, sets Has_PE False if a component 8545 -- or discriminant does not meet the preelaborable initialization rules. 8546 8547 ---------------------- 8548 -- Check_Components -- 8549 ---------------------- 8550 8551 procedure Check_Components (E : Entity_Id) is 8552 Ent : Entity_Id; 8553 Exp : Node_Id; 8554 8555 function Is_Preelaborable_Expression (N : Node_Id) return Boolean; 8556 -- Returns True if and only if the expression denoted by N does not 8557 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). 8558 8559 --------------------------------- 8560 -- Is_Preelaborable_Expression -- 8561 --------------------------------- 8562 8563 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is 8564 Exp : Node_Id; 8565 Assn : Node_Id; 8566 Choice : Node_Id; 8567 Comp_Type : Entity_Id; 8568 Is_Array_Aggr : Boolean; 8569 8570 begin 8571 if Is_OK_Static_Expression (N) then 8572 return True; 8573 8574 elsif Nkind (N) = N_Null then 8575 return True; 8576 8577 -- Attributes are allowed in general, even if their prefix is a 8578 -- formal type. (It seems that certain attributes known not to be 8579 -- static might not be allowed, but there are no rules to prevent 8580 -- them.) 8581 8582 elsif Nkind (N) = N_Attribute_Reference then 8583 return True; 8584 8585 -- The name of a discriminant evaluated within its parent type is 8586 -- defined to be preelaborable (10.2.1(8)). Note that we test for 8587 -- names that denote discriminals as well as discriminants to 8588 -- catch references occurring within init procs. 8589 8590 elsif Is_Entity_Name (N) 8591 and then 8592 (Ekind (Entity (N)) = E_Discriminant 8593 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) 8594 and then Present (Discriminal_Link (Entity (N))))) 8595 then 8596 return True; 8597 8598 elsif Nkind (N) = N_Qualified_Expression then 8599 return Is_Preelaborable_Expression (Expression (N)); 8600 8601 -- For aggregates we have to check that each of the associations 8602 -- is preelaborable. 8603 8604 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 8605 Is_Array_Aggr := Is_Array_Type (Etype (N)); 8606 8607 if Is_Array_Aggr then 8608 Comp_Type := Component_Type (Etype (N)); 8609 end if; 8610 8611 -- Check the ancestor part of extension aggregates, which must 8612 -- be either the name of a type that has preelaborable init or 8613 -- an expression that is preelaborable. 8614 8615 if Nkind (N) = N_Extension_Aggregate then 8616 declare 8617 Anc_Part : constant Node_Id := Ancestor_Part (N); 8618 8619 begin 8620 if Is_Entity_Name (Anc_Part) 8621 and then Is_Type (Entity (Anc_Part)) 8622 then 8623 if not Has_Preelaborable_Initialization 8624 (Entity (Anc_Part)) 8625 then 8626 return False; 8627 end if; 8628 8629 elsif not Is_Preelaborable_Expression (Anc_Part) then 8630 return False; 8631 end if; 8632 end; 8633 end if; 8634 8635 -- Check positional associations 8636 8637 Exp := First (Expressions (N)); 8638 while Present (Exp) loop 8639 if not Is_Preelaborable_Expression (Exp) then 8640 return False; 8641 end if; 8642 8643 Next (Exp); 8644 end loop; 8645 8646 -- Check named associations 8647 8648 Assn := First (Component_Associations (N)); 8649 while Present (Assn) loop 8650 Choice := First (Choices (Assn)); 8651 while Present (Choice) loop 8652 if Is_Array_Aggr then 8653 if Nkind (Choice) = N_Others_Choice then 8654 null; 8655 8656 elsif Nkind (Choice) = N_Range then 8657 if not Is_OK_Static_Range (Choice) then 8658 return False; 8659 end if; 8660 8661 elsif not Is_OK_Static_Expression (Choice) then 8662 return False; 8663 end if; 8664 8665 else 8666 Comp_Type := Etype (Choice); 8667 end if; 8668 8669 Next (Choice); 8670 end loop; 8671 8672 -- If the association has a <> at this point, then we have 8673 -- to check whether the component's type has preelaborable 8674 -- initialization. Note that this only occurs when the 8675 -- association's corresponding component does not have a 8676 -- default expression, the latter case having already been 8677 -- expanded as an expression for the association. 8678 8679 if Box_Present (Assn) then 8680 if not Has_Preelaborable_Initialization (Comp_Type) then 8681 return False; 8682 end if; 8683 8684 -- In the expression case we check whether the expression 8685 -- is preelaborable. 8686 8687 elsif 8688 not Is_Preelaborable_Expression (Expression (Assn)) 8689 then 8690 return False; 8691 end if; 8692 8693 Next (Assn); 8694 end loop; 8695 8696 -- If we get here then aggregate as a whole is preelaborable 8697 8698 return True; 8699 8700 -- All other cases are not preelaborable 8701 8702 else 8703 return False; 8704 end if; 8705 end Is_Preelaborable_Expression; 8706 8707 -- Start of processing for Check_Components 8708 8709 begin 8710 -- Loop through entities of record or protected type 8711 8712 Ent := E; 8713 while Present (Ent) loop 8714 8715 -- We are interested only in components and discriminants 8716 8717 Exp := Empty; 8718 8719 case Ekind (Ent) is 8720 when E_Component => 8721 8722 -- Get default expression if any. If there is no declaration 8723 -- node, it means we have an internal entity. The parent and 8724 -- tag fields are examples of such entities. For such cases, 8725 -- we just test the type of the entity. 8726 8727 if Present (Declaration_Node (Ent)) then 8728 Exp := Expression (Declaration_Node (Ent)); 8729 end if; 8730 8731 when E_Discriminant => 8732 8733 -- Note: for a renamed discriminant, the Declaration_Node 8734 -- may point to the one from the ancestor, and have a 8735 -- different expression, so use the proper attribute to 8736 -- retrieve the expression from the derived constraint. 8737 8738 Exp := Discriminant_Default_Value (Ent); 8739 8740 when others => 8741 goto Check_Next_Entity; 8742 end case; 8743 8744 -- A component has PI if it has no default expression and the 8745 -- component type has PI. 8746 8747 if No (Exp) then 8748 if not Has_Preelaborable_Initialization (Etype (Ent)) then 8749 Has_PE := False; 8750 exit; 8751 end if; 8752 8753 -- Require the default expression to be preelaborable 8754 8755 elsif not Is_Preelaborable_Expression (Exp) then 8756 Has_PE := False; 8757 exit; 8758 end if; 8759 8760 <<Check_Next_Entity>> 8761 Next_Entity (Ent); 8762 end loop; 8763 end Check_Components; 8764 8765 -- Start of processing for Has_Preelaborable_Initialization 8766 8767 begin 8768 -- Immediate return if already marked as known preelaborable init. This 8769 -- covers types for which this function has already been called once 8770 -- and returned True (in which case the result is cached), and also 8771 -- types to which a pragma Preelaborable_Initialization applies. 8772 8773 if Known_To_Have_Preelab_Init (E) then 8774 return True; 8775 end if; 8776 8777 -- If the type is a subtype representing a generic actual type, then 8778 -- test whether its base type has preelaborable initialization since 8779 -- the subtype representing the actual does not inherit this attribute 8780 -- from the actual or formal. (but maybe it should???) 8781 8782 if Is_Generic_Actual_Type (E) then 8783 return Has_Preelaborable_Initialization (Base_Type (E)); 8784 end if; 8785 8786 -- All elementary types have preelaborable initialization 8787 8788 if Is_Elementary_Type (E) then 8789 Has_PE := True; 8790 8791 -- Array types have PI if the component type has PI 8792 8793 elsif Is_Array_Type (E) then 8794 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 8795 8796 -- A derived type has preelaborable initialization if its parent type 8797 -- has preelaborable initialization and (in the case of a derived record 8798 -- extension) if the non-inherited components all have preelaborable 8799 -- initialization. However, a user-defined controlled type with an 8800 -- overriding Initialize procedure does not have preelaborable 8801 -- initialization. 8802 8803 elsif Is_Derived_Type (E) then 8804 8805 -- If the derived type is a private extension then it doesn't have 8806 -- preelaborable initialization. 8807 8808 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 8809 return False; 8810 end if; 8811 8812 -- First check whether ancestor type has preelaborable initialization 8813 8814 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 8815 8816 -- If OK, check extension components (if any) 8817 8818 if Has_PE and then Is_Record_Type (E) then 8819 Check_Components (First_Entity (E)); 8820 end if; 8821 8822 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 8823 -- with a user defined Initialize procedure does not have PI. If 8824 -- the type is untagged, the control primitives come from a component 8825 -- that has already been checked. 8826 8827 if Has_PE 8828 and then Is_Controlled (E) 8829 and then Is_Tagged_Type (E) 8830 and then Has_Overriding_Initialize (E) 8831 then 8832 Has_PE := False; 8833 end if; 8834 8835 -- Private types not derived from a type having preelaborable init and 8836 -- that are not marked with pragma Preelaborable_Initialization do not 8837 -- have preelaborable initialization. 8838 8839 elsif Is_Private_Type (E) then 8840 return False; 8841 8842 -- Record type has PI if it is non private and all components have PI 8843 8844 elsif Is_Record_Type (E) then 8845 Has_PE := True; 8846 Check_Components (First_Entity (E)); 8847 8848 -- Protected types must not have entries, and components must meet 8849 -- same set of rules as for record components. 8850 8851 elsif Is_Protected_Type (E) then 8852 if Has_Entries (E) then 8853 Has_PE := False; 8854 else 8855 Has_PE := True; 8856 Check_Components (First_Entity (E)); 8857 Check_Components (First_Private_Entity (E)); 8858 end if; 8859 8860 -- Type System.Address always has preelaborable initialization 8861 8862 elsif Is_RTE (E, RE_Address) then 8863 Has_PE := True; 8864 8865 -- In all other cases, type does not have preelaborable initialization 8866 8867 else 8868 return False; 8869 end if; 8870 8871 -- If type has preelaborable initialization, cache result 8872 8873 if Has_PE then 8874 Set_Known_To_Have_Preelab_Init (E); 8875 end if; 8876 8877 return Has_PE; 8878 end Has_Preelaborable_Initialization; 8879 8880 --------------------------- 8881 -- Has_Private_Component -- 8882 --------------------------- 8883 8884 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 8885 Btype : Entity_Id := Base_Type (Type_Id); 8886 Component : Entity_Id; 8887 8888 begin 8889 if Error_Posted (Type_Id) 8890 or else Error_Posted (Btype) 8891 then 8892 return False; 8893 end if; 8894 8895 if Is_Class_Wide_Type (Btype) then 8896 Btype := Root_Type (Btype); 8897 end if; 8898 8899 if Is_Private_Type (Btype) then 8900 declare 8901 UT : constant Entity_Id := Underlying_Type (Btype); 8902 begin 8903 if No (UT) then 8904 if No (Full_View (Btype)) then 8905 return not Is_Generic_Type (Btype) 8906 and then 8907 not Is_Generic_Type (Root_Type (Btype)); 8908 else 8909 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 8910 end if; 8911 else 8912 return not Is_Frozen (UT) and then Has_Private_Component (UT); 8913 end if; 8914 end; 8915 8916 elsif Is_Array_Type (Btype) then 8917 return Has_Private_Component (Component_Type (Btype)); 8918 8919 elsif Is_Record_Type (Btype) then 8920 Component := First_Component (Btype); 8921 while Present (Component) loop 8922 if Has_Private_Component (Etype (Component)) then 8923 return True; 8924 end if; 8925 8926 Next_Component (Component); 8927 end loop; 8928 8929 return False; 8930 8931 elsif Is_Protected_Type (Btype) 8932 and then Present (Corresponding_Record_Type (Btype)) 8933 then 8934 return Has_Private_Component (Corresponding_Record_Type (Btype)); 8935 8936 else 8937 return False; 8938 end if; 8939 end Has_Private_Component; 8940 8941 ---------------------- 8942 -- Has_Signed_Zeros -- 8943 ---------------------- 8944 8945 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 8946 begin 8947 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 8948 end Has_Signed_Zeros; 8949 8950 ------------------------------ 8951 -- Has_Significant_Contract -- 8952 ------------------------------ 8953 8954 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 8955 Subp_Nam : constant Name_Id := Chars (Subp_Id); 8956 8957 begin 8958 -- _Finalizer procedure 8959 8960 if Subp_Nam = Name_uFinalizer then 8961 return False; 8962 8963 -- _Postconditions procedure 8964 8965 elsif Subp_Nam = Name_uPostconditions then 8966 return False; 8967 8968 -- Predicate function 8969 8970 elsif Ekind (Subp_Id) = E_Function 8971 and then Is_Predicate_Function (Subp_Id) 8972 then 8973 return False; 8974 8975 -- TSS subprogram 8976 8977 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 8978 return False; 8979 8980 else 8981 return True; 8982 end if; 8983 end Has_Significant_Contract; 8984 8985 ----------------------------- 8986 -- Has_Static_Array_Bounds -- 8987 ----------------------------- 8988 8989 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 8990 Ndims : constant Nat := Number_Dimensions (Typ); 8991 8992 Index : Node_Id; 8993 Low : Node_Id; 8994 High : Node_Id; 8995 8996 begin 8997 -- Unconstrained types do not have static bounds 8998 8999 if not Is_Constrained (Typ) then 9000 return False; 9001 end if; 9002 9003 -- First treat string literals specially, as the lower bound and length 9004 -- of string literals are not stored like those of arrays. 9005 9006 -- A string literal always has static bounds 9007 9008 if Ekind (Typ) = E_String_Literal_Subtype then 9009 return True; 9010 end if; 9011 9012 -- Treat all dimensions in turn 9013 9014 Index := First_Index (Typ); 9015 for Indx in 1 .. Ndims loop 9016 9017 -- In case of an illegal index which is not a discrete type, return 9018 -- that the type is not static. 9019 9020 if not Is_Discrete_Type (Etype (Index)) 9021 or else Etype (Index) = Any_Type 9022 then 9023 return False; 9024 end if; 9025 9026 Get_Index_Bounds (Index, Low, High); 9027 9028 if Error_Posted (Low) or else Error_Posted (High) then 9029 return False; 9030 end if; 9031 9032 if Is_OK_Static_Expression (Low) 9033 and then 9034 Is_OK_Static_Expression (High) 9035 then 9036 null; 9037 else 9038 return False; 9039 end if; 9040 9041 Next (Index); 9042 end loop; 9043 9044 -- If we fall through the loop, all indexes matched 9045 9046 return True; 9047 end Has_Static_Array_Bounds; 9048 9049 ---------------- 9050 -- Has_Stream -- 9051 ---------------- 9052 9053 function Has_Stream (T : Entity_Id) return Boolean is 9054 E : Entity_Id; 9055 9056 begin 9057 if No (T) then 9058 return False; 9059 9060 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 9061 return True; 9062 9063 elsif Is_Array_Type (T) then 9064 return Has_Stream (Component_Type (T)); 9065 9066 elsif Is_Record_Type (T) then 9067 E := First_Component (T); 9068 while Present (E) loop 9069 if Has_Stream (Etype (E)) then 9070 return True; 9071 else 9072 Next_Component (E); 9073 end if; 9074 end loop; 9075 9076 return False; 9077 9078 elsif Is_Private_Type (T) then 9079 return Has_Stream (Underlying_Type (T)); 9080 9081 else 9082 return False; 9083 end if; 9084 end Has_Stream; 9085 9086 ---------------- 9087 -- Has_Suffix -- 9088 ---------------- 9089 9090 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 9091 begin 9092 Get_Name_String (Chars (E)); 9093 return Name_Buffer (Name_Len) = Suffix; 9094 end Has_Suffix; 9095 9096 ---------------- 9097 -- Add_Suffix -- 9098 ---------------- 9099 9100 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 9101 begin 9102 Get_Name_String (Chars (E)); 9103 Add_Char_To_Name_Buffer (Suffix); 9104 return Name_Find; 9105 end Add_Suffix; 9106 9107 ------------------- 9108 -- Remove_Suffix -- 9109 ------------------- 9110 9111 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 9112 begin 9113 pragma Assert (Has_Suffix (E, Suffix)); 9114 Get_Name_String (Chars (E)); 9115 Name_Len := Name_Len - 1; 9116 return Name_Find; 9117 end Remove_Suffix; 9118 9119 -------------------------- 9120 -- Has_Tagged_Component -- 9121 -------------------------- 9122 9123 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 9124 Comp : Entity_Id; 9125 9126 begin 9127 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 9128 return Has_Tagged_Component (Underlying_Type (Typ)); 9129 9130 elsif Is_Array_Type (Typ) then 9131 return Has_Tagged_Component (Component_Type (Typ)); 9132 9133 elsif Is_Tagged_Type (Typ) then 9134 return True; 9135 9136 elsif Is_Record_Type (Typ) then 9137 Comp := First_Component (Typ); 9138 while Present (Comp) loop 9139 if Has_Tagged_Component (Etype (Comp)) then 9140 return True; 9141 end if; 9142 9143 Next_Component (Comp); 9144 end loop; 9145 9146 return False; 9147 9148 else 9149 return False; 9150 end if; 9151 end Has_Tagged_Component; 9152 9153 ---------------------------- 9154 -- Has_Volatile_Component -- 9155 ---------------------------- 9156 9157 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 9158 Comp : Entity_Id; 9159 9160 begin 9161 if Has_Volatile_Components (Typ) then 9162 return True; 9163 9164 elsif Is_Array_Type (Typ) then 9165 return Is_Volatile (Component_Type (Typ)); 9166 9167 elsif Is_Record_Type (Typ) then 9168 Comp := First_Component (Typ); 9169 while Present (Comp) loop 9170 if Is_Volatile_Object (Comp) then 9171 return True; 9172 end if; 9173 9174 Comp := Next_Component (Comp); 9175 end loop; 9176 end if; 9177 9178 return False; 9179 end Has_Volatile_Component; 9180 9181 ------------------------- 9182 -- Implementation_Kind -- 9183 ------------------------- 9184 9185 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 9186 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 9187 Arg : Node_Id; 9188 begin 9189 pragma Assert (Present (Impl_Prag)); 9190 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 9191 return Chars (Get_Pragma_Arg (Arg)); 9192 end Implementation_Kind; 9193 9194 -------------------------- 9195 -- Implements_Interface -- 9196 -------------------------- 9197 9198 function Implements_Interface 9199 (Typ_Ent : Entity_Id; 9200 Iface_Ent : Entity_Id; 9201 Exclude_Parents : Boolean := False) return Boolean 9202 is 9203 Ifaces_List : Elist_Id; 9204 Elmt : Elmt_Id; 9205 Iface : Entity_Id := Base_Type (Iface_Ent); 9206 Typ : Entity_Id := Base_Type (Typ_Ent); 9207 9208 begin 9209 if Is_Class_Wide_Type (Typ) then 9210 Typ := Root_Type (Typ); 9211 end if; 9212 9213 if not Has_Interfaces (Typ) then 9214 return False; 9215 end if; 9216 9217 if Is_Class_Wide_Type (Iface) then 9218 Iface := Root_Type (Iface); 9219 end if; 9220 9221 Collect_Interfaces (Typ, Ifaces_List); 9222 9223 Elmt := First_Elmt (Ifaces_List); 9224 while Present (Elmt) loop 9225 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 9226 and then Exclude_Parents 9227 then 9228 null; 9229 9230 elsif Node (Elmt) = Iface then 9231 return True; 9232 end if; 9233 9234 Next_Elmt (Elmt); 9235 end loop; 9236 9237 return False; 9238 end Implements_Interface; 9239 9240 ------------------------------------ 9241 -- In_Assertion_Expression_Pragma -- 9242 ------------------------------------ 9243 9244 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 9245 Par : Node_Id; 9246 Prag : Node_Id := Empty; 9247 9248 begin 9249 -- Climb the parent chain looking for an enclosing pragma 9250 9251 Par := N; 9252 while Present (Par) loop 9253 if Nkind (Par) = N_Pragma then 9254 Prag := Par; 9255 exit; 9256 9257 -- Precondition-like pragmas are expanded into if statements, check 9258 -- the original node instead. 9259 9260 elsif Nkind (Original_Node (Par)) = N_Pragma then 9261 Prag := Original_Node (Par); 9262 exit; 9263 9264 -- The expansion of attribute 'Old generates a constant to capture 9265 -- the result of the prefix. If the parent traversal reaches 9266 -- one of these constants, then the node technically came from a 9267 -- postcondition-like pragma. Note that the Ekind is not tested here 9268 -- because N may be the expression of an object declaration which is 9269 -- currently being analyzed. Such objects carry Ekind of E_Void. 9270 9271 elsif Nkind (Par) = N_Object_Declaration 9272 and then Constant_Present (Par) 9273 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 9274 then 9275 return True; 9276 9277 -- Prevent the search from going too far 9278 9279 elsif Is_Body_Or_Package_Declaration (Par) then 9280 return False; 9281 end if; 9282 9283 Par := Parent (Par); 9284 end loop; 9285 9286 return 9287 Present (Prag) 9288 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 9289 end In_Assertion_Expression_Pragma; 9290 9291 ----------------- 9292 -- In_Instance -- 9293 ----------------- 9294 9295 function In_Instance return Boolean is 9296 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 9297 S : Entity_Id; 9298 9299 begin 9300 S := Current_Scope; 9301 while Present (S) and then S /= Standard_Standard loop 9302 if Ekind_In (S, E_Function, E_Package, E_Procedure) 9303 and then Is_Generic_Instance (S) 9304 then 9305 -- A child instance is always compiled in the context of a parent 9306 -- instance. Nevertheless, the actuals are not analyzed in an 9307 -- instance context. We detect this case by examining the current 9308 -- compilation unit, which must be a child instance, and checking 9309 -- that it is not currently on the scope stack. 9310 9311 if Is_Child_Unit (Curr_Unit) 9312 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 9313 N_Package_Instantiation 9314 and then not In_Open_Scopes (Curr_Unit) 9315 then 9316 return False; 9317 else 9318 return True; 9319 end if; 9320 end if; 9321 9322 S := Scope (S); 9323 end loop; 9324 9325 return False; 9326 end In_Instance; 9327 9328 ---------------------- 9329 -- In_Instance_Body -- 9330 ---------------------- 9331 9332 function In_Instance_Body return Boolean is 9333 S : Entity_Id; 9334 9335 begin 9336 S := Current_Scope; 9337 while Present (S) and then S /= Standard_Standard loop 9338 if Ekind_In (S, E_Function, E_Procedure) 9339 and then Is_Generic_Instance (S) 9340 then 9341 return True; 9342 9343 elsif Ekind (S) = E_Package 9344 and then In_Package_Body (S) 9345 and then Is_Generic_Instance (S) 9346 then 9347 return True; 9348 end if; 9349 9350 S := Scope (S); 9351 end loop; 9352 9353 return False; 9354 end In_Instance_Body; 9355 9356 ----------------------------- 9357 -- In_Instance_Not_Visible -- 9358 ----------------------------- 9359 9360 function In_Instance_Not_Visible return Boolean is 9361 S : Entity_Id; 9362 9363 begin 9364 S := Current_Scope; 9365 while Present (S) and then S /= Standard_Standard loop 9366 if Ekind_In (S, E_Function, E_Procedure) 9367 and then Is_Generic_Instance (S) 9368 then 9369 return True; 9370 9371 elsif Ekind (S) = E_Package 9372 and then (In_Package_Body (S) or else In_Private_Part (S)) 9373 and then Is_Generic_Instance (S) 9374 then 9375 return True; 9376 end if; 9377 9378 S := Scope (S); 9379 end loop; 9380 9381 return False; 9382 end In_Instance_Not_Visible; 9383 9384 ------------------------------ 9385 -- In_Instance_Visible_Part -- 9386 ------------------------------ 9387 9388 function In_Instance_Visible_Part return Boolean is 9389 S : Entity_Id; 9390 9391 begin 9392 S := Current_Scope; 9393 while Present (S) and then S /= Standard_Standard loop 9394 if Ekind (S) = E_Package 9395 and then Is_Generic_Instance (S) 9396 and then not In_Package_Body (S) 9397 and then not In_Private_Part (S) 9398 then 9399 return True; 9400 end if; 9401 9402 S := Scope (S); 9403 end loop; 9404 9405 return False; 9406 end In_Instance_Visible_Part; 9407 9408 --------------------- 9409 -- In_Package_Body -- 9410 --------------------- 9411 9412 function In_Package_Body return Boolean is 9413 S : Entity_Id; 9414 9415 begin 9416 S := Current_Scope; 9417 while Present (S) and then S /= Standard_Standard loop 9418 if Ekind (S) = E_Package and then In_Package_Body (S) then 9419 return True; 9420 else 9421 S := Scope (S); 9422 end if; 9423 end loop; 9424 9425 return False; 9426 end In_Package_Body; 9427 9428 -------------------------------- 9429 -- In_Parameter_Specification -- 9430 -------------------------------- 9431 9432 function In_Parameter_Specification (N : Node_Id) return Boolean is 9433 PN : Node_Id; 9434 9435 begin 9436 PN := Parent (N); 9437 while Present (PN) loop 9438 if Nkind (PN) = N_Parameter_Specification then 9439 return True; 9440 end if; 9441 9442 PN := Parent (PN); 9443 end loop; 9444 9445 return False; 9446 end In_Parameter_Specification; 9447 9448 -------------------------- 9449 -- In_Pragma_Expression -- 9450 -------------------------- 9451 9452 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 9453 P : Node_Id; 9454 begin 9455 P := Parent (N); 9456 loop 9457 if No (P) then 9458 return False; 9459 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 9460 return True; 9461 else 9462 P := Parent (P); 9463 end if; 9464 end loop; 9465 end In_Pragma_Expression; 9466 9467 ------------------------------------- 9468 -- In_Reverse_Storage_Order_Object -- 9469 ------------------------------------- 9470 9471 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 9472 Pref : Node_Id; 9473 Btyp : Entity_Id := Empty; 9474 9475 begin 9476 -- Climb up indexed components 9477 9478 Pref := N; 9479 loop 9480 case Nkind (Pref) is 9481 when N_Selected_Component => 9482 Pref := Prefix (Pref); 9483 exit; 9484 9485 when N_Indexed_Component => 9486 Pref := Prefix (Pref); 9487 9488 when others => 9489 Pref := Empty; 9490 exit; 9491 end case; 9492 end loop; 9493 9494 if Present (Pref) then 9495 Btyp := Base_Type (Etype (Pref)); 9496 end if; 9497 9498 return Present (Btyp) 9499 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 9500 and then Reverse_Storage_Order (Btyp); 9501 end In_Reverse_Storage_Order_Object; 9502 9503 -------------------------------------- 9504 -- In_Subprogram_Or_Concurrent_Unit -- 9505 -------------------------------------- 9506 9507 function In_Subprogram_Or_Concurrent_Unit return Boolean is 9508 E : Entity_Id; 9509 K : Entity_Kind; 9510 9511 begin 9512 -- Use scope chain to check successively outer scopes 9513 9514 E := Current_Scope; 9515 loop 9516 K := Ekind (E); 9517 9518 if K in Subprogram_Kind 9519 or else K in Concurrent_Kind 9520 or else K in Generic_Subprogram_Kind 9521 then 9522 return True; 9523 9524 elsif E = Standard_Standard then 9525 return False; 9526 end if; 9527 9528 E := Scope (E); 9529 end loop; 9530 end In_Subprogram_Or_Concurrent_Unit; 9531 9532 --------------------- 9533 -- In_Visible_Part -- 9534 --------------------- 9535 9536 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 9537 begin 9538 return Is_Package_Or_Generic_Package (Scope_Id) 9539 and then In_Open_Scopes (Scope_Id) 9540 and then not In_Package_Body (Scope_Id) 9541 and then not In_Private_Part (Scope_Id); 9542 end In_Visible_Part; 9543 9544 -------------------------------- 9545 -- Incomplete_Or_Partial_View -- 9546 -------------------------------- 9547 9548 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 9549 function Inspect_Decls 9550 (Decls : List_Id; 9551 Taft : Boolean := False) return Entity_Id; 9552 -- Check whether a declarative region contains the incomplete or partial 9553 -- view of Id. 9554 9555 ------------------- 9556 -- Inspect_Decls -- 9557 ------------------- 9558 9559 function Inspect_Decls 9560 (Decls : List_Id; 9561 Taft : Boolean := False) return Entity_Id 9562 is 9563 Decl : Node_Id; 9564 Match : Node_Id; 9565 9566 begin 9567 Decl := First (Decls); 9568 while Present (Decl) loop 9569 Match := Empty; 9570 9571 if Taft then 9572 if Nkind (Decl) = N_Incomplete_Type_Declaration then 9573 Match := Defining_Identifier (Decl); 9574 end if; 9575 9576 else 9577 if Nkind_In (Decl, N_Private_Extension_Declaration, 9578 N_Private_Type_Declaration) 9579 then 9580 Match := Defining_Identifier (Decl); 9581 end if; 9582 end if; 9583 9584 if Present (Match) 9585 and then Present (Full_View (Match)) 9586 and then Full_View (Match) = Id 9587 then 9588 return Match; 9589 end if; 9590 9591 Next (Decl); 9592 end loop; 9593 9594 return Empty; 9595 end Inspect_Decls; 9596 9597 -- Local variables 9598 9599 Prev : Entity_Id; 9600 9601 -- Start of processing for Incomplete_Or_Partial_View 9602 9603 begin 9604 -- Deferred constant or incomplete type case 9605 9606 Prev := Current_Entity_In_Scope (Id); 9607 9608 if Present (Prev) 9609 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 9610 and then Present (Full_View (Prev)) 9611 and then Full_View (Prev) = Id 9612 then 9613 return Prev; 9614 end if; 9615 9616 -- Private or Taft amendment type case 9617 9618 declare 9619 Pkg : constant Entity_Id := Scope (Id); 9620 Pkg_Decl : Node_Id := Pkg; 9621 9622 begin 9623 if Present (Pkg) and then Ekind (Pkg) = E_Package then 9624 while Nkind (Pkg_Decl) /= N_Package_Specification loop 9625 Pkg_Decl := Parent (Pkg_Decl); 9626 end loop; 9627 9628 -- It is knows that Typ has a private view, look for it in the 9629 -- visible declarations of the enclosing scope. A special case 9630 -- of this is when the two views have been exchanged - the full 9631 -- appears earlier than the private. 9632 9633 if Has_Private_Declaration (Id) then 9634 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 9635 9636 -- Exchanged view case, look in the private declarations 9637 9638 if No (Prev) then 9639 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 9640 end if; 9641 9642 return Prev; 9643 9644 -- Otherwise if this is the package body, then Typ is a potential 9645 -- Taft amendment type. The incomplete view should be located in 9646 -- the private declarations of the enclosing scope. 9647 9648 elsif In_Package_Body (Pkg) then 9649 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 9650 end if; 9651 end if; 9652 end; 9653 9654 -- The type has no incomplete or private view 9655 9656 return Empty; 9657 end Incomplete_Or_Partial_View; 9658 9659 ----------------------------------------- 9660 -- Inherit_Default_Init_Cond_Procedure -- 9661 ----------------------------------------- 9662 9663 procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is 9664 Par_Typ : constant Entity_Id := Etype (Typ); 9665 9666 begin 9667 -- A derived type inherits the default initial condition procedure of 9668 -- its parent type. 9669 9670 if No (Default_Init_Cond_Procedure (Typ)) then 9671 Set_Default_Init_Cond_Procedure 9672 (Typ, Default_Init_Cond_Procedure (Par_Typ)); 9673 end if; 9674 end Inherit_Default_Init_Cond_Procedure; 9675 9676 ---------------------------- 9677 -- Inherit_Rep_Item_Chain -- 9678 ---------------------------- 9679 9680 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 9681 From_Item : constant Node_Id := First_Rep_Item (From_Typ); 9682 Item : Node_Id := Empty; 9683 Last_Item : Node_Id := Empty; 9684 9685 begin 9686 -- Reach the end of the destination type's chain (if any) and capture 9687 -- the last item. 9688 9689 Item := First_Rep_Item (Typ); 9690 while Present (Item) loop 9691 9692 -- Do not inherit a chain that has been inherited already 9693 9694 if Item = From_Item then 9695 return; 9696 end if; 9697 9698 Last_Item := Item; 9699 Item := Next_Rep_Item (Item); 9700 end loop; 9701 9702 -- When the destination type has a rep item chain, the chain of the 9703 -- source type is appended to it. 9704 9705 if Present (Last_Item) then 9706 Set_Next_Rep_Item (Last_Item, From_Item); 9707 9708 -- Otherwise the destination type directly inherits the rep item chain 9709 -- of the source type (if any). 9710 9711 else 9712 Set_First_Rep_Item (Typ, From_Item); 9713 end if; 9714 end Inherit_Rep_Item_Chain; 9715 9716 --------------------------------- 9717 -- Inherit_Subprogram_Contract -- 9718 --------------------------------- 9719 9720 procedure Inherit_Subprogram_Contract 9721 (Subp : Entity_Id; 9722 From_Subp : Entity_Id) 9723 is 9724 procedure Inherit_Pragma (Prag_Id : Pragma_Id); 9725 -- Propagate a pragma denoted by Prag_Id from From_Subp's contract to 9726 -- Subp's contract. 9727 9728 -------------------- 9729 -- Inherit_Pragma -- 9730 -------------------- 9731 9732 procedure Inherit_Pragma (Prag_Id : Pragma_Id) is 9733 Prag : constant Node_Id := Get_Pragma (From_Subp, Prag_Id); 9734 New_Prag : Node_Id; 9735 9736 begin 9737 -- A pragma cannot be part of more than one First_Pragma/Next_Pragma 9738 -- chains, therefore the node must be replicated. The new pragma is 9739 -- flagged is inherited for distrinction purposes. 9740 9741 if Present (Prag) then 9742 New_Prag := New_Copy_Tree (Prag); 9743 Set_Is_Inherited (New_Prag); 9744 9745 Add_Contract_Item (New_Prag, Subp); 9746 end if; 9747 end Inherit_Pragma; 9748 9749 -- Start of processing for Inherit_Subprogram_Contract 9750 9751 begin 9752 -- Inheritance is carried out only when both entities are subprograms 9753 -- with contracts. 9754 9755 if Is_Subprogram_Or_Generic_Subprogram (Subp) 9756 and then Is_Subprogram_Or_Generic_Subprogram (From_Subp) 9757 and then Present (Contract (From_Subp)) 9758 then 9759 Inherit_Pragma (Pragma_Extensions_Visible); 9760 end if; 9761 end Inherit_Subprogram_Contract; 9762 9763 --------------------------------- 9764 -- Insert_Explicit_Dereference -- 9765 --------------------------------- 9766 9767 procedure Insert_Explicit_Dereference (N : Node_Id) is 9768 New_Prefix : constant Node_Id := Relocate_Node (N); 9769 Ent : Entity_Id := Empty; 9770 Pref : Node_Id; 9771 I : Interp_Index; 9772 It : Interp; 9773 T : Entity_Id; 9774 9775 begin 9776 Save_Interps (N, New_Prefix); 9777 9778 Rewrite (N, 9779 Make_Explicit_Dereference (Sloc (Parent (N)), 9780 Prefix => New_Prefix)); 9781 9782 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 9783 9784 if Is_Overloaded (New_Prefix) then 9785 9786 -- The dereference is also overloaded, and its interpretations are 9787 -- the designated types of the interpretations of the original node. 9788 9789 Set_Etype (N, Any_Type); 9790 9791 Get_First_Interp (New_Prefix, I, It); 9792 while Present (It.Nam) loop 9793 T := It.Typ; 9794 9795 if Is_Access_Type (T) then 9796 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 9797 end if; 9798 9799 Get_Next_Interp (I, It); 9800 end loop; 9801 9802 End_Interp_List; 9803 9804 else 9805 -- Prefix is unambiguous: mark the original prefix (which might 9806 -- Come_From_Source) as a reference, since the new (relocated) one 9807 -- won't be taken into account. 9808 9809 if Is_Entity_Name (New_Prefix) then 9810 Ent := Entity (New_Prefix); 9811 Pref := New_Prefix; 9812 9813 -- For a retrieval of a subcomponent of some composite object, 9814 -- retrieve the ultimate entity if there is one. 9815 9816 elsif Nkind_In (New_Prefix, N_Selected_Component, 9817 N_Indexed_Component) 9818 then 9819 Pref := Prefix (New_Prefix); 9820 while Present (Pref) 9821 and then Nkind_In (Pref, N_Selected_Component, 9822 N_Indexed_Component) 9823 loop 9824 Pref := Prefix (Pref); 9825 end loop; 9826 9827 if Present (Pref) and then Is_Entity_Name (Pref) then 9828 Ent := Entity (Pref); 9829 end if; 9830 end if; 9831 9832 -- Place the reference on the entity node 9833 9834 if Present (Ent) then 9835 Generate_Reference (Ent, Pref); 9836 end if; 9837 end if; 9838 end Insert_Explicit_Dereference; 9839 9840 ------------------------------------------ 9841 -- Inspect_Deferred_Constant_Completion -- 9842 ------------------------------------------ 9843 9844 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 9845 Decl : Node_Id; 9846 9847 begin 9848 Decl := First (Decls); 9849 while Present (Decl) loop 9850 9851 -- Deferred constant signature 9852 9853 if Nkind (Decl) = N_Object_Declaration 9854 and then Constant_Present (Decl) 9855 and then No (Expression (Decl)) 9856 9857 -- No need to check internally generated constants 9858 9859 and then Comes_From_Source (Decl) 9860 9861 -- The constant is not completed. A full object declaration or a 9862 -- pragma Import complete a deferred constant. 9863 9864 and then not Has_Completion (Defining_Identifier (Decl)) 9865 then 9866 Error_Msg_N 9867 ("constant declaration requires initialization expression", 9868 Defining_Identifier (Decl)); 9869 end if; 9870 9871 Decl := Next (Decl); 9872 end loop; 9873 end Inspect_Deferred_Constant_Completion; 9874 9875 ----------------------------- 9876 -- Install_Generic_Formals -- 9877 ----------------------------- 9878 9879 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 9880 E : Entity_Id; 9881 9882 begin 9883 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 9884 9885 E := First_Entity (Subp_Id); 9886 while Present (E) loop 9887 Install_Entity (E); 9888 Next_Entity (E); 9889 end loop; 9890 end Install_Generic_Formals; 9891 9892 ----------------------------- 9893 -- Is_Actual_Out_Parameter -- 9894 ----------------------------- 9895 9896 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 9897 Formal : Entity_Id; 9898 Call : Node_Id; 9899 begin 9900 Find_Actual (N, Formal, Call); 9901 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 9902 end Is_Actual_Out_Parameter; 9903 9904 ------------------------- 9905 -- Is_Actual_Parameter -- 9906 ------------------------- 9907 9908 function Is_Actual_Parameter (N : Node_Id) return Boolean is 9909 PK : constant Node_Kind := Nkind (Parent (N)); 9910 9911 begin 9912 case PK is 9913 when N_Parameter_Association => 9914 return N = Explicit_Actual_Parameter (Parent (N)); 9915 9916 when N_Subprogram_Call => 9917 return Is_List_Member (N) 9918 and then 9919 List_Containing (N) = Parameter_Associations (Parent (N)); 9920 9921 when others => 9922 return False; 9923 end case; 9924 end Is_Actual_Parameter; 9925 9926 -------------------------------- 9927 -- Is_Actual_Tagged_Parameter -- 9928 -------------------------------- 9929 9930 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 9931 Formal : Entity_Id; 9932 Call : Node_Id; 9933 begin 9934 Find_Actual (N, Formal, Call); 9935 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 9936 end Is_Actual_Tagged_Parameter; 9937 9938 --------------------- 9939 -- Is_Aliased_View -- 9940 --------------------- 9941 9942 function Is_Aliased_View (Obj : Node_Id) return Boolean is 9943 E : Entity_Id; 9944 9945 begin 9946 if Is_Entity_Name (Obj) then 9947 E := Entity (Obj); 9948 9949 return 9950 (Is_Object (E) 9951 and then 9952 (Is_Aliased (E) 9953 or else (Present (Renamed_Object (E)) 9954 and then Is_Aliased_View (Renamed_Object (E))))) 9955 9956 or else ((Is_Formal (E) 9957 or else Ekind_In (E, E_Generic_In_Out_Parameter, 9958 E_Generic_In_Parameter)) 9959 and then Is_Tagged_Type (Etype (E))) 9960 9961 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 9962 9963 -- Current instance of type, either directly or as rewritten 9964 -- reference to the current object. 9965 9966 or else (Is_Entity_Name (Original_Node (Obj)) 9967 and then Present (Entity (Original_Node (Obj))) 9968 and then Is_Type (Entity (Original_Node (Obj)))) 9969 9970 or else (Is_Type (E) and then E = Current_Scope) 9971 9972 or else (Is_Incomplete_Or_Private_Type (E) 9973 and then Full_View (E) = Current_Scope) 9974 9975 -- Ada 2012 AI05-0053: the return object of an extended return 9976 -- statement is aliased if its type is immutably limited. 9977 9978 or else (Is_Return_Object (E) 9979 and then Is_Limited_View (Etype (E))); 9980 9981 elsif Nkind (Obj) = N_Selected_Component then 9982 return Is_Aliased (Entity (Selector_Name (Obj))); 9983 9984 elsif Nkind (Obj) = N_Indexed_Component then 9985 return Has_Aliased_Components (Etype (Prefix (Obj))) 9986 or else 9987 (Is_Access_Type (Etype (Prefix (Obj))) 9988 and then Has_Aliased_Components 9989 (Designated_Type (Etype (Prefix (Obj))))); 9990 9991 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 9992 return Is_Tagged_Type (Etype (Obj)) 9993 and then Is_Aliased_View (Expression (Obj)); 9994 9995 elsif Nkind (Obj) = N_Explicit_Dereference then 9996 return Nkind (Original_Node (Obj)) /= N_Function_Call; 9997 9998 else 9999 return False; 10000 end if; 10001 end Is_Aliased_View; 10002 10003 ------------------------- 10004 -- Is_Ancestor_Package -- 10005 ------------------------- 10006 10007 function Is_Ancestor_Package 10008 (E1 : Entity_Id; 10009 E2 : Entity_Id) return Boolean 10010 is 10011 Par : Entity_Id; 10012 10013 begin 10014 Par := E2; 10015 while Present (Par) and then Par /= Standard_Standard loop 10016 if Par = E1 then 10017 return True; 10018 end if; 10019 10020 Par := Scope (Par); 10021 end loop; 10022 10023 return False; 10024 end Is_Ancestor_Package; 10025 10026 ---------------------- 10027 -- Is_Atomic_Object -- 10028 ---------------------- 10029 10030 function Is_Atomic_Object (N : Node_Id) return Boolean is 10031 10032 function Object_Has_Atomic_Components (N : Node_Id) return Boolean; 10033 -- Determines if given object has atomic components 10034 10035 function Is_Atomic_Prefix (N : Node_Id) return Boolean; 10036 -- If prefix is an implicit dereference, examine designated type 10037 10038 ---------------------- 10039 -- Is_Atomic_Prefix -- 10040 ---------------------- 10041 10042 function Is_Atomic_Prefix (N : Node_Id) return Boolean is 10043 begin 10044 if Is_Access_Type (Etype (N)) then 10045 return 10046 Has_Atomic_Components (Designated_Type (Etype (N))); 10047 else 10048 return Object_Has_Atomic_Components (N); 10049 end if; 10050 end Is_Atomic_Prefix; 10051 10052 ---------------------------------- 10053 -- Object_Has_Atomic_Components -- 10054 ---------------------------------- 10055 10056 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is 10057 begin 10058 if Has_Atomic_Components (Etype (N)) 10059 or else Is_Atomic (Etype (N)) 10060 then 10061 return True; 10062 10063 elsif Is_Entity_Name (N) 10064 and then (Has_Atomic_Components (Entity (N)) 10065 or else Is_Atomic (Entity (N))) 10066 then 10067 return True; 10068 10069 elsif Nkind (N) = N_Selected_Component 10070 and then Is_Atomic (Entity (Selector_Name (N))) 10071 then 10072 return True; 10073 10074 elsif Nkind (N) = N_Indexed_Component 10075 or else Nkind (N) = N_Selected_Component 10076 then 10077 return Is_Atomic_Prefix (Prefix (N)); 10078 10079 else 10080 return False; 10081 end if; 10082 end Object_Has_Atomic_Components; 10083 10084 -- Start of processing for Is_Atomic_Object 10085 10086 begin 10087 -- Predicate is not relevant to subprograms 10088 10089 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then 10090 return False; 10091 10092 elsif Is_Atomic (Etype (N)) 10093 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) 10094 then 10095 return True; 10096 10097 elsif Nkind (N) = N_Selected_Component 10098 and then Is_Atomic (Entity (Selector_Name (N))) 10099 then 10100 return True; 10101 10102 elsif Nkind (N) = N_Indexed_Component 10103 or else Nkind (N) = N_Selected_Component 10104 then 10105 return Is_Atomic_Prefix (Prefix (N)); 10106 10107 else 10108 return False; 10109 end if; 10110 end Is_Atomic_Object; 10111 10112 ------------------------- 10113 -- Is_Attribute_Result -- 10114 ------------------------- 10115 10116 function Is_Attribute_Result (N : Node_Id) return Boolean is 10117 begin 10118 return Nkind (N) = N_Attribute_Reference 10119 and then Attribute_Name (N) = Name_Result; 10120 end Is_Attribute_Result; 10121 10122 ------------------------------------ 10123 -- Is_Body_Or_Package_Declaration -- 10124 ------------------------------------ 10125 10126 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 10127 begin 10128 return Nkind_In (N, N_Entry_Body, 10129 N_Package_Body, 10130 N_Package_Declaration, 10131 N_Protected_Body, 10132 N_Subprogram_Body, 10133 N_Task_Body); 10134 end Is_Body_Or_Package_Declaration; 10135 10136 ----------------------- 10137 -- Is_Bounded_String -- 10138 ----------------------- 10139 10140 function Is_Bounded_String (T : Entity_Id) return Boolean is 10141 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 10142 10143 begin 10144 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 10145 -- Super_String, or one of the [Wide_]Wide_ versions. This will 10146 -- be True for all the Bounded_String types in instances of the 10147 -- Generic_Bounded_Length generics, and for types derived from those. 10148 10149 return Present (Under) 10150 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 10151 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 10152 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 10153 end Is_Bounded_String; 10154 10155 ------------------------- 10156 -- Is_Child_Or_Sibling -- 10157 ------------------------- 10158 10159 function Is_Child_Or_Sibling 10160 (Pack_1 : Entity_Id; 10161 Pack_2 : Entity_Id) return Boolean 10162 is 10163 function Distance_From_Standard (Pack : Entity_Id) return Nat; 10164 -- Given an arbitrary package, return the number of "climbs" necessary 10165 -- to reach scope Standard_Standard. 10166 10167 procedure Equalize_Depths 10168 (Pack : in out Entity_Id; 10169 Depth : in out Nat; 10170 Depth_To_Reach : Nat); 10171 -- Given an arbitrary package, its depth and a target depth to reach, 10172 -- climb the scope chain until the said depth is reached. The pointer 10173 -- to the package and its depth a modified during the climb. 10174 10175 ---------------------------- 10176 -- Distance_From_Standard -- 10177 ---------------------------- 10178 10179 function Distance_From_Standard (Pack : Entity_Id) return Nat is 10180 Dist : Nat; 10181 Scop : Entity_Id; 10182 10183 begin 10184 Dist := 0; 10185 Scop := Pack; 10186 while Present (Scop) and then Scop /= Standard_Standard loop 10187 Dist := Dist + 1; 10188 Scop := Scope (Scop); 10189 end loop; 10190 10191 return Dist; 10192 end Distance_From_Standard; 10193 10194 --------------------- 10195 -- Equalize_Depths -- 10196 --------------------- 10197 10198 procedure Equalize_Depths 10199 (Pack : in out Entity_Id; 10200 Depth : in out Nat; 10201 Depth_To_Reach : Nat) 10202 is 10203 begin 10204 -- The package must be at a greater or equal depth 10205 10206 if Depth < Depth_To_Reach then 10207 raise Program_Error; 10208 end if; 10209 10210 -- Climb the scope chain until the desired depth is reached 10211 10212 while Present (Pack) and then Depth /= Depth_To_Reach loop 10213 Pack := Scope (Pack); 10214 Depth := Depth - 1; 10215 end loop; 10216 end Equalize_Depths; 10217 10218 -- Local variables 10219 10220 P_1 : Entity_Id := Pack_1; 10221 P_1_Child : Boolean := False; 10222 P_1_Depth : Nat := Distance_From_Standard (P_1); 10223 P_2 : Entity_Id := Pack_2; 10224 P_2_Child : Boolean := False; 10225 P_2_Depth : Nat := Distance_From_Standard (P_2); 10226 10227 -- Start of processing for Is_Child_Or_Sibling 10228 10229 begin 10230 pragma Assert 10231 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 10232 10233 -- Both packages denote the same entity, therefore they cannot be 10234 -- children or siblings. 10235 10236 if P_1 = P_2 then 10237 return False; 10238 10239 -- One of the packages is at a deeper level than the other. Note that 10240 -- both may still come from differen hierarchies. 10241 10242 -- (root) P_2 10243 -- / \ : 10244 -- X P_2 or X 10245 -- : : 10246 -- P_1 P_1 10247 10248 elsif P_1_Depth > P_2_Depth then 10249 Equalize_Depths 10250 (Pack => P_1, 10251 Depth => P_1_Depth, 10252 Depth_To_Reach => P_2_Depth); 10253 P_1_Child := True; 10254 10255 -- (root) P_1 10256 -- / \ : 10257 -- P_1 X or X 10258 -- : : 10259 -- P_2 P_2 10260 10261 elsif P_2_Depth > P_1_Depth then 10262 Equalize_Depths 10263 (Pack => P_2, 10264 Depth => P_2_Depth, 10265 Depth_To_Reach => P_1_Depth); 10266 P_2_Child := True; 10267 end if; 10268 10269 -- At this stage the package pointers have been elevated to the same 10270 -- depth. If the related entities are the same, then one package is a 10271 -- potential child of the other: 10272 10273 -- P_1 10274 -- : 10275 -- X became P_1 P_2 or vica versa 10276 -- : 10277 -- P_2 10278 10279 if P_1 = P_2 then 10280 if P_1_Child then 10281 return Is_Child_Unit (Pack_1); 10282 10283 else pragma Assert (P_2_Child); 10284 return Is_Child_Unit (Pack_2); 10285 end if; 10286 10287 -- The packages may come from the same package chain or from entirely 10288 -- different hierarcies. To determine this, climb the scope stack until 10289 -- a common root is found. 10290 10291 -- (root) (root 1) (root 2) 10292 -- / \ | | 10293 -- P_1 P_2 P_1 P_2 10294 10295 else 10296 while Present (P_1) and then Present (P_2) loop 10297 10298 -- The two packages may be siblings 10299 10300 if P_1 = P_2 then 10301 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 10302 end if; 10303 10304 P_1 := Scope (P_1); 10305 P_2 := Scope (P_2); 10306 end loop; 10307 end if; 10308 10309 return False; 10310 end Is_Child_Or_Sibling; 10311 10312 ----------------------------- 10313 -- Is_Concurrent_Interface -- 10314 ----------------------------- 10315 10316 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 10317 begin 10318 return Is_Interface (T) 10319 and then 10320 (Is_Protected_Interface (T) 10321 or else Is_Synchronized_Interface (T) 10322 or else Is_Task_Interface (T)); 10323 end Is_Concurrent_Interface; 10324 10325 --------------------------- 10326 -- Is_Container_Element -- 10327 --------------------------- 10328 10329 function Is_Container_Element (Exp : Node_Id) return Boolean is 10330 Loc : constant Source_Ptr := Sloc (Exp); 10331 Pref : constant Node_Id := Prefix (Exp); 10332 10333 Call : Node_Id; 10334 -- Call to an indexing aspect 10335 10336 Cont_Typ : Entity_Id; 10337 -- The type of the container being accessed 10338 10339 Elem_Typ : Entity_Id; 10340 -- Its element type 10341 10342 Indexing : Entity_Id; 10343 Is_Const : Boolean; 10344 -- Indicates that constant indexing is used, and the element is thus 10345 -- a constant. 10346 10347 Ref_Typ : Entity_Id; 10348 -- The reference type returned by the indexing operation 10349 10350 begin 10351 -- If C is a container, in a context that imposes the element type of 10352 -- that container, the indexing notation C (X) is rewritten as: 10353 10354 -- Indexing (C, X).Discr.all 10355 10356 -- where Indexing is one of the indexing aspects of the container. 10357 -- If the context does not require a reference, the construct can be 10358 -- rewritten as 10359 10360 -- Element (C, X) 10361 10362 -- First, verify that the construct has the proper form 10363 10364 if not Expander_Active then 10365 return False; 10366 10367 elsif Nkind (Pref) /= N_Selected_Component then 10368 return False; 10369 10370 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 10371 return False; 10372 10373 else 10374 Call := Prefix (Pref); 10375 Ref_Typ := Etype (Call); 10376 end if; 10377 10378 if not Has_Implicit_Dereference (Ref_Typ) 10379 or else No (First (Parameter_Associations (Call))) 10380 or else not Is_Entity_Name (Name (Call)) 10381 then 10382 return False; 10383 end if; 10384 10385 -- Retrieve type of container object, and its iterator aspects 10386 10387 Cont_Typ := Etype (First (Parameter_Associations (Call))); 10388 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 10389 Is_Const := False; 10390 10391 if No (Indexing) then 10392 10393 -- Container should have at least one indexing operation 10394 10395 return False; 10396 10397 elsif Entity (Name (Call)) /= Entity (Indexing) then 10398 10399 -- This may be a variable indexing operation 10400 10401 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 10402 10403 if No (Indexing) 10404 or else Entity (Name (Call)) /= Entity (Indexing) 10405 then 10406 return False; 10407 end if; 10408 10409 else 10410 Is_Const := True; 10411 end if; 10412 10413 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 10414 10415 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 10416 return False; 10417 end if; 10418 10419 -- Check that the expression is not the target of an assignment, in 10420 -- which case the rewriting is not possible. 10421 10422 if not Is_Const then 10423 declare 10424 Par : Node_Id; 10425 10426 begin 10427 Par := Exp; 10428 while Present (Par) 10429 loop 10430 if Nkind (Parent (Par)) = N_Assignment_Statement 10431 and then Par = Name (Parent (Par)) 10432 then 10433 return False; 10434 10435 -- A renaming produces a reference, and the transformation 10436 -- does not apply. 10437 10438 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 10439 return False; 10440 10441 elsif Nkind_In 10442 (Nkind (Parent (Par)), N_Function_Call, 10443 N_Procedure_Call_Statement, 10444 N_Entry_Call_Statement) 10445 then 10446 -- Check that the element is not part of an actual for an 10447 -- in-out parameter. 10448 10449 declare 10450 F : Entity_Id; 10451 A : Node_Id; 10452 10453 begin 10454 F := First_Formal (Entity (Name (Parent (Par)))); 10455 A := First (Parameter_Associations (Parent (Par))); 10456 while Present (F) loop 10457 if A = Par and then Ekind (F) /= E_In_Parameter then 10458 return False; 10459 end if; 10460 10461 Next_Formal (F); 10462 Next (A); 10463 end loop; 10464 end; 10465 10466 -- E_In_Parameter in a call: element is not modified. 10467 10468 exit; 10469 end if; 10470 10471 Par := Parent (Par); 10472 end loop; 10473 end; 10474 end if; 10475 10476 -- The expression has the proper form and the context requires the 10477 -- element type. Retrieve the Element function of the container and 10478 -- rewrite the construct as a call to it. 10479 10480 declare 10481 Op : Elmt_Id; 10482 10483 begin 10484 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 10485 while Present (Op) loop 10486 exit when Chars (Node (Op)) = Name_Element; 10487 Next_Elmt (Op); 10488 end loop; 10489 10490 if No (Op) then 10491 return False; 10492 10493 else 10494 Rewrite (Exp, 10495 Make_Function_Call (Loc, 10496 Name => New_Occurrence_Of (Node (Op), Loc), 10497 Parameter_Associations => Parameter_Associations (Call))); 10498 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 10499 return True; 10500 end if; 10501 end; 10502 end Is_Container_Element; 10503 10504 ----------------------- 10505 -- Is_Constant_Bound -- 10506 ----------------------- 10507 10508 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 10509 begin 10510 if Compile_Time_Known_Value (Exp) then 10511 return True; 10512 10513 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 10514 return Is_Constant_Object (Entity (Exp)) 10515 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 10516 10517 elsif Nkind (Exp) in N_Binary_Op then 10518 return Is_Constant_Bound (Left_Opnd (Exp)) 10519 and then Is_Constant_Bound (Right_Opnd (Exp)) 10520 and then Scope (Entity (Exp)) = Standard_Standard; 10521 10522 else 10523 return False; 10524 end if; 10525 end Is_Constant_Bound; 10526 10527 -------------------------------------- 10528 -- Is_Controlling_Limited_Procedure -- 10529 -------------------------------------- 10530 10531 function Is_Controlling_Limited_Procedure 10532 (Proc_Nam : Entity_Id) return Boolean 10533 is 10534 Param_Typ : Entity_Id := Empty; 10535 10536 begin 10537 if Ekind (Proc_Nam) = E_Procedure 10538 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 10539 then 10540 Param_Typ := Etype (Parameter_Type (First ( 10541 Parameter_Specifications (Parent (Proc_Nam))))); 10542 10543 -- In this case where an Itype was created, the procedure call has been 10544 -- rewritten. 10545 10546 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 10547 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 10548 and then 10549 Present (Parameter_Associations 10550 (Associated_Node_For_Itype (Proc_Nam))) 10551 then 10552 Param_Typ := 10553 Etype (First (Parameter_Associations 10554 (Associated_Node_For_Itype (Proc_Nam)))); 10555 end if; 10556 10557 if Present (Param_Typ) then 10558 return 10559 Is_Interface (Param_Typ) 10560 and then Is_Limited_Record (Param_Typ); 10561 end if; 10562 10563 return False; 10564 end Is_Controlling_Limited_Procedure; 10565 10566 ----------------------------- 10567 -- Is_CPP_Constructor_Call -- 10568 ----------------------------- 10569 10570 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 10571 begin 10572 return Nkind (N) = N_Function_Call 10573 and then Is_CPP_Class (Etype (Etype (N))) 10574 and then Is_Constructor (Entity (Name (N))) 10575 and then Is_Imported (Entity (Name (N))); 10576 end Is_CPP_Constructor_Call; 10577 10578 -------------------- 10579 -- Is_Declaration -- 10580 -------------------- 10581 10582 function Is_Declaration (N : Node_Id) return Boolean is 10583 begin 10584 case Nkind (N) is 10585 when N_Abstract_Subprogram_Declaration | 10586 N_Exception_Declaration | 10587 N_Exception_Renaming_Declaration | 10588 N_Full_Type_Declaration | 10589 N_Generic_Function_Renaming_Declaration | 10590 N_Generic_Package_Declaration | 10591 N_Generic_Package_Renaming_Declaration | 10592 N_Generic_Procedure_Renaming_Declaration | 10593 N_Generic_Subprogram_Declaration | 10594 N_Number_Declaration | 10595 N_Object_Declaration | 10596 N_Object_Renaming_Declaration | 10597 N_Package_Declaration | 10598 N_Package_Renaming_Declaration | 10599 N_Private_Extension_Declaration | 10600 N_Private_Type_Declaration | 10601 N_Subprogram_Declaration | 10602 N_Subprogram_Renaming_Declaration | 10603 N_Subtype_Declaration => 10604 return True; 10605 10606 when others => 10607 return False; 10608 end case; 10609 end Is_Declaration; 10610 10611 ----------------- 10612 -- Is_Delegate -- 10613 ----------------- 10614 10615 function Is_Delegate (T : Entity_Id) return Boolean is 10616 Desig_Type : Entity_Id; 10617 10618 begin 10619 if VM_Target /= CLI_Target then 10620 return False; 10621 end if; 10622 10623 -- Access-to-subprograms are delegates in CIL 10624 10625 if Ekind (T) = E_Access_Subprogram_Type then 10626 return True; 10627 end if; 10628 10629 if not Is_Access_Type (T) then 10630 10631 -- A delegate is a managed pointer. If no designated type is defined 10632 -- it means that it's not a delegate. 10633 10634 return False; 10635 end if; 10636 10637 Desig_Type := Etype (Directly_Designated_Type (T)); 10638 10639 if not Is_Tagged_Type (Desig_Type) then 10640 return False; 10641 end if; 10642 10643 -- Test if the type is inherited from [mscorlib]System.Delegate 10644 10645 while Etype (Desig_Type) /= Desig_Type loop 10646 if Chars (Scope (Desig_Type)) /= No_Name 10647 and then Is_Imported (Scope (Desig_Type)) 10648 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" 10649 then 10650 return True; 10651 end if; 10652 10653 Desig_Type := Etype (Desig_Type); 10654 end loop; 10655 10656 return False; 10657 end Is_Delegate; 10658 10659 ---------------------------------------------- 10660 -- Is_Dependent_Component_Of_Mutable_Object -- 10661 ---------------------------------------------- 10662 10663 function Is_Dependent_Component_Of_Mutable_Object 10664 (Object : Node_Id) return Boolean 10665 is 10666 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; 10667 -- Returns True if and only if Comp is declared within a variant part 10668 10669 -------------------------------- 10670 -- Is_Declared_Within_Variant -- 10671 -------------------------------- 10672 10673 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 10674 Comp_Decl : constant Node_Id := Parent (Comp); 10675 Comp_List : constant Node_Id := Parent (Comp_Decl); 10676 begin 10677 return Nkind (Parent (Comp_List)) = N_Variant; 10678 end Is_Declared_Within_Variant; 10679 10680 P : Node_Id; 10681 Prefix_Type : Entity_Id; 10682 P_Aliased : Boolean := False; 10683 Comp : Entity_Id; 10684 10685 Deref : Node_Id := Object; 10686 -- Dereference node, in something like X.all.Y(2) 10687 10688 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 10689 10690 begin 10691 -- Find the dereference node if any 10692 10693 while Nkind_In (Deref, N_Indexed_Component, 10694 N_Selected_Component, 10695 N_Slice) 10696 loop 10697 Deref := Prefix (Deref); 10698 end loop; 10699 10700 -- Ada 2005: If we have a component or slice of a dereference, 10701 -- something like X.all.Y (2), and the type of X is access-to-constant, 10702 -- Is_Variable will return False, because it is indeed a constant 10703 -- view. But it might be a view of a variable object, so we want the 10704 -- following condition to be True in that case. 10705 10706 if Is_Variable (Object) 10707 or else (Ada_Version >= Ada_2005 10708 and then Nkind (Deref) = N_Explicit_Dereference) 10709 then 10710 if Nkind (Object) = N_Selected_Component then 10711 P := Prefix (Object); 10712 Prefix_Type := Etype (P); 10713 10714 if Is_Entity_Name (P) then 10715 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 10716 Prefix_Type := Base_Type (Prefix_Type); 10717 end if; 10718 10719 if Is_Aliased (Entity (P)) then 10720 P_Aliased := True; 10721 end if; 10722 10723 -- A discriminant check on a selected component may be expanded 10724 -- into a dereference when removing side-effects. Recover the 10725 -- original node and its type, which may be unconstrained. 10726 10727 elsif Nkind (P) = N_Explicit_Dereference 10728 and then not (Comes_From_Source (P)) 10729 then 10730 P := Original_Node (P); 10731 Prefix_Type := Etype (P); 10732 10733 else 10734 -- Check for prefix being an aliased component??? 10735 10736 null; 10737 10738 end if; 10739 10740 -- A heap object is constrained by its initial value 10741 10742 -- Ada 2005 (AI-363): Always assume the object could be mutable in 10743 -- the dereferenced case, since the access value might denote an 10744 -- unconstrained aliased object, whereas in Ada 95 the designated 10745 -- object is guaranteed to be constrained. A worst-case assumption 10746 -- has to apply in Ada 2005 because we can't tell at compile 10747 -- time whether the object is "constrained by its initial value" 10748 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 10749 -- rules (these rules are acknowledged to need fixing). 10750 10751 if Ada_Version < Ada_2005 then 10752 if Is_Access_Type (Prefix_Type) 10753 or else Nkind (P) = N_Explicit_Dereference 10754 then 10755 return False; 10756 end if; 10757 10758 else pragma Assert (Ada_Version >= Ada_2005); 10759 if Is_Access_Type (Prefix_Type) then 10760 10761 -- If the access type is pool-specific, and there is no 10762 -- constrained partial view of the designated type, then the 10763 -- designated object is known to be constrained. 10764 10765 if Ekind (Prefix_Type) = E_Access_Type 10766 and then not Object_Type_Has_Constrained_Partial_View 10767 (Typ => Designated_Type (Prefix_Type), 10768 Scop => Current_Scope) 10769 then 10770 return False; 10771 10772 -- Otherwise (general access type, or there is a constrained 10773 -- partial view of the designated type), we need to check 10774 -- based on the designated type. 10775 10776 else 10777 Prefix_Type := Designated_Type (Prefix_Type); 10778 end if; 10779 end if; 10780 end if; 10781 10782 Comp := 10783 Original_Record_Component (Entity (Selector_Name (Object))); 10784 10785 -- As per AI-0017, the renaming is illegal in a generic body, even 10786 -- if the subtype is indefinite. 10787 10788 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 10789 10790 if not Is_Constrained (Prefix_Type) 10791 and then (not Is_Indefinite_Subtype (Prefix_Type) 10792 or else 10793 (Is_Generic_Type (Prefix_Type) 10794 and then Ekind (Current_Scope) = E_Generic_Package 10795 and then In_Package_Body (Current_Scope))) 10796 10797 and then (Is_Declared_Within_Variant (Comp) 10798 or else Has_Discriminant_Dependent_Constraint (Comp)) 10799 and then (not P_Aliased or else Ada_Version >= Ada_2005) 10800 then 10801 return True; 10802 10803 -- If the prefix is of an access type at this point, then we want 10804 -- to return False, rather than calling this function recursively 10805 -- on the access object (which itself might be a discriminant- 10806 -- dependent component of some other object, but that isn't 10807 -- relevant to checking the object passed to us). This avoids 10808 -- issuing wrong errors when compiling with -gnatc, where there 10809 -- can be implicit dereferences that have not been expanded. 10810 10811 elsif Is_Access_Type (Etype (Prefix (Object))) then 10812 return False; 10813 10814 else 10815 return 10816 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 10817 end if; 10818 10819 elsif Nkind (Object) = N_Indexed_Component 10820 or else Nkind (Object) = N_Slice 10821 then 10822 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 10823 10824 -- A type conversion that Is_Variable is a view conversion: 10825 -- go back to the denoted object. 10826 10827 elsif Nkind (Object) = N_Type_Conversion then 10828 return 10829 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 10830 end if; 10831 end if; 10832 10833 return False; 10834 end Is_Dependent_Component_Of_Mutable_Object; 10835 10836 --------------------- 10837 -- Is_Dereferenced -- 10838 --------------------- 10839 10840 function Is_Dereferenced (N : Node_Id) return Boolean is 10841 P : constant Node_Id := Parent (N); 10842 begin 10843 return Nkind_In (P, N_Selected_Component, 10844 N_Explicit_Dereference, 10845 N_Indexed_Component, 10846 N_Slice) 10847 and then Prefix (P) = N; 10848 end Is_Dereferenced; 10849 10850 ---------------------- 10851 -- Is_Descendent_Of -- 10852 ---------------------- 10853 10854 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 10855 T : Entity_Id; 10856 Etyp : Entity_Id; 10857 10858 begin 10859 pragma Assert (Nkind (T1) in N_Entity); 10860 pragma Assert (Nkind (T2) in N_Entity); 10861 10862 T := Base_Type (T1); 10863 10864 -- Immediate return if the types match 10865 10866 if T = T2 then 10867 return True; 10868 10869 -- Comment needed here ??? 10870 10871 elsif Ekind (T) = E_Class_Wide_Type then 10872 return Etype (T) = T2; 10873 10874 -- All other cases 10875 10876 else 10877 loop 10878 Etyp := Etype (T); 10879 10880 -- Done if we found the type we are looking for 10881 10882 if Etyp = T2 then 10883 return True; 10884 10885 -- Done if no more derivations to check 10886 10887 elsif T = T1 10888 or else T = Etyp 10889 then 10890 return False; 10891 10892 -- Following test catches error cases resulting from prev errors 10893 10894 elsif No (Etyp) then 10895 return False; 10896 10897 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 10898 return False; 10899 10900 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 10901 return False; 10902 end if; 10903 10904 T := Base_Type (Etyp); 10905 end loop; 10906 end if; 10907 end Is_Descendent_Of; 10908 10909 ----------------------------- 10910 -- Is_Effectively_Volatile -- 10911 ----------------------------- 10912 10913 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is 10914 begin 10915 if Is_Type (Id) then 10916 10917 -- An arbitrary type is effectively volatile when it is subject to 10918 -- pragma Atomic or Volatile. 10919 10920 if Is_Volatile (Id) then 10921 return True; 10922 10923 -- An array type is effectively volatile when it is subject to pragma 10924 -- Atomic_Components or Volatile_Components or its compolent type is 10925 -- effectively volatile. 10926 10927 elsif Is_Array_Type (Id) then 10928 return 10929 Has_Volatile_Components (Id) 10930 or else 10931 Is_Effectively_Volatile (Component_Type (Base_Type (Id))); 10932 10933 else 10934 return False; 10935 end if; 10936 10937 -- Otherwise Id denotes an object 10938 10939 else 10940 return 10941 Is_Volatile (Id) 10942 or else Has_Volatile_Components (Id) 10943 or else Is_Effectively_Volatile (Etype (Id)); 10944 end if; 10945 end Is_Effectively_Volatile; 10946 10947 ------------------------------------ 10948 -- Is_Effectively_Volatile_Object -- 10949 ------------------------------------ 10950 10951 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 10952 begin 10953 if Is_Entity_Name (N) then 10954 return Is_Effectively_Volatile (Entity (N)); 10955 10956 elsif Nkind (N) = N_Expanded_Name then 10957 return Is_Effectively_Volatile (Entity (N)); 10958 10959 elsif Nkind (N) = N_Indexed_Component then 10960 return Is_Effectively_Volatile_Object (Prefix (N)); 10961 10962 elsif Nkind (N) = N_Selected_Component then 10963 return 10964 Is_Effectively_Volatile_Object (Prefix (N)) 10965 or else 10966 Is_Effectively_Volatile_Object (Selector_Name (N)); 10967 10968 else 10969 return False; 10970 end if; 10971 end Is_Effectively_Volatile_Object; 10972 10973 ---------------------------- 10974 -- Is_Expression_Function -- 10975 ---------------------------- 10976 10977 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 10978 Decl : Node_Id; 10979 10980 begin 10981 if Ekind (Subp) /= E_Function then 10982 return False; 10983 10984 else 10985 Decl := Unit_Declaration_Node (Subp); 10986 return Nkind (Decl) = N_Subprogram_Declaration 10987 and then 10988 (Nkind (Original_Node (Decl)) = N_Expression_Function 10989 or else 10990 (Present (Corresponding_Body (Decl)) 10991 and then 10992 Nkind (Original_Node 10993 (Unit_Declaration_Node 10994 (Corresponding_Body (Decl)))) = 10995 N_Expression_Function)); 10996 end if; 10997 end Is_Expression_Function; 10998 10999 ----------------------- 11000 -- Is_EVF_Expression -- 11001 ----------------------- 11002 11003 function Is_EVF_Expression (N : Node_Id) return Boolean is 11004 Orig_N : constant Node_Id := Original_Node (N); 11005 Alt : Node_Id; 11006 Expr : Node_Id; 11007 Id : Entity_Id; 11008 11009 begin 11010 -- Detect a reference to a formal parameter of a specific tagged type 11011 -- whose related subprogram is subject to pragma Expresions_Visible with 11012 -- value "False". 11013 11014 if Is_Entity_Name (N) and then Present (Entity (N)) then 11015 Id := Entity (N); 11016 11017 return 11018 Is_Formal (Id) 11019 and then Is_Specific_Tagged_Type (Etype (Id)) 11020 and then Extensions_Visible_Status (Id) = 11021 Extensions_Visible_False; 11022 11023 -- A case expression is an EVF expression when it contains at least one 11024 -- EVF dependent_expression. Note that a case expression may have been 11025 -- expanded, hence the use of Original_Node. 11026 11027 elsif Nkind (Orig_N) = N_Case_Expression then 11028 Alt := First (Alternatives (Orig_N)); 11029 while Present (Alt) loop 11030 if Is_EVF_Expression (Expression (Alt)) then 11031 return True; 11032 end if; 11033 11034 Next (Alt); 11035 end loop; 11036 11037 -- An if expression is an EVF expression when it contains at least one 11038 -- EVF dependent_expression. Note that an if expression may have been 11039 -- expanded, hence the use of Original_Node. 11040 11041 elsif Nkind (Orig_N) = N_If_Expression then 11042 Expr := Next (First (Expressions (Orig_N))); 11043 while Present (Expr) loop 11044 if Is_EVF_Expression (Expr) then 11045 return True; 11046 end if; 11047 11048 Next (Expr); 11049 end loop; 11050 11051 -- A qualified expression or a type conversion is an EVF expression when 11052 -- its operand is an EVF expression. 11053 11054 elsif Nkind_In (N, N_Qualified_Expression, 11055 N_Unchecked_Type_Conversion, 11056 N_Type_Conversion) 11057 then 11058 return Is_EVF_Expression (Expression (N)); 11059 11060 -- Attributes 'Loop_Entry, 'Old and 'Update are an EVF expression when 11061 -- their prefix denotes an EVF expression. 11062 11063 elsif Nkind (N) = N_Attribute_Reference 11064 and then Nam_In (Attribute_Name (N), Name_Loop_Entry, 11065 Name_Old, 11066 Name_Update) 11067 then 11068 return Is_EVF_Expression (Prefix (N)); 11069 end if; 11070 11071 return False; 11072 end Is_EVF_Expression; 11073 11074 -------------- 11075 -- Is_False -- 11076 -------------- 11077 11078 function Is_False (U : Uint) return Boolean is 11079 begin 11080 return (U = 0); 11081 end Is_False; 11082 11083 --------------------------- 11084 -- Is_Fixed_Model_Number -- 11085 --------------------------- 11086 11087 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 11088 S : constant Ureal := Small_Value (T); 11089 M : Urealp.Save_Mark; 11090 R : Boolean; 11091 begin 11092 M := Urealp.Mark; 11093 R := (U = UR_Trunc (U / S) * S); 11094 Urealp.Release (M); 11095 return R; 11096 end Is_Fixed_Model_Number; 11097 11098 ------------------------------- 11099 -- Is_Fully_Initialized_Type -- 11100 ------------------------------- 11101 11102 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 11103 begin 11104 -- Scalar types 11105 11106 if Is_Scalar_Type (Typ) then 11107 11108 -- A scalar type with an aspect Default_Value is fully initialized 11109 11110 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 11111 -- of a scalar type, but we don't take that into account here, since 11112 -- we don't want these to affect warnings. 11113 11114 return Has_Default_Aspect (Typ); 11115 11116 elsif Is_Access_Type (Typ) then 11117 return True; 11118 11119 elsif Is_Array_Type (Typ) then 11120 if Is_Fully_Initialized_Type (Component_Type (Typ)) 11121 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 11122 then 11123 return True; 11124 end if; 11125 11126 -- An interesting case, if we have a constrained type one of whose 11127 -- bounds is known to be null, then there are no elements to be 11128 -- initialized, so all the elements are initialized. 11129 11130 if Is_Constrained (Typ) then 11131 declare 11132 Indx : Node_Id; 11133 Indx_Typ : Entity_Id; 11134 Lbd, Hbd : Node_Id; 11135 11136 begin 11137 Indx := First_Index (Typ); 11138 while Present (Indx) loop 11139 if Etype (Indx) = Any_Type then 11140 return False; 11141 11142 -- If index is a range, use directly 11143 11144 elsif Nkind (Indx) = N_Range then 11145 Lbd := Low_Bound (Indx); 11146 Hbd := High_Bound (Indx); 11147 11148 else 11149 Indx_Typ := Etype (Indx); 11150 11151 if Is_Private_Type (Indx_Typ) then 11152 Indx_Typ := Full_View (Indx_Typ); 11153 end if; 11154 11155 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 11156 return False; 11157 else 11158 Lbd := Type_Low_Bound (Indx_Typ); 11159 Hbd := Type_High_Bound (Indx_Typ); 11160 end if; 11161 end if; 11162 11163 if Compile_Time_Known_Value (Lbd) 11164 and then 11165 Compile_Time_Known_Value (Hbd) 11166 then 11167 if Expr_Value (Hbd) < Expr_Value (Lbd) then 11168 return True; 11169 end if; 11170 end if; 11171 11172 Next_Index (Indx); 11173 end loop; 11174 end; 11175 end if; 11176 11177 -- If no null indexes, then type is not fully initialized 11178 11179 return False; 11180 11181 -- Record types 11182 11183 elsif Is_Record_Type (Typ) then 11184 if Has_Discriminants (Typ) 11185 and then 11186 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 11187 and then Is_Fully_Initialized_Variant (Typ) 11188 then 11189 return True; 11190 end if; 11191 11192 -- We consider bounded string types to be fully initialized, because 11193 -- otherwise we get false alarms when the Data component is not 11194 -- default-initialized. 11195 11196 if Is_Bounded_String (Typ) then 11197 return True; 11198 end if; 11199 11200 -- Controlled records are considered to be fully initialized if 11201 -- there is a user defined Initialize routine. This may not be 11202 -- entirely correct, but as the spec notes, we are guessing here 11203 -- what is best from the point of view of issuing warnings. 11204 11205 if Is_Controlled (Typ) then 11206 declare 11207 Utyp : constant Entity_Id := Underlying_Type (Typ); 11208 11209 begin 11210 if Present (Utyp) then 11211 declare 11212 Init : constant Entity_Id := 11213 (Find_Prim_Op 11214 (Underlying_Type (Typ), Name_Initialize)); 11215 11216 begin 11217 if Present (Init) 11218 and then Comes_From_Source (Init) 11219 and then not 11220 Is_Predefined_File_Name 11221 (File_Name (Get_Source_File_Index (Sloc (Init)))) 11222 then 11223 return True; 11224 11225 elsif Has_Null_Extension (Typ) 11226 and then 11227 Is_Fully_Initialized_Type 11228 (Etype (Base_Type (Typ))) 11229 then 11230 return True; 11231 end if; 11232 end; 11233 end if; 11234 end; 11235 end if; 11236 11237 -- Otherwise see if all record components are initialized 11238 11239 declare 11240 Ent : Entity_Id; 11241 11242 begin 11243 Ent := First_Entity (Typ); 11244 while Present (Ent) loop 11245 if Ekind (Ent) = E_Component 11246 and then (No (Parent (Ent)) 11247 or else No (Expression (Parent (Ent)))) 11248 and then not Is_Fully_Initialized_Type (Etype (Ent)) 11249 11250 -- Special VM case for tag components, which need to be 11251 -- defined in this case, but are never initialized as VMs 11252 -- are using other dispatching mechanisms. Ignore this 11253 -- uninitialized case. Note that this applies both to the 11254 -- uTag entry and the main vtable pointer (CPP_Class case). 11255 11256 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 11257 then 11258 return False; 11259 end if; 11260 11261 Next_Entity (Ent); 11262 end loop; 11263 end; 11264 11265 -- No uninitialized components, so type is fully initialized. 11266 -- Note that this catches the case of no components as well. 11267 11268 return True; 11269 11270 elsif Is_Concurrent_Type (Typ) then 11271 return True; 11272 11273 elsif Is_Private_Type (Typ) then 11274 declare 11275 U : constant Entity_Id := Underlying_Type (Typ); 11276 11277 begin 11278 if No (U) then 11279 return False; 11280 else 11281 return Is_Fully_Initialized_Type (U); 11282 end if; 11283 end; 11284 11285 else 11286 return False; 11287 end if; 11288 end Is_Fully_Initialized_Type; 11289 11290 ---------------------------------- 11291 -- Is_Fully_Initialized_Variant -- 11292 ---------------------------------- 11293 11294 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 11295 Loc : constant Source_Ptr := Sloc (Typ); 11296 Constraints : constant List_Id := New_List; 11297 Components : constant Elist_Id := New_Elmt_List; 11298 Comp_Elmt : Elmt_Id; 11299 Comp_Id : Node_Id; 11300 Comp_List : Node_Id; 11301 Discr : Entity_Id; 11302 Discr_Val : Node_Id; 11303 11304 Report_Errors : Boolean; 11305 pragma Warnings (Off, Report_Errors); 11306 11307 begin 11308 if Serious_Errors_Detected > 0 then 11309 return False; 11310 end if; 11311 11312 if Is_Record_Type (Typ) 11313 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 11314 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 11315 then 11316 Comp_List := Component_List (Type_Definition (Parent (Typ))); 11317 11318 Discr := First_Discriminant (Typ); 11319 while Present (Discr) loop 11320 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 11321 Discr_Val := Expression (Parent (Discr)); 11322 11323 if Present (Discr_Val) 11324 and then Is_OK_Static_Expression (Discr_Val) 11325 then 11326 Append_To (Constraints, 11327 Make_Component_Association (Loc, 11328 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 11329 Expression => New_Copy (Discr_Val))); 11330 else 11331 return False; 11332 end if; 11333 else 11334 return False; 11335 end if; 11336 11337 Next_Discriminant (Discr); 11338 end loop; 11339 11340 Gather_Components 11341 (Typ => Typ, 11342 Comp_List => Comp_List, 11343 Governed_By => Constraints, 11344 Into => Components, 11345 Report_Errors => Report_Errors); 11346 11347 -- Check that each component present is fully initialized 11348 11349 Comp_Elmt := First_Elmt (Components); 11350 while Present (Comp_Elmt) loop 11351 Comp_Id := Node (Comp_Elmt); 11352 11353 if Ekind (Comp_Id) = E_Component 11354 and then (No (Parent (Comp_Id)) 11355 or else No (Expression (Parent (Comp_Id)))) 11356 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 11357 then 11358 return False; 11359 end if; 11360 11361 Next_Elmt (Comp_Elmt); 11362 end loop; 11363 11364 return True; 11365 11366 elsif Is_Private_Type (Typ) then 11367 declare 11368 U : constant Entity_Id := Underlying_Type (Typ); 11369 11370 begin 11371 if No (U) then 11372 return False; 11373 else 11374 return Is_Fully_Initialized_Variant (U); 11375 end if; 11376 end; 11377 11378 else 11379 return False; 11380 end if; 11381 end Is_Fully_Initialized_Variant; 11382 11383 ---------------------------- 11384 -- Is_Inherited_Operation -- 11385 ---------------------------- 11386 11387 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 11388 pragma Assert (Is_Overloadable (E)); 11389 Kind : constant Node_Kind := Nkind (Parent (E)); 11390 begin 11391 return Kind = N_Full_Type_Declaration 11392 or else Kind = N_Private_Extension_Declaration 11393 or else Kind = N_Subtype_Declaration 11394 or else (Ekind (E) = E_Enumeration_Literal 11395 and then Is_Derived_Type (Etype (E))); 11396 end Is_Inherited_Operation; 11397 11398 ------------------------------------- 11399 -- Is_Inherited_Operation_For_Type -- 11400 ------------------------------------- 11401 11402 function Is_Inherited_Operation_For_Type 11403 (E : Entity_Id; 11404 Typ : Entity_Id) return Boolean 11405 is 11406 begin 11407 -- Check that the operation has been created by the type declaration 11408 11409 return Is_Inherited_Operation (E) 11410 and then Defining_Identifier (Parent (E)) = Typ; 11411 end Is_Inherited_Operation_For_Type; 11412 11413 ----------------- 11414 -- Is_Iterator -- 11415 ----------------- 11416 11417 function Is_Iterator (Typ : Entity_Id) return Boolean is 11418 Ifaces_List : Elist_Id; 11419 Iface_Elmt : Elmt_Id; 11420 Iface : Entity_Id; 11421 11422 begin 11423 if Is_Class_Wide_Type (Typ) 11424 and then Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, 11425 Name_Reversible_Iterator) 11426 and then 11427 Is_Predefined_File_Name 11428 (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) 11429 then 11430 return True; 11431 11432 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 11433 return False; 11434 11435 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 11436 return True; 11437 11438 else 11439 Collect_Interfaces (Typ, Ifaces_List); 11440 11441 Iface_Elmt := First_Elmt (Ifaces_List); 11442 while Present (Iface_Elmt) loop 11443 Iface := Node (Iface_Elmt); 11444 if Chars (Iface) = Name_Forward_Iterator 11445 and then 11446 Is_Predefined_File_Name 11447 (Unit_File_Name (Get_Source_Unit (Iface))) 11448 then 11449 return True; 11450 end if; 11451 11452 Next_Elmt (Iface_Elmt); 11453 end loop; 11454 11455 return False; 11456 end if; 11457 end Is_Iterator; 11458 11459 ------------ 11460 -- Is_LHS -- 11461 ------------ 11462 11463 -- We seem to have a lot of overlapping functions that do similar things 11464 -- (testing for left hand sides or lvalues???). 11465 11466 function Is_LHS (N : Node_Id) return Is_LHS_Result is 11467 P : constant Node_Id := Parent (N); 11468 11469 begin 11470 -- Return True if we are the left hand side of an assignment statement 11471 11472 if Nkind (P) = N_Assignment_Statement then 11473 if Name (P) = N then 11474 return Yes; 11475 else 11476 return No; 11477 end if; 11478 11479 -- Case of prefix of indexed or selected component or slice 11480 11481 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 11482 and then N = Prefix (P) 11483 then 11484 -- Here we have the case where the parent P is N.Q or N(Q .. R). 11485 -- If P is an LHS, then N is also effectively an LHS, but there 11486 -- is an important exception. If N is of an access type, then 11487 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 11488 -- case this makes N.all a left hand side but not N itself. 11489 11490 -- If we don't know the type yet, this is the case where we return 11491 -- Unknown, since the answer depends on the type which is unknown. 11492 11493 if No (Etype (N)) then 11494 return Unknown; 11495 11496 -- We have an Etype set, so we can check it 11497 11498 elsif Is_Access_Type (Etype (N)) then 11499 return No; 11500 11501 -- OK, not access type case, so just test whole expression 11502 11503 else 11504 return Is_LHS (P); 11505 end if; 11506 11507 -- All other cases are not left hand sides 11508 11509 else 11510 return No; 11511 end if; 11512 end Is_LHS; 11513 11514 ----------------------------- 11515 -- Is_Library_Level_Entity -- 11516 ----------------------------- 11517 11518 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 11519 begin 11520 -- The following is a small optimization, and it also properly handles 11521 -- discriminals, which in task bodies might appear in expressions before 11522 -- the corresponding procedure has been created, and which therefore do 11523 -- not have an assigned scope. 11524 11525 if Is_Formal (E) then 11526 return False; 11527 end if; 11528 11529 -- Normal test is simply that the enclosing dynamic scope is Standard 11530 11531 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 11532 end Is_Library_Level_Entity; 11533 11534 -------------------------------- 11535 -- Is_Limited_Class_Wide_Type -- 11536 -------------------------------- 11537 11538 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 11539 begin 11540 return 11541 Is_Class_Wide_Type (Typ) 11542 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 11543 end Is_Limited_Class_Wide_Type; 11544 11545 --------------------------------- 11546 -- Is_Local_Variable_Reference -- 11547 --------------------------------- 11548 11549 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 11550 begin 11551 if not Is_Entity_Name (Expr) then 11552 return False; 11553 11554 else 11555 declare 11556 Ent : constant Entity_Id := Entity (Expr); 11557 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 11558 begin 11559 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 11560 return False; 11561 else 11562 return Present (Sub) and then Sub = Current_Subprogram; 11563 end if; 11564 end; 11565 end if; 11566 end Is_Local_Variable_Reference; 11567 11568 ------------------------- 11569 -- Is_Object_Reference -- 11570 ------------------------- 11571 11572 function Is_Object_Reference (N : Node_Id) return Boolean is 11573 11574 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 11575 -- Determine whether N is the name of an internally-generated renaming 11576 11577 -------------------------------------- 11578 -- Is_Internally_Generated_Renaming -- 11579 -------------------------------------- 11580 11581 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 11582 P : Node_Id; 11583 11584 begin 11585 P := N; 11586 while Present (P) loop 11587 if Nkind (P) = N_Object_Renaming_Declaration then 11588 return not Comes_From_Source (P); 11589 elsif Is_List_Member (P) then 11590 return False; 11591 end if; 11592 11593 P := Parent (P); 11594 end loop; 11595 11596 return False; 11597 end Is_Internally_Generated_Renaming; 11598 11599 -- Start of processing for Is_Object_Reference 11600 11601 begin 11602 if Is_Entity_Name (N) then 11603 return Present (Entity (N)) and then Is_Object (Entity (N)); 11604 11605 else 11606 case Nkind (N) is 11607 when N_Indexed_Component | N_Slice => 11608 return 11609 Is_Object_Reference (Prefix (N)) 11610 or else Is_Access_Type (Etype (Prefix (N))); 11611 11612 -- In Ada 95, a function call is a constant object; a procedure 11613 -- call is not. 11614 11615 when N_Function_Call => 11616 return Etype (N) /= Standard_Void_Type; 11617 11618 -- Attributes 'Input, 'Old and 'Result produce objects 11619 11620 when N_Attribute_Reference => 11621 return 11622 Nam_In 11623 (Attribute_Name (N), Name_Input, Name_Old, Name_Result); 11624 11625 when N_Selected_Component => 11626 return 11627 Is_Object_Reference (Selector_Name (N)) 11628 and then 11629 (Is_Object_Reference (Prefix (N)) 11630 or else Is_Access_Type (Etype (Prefix (N)))); 11631 11632 when N_Explicit_Dereference => 11633 return True; 11634 11635 -- A view conversion of a tagged object is an object reference 11636 11637 when N_Type_Conversion => 11638 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 11639 and then Is_Tagged_Type (Etype (Expression (N))) 11640 and then Is_Object_Reference (Expression (N)); 11641 11642 -- An unchecked type conversion is considered to be an object if 11643 -- the operand is an object (this construction arises only as a 11644 -- result of expansion activities). 11645 11646 when N_Unchecked_Type_Conversion => 11647 return True; 11648 11649 -- Allow string literals to act as objects as long as they appear 11650 -- in internally-generated renamings. The expansion of iterators 11651 -- may generate such renamings when the range involves a string 11652 -- literal. 11653 11654 when N_String_Literal => 11655 return Is_Internally_Generated_Renaming (Parent (N)); 11656 11657 -- AI05-0003: In Ada 2012 a qualified expression is a name. 11658 -- This allows disambiguation of function calls and the use 11659 -- of aggregates in more contexts. 11660 11661 when N_Qualified_Expression => 11662 if Ada_Version < Ada_2012 then 11663 return False; 11664 else 11665 return Is_Object_Reference (Expression (N)) 11666 or else Nkind (Expression (N)) = N_Aggregate; 11667 end if; 11668 11669 when others => 11670 return False; 11671 end case; 11672 end if; 11673 end Is_Object_Reference; 11674 11675 ----------------------------------- 11676 -- Is_OK_Variable_For_Out_Formal -- 11677 ----------------------------------- 11678 11679 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 11680 begin 11681 Note_Possible_Modification (AV, Sure => True); 11682 11683 -- We must reject parenthesized variable names. Comes_From_Source is 11684 -- checked because there are currently cases where the compiler violates 11685 -- this rule (e.g. passing a task object to its controlled Initialize 11686 -- routine). This should be properly documented in sinfo??? 11687 11688 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 11689 return False; 11690 11691 -- A variable is always allowed 11692 11693 elsif Is_Variable (AV) then 11694 return True; 11695 11696 -- Generalized indexing operations are rewritten as explicit 11697 -- dereferences, and it is only during resolution that we can 11698 -- check whether the context requires an access_to_variable type. 11699 11700 elsif Nkind (AV) = N_Explicit_Dereference 11701 and then Ada_Version >= Ada_2012 11702 and then Nkind (Original_Node (AV)) = N_Indexed_Component 11703 and then Present (Etype (Original_Node (AV))) 11704 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 11705 then 11706 return not Is_Access_Constant (Etype (Prefix (AV))); 11707 11708 -- Unchecked conversions are allowed only if they come from the 11709 -- generated code, which sometimes uses unchecked conversions for out 11710 -- parameters in cases where code generation is unaffected. We tell 11711 -- source unchecked conversions by seeing if they are rewrites of 11712 -- an original Unchecked_Conversion function call, or of an explicit 11713 -- conversion of a function call or an aggregate (as may happen in the 11714 -- expansion of a packed array aggregate). 11715 11716 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 11717 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then 11718 return False; 11719 11720 elsif Comes_From_Source (AV) 11721 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 11722 then 11723 return False; 11724 11725 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 11726 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 11727 11728 else 11729 return True; 11730 end if; 11731 11732 -- Normal type conversions are allowed if argument is a variable 11733 11734 elsif Nkind (AV) = N_Type_Conversion then 11735 if Is_Variable (Expression (AV)) 11736 and then Paren_Count (Expression (AV)) = 0 11737 then 11738 Note_Possible_Modification (Expression (AV), Sure => True); 11739 return True; 11740 11741 -- We also allow a non-parenthesized expression that raises 11742 -- constraint error if it rewrites what used to be a variable 11743 11744 elsif Raises_Constraint_Error (Expression (AV)) 11745 and then Paren_Count (Expression (AV)) = 0 11746 and then Is_Variable (Original_Node (Expression (AV))) 11747 then 11748 return True; 11749 11750 -- Type conversion of something other than a variable 11751 11752 else 11753 return False; 11754 end if; 11755 11756 -- If this node is rewritten, then test the original form, if that is 11757 -- OK, then we consider the rewritten node OK (for example, if the 11758 -- original node is a conversion, then Is_Variable will not be true 11759 -- but we still want to allow the conversion if it converts a variable). 11760 11761 elsif Original_Node (AV) /= AV then 11762 11763 -- In Ada 2012, the explicit dereference may be a rewritten call to a 11764 -- Reference function. 11765 11766 if Ada_Version >= Ada_2012 11767 and then Nkind (Original_Node (AV)) = N_Function_Call 11768 and then 11769 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 11770 then 11771 return True; 11772 11773 else 11774 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 11775 end if; 11776 11777 -- All other non-variables are rejected 11778 11779 else 11780 return False; 11781 end if; 11782 end Is_OK_Variable_For_Out_Formal; 11783 11784 ----------------------------------- 11785 -- Is_Partially_Initialized_Type -- 11786 ----------------------------------- 11787 11788 function Is_Partially_Initialized_Type 11789 (Typ : Entity_Id; 11790 Include_Implicit : Boolean := True) return Boolean 11791 is 11792 begin 11793 if Is_Scalar_Type (Typ) then 11794 return False; 11795 11796 elsif Is_Access_Type (Typ) then 11797 return Include_Implicit; 11798 11799 elsif Is_Array_Type (Typ) then 11800 11801 -- If component type is partially initialized, so is array type 11802 11803 if Is_Partially_Initialized_Type 11804 (Component_Type (Typ), Include_Implicit) 11805 then 11806 return True; 11807 11808 -- Otherwise we are only partially initialized if we are fully 11809 -- initialized (this is the empty array case, no point in us 11810 -- duplicating that code here). 11811 11812 else 11813 return Is_Fully_Initialized_Type (Typ); 11814 end if; 11815 11816 elsif Is_Record_Type (Typ) then 11817 11818 -- A discriminated type is always partially initialized if in 11819 -- all mode 11820 11821 if Has_Discriminants (Typ) and then Include_Implicit then 11822 return True; 11823 11824 -- A tagged type is always partially initialized 11825 11826 elsif Is_Tagged_Type (Typ) then 11827 return True; 11828 11829 -- Case of non-discriminated record 11830 11831 else 11832 declare 11833 Ent : Entity_Id; 11834 11835 Component_Present : Boolean := False; 11836 -- Set True if at least one component is present. If no 11837 -- components are present, then record type is fully 11838 -- initialized (another odd case, like the null array). 11839 11840 begin 11841 -- Loop through components 11842 11843 Ent := First_Entity (Typ); 11844 while Present (Ent) loop 11845 if Ekind (Ent) = E_Component then 11846 Component_Present := True; 11847 11848 -- If a component has an initialization expression then 11849 -- the enclosing record type is partially initialized 11850 11851 if Present (Parent (Ent)) 11852 and then Present (Expression (Parent (Ent))) 11853 then 11854 return True; 11855 11856 -- If a component is of a type which is itself partially 11857 -- initialized, then the enclosing record type is also. 11858 11859 elsif Is_Partially_Initialized_Type 11860 (Etype (Ent), Include_Implicit) 11861 then 11862 return True; 11863 end if; 11864 end if; 11865 11866 Next_Entity (Ent); 11867 end loop; 11868 11869 -- No initialized components found. If we found any components 11870 -- they were all uninitialized so the result is false. 11871 11872 if Component_Present then 11873 return False; 11874 11875 -- But if we found no components, then all the components are 11876 -- initialized so we consider the type to be initialized. 11877 11878 else 11879 return True; 11880 end if; 11881 end; 11882 end if; 11883 11884 -- Concurrent types are always fully initialized 11885 11886 elsif Is_Concurrent_Type (Typ) then 11887 return True; 11888 11889 -- For a private type, go to underlying type. If there is no underlying 11890 -- type then just assume this partially initialized. Not clear if this 11891 -- can happen in a non-error case, but no harm in testing for this. 11892 11893 elsif Is_Private_Type (Typ) then 11894 declare 11895 U : constant Entity_Id := Underlying_Type (Typ); 11896 begin 11897 if No (U) then 11898 return True; 11899 else 11900 return Is_Partially_Initialized_Type (U, Include_Implicit); 11901 end if; 11902 end; 11903 11904 -- For any other type (are there any?) assume partially initialized 11905 11906 else 11907 return True; 11908 end if; 11909 end Is_Partially_Initialized_Type; 11910 11911 ------------------------------------ 11912 -- Is_Potentially_Persistent_Type -- 11913 ------------------------------------ 11914 11915 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 11916 Comp : Entity_Id; 11917 Indx : Node_Id; 11918 11919 begin 11920 -- For private type, test corresponding full type 11921 11922 if Is_Private_Type (T) then 11923 return Is_Potentially_Persistent_Type (Full_View (T)); 11924 11925 -- Scalar types are potentially persistent 11926 11927 elsif Is_Scalar_Type (T) then 11928 return True; 11929 11930 -- Record type is potentially persistent if not tagged and the types of 11931 -- all it components are potentially persistent, and no component has 11932 -- an initialization expression. 11933 11934 elsif Is_Record_Type (T) 11935 and then not Is_Tagged_Type (T) 11936 and then not Is_Partially_Initialized_Type (T) 11937 then 11938 Comp := First_Component (T); 11939 while Present (Comp) loop 11940 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 11941 return False; 11942 else 11943 Next_Entity (Comp); 11944 end if; 11945 end loop; 11946 11947 return True; 11948 11949 -- Array type is potentially persistent if its component type is 11950 -- potentially persistent and if all its constraints are static. 11951 11952 elsif Is_Array_Type (T) then 11953 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 11954 return False; 11955 end if; 11956 11957 Indx := First_Index (T); 11958 while Present (Indx) loop 11959 if not Is_OK_Static_Subtype (Etype (Indx)) then 11960 return False; 11961 else 11962 Next_Index (Indx); 11963 end if; 11964 end loop; 11965 11966 return True; 11967 11968 -- All other types are not potentially persistent 11969 11970 else 11971 return False; 11972 end if; 11973 end Is_Potentially_Persistent_Type; 11974 11975 -------------------------------- 11976 -- Is_Potentially_Unevaluated -- 11977 -------------------------------- 11978 11979 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 11980 Par : Node_Id; 11981 Expr : Node_Id; 11982 11983 begin 11984 Expr := N; 11985 Par := Parent (N); 11986 11987 -- A postcondition whose expression is a short-circuit is broken down 11988 -- into individual aspects for better exception reporting. The original 11989 -- short-circuit expression is rewritten as the second operand, and an 11990 -- occurrence of 'Old in that operand is potentially unevaluated. 11991 -- See Sem_ch13.adb for details of this transformation. 11992 11993 if Nkind (Original_Node (Par)) = N_And_Then then 11994 return True; 11995 end if; 11996 11997 while not Nkind_In (Par, N_If_Expression, 11998 N_Case_Expression, 11999 N_And_Then, 12000 N_Or_Else, 12001 N_In, 12002 N_Not_In) 12003 loop 12004 Expr := Par; 12005 Par := Parent (Par); 12006 12007 -- If the context is not an expression, or if is the result of 12008 -- expansion of an enclosing construct (such as another attribute) 12009 -- the predicate does not apply. 12010 12011 if Nkind (Par) not in N_Subexpr 12012 or else not Comes_From_Source (Par) 12013 then 12014 return False; 12015 end if; 12016 end loop; 12017 12018 if Nkind (Par) = N_If_Expression then 12019 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 12020 12021 elsif Nkind (Par) = N_Case_Expression then 12022 return Expr /= Expression (Par); 12023 12024 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then 12025 return Expr = Right_Opnd (Par); 12026 12027 elsif Nkind_In (Par, N_In, N_Not_In) then 12028 return Expr /= Left_Opnd (Par); 12029 12030 else 12031 return False; 12032 end if; 12033 end Is_Potentially_Unevaluated; 12034 12035 --------------------------------- 12036 -- Is_Protected_Self_Reference -- 12037 --------------------------------- 12038 12039 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 12040 12041 function In_Access_Definition (N : Node_Id) return Boolean; 12042 -- Returns true if N belongs to an access definition 12043 12044 -------------------------- 12045 -- In_Access_Definition -- 12046 -------------------------- 12047 12048 function In_Access_Definition (N : Node_Id) return Boolean is 12049 P : Node_Id; 12050 12051 begin 12052 P := Parent (N); 12053 while Present (P) loop 12054 if Nkind (P) = N_Access_Definition then 12055 return True; 12056 end if; 12057 12058 P := Parent (P); 12059 end loop; 12060 12061 return False; 12062 end In_Access_Definition; 12063 12064 -- Start of processing for Is_Protected_Self_Reference 12065 12066 begin 12067 -- Verify that prefix is analyzed and has the proper form. Note that 12068 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address, 12069 -- which also produce the address of an entity, do not analyze their 12070 -- prefix because they denote entities that are not necessarily visible. 12071 -- Neither of them can apply to a protected type. 12072 12073 return Ada_Version >= Ada_2005 12074 and then Is_Entity_Name (N) 12075 and then Present (Entity (N)) 12076 and then Is_Protected_Type (Entity (N)) 12077 and then In_Open_Scopes (Entity (N)) 12078 and then not In_Access_Definition (N); 12079 end Is_Protected_Self_Reference; 12080 12081 ----------------------------- 12082 -- Is_RCI_Pkg_Spec_Or_Body -- 12083 ----------------------------- 12084 12085 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 12086 12087 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 12088 -- Return True if the unit of Cunit is an RCI package declaration 12089 12090 --------------------------- 12091 -- Is_RCI_Pkg_Decl_Cunit -- 12092 --------------------------- 12093 12094 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 12095 The_Unit : constant Node_Id := Unit (Cunit); 12096 12097 begin 12098 if Nkind (The_Unit) /= N_Package_Declaration then 12099 return False; 12100 end if; 12101 12102 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 12103 end Is_RCI_Pkg_Decl_Cunit; 12104 12105 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 12106 12107 begin 12108 return Is_RCI_Pkg_Decl_Cunit (Cunit) 12109 or else 12110 (Nkind (Unit (Cunit)) = N_Package_Body 12111 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 12112 end Is_RCI_Pkg_Spec_Or_Body; 12113 12114 ----------------------------------------- 12115 -- Is_Remote_Access_To_Class_Wide_Type -- 12116 ----------------------------------------- 12117 12118 function Is_Remote_Access_To_Class_Wide_Type 12119 (E : Entity_Id) return Boolean 12120 is 12121 begin 12122 -- A remote access to class-wide type is a general access to object type 12123 -- declared in the visible part of a Remote_Types or Remote_Call_ 12124 -- Interface unit. 12125 12126 return Ekind (E) = E_General_Access_Type 12127 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 12128 end Is_Remote_Access_To_Class_Wide_Type; 12129 12130 ----------------------------------------- 12131 -- Is_Remote_Access_To_Subprogram_Type -- 12132 ----------------------------------------- 12133 12134 function Is_Remote_Access_To_Subprogram_Type 12135 (E : Entity_Id) return Boolean 12136 is 12137 begin 12138 return (Ekind (E) = E_Access_Subprogram_Type 12139 or else (Ekind (E) = E_Record_Type 12140 and then Present (Corresponding_Remote_Type (E)))) 12141 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 12142 end Is_Remote_Access_To_Subprogram_Type; 12143 12144 -------------------- 12145 -- Is_Remote_Call -- 12146 -------------------- 12147 12148 function Is_Remote_Call (N : Node_Id) return Boolean is 12149 begin 12150 if Nkind (N) not in N_Subprogram_Call then 12151 12152 -- An entry call cannot be remote 12153 12154 return False; 12155 12156 elsif Nkind (Name (N)) in N_Has_Entity 12157 and then Is_Remote_Call_Interface (Entity (Name (N))) 12158 then 12159 -- A subprogram declared in the spec of a RCI package is remote 12160 12161 return True; 12162 12163 elsif Nkind (Name (N)) = N_Explicit_Dereference 12164 and then Is_Remote_Access_To_Subprogram_Type 12165 (Etype (Prefix (Name (N)))) 12166 then 12167 -- The dereference of a RAS is a remote call 12168 12169 return True; 12170 12171 elsif Present (Controlling_Argument (N)) 12172 and then Is_Remote_Access_To_Class_Wide_Type 12173 (Etype (Controlling_Argument (N))) 12174 then 12175 -- Any primitive operation call with a controlling argument of 12176 -- a RACW type is a remote call. 12177 12178 return True; 12179 end if; 12180 12181 -- All other calls are local calls 12182 12183 return False; 12184 end Is_Remote_Call; 12185 12186 ---------------------- 12187 -- Is_Renamed_Entry -- 12188 ---------------------- 12189 12190 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 12191 Orig_Node : Node_Id := Empty; 12192 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 12193 12194 function Is_Entry (Nam : Node_Id) return Boolean; 12195 -- Determine whether Nam is an entry. Traverse selectors if there are 12196 -- nested selected components. 12197 12198 -------------- 12199 -- Is_Entry -- 12200 -------------- 12201 12202 function Is_Entry (Nam : Node_Id) return Boolean is 12203 begin 12204 if Nkind (Nam) = N_Selected_Component then 12205 return Is_Entry (Selector_Name (Nam)); 12206 end if; 12207 12208 return Ekind (Entity (Nam)) = E_Entry; 12209 end Is_Entry; 12210 12211 -- Start of processing for Is_Renamed_Entry 12212 12213 begin 12214 if Present (Alias (Proc_Nam)) then 12215 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 12216 end if; 12217 12218 -- Look for a rewritten subprogram renaming declaration 12219 12220 if Nkind (Subp_Decl) = N_Subprogram_Declaration 12221 and then Present (Original_Node (Subp_Decl)) 12222 then 12223 Orig_Node := Original_Node (Subp_Decl); 12224 end if; 12225 12226 -- The rewritten subprogram is actually an entry 12227 12228 if Present (Orig_Node) 12229 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 12230 and then Is_Entry (Name (Orig_Node)) 12231 then 12232 return True; 12233 end if; 12234 12235 return False; 12236 end Is_Renamed_Entry; 12237 12238 ---------------------------- 12239 -- Is_Reversible_Iterator -- 12240 ---------------------------- 12241 12242 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 12243 Ifaces_List : Elist_Id; 12244 Iface_Elmt : Elmt_Id; 12245 Iface : Entity_Id; 12246 12247 begin 12248 if Is_Class_Wide_Type (Typ) 12249 and then Chars (Etype (Typ)) = Name_Reversible_Iterator 12250 and then Is_Predefined_File_Name 12251 (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) 12252 then 12253 return True; 12254 12255 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 12256 return False; 12257 12258 else 12259 Collect_Interfaces (Typ, Ifaces_List); 12260 12261 Iface_Elmt := First_Elmt (Ifaces_List); 12262 while Present (Iface_Elmt) loop 12263 Iface := Node (Iface_Elmt); 12264 if Chars (Iface) = Name_Reversible_Iterator 12265 and then 12266 Is_Predefined_File_Name 12267 (Unit_File_Name (Get_Source_Unit (Iface))) 12268 then 12269 return True; 12270 end if; 12271 12272 Next_Elmt (Iface_Elmt); 12273 end loop; 12274 end if; 12275 12276 return False; 12277 end Is_Reversible_Iterator; 12278 12279 ---------------------- 12280 -- Is_Selector_Name -- 12281 ---------------------- 12282 12283 function Is_Selector_Name (N : Node_Id) return Boolean is 12284 begin 12285 if not Is_List_Member (N) then 12286 declare 12287 P : constant Node_Id := Parent (N); 12288 begin 12289 return Nkind_In (P, N_Expanded_Name, 12290 N_Generic_Association, 12291 N_Parameter_Association, 12292 N_Selected_Component) 12293 and then Selector_Name (P) = N; 12294 end; 12295 12296 else 12297 declare 12298 L : constant List_Id := List_Containing (N); 12299 P : constant Node_Id := Parent (L); 12300 begin 12301 return (Nkind (P) = N_Discriminant_Association 12302 and then Selector_Names (P) = L) 12303 or else 12304 (Nkind (P) = N_Component_Association 12305 and then Choices (P) = L); 12306 end; 12307 end if; 12308 end Is_Selector_Name; 12309 12310 ------------------------------------- 12311 -- Is_SPARK_05_Initialization_Expr -- 12312 ------------------------------------- 12313 12314 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is 12315 Is_Ok : Boolean; 12316 Expr : Node_Id; 12317 Comp_Assn : Node_Id; 12318 Orig_N : constant Node_Id := Original_Node (N); 12319 12320 begin 12321 Is_Ok := True; 12322 12323 if not Comes_From_Source (Orig_N) then 12324 goto Done; 12325 end if; 12326 12327 pragma Assert (Nkind (Orig_N) in N_Subexpr); 12328 12329 case Nkind (Orig_N) is 12330 when N_Character_Literal | 12331 N_Integer_Literal | 12332 N_Real_Literal | 12333 N_String_Literal => 12334 null; 12335 12336 when N_Identifier | 12337 N_Expanded_Name => 12338 if Is_Entity_Name (Orig_N) 12339 and then Present (Entity (Orig_N)) -- needed in some cases 12340 then 12341 case Ekind (Entity (Orig_N)) is 12342 when E_Constant | 12343 E_Enumeration_Literal | 12344 E_Named_Integer | 12345 E_Named_Real => 12346 null; 12347 when others => 12348 if Is_Type (Entity (Orig_N)) then 12349 null; 12350 else 12351 Is_Ok := False; 12352 end if; 12353 end case; 12354 end if; 12355 12356 when N_Qualified_Expression | 12357 N_Type_Conversion => 12358 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); 12359 12360 when N_Unary_Op => 12361 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 12362 12363 when N_Binary_Op | 12364 N_Short_Circuit | 12365 N_Membership_Test => 12366 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) 12367 and then 12368 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 12369 12370 when N_Aggregate | 12371 N_Extension_Aggregate => 12372 if Nkind (Orig_N) = N_Extension_Aggregate then 12373 Is_Ok := 12374 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); 12375 end if; 12376 12377 Expr := First (Expressions (Orig_N)); 12378 while Present (Expr) loop 12379 if not Is_SPARK_05_Initialization_Expr (Expr) then 12380 Is_Ok := False; 12381 goto Done; 12382 end if; 12383 12384 Next (Expr); 12385 end loop; 12386 12387 Comp_Assn := First (Component_Associations (Orig_N)); 12388 while Present (Comp_Assn) loop 12389 Expr := Expression (Comp_Assn); 12390 12391 -- Note: test for Present here needed for box assocation 12392 12393 if Present (Expr) 12394 and then not Is_SPARK_05_Initialization_Expr (Expr) 12395 then 12396 Is_Ok := False; 12397 goto Done; 12398 end if; 12399 12400 Next (Comp_Assn); 12401 end loop; 12402 12403 when N_Attribute_Reference => 12404 if Nkind (Prefix (Orig_N)) in N_Subexpr then 12405 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); 12406 end if; 12407 12408 Expr := First (Expressions (Orig_N)); 12409 while Present (Expr) loop 12410 if not Is_SPARK_05_Initialization_Expr (Expr) then 12411 Is_Ok := False; 12412 goto Done; 12413 end if; 12414 12415 Next (Expr); 12416 end loop; 12417 12418 -- Selected components might be expanded named not yet resolved, so 12419 -- default on the safe side. (Eg on sparklex.ads) 12420 12421 when N_Selected_Component => 12422 null; 12423 12424 when others => 12425 Is_Ok := False; 12426 end case; 12427 12428 <<Done>> 12429 return Is_Ok; 12430 end Is_SPARK_05_Initialization_Expr; 12431 12432 ---------------------------------- 12433 -- Is_SPARK_05_Object_Reference -- 12434 ---------------------------------- 12435 12436 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is 12437 begin 12438 if Is_Entity_Name (N) then 12439 return Present (Entity (N)) 12440 and then 12441 (Ekind_In (Entity (N), E_Constant, E_Variable) 12442 or else Ekind (Entity (N)) in Formal_Kind); 12443 12444 else 12445 case Nkind (N) is 12446 when N_Selected_Component => 12447 return Is_SPARK_05_Object_Reference (Prefix (N)); 12448 12449 when others => 12450 return False; 12451 end case; 12452 end if; 12453 end Is_SPARK_05_Object_Reference; 12454 12455 ----------------------------- 12456 -- Is_Specific_Tagged_Type -- 12457 ----------------------------- 12458 12459 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 12460 Full_Typ : Entity_Id; 12461 12462 begin 12463 -- Handle private types 12464 12465 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 12466 Full_Typ := Full_View (Typ); 12467 else 12468 Full_Typ := Typ; 12469 end if; 12470 12471 -- A specific tagged type is a non-class-wide tagged type 12472 12473 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 12474 end Is_Specific_Tagged_Type; 12475 12476 ------------------ 12477 -- Is_Statement -- 12478 ------------------ 12479 12480 function Is_Statement (N : Node_Id) return Boolean is 12481 begin 12482 return 12483 Nkind (N) in N_Statement_Other_Than_Procedure_Call 12484 or else Nkind (N) = N_Procedure_Call_Statement; 12485 end Is_Statement; 12486 12487 -------------------------------------------------- 12488 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 12489 -------------------------------------------------- 12490 12491 function Is_Subprogram_Stub_Without_Prior_Declaration 12492 (N : Node_Id) return Boolean 12493 is 12494 begin 12495 -- A subprogram stub without prior declaration serves as declaration for 12496 -- the actual subprogram body. As such, it has an attached defining 12497 -- entity of E_[Generic_]Function or E_[Generic_]Procedure. 12498 12499 return Nkind (N) = N_Subprogram_Body_Stub 12500 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; 12501 end Is_Subprogram_Stub_Without_Prior_Declaration; 12502 12503 --------------------------------- 12504 -- Is_Synchronized_Tagged_Type -- 12505 --------------------------------- 12506 12507 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 12508 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 12509 12510 begin 12511 -- A task or protected type derived from an interface is a tagged type. 12512 -- Such a tagged type is called a synchronized tagged type, as are 12513 -- synchronized interfaces and private extensions whose declaration 12514 -- includes the reserved word synchronized. 12515 12516 return (Is_Tagged_Type (E) 12517 and then (Kind = E_Task_Type 12518 or else 12519 Kind = E_Protected_Type)) 12520 or else 12521 (Is_Interface (E) 12522 and then Is_Synchronized_Interface (E)) 12523 or else 12524 (Ekind (E) = E_Record_Type_With_Private 12525 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 12526 and then (Synchronized_Present (Parent (E)) 12527 or else Is_Synchronized_Interface (Etype (E)))); 12528 end Is_Synchronized_Tagged_Type; 12529 12530 ----------------- 12531 -- Is_Transfer -- 12532 ----------------- 12533 12534 function Is_Transfer (N : Node_Id) return Boolean is 12535 Kind : constant Node_Kind := Nkind (N); 12536 12537 begin 12538 if Kind = N_Simple_Return_Statement 12539 or else 12540 Kind = N_Extended_Return_Statement 12541 or else 12542 Kind = N_Goto_Statement 12543 or else 12544 Kind = N_Raise_Statement 12545 or else 12546 Kind = N_Requeue_Statement 12547 then 12548 return True; 12549 12550 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 12551 and then No (Condition (N)) 12552 then 12553 return True; 12554 12555 elsif Kind = N_Procedure_Call_Statement 12556 and then Is_Entity_Name (Name (N)) 12557 and then Present (Entity (Name (N))) 12558 and then No_Return (Entity (Name (N))) 12559 then 12560 return True; 12561 12562 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 12563 return True; 12564 12565 else 12566 return False; 12567 end if; 12568 end Is_Transfer; 12569 12570 ------------- 12571 -- Is_True -- 12572 ------------- 12573 12574 function Is_True (U : Uint) return Boolean is 12575 begin 12576 return (U /= 0); 12577 end Is_True; 12578 12579 -------------------------------------- 12580 -- Is_Unchecked_Conversion_Instance -- 12581 -------------------------------------- 12582 12583 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 12584 Gen_Par : Entity_Id; 12585 12586 begin 12587 -- Look for a function whose generic parent is the predefined intrinsic 12588 -- function Unchecked_Conversion. 12589 12590 if Ekind (Id) = E_Function then 12591 Gen_Par := Generic_Parent (Parent (Id)); 12592 12593 return 12594 Present (Gen_Par) 12595 and then Chars (Gen_Par) = Name_Unchecked_Conversion 12596 and then Is_Intrinsic_Subprogram (Gen_Par) 12597 and then Is_Predefined_File_Name 12598 (Unit_File_Name (Get_Source_Unit (Gen_Par))); 12599 end if; 12600 12601 return False; 12602 end Is_Unchecked_Conversion_Instance; 12603 12604 ------------------------------- 12605 -- Is_Universal_Numeric_Type -- 12606 ------------------------------- 12607 12608 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 12609 begin 12610 return T = Universal_Integer or else T = Universal_Real; 12611 end Is_Universal_Numeric_Type; 12612 12613 ------------------- 12614 -- Is_Value_Type -- 12615 ------------------- 12616 12617 function Is_Value_Type (T : Entity_Id) return Boolean is 12618 begin 12619 return VM_Target = CLI_Target 12620 and then Nkind (T) in N_Has_Chars 12621 and then Chars (T) /= No_Name 12622 and then Get_Name_String (Chars (T)) = "valuetype"; 12623 end Is_Value_Type; 12624 12625 ---------------------------- 12626 -- Is_Variable_Size_Array -- 12627 ---------------------------- 12628 12629 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 12630 Idx : Node_Id; 12631 12632 begin 12633 pragma Assert (Is_Array_Type (E)); 12634 12635 -- Check if some index is initialized with a non-constant value 12636 12637 Idx := First_Index (E); 12638 while Present (Idx) loop 12639 if Nkind (Idx) = N_Range then 12640 if not Is_Constant_Bound (Low_Bound (Idx)) 12641 or else not Is_Constant_Bound (High_Bound (Idx)) 12642 then 12643 return True; 12644 end if; 12645 end if; 12646 12647 Idx := Next_Index (Idx); 12648 end loop; 12649 12650 return False; 12651 end Is_Variable_Size_Array; 12652 12653 ----------------------------- 12654 -- Is_Variable_Size_Record -- 12655 ----------------------------- 12656 12657 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 12658 Comp : Entity_Id; 12659 Comp_Typ : Entity_Id; 12660 12661 begin 12662 pragma Assert (Is_Record_Type (E)); 12663 12664 Comp := First_Entity (E); 12665 while Present (Comp) loop 12666 Comp_Typ := Etype (Comp); 12667 12668 -- Recursive call if the record type has discriminants 12669 12670 if Is_Record_Type (Comp_Typ) 12671 and then Has_Discriminants (Comp_Typ) 12672 and then Is_Variable_Size_Record (Comp_Typ) 12673 then 12674 return True; 12675 12676 elsif Is_Array_Type (Comp_Typ) 12677 and then Is_Variable_Size_Array (Comp_Typ) 12678 then 12679 return True; 12680 end if; 12681 12682 Next_Entity (Comp); 12683 end loop; 12684 12685 return False; 12686 end Is_Variable_Size_Record; 12687 12688 ----------------- 12689 -- Is_Variable -- 12690 ----------------- 12691 12692 function Is_Variable 12693 (N : Node_Id; 12694 Use_Original_Node : Boolean := True) return Boolean 12695 is 12696 Orig_Node : Node_Id; 12697 12698 function In_Protected_Function (E : Entity_Id) return Boolean; 12699 -- Within a protected function, the private components of the enclosing 12700 -- protected type are constants. A function nested within a (protected) 12701 -- procedure is not itself protected. Within the body of a protected 12702 -- function the current instance of the protected type is a constant. 12703 12704 function Is_Variable_Prefix (P : Node_Id) return Boolean; 12705 -- Prefixes can involve implicit dereferences, in which case we must 12706 -- test for the case of a reference of a constant access type, which can 12707 -- can never be a variable. 12708 12709 --------------------------- 12710 -- In_Protected_Function -- 12711 --------------------------- 12712 12713 function In_Protected_Function (E : Entity_Id) return Boolean is 12714 Prot : Entity_Id; 12715 S : Entity_Id; 12716 12717 begin 12718 -- E is the current instance of a type 12719 12720 if Is_Type (E) then 12721 Prot := E; 12722 12723 -- E is an object 12724 12725 else 12726 Prot := Scope (E); 12727 end if; 12728 12729 if not Is_Protected_Type (Prot) then 12730 return False; 12731 12732 else 12733 S := Current_Scope; 12734 while Present (S) and then S /= Prot loop 12735 if Ekind (S) = E_Function and then Scope (S) = Prot then 12736 return True; 12737 end if; 12738 12739 S := Scope (S); 12740 end loop; 12741 12742 return False; 12743 end if; 12744 end In_Protected_Function; 12745 12746 ------------------------ 12747 -- Is_Variable_Prefix -- 12748 ------------------------ 12749 12750 function Is_Variable_Prefix (P : Node_Id) return Boolean is 12751 begin 12752 if Is_Access_Type (Etype (P)) then 12753 return not Is_Access_Constant (Root_Type (Etype (P))); 12754 12755 -- For the case of an indexed component whose prefix has a packed 12756 -- array type, the prefix has been rewritten into a type conversion. 12757 -- Determine variable-ness from the converted expression. 12758 12759 elsif Nkind (P) = N_Type_Conversion 12760 and then not Comes_From_Source (P) 12761 and then Is_Array_Type (Etype (P)) 12762 and then Is_Packed (Etype (P)) 12763 then 12764 return Is_Variable (Expression (P)); 12765 12766 else 12767 return Is_Variable (P); 12768 end if; 12769 end Is_Variable_Prefix; 12770 12771 -- Start of processing for Is_Variable 12772 12773 begin 12774 -- Check if we perform the test on the original node since this may be a 12775 -- test of syntactic categories which must not be disturbed by whatever 12776 -- rewriting might have occurred. For example, an aggregate, which is 12777 -- certainly NOT a variable, could be turned into a variable by 12778 -- expansion. 12779 12780 if Use_Original_Node then 12781 Orig_Node := Original_Node (N); 12782 else 12783 Orig_Node := N; 12784 end if; 12785 12786 -- Definitely OK if Assignment_OK is set. Since this is something that 12787 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 12788 12789 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 12790 return True; 12791 12792 -- Normally we go to the original node, but there is one exception where 12793 -- we use the rewritten node, namely when it is an explicit dereference. 12794 -- The generated code may rewrite a prefix which is an access type with 12795 -- an explicit dereference. The dereference is a variable, even though 12796 -- the original node may not be (since it could be a constant of the 12797 -- access type). 12798 12799 -- In Ada 2005 we have a further case to consider: the prefix may be a 12800 -- function call given in prefix notation. The original node appears to 12801 -- be a selected component, but we need to examine the call. 12802 12803 elsif Nkind (N) = N_Explicit_Dereference 12804 and then Nkind (Orig_Node) /= N_Explicit_Dereference 12805 and then Present (Etype (Orig_Node)) 12806 and then Is_Access_Type (Etype (Orig_Node)) 12807 then 12808 -- Note that if the prefix is an explicit dereference that does not 12809 -- come from source, we must check for a rewritten function call in 12810 -- prefixed notation before other forms of rewriting, to prevent a 12811 -- compiler crash. 12812 12813 return 12814 (Nkind (Orig_Node) = N_Function_Call 12815 and then not Is_Access_Constant (Etype (Prefix (N)))) 12816 or else 12817 Is_Variable_Prefix (Original_Node (Prefix (N))); 12818 12819 -- in Ada 2012, the dereference may have been added for a type with 12820 -- a declared implicit dereference aspect. Check that it is not an 12821 -- access to constant. 12822 12823 elsif Nkind (N) = N_Explicit_Dereference 12824 and then Present (Etype (Orig_Node)) 12825 and then Ada_Version >= Ada_2012 12826 and then Has_Implicit_Dereference (Etype (Orig_Node)) 12827 then 12828 return not Is_Access_Constant (Etype (Prefix (N))); 12829 12830 -- A function call is never a variable 12831 12832 elsif Nkind (N) = N_Function_Call then 12833 return False; 12834 12835 -- All remaining checks use the original node 12836 12837 elsif Is_Entity_Name (Orig_Node) 12838 and then Present (Entity (Orig_Node)) 12839 then 12840 declare 12841 E : constant Entity_Id := Entity (Orig_Node); 12842 K : constant Entity_Kind := Ekind (E); 12843 12844 begin 12845 return (K = E_Variable 12846 and then Nkind (Parent (E)) /= N_Exception_Handler) 12847 or else (K = E_Component 12848 and then not In_Protected_Function (E)) 12849 or else K = E_Out_Parameter 12850 or else K = E_In_Out_Parameter 12851 or else K = E_Generic_In_Out_Parameter 12852 12853 -- Current instance of type. If this is a protected type, check 12854 -- we are not within the body of one of its protected functions. 12855 12856 or else (Is_Type (E) 12857 and then In_Open_Scopes (E) 12858 and then not In_Protected_Function (E)) 12859 12860 or else (Is_Incomplete_Or_Private_Type (E) 12861 and then In_Open_Scopes (Full_View (E))); 12862 end; 12863 12864 else 12865 case Nkind (Orig_Node) is 12866 when N_Indexed_Component | N_Slice => 12867 return Is_Variable_Prefix (Prefix (Orig_Node)); 12868 12869 when N_Selected_Component => 12870 return (Is_Variable (Selector_Name (Orig_Node)) 12871 and then Is_Variable_Prefix (Prefix (Orig_Node))) 12872 or else 12873 (Nkind (N) = N_Expanded_Name 12874 and then Scope (Entity (N)) = Entity (Prefix (N))); 12875 12876 -- For an explicit dereference, the type of the prefix cannot 12877 -- be an access to constant or an access to subprogram. 12878 12879 when N_Explicit_Dereference => 12880 declare 12881 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 12882 begin 12883 return Is_Access_Type (Typ) 12884 and then not Is_Access_Constant (Root_Type (Typ)) 12885 and then Ekind (Typ) /= E_Access_Subprogram_Type; 12886 end; 12887 12888 -- The type conversion is the case where we do not deal with the 12889 -- context dependent special case of an actual parameter. Thus 12890 -- the type conversion is only considered a variable for the 12891 -- purposes of this routine if the target type is tagged. However, 12892 -- a type conversion is considered to be a variable if it does not 12893 -- come from source (this deals for example with the conversions 12894 -- of expressions to their actual subtypes). 12895 12896 when N_Type_Conversion => 12897 return Is_Variable (Expression (Orig_Node)) 12898 and then 12899 (not Comes_From_Source (Orig_Node) 12900 or else 12901 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 12902 and then 12903 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 12904 12905 -- GNAT allows an unchecked type conversion as a variable. This 12906 -- only affects the generation of internal expanded code, since 12907 -- calls to instantiations of Unchecked_Conversion are never 12908 -- considered variables (since they are function calls). 12909 12910 when N_Unchecked_Type_Conversion => 12911 return Is_Variable (Expression (Orig_Node)); 12912 12913 when others => 12914 return False; 12915 end case; 12916 end if; 12917 end Is_Variable; 12918 12919 --------------------------- 12920 -- Is_Visibly_Controlled -- 12921 --------------------------- 12922 12923 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 12924 Root : constant Entity_Id := Root_Type (T); 12925 begin 12926 return Chars (Scope (Root)) = Name_Finalization 12927 and then Chars (Scope (Scope (Root))) = Name_Ada 12928 and then Scope (Scope (Scope (Root))) = Standard_Standard; 12929 end Is_Visibly_Controlled; 12930 12931 ------------------------ 12932 -- Is_Volatile_Object -- 12933 ------------------------ 12934 12935 function Is_Volatile_Object (N : Node_Id) return Boolean is 12936 12937 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 12938 -- If prefix is an implicit dereference, examine designated type 12939 12940 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 12941 -- Determines if given object has volatile components 12942 12943 ------------------------ 12944 -- Is_Volatile_Prefix -- 12945 ------------------------ 12946 12947 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 12948 Typ : constant Entity_Id := Etype (N); 12949 12950 begin 12951 if Is_Access_Type (Typ) then 12952 declare 12953 Dtyp : constant Entity_Id := Designated_Type (Typ); 12954 12955 begin 12956 return Is_Volatile (Dtyp) 12957 or else Has_Volatile_Components (Dtyp); 12958 end; 12959 12960 else 12961 return Object_Has_Volatile_Components (N); 12962 end if; 12963 end Is_Volatile_Prefix; 12964 12965 ------------------------------------ 12966 -- Object_Has_Volatile_Components -- 12967 ------------------------------------ 12968 12969 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 12970 Typ : constant Entity_Id := Etype (N); 12971 12972 begin 12973 if Is_Volatile (Typ) 12974 or else Has_Volatile_Components (Typ) 12975 then 12976 return True; 12977 12978 elsif Is_Entity_Name (N) 12979 and then (Has_Volatile_Components (Entity (N)) 12980 or else Is_Volatile (Entity (N))) 12981 then 12982 return True; 12983 12984 elsif Nkind (N) = N_Indexed_Component 12985 or else Nkind (N) = N_Selected_Component 12986 then 12987 return Is_Volatile_Prefix (Prefix (N)); 12988 12989 else 12990 return False; 12991 end if; 12992 end Object_Has_Volatile_Components; 12993 12994 -- Start of processing for Is_Volatile_Object 12995 12996 begin 12997 if Nkind (N) = N_Defining_Identifier then 12998 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 12999 13000 elsif Nkind (N) = N_Expanded_Name then 13001 return Is_Volatile_Object (Entity (N)); 13002 13003 elsif Is_Volatile (Etype (N)) 13004 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 13005 then 13006 return True; 13007 13008 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 13009 and then Is_Volatile_Prefix (Prefix (N)) 13010 then 13011 return True; 13012 13013 elsif Nkind (N) = N_Selected_Component 13014 and then Is_Volatile (Entity (Selector_Name (N))) 13015 then 13016 return True; 13017 13018 else 13019 return False; 13020 end if; 13021 end Is_Volatile_Object; 13022 13023 --------------------------- 13024 -- Itype_Has_Declaration -- 13025 --------------------------- 13026 13027 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 13028 begin 13029 pragma Assert (Is_Itype (Id)); 13030 return Present (Parent (Id)) 13031 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 13032 N_Subtype_Declaration) 13033 and then Defining_Entity (Parent (Id)) = Id; 13034 end Itype_Has_Declaration; 13035 13036 ------------------------- 13037 -- Kill_Current_Values -- 13038 ------------------------- 13039 13040 procedure Kill_Current_Values 13041 (Ent : Entity_Id; 13042 Last_Assignment_Only : Boolean := False) 13043 is 13044 begin 13045 if Is_Assignable (Ent) then 13046 Set_Last_Assignment (Ent, Empty); 13047 end if; 13048 13049 if Is_Object (Ent) then 13050 if not Last_Assignment_Only then 13051 Kill_Checks (Ent); 13052 Set_Current_Value (Ent, Empty); 13053 13054 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 13055 -- for a constant. Once the constant is elaborated, its value is 13056 -- not changed, therefore the associated flags that describe the 13057 -- value should not be modified either. 13058 13059 if Ekind (Ent) = E_Constant then 13060 null; 13061 13062 -- Non-constant entities 13063 13064 else 13065 if not Can_Never_Be_Null (Ent) then 13066 Set_Is_Known_Non_Null (Ent, False); 13067 end if; 13068 13069 Set_Is_Known_Null (Ent, False); 13070 13071 -- Reset the Is_Known_Valid flag unless the type is always 13072 -- valid. This does not apply to a loop parameter because its 13073 -- bounds are defined by the loop header and therefore always 13074 -- valid. 13075 13076 if not Is_Known_Valid (Etype (Ent)) 13077 and then Ekind (Ent) /= E_Loop_Parameter 13078 then 13079 Set_Is_Known_Valid (Ent, False); 13080 end if; 13081 end if; 13082 end if; 13083 end if; 13084 end Kill_Current_Values; 13085 13086 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 13087 S : Entity_Id; 13088 13089 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 13090 -- Clear current value for entity E and all entities chained to E 13091 13092 ------------------------------------------ 13093 -- Kill_Current_Values_For_Entity_Chain -- 13094 ------------------------------------------ 13095 13096 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 13097 Ent : Entity_Id; 13098 begin 13099 Ent := E; 13100 while Present (Ent) loop 13101 Kill_Current_Values (Ent, Last_Assignment_Only); 13102 Next_Entity (Ent); 13103 end loop; 13104 end Kill_Current_Values_For_Entity_Chain; 13105 13106 -- Start of processing for Kill_Current_Values 13107 13108 begin 13109 -- Kill all saved checks, a special case of killing saved values 13110 13111 if not Last_Assignment_Only then 13112 Kill_All_Checks; 13113 end if; 13114 13115 -- Loop through relevant scopes, which includes the current scope and 13116 -- any parent scopes if the current scope is a block or a package. 13117 13118 S := Current_Scope; 13119 Scope_Loop : loop 13120 13121 -- Clear current values of all entities in current scope 13122 13123 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 13124 13125 -- If scope is a package, also clear current values of all private 13126 -- entities in the scope. 13127 13128 if Is_Package_Or_Generic_Package (S) 13129 or else Is_Concurrent_Type (S) 13130 then 13131 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 13132 end if; 13133 13134 -- If this is a not a subprogram, deal with parents 13135 13136 if not Is_Subprogram (S) then 13137 S := Scope (S); 13138 exit Scope_Loop when S = Standard_Standard; 13139 else 13140 exit Scope_Loop; 13141 end if; 13142 end loop Scope_Loop; 13143 end Kill_Current_Values; 13144 13145 -------------------------- 13146 -- Kill_Size_Check_Code -- 13147 -------------------------- 13148 13149 procedure Kill_Size_Check_Code (E : Entity_Id) is 13150 begin 13151 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 13152 and then Present (Size_Check_Code (E)) 13153 then 13154 Remove (Size_Check_Code (E)); 13155 Set_Size_Check_Code (E, Empty); 13156 end if; 13157 end Kill_Size_Check_Code; 13158 13159 -------------------------- 13160 -- Known_To_Be_Assigned -- 13161 -------------------------- 13162 13163 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 13164 P : constant Node_Id := Parent (N); 13165 13166 begin 13167 case Nkind (P) is 13168 13169 -- Test left side of assignment 13170 13171 when N_Assignment_Statement => 13172 return N = Name (P); 13173 13174 -- Function call arguments are never lvalues 13175 13176 when N_Function_Call => 13177 return False; 13178 13179 -- Positional parameter for procedure or accept call 13180 13181 when N_Procedure_Call_Statement | 13182 N_Accept_Statement 13183 => 13184 declare 13185 Proc : Entity_Id; 13186 Form : Entity_Id; 13187 Act : Node_Id; 13188 13189 begin 13190 Proc := Get_Subprogram_Entity (P); 13191 13192 if No (Proc) then 13193 return False; 13194 end if; 13195 13196 -- If we are not a list member, something is strange, so 13197 -- be conservative and return False. 13198 13199 if not Is_List_Member (N) then 13200 return False; 13201 end if; 13202 13203 -- We are going to find the right formal by stepping forward 13204 -- through the formals, as we step backwards in the actuals. 13205 13206 Form := First_Formal (Proc); 13207 Act := N; 13208 loop 13209 -- If no formal, something is weird, so be conservative 13210 -- and return False. 13211 13212 if No (Form) then 13213 return False; 13214 end if; 13215 13216 Prev (Act); 13217 exit when No (Act); 13218 Next_Formal (Form); 13219 end loop; 13220 13221 return Ekind (Form) /= E_In_Parameter; 13222 end; 13223 13224 -- Named parameter for procedure or accept call 13225 13226 when N_Parameter_Association => 13227 declare 13228 Proc : Entity_Id; 13229 Form : Entity_Id; 13230 13231 begin 13232 Proc := Get_Subprogram_Entity (Parent (P)); 13233 13234 if No (Proc) then 13235 return False; 13236 end if; 13237 13238 -- Loop through formals to find the one that matches 13239 13240 Form := First_Formal (Proc); 13241 loop 13242 -- If no matching formal, that's peculiar, some kind of 13243 -- previous error, so return False to be conservative. 13244 -- Actually this also happens in legal code in the case 13245 -- where P is a parameter association for an Extra_Formal??? 13246 13247 if No (Form) then 13248 return False; 13249 end if; 13250 13251 -- Else test for match 13252 13253 if Chars (Form) = Chars (Selector_Name (P)) then 13254 return Ekind (Form) /= E_In_Parameter; 13255 end if; 13256 13257 Next_Formal (Form); 13258 end loop; 13259 end; 13260 13261 -- Test for appearing in a conversion that itself appears 13262 -- in an lvalue context, since this should be an lvalue. 13263 13264 when N_Type_Conversion => 13265 return Known_To_Be_Assigned (P); 13266 13267 -- All other references are definitely not known to be modifications 13268 13269 when others => 13270 return False; 13271 13272 end case; 13273 end Known_To_Be_Assigned; 13274 13275 --------------------------- 13276 -- Last_Source_Statement -- 13277 --------------------------- 13278 13279 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 13280 N : Node_Id; 13281 13282 begin 13283 N := Last (Statements (HSS)); 13284 while Present (N) loop 13285 exit when Comes_From_Source (N); 13286 Prev (N); 13287 end loop; 13288 13289 return N; 13290 end Last_Source_Statement; 13291 13292 ---------------------------------- 13293 -- Matching_Static_Array_Bounds -- 13294 ---------------------------------- 13295 13296 function Matching_Static_Array_Bounds 13297 (L_Typ : Node_Id; 13298 R_Typ : Node_Id) return Boolean 13299 is 13300 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 13301 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 13302 13303 L_Index : Node_Id; 13304 R_Index : Node_Id; 13305 L_Low : Node_Id; 13306 L_High : Node_Id; 13307 L_Len : Uint; 13308 R_Low : Node_Id; 13309 R_High : Node_Id; 13310 R_Len : Uint; 13311 13312 begin 13313 if L_Ndims /= R_Ndims then 13314 return False; 13315 end if; 13316 13317 -- Unconstrained types do not have static bounds 13318 13319 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 13320 return False; 13321 end if; 13322 13323 -- First treat specially the first dimension, as the lower bound and 13324 -- length of string literals are not stored like those of arrays. 13325 13326 if Ekind (L_Typ) = E_String_Literal_Subtype then 13327 L_Low := String_Literal_Low_Bound (L_Typ); 13328 L_Len := String_Literal_Length (L_Typ); 13329 else 13330 L_Index := First_Index (L_Typ); 13331 Get_Index_Bounds (L_Index, L_Low, L_High); 13332 13333 if Is_OK_Static_Expression (L_Low) 13334 and then 13335 Is_OK_Static_Expression (L_High) 13336 then 13337 if Expr_Value (L_High) < Expr_Value (L_Low) then 13338 L_Len := Uint_0; 13339 else 13340 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 13341 end if; 13342 else 13343 return False; 13344 end if; 13345 end if; 13346 13347 if Ekind (R_Typ) = E_String_Literal_Subtype then 13348 R_Low := String_Literal_Low_Bound (R_Typ); 13349 R_Len := String_Literal_Length (R_Typ); 13350 else 13351 R_Index := First_Index (R_Typ); 13352 Get_Index_Bounds (R_Index, R_Low, R_High); 13353 13354 if Is_OK_Static_Expression (R_Low) 13355 and then 13356 Is_OK_Static_Expression (R_High) 13357 then 13358 if Expr_Value (R_High) < Expr_Value (R_Low) then 13359 R_Len := Uint_0; 13360 else 13361 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 13362 end if; 13363 else 13364 return False; 13365 end if; 13366 end if; 13367 13368 if (Is_OK_Static_Expression (L_Low) 13369 and then 13370 Is_OK_Static_Expression (R_Low)) 13371 and then Expr_Value (L_Low) = Expr_Value (R_Low) 13372 and then L_Len = R_Len 13373 then 13374 null; 13375 else 13376 return False; 13377 end if; 13378 13379 -- Then treat all other dimensions 13380 13381 for Indx in 2 .. L_Ndims loop 13382 Next (L_Index); 13383 Next (R_Index); 13384 13385 Get_Index_Bounds (L_Index, L_Low, L_High); 13386 Get_Index_Bounds (R_Index, R_Low, R_High); 13387 13388 if (Is_OK_Static_Expression (L_Low) and then 13389 Is_OK_Static_Expression (L_High) and then 13390 Is_OK_Static_Expression (R_Low) and then 13391 Is_OK_Static_Expression (R_High)) 13392 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 13393 and then 13394 Expr_Value (L_High) = Expr_Value (R_High)) 13395 then 13396 null; 13397 else 13398 return False; 13399 end if; 13400 end loop; 13401 13402 -- If we fall through the loop, all indexes matched 13403 13404 return True; 13405 end Matching_Static_Array_Bounds; 13406 13407 ------------------- 13408 -- May_Be_Lvalue -- 13409 ------------------- 13410 13411 function May_Be_Lvalue (N : Node_Id) return Boolean is 13412 P : constant Node_Id := Parent (N); 13413 13414 begin 13415 case Nkind (P) is 13416 13417 -- Test left side of assignment 13418 13419 when N_Assignment_Statement => 13420 return N = Name (P); 13421 13422 -- Test prefix of component or attribute. Note that the prefix of an 13423 -- explicit or implicit dereference cannot be an l-value. 13424 13425 when N_Attribute_Reference => 13426 return N = Prefix (P) 13427 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)); 13428 13429 -- For an expanded name, the name is an lvalue if the expanded name 13430 -- is an lvalue, but the prefix is never an lvalue, since it is just 13431 -- the scope where the name is found. 13432 13433 when N_Expanded_Name => 13434 if N = Prefix (P) then 13435 return May_Be_Lvalue (P); 13436 else 13437 return False; 13438 end if; 13439 13440 -- For a selected component A.B, A is certainly an lvalue if A.B is. 13441 -- B is a little interesting, if we have A.B := 3, there is some 13442 -- discussion as to whether B is an lvalue or not, we choose to say 13443 -- it is. Note however that A is not an lvalue if it is of an access 13444 -- type since this is an implicit dereference. 13445 13446 when N_Selected_Component => 13447 if N = Prefix (P) 13448 and then Present (Etype (N)) 13449 and then Is_Access_Type (Etype (N)) 13450 then 13451 return False; 13452 else 13453 return May_Be_Lvalue (P); 13454 end if; 13455 13456 -- For an indexed component or slice, the index or slice bounds is 13457 -- never an lvalue. The prefix is an lvalue if the indexed component 13458 -- or slice is an lvalue, except if it is an access type, where we 13459 -- have an implicit dereference. 13460 13461 when N_Indexed_Component | N_Slice => 13462 if N /= Prefix (P) 13463 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 13464 then 13465 return False; 13466 else 13467 return May_Be_Lvalue (P); 13468 end if; 13469 13470 -- Prefix of a reference is an lvalue if the reference is an lvalue 13471 13472 when N_Reference => 13473 return May_Be_Lvalue (P); 13474 13475 -- Prefix of explicit dereference is never an lvalue 13476 13477 when N_Explicit_Dereference => 13478 return False; 13479 13480 -- Positional parameter for subprogram, entry, or accept call. 13481 -- In older versions of Ada function call arguments are never 13482 -- lvalues. In Ada 2012 functions can have in-out parameters. 13483 13484 when N_Subprogram_Call | 13485 N_Entry_Call_Statement | 13486 N_Accept_Statement 13487 => 13488 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 13489 return False; 13490 end if; 13491 13492 -- The following mechanism is clumsy and fragile. A single flag 13493 -- set in Resolve_Actuals would be preferable ??? 13494 13495 declare 13496 Proc : Entity_Id; 13497 Form : Entity_Id; 13498 Act : Node_Id; 13499 13500 begin 13501 Proc := Get_Subprogram_Entity (P); 13502 13503 if No (Proc) then 13504 return True; 13505 end if; 13506 13507 -- If we are not a list member, something is strange, so be 13508 -- conservative and return True. 13509 13510 if not Is_List_Member (N) then 13511 return True; 13512 end if; 13513 13514 -- We are going to find the right formal by stepping forward 13515 -- through the formals, as we step backwards in the actuals. 13516 13517 Form := First_Formal (Proc); 13518 Act := N; 13519 loop 13520 -- If no formal, something is weird, so be conservative and 13521 -- return True. 13522 13523 if No (Form) then 13524 return True; 13525 end if; 13526 13527 Prev (Act); 13528 exit when No (Act); 13529 Next_Formal (Form); 13530 end loop; 13531 13532 return Ekind (Form) /= E_In_Parameter; 13533 end; 13534 13535 -- Named parameter for procedure or accept call 13536 13537 when N_Parameter_Association => 13538 declare 13539 Proc : Entity_Id; 13540 Form : Entity_Id; 13541 13542 begin 13543 Proc := Get_Subprogram_Entity (Parent (P)); 13544 13545 if No (Proc) then 13546 return True; 13547 end if; 13548 13549 -- Loop through formals to find the one that matches 13550 13551 Form := First_Formal (Proc); 13552 loop 13553 -- If no matching formal, that's peculiar, some kind of 13554 -- previous error, so return True to be conservative. 13555 -- Actually happens with legal code for an unresolved call 13556 -- where we may get the wrong homonym??? 13557 13558 if No (Form) then 13559 return True; 13560 end if; 13561 13562 -- Else test for match 13563 13564 if Chars (Form) = Chars (Selector_Name (P)) then 13565 return Ekind (Form) /= E_In_Parameter; 13566 end if; 13567 13568 Next_Formal (Form); 13569 end loop; 13570 end; 13571 13572 -- Test for appearing in a conversion that itself appears in an 13573 -- lvalue context, since this should be an lvalue. 13574 13575 when N_Type_Conversion => 13576 return May_Be_Lvalue (P); 13577 13578 -- Test for appearance in object renaming declaration 13579 13580 when N_Object_Renaming_Declaration => 13581 return True; 13582 13583 -- All other references are definitely not lvalues 13584 13585 when others => 13586 return False; 13587 13588 end case; 13589 end May_Be_Lvalue; 13590 13591 ----------------------- 13592 -- Mark_Coextensions -- 13593 ----------------------- 13594 13595 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 13596 Is_Dynamic : Boolean; 13597 -- Indicates whether the context causes nested coextensions to be 13598 -- dynamic or static 13599 13600 function Mark_Allocator (N : Node_Id) return Traverse_Result; 13601 -- Recognize an allocator node and label it as a dynamic coextension 13602 13603 -------------------- 13604 -- Mark_Allocator -- 13605 -------------------- 13606 13607 function Mark_Allocator (N : Node_Id) return Traverse_Result is 13608 begin 13609 if Nkind (N) = N_Allocator then 13610 if Is_Dynamic then 13611 Set_Is_Dynamic_Coextension (N); 13612 13613 -- If the allocator expression is potentially dynamic, it may 13614 -- be expanded out of order and require dynamic allocation 13615 -- anyway, so we treat the coextension itself as dynamic. 13616 -- Potential optimization ??? 13617 13618 elsif Nkind (Expression (N)) = N_Qualified_Expression 13619 and then Nkind (Expression (Expression (N))) = N_Op_Concat 13620 then 13621 Set_Is_Dynamic_Coextension (N); 13622 else 13623 Set_Is_Static_Coextension (N); 13624 end if; 13625 end if; 13626 13627 return OK; 13628 end Mark_Allocator; 13629 13630 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 13631 13632 -- Start of processing Mark_Coextensions 13633 13634 begin 13635 case Nkind (Context_Nod) is 13636 13637 -- Comment here ??? 13638 13639 when N_Assignment_Statement => 13640 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator; 13641 13642 -- An allocator that is a component of a returned aggregate 13643 -- must be dynamic. 13644 13645 when N_Simple_Return_Statement => 13646 declare 13647 Expr : constant Node_Id := Expression (Context_Nod); 13648 begin 13649 Is_Dynamic := 13650 Nkind (Expr) = N_Allocator 13651 or else 13652 (Nkind (Expr) = N_Qualified_Expression 13653 and then Nkind (Expression (Expr)) = N_Aggregate); 13654 end; 13655 13656 -- An alloctor within an object declaration in an extended return 13657 -- statement is of necessity dynamic. 13658 13659 when N_Object_Declaration => 13660 Is_Dynamic := Nkind (Root_Nod) = N_Allocator 13661 or else 13662 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 13663 13664 -- This routine should not be called for constructs which may not 13665 -- contain coextensions. 13666 13667 when others => 13668 raise Program_Error; 13669 end case; 13670 13671 Mark_Allocators (Root_Nod); 13672 end Mark_Coextensions; 13673 13674 ---------------------- 13675 -- Needs_One_Actual -- 13676 ---------------------- 13677 13678 function Needs_One_Actual (E : Entity_Id) return Boolean is 13679 Formal : Entity_Id; 13680 13681 begin 13682 -- Ada 2005 or later, and formals present 13683 13684 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then 13685 Formal := Next_Formal (First_Formal (E)); 13686 while Present (Formal) loop 13687 if No (Default_Value (Formal)) then 13688 return False; 13689 end if; 13690 13691 Next_Formal (Formal); 13692 end loop; 13693 13694 return True; 13695 13696 -- Ada 83/95 or no formals 13697 13698 else 13699 return False; 13700 end if; 13701 end Needs_One_Actual; 13702 13703 ------------------------ 13704 -- New_Copy_List_Tree -- 13705 ------------------------ 13706 13707 function New_Copy_List_Tree (List : List_Id) return List_Id is 13708 NL : List_Id; 13709 E : Node_Id; 13710 13711 begin 13712 if List = No_List then 13713 return No_List; 13714 13715 else 13716 NL := New_List; 13717 E := First (List); 13718 13719 while Present (E) loop 13720 Append (New_Copy_Tree (E), NL); 13721 E := Next (E); 13722 end loop; 13723 13724 return NL; 13725 end if; 13726 end New_Copy_List_Tree; 13727 13728 -------------------------------------------------- 13729 -- New_Copy_Tree Auxiliary Data and Subprograms -- 13730 -------------------------------------------------- 13731 13732 use Atree.Unchecked_Access; 13733 use Atree_Private_Part; 13734 13735 -- Our approach here requires a two pass traversal of the tree. The 13736 -- first pass visits all nodes that eventually will be copied looking 13737 -- for defining Itypes. If any defining Itypes are found, then they are 13738 -- copied, and an entry is added to the replacement map. In the second 13739 -- phase, the tree is copied, using the replacement map to replace any 13740 -- Itype references within the copied tree. 13741 13742 -- The following hash tables are used if the Map supplied has more 13743 -- than hash threshold entries to speed up access to the map. If 13744 -- there are fewer entries, then the map is searched sequentially 13745 -- (because setting up a hash table for only a few entries takes 13746 -- more time than it saves. 13747 13748 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; 13749 -- Hash function used for hash operations 13750 13751 ------------------- 13752 -- New_Copy_Hash -- 13753 ------------------- 13754 13755 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is 13756 begin 13757 return Nat (E) mod (NCT_Header_Num'Last + 1); 13758 end New_Copy_Hash; 13759 13760 --------------- 13761 -- NCT_Assoc -- 13762 --------------- 13763 13764 -- The hash table NCT_Assoc associates old entities in the table 13765 -- with their corresponding new entities (i.e. the pairs of entries 13766 -- presented in the original Map argument are Key-Element pairs). 13767 13768 package NCT_Assoc is new Simple_HTable ( 13769 Header_Num => NCT_Header_Num, 13770 Element => Entity_Id, 13771 No_Element => Empty, 13772 Key => Entity_Id, 13773 Hash => New_Copy_Hash, 13774 Equal => Types."="); 13775 13776 --------------------- 13777 -- NCT_Itype_Assoc -- 13778 --------------------- 13779 13780 -- The hash table NCT_Itype_Assoc contains entries only for those 13781 -- old nodes which have a non-empty Associated_Node_For_Itype set. 13782 -- The key is the associated node, and the element is the new node 13783 -- itself (NOT the associated node for the new node). 13784 13785 package NCT_Itype_Assoc is new Simple_HTable ( 13786 Header_Num => NCT_Header_Num, 13787 Element => Entity_Id, 13788 No_Element => Empty, 13789 Key => Entity_Id, 13790 Hash => New_Copy_Hash, 13791 Equal => Types."="); 13792 13793 ------------------- 13794 -- New_Copy_Tree -- 13795 ------------------- 13796 13797 function New_Copy_Tree 13798 (Source : Node_Id; 13799 Map : Elist_Id := No_Elist; 13800 New_Sloc : Source_Ptr := No_Location; 13801 New_Scope : Entity_Id := Empty) return Node_Id 13802 is 13803 Actual_Map : Elist_Id := Map; 13804 -- This is the actual map for the copy. It is initialized with the 13805 -- given elements, and then enlarged as required for Itypes that are 13806 -- copied during the first phase of the copy operation. The visit 13807 -- procedures add elements to this map as Itypes are encountered. 13808 -- The reason we cannot use Map directly, is that it may well be 13809 -- (and normally is) initialized to No_Elist, and if we have mapped 13810 -- entities, we have to reset it to point to a real Elist. 13811 13812 function Assoc (N : Node_Or_Entity_Id) return Node_Id; 13813 -- Called during second phase to map entities into their corresponding 13814 -- copies using Actual_Map. If the argument is not an entity, or is not 13815 -- in Actual_Map, then it is returned unchanged. 13816 13817 procedure Build_NCT_Hash_Tables; 13818 -- Builds hash tables (number of elements >= threshold value) 13819 13820 function Copy_Elist_With_Replacement 13821 (Old_Elist : Elist_Id) return Elist_Id; 13822 -- Called during second phase to copy element list doing replacements 13823 13824 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id); 13825 -- Called during the second phase to process a copied Itype. The actual 13826 -- copy happened during the first phase (so that we could make the entry 13827 -- in the mapping), but we still have to deal with the descendents of 13828 -- the copied Itype and copy them where necessary. 13829 13830 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id; 13831 -- Called during second phase to copy list doing replacements 13832 13833 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id; 13834 -- Called during second phase to copy node doing replacements 13835 13836 procedure Visit_Elist (E : Elist_Id); 13837 -- Called during first phase to visit all elements of an Elist 13838 13839 procedure Visit_Field (F : Union_Id; N : Node_Id); 13840 -- Visit a single field, recursing to call Visit_Node or Visit_List 13841 -- if the field is a syntactic descendent of the current node (i.e. 13842 -- its parent is Node N). 13843 13844 procedure Visit_Itype (Old_Itype : Entity_Id); 13845 -- Called during first phase to visit subsidiary fields of a defining 13846 -- Itype, and also create a copy and make an entry in the replacement 13847 -- map for the new copy. 13848 13849 procedure Visit_List (L : List_Id); 13850 -- Called during first phase to visit all elements of a List 13851 13852 procedure Visit_Node (N : Node_Or_Entity_Id); 13853 -- Called during first phase to visit a node and all its subtrees 13854 13855 ----------- 13856 -- Assoc -- 13857 ----------- 13858 13859 function Assoc (N : Node_Or_Entity_Id) return Node_Id is 13860 E : Elmt_Id; 13861 Ent : Entity_Id; 13862 13863 begin 13864 if not Has_Extension (N) or else No (Actual_Map) then 13865 return N; 13866 13867 elsif NCT_Hash_Tables_Used then 13868 Ent := NCT_Assoc.Get (Entity_Id (N)); 13869 13870 if Present (Ent) then 13871 return Ent; 13872 else 13873 return N; 13874 end if; 13875 13876 -- No hash table used, do serial search 13877 13878 else 13879 E := First_Elmt (Actual_Map); 13880 while Present (E) loop 13881 if Node (E) = N then 13882 return Node (Next_Elmt (E)); 13883 else 13884 E := Next_Elmt (Next_Elmt (E)); 13885 end if; 13886 end loop; 13887 end if; 13888 13889 return N; 13890 end Assoc; 13891 13892 --------------------------- 13893 -- Build_NCT_Hash_Tables -- 13894 --------------------------- 13895 13896 procedure Build_NCT_Hash_Tables is 13897 Elmt : Elmt_Id; 13898 Ent : Entity_Id; 13899 begin 13900 if NCT_Hash_Table_Setup then 13901 NCT_Assoc.Reset; 13902 NCT_Itype_Assoc.Reset; 13903 end if; 13904 13905 Elmt := First_Elmt (Actual_Map); 13906 while Present (Elmt) loop 13907 Ent := Node (Elmt); 13908 13909 -- Get new entity, and associate old and new 13910 13911 Next_Elmt (Elmt); 13912 NCT_Assoc.Set (Ent, Node (Elmt)); 13913 13914 if Is_Type (Ent) then 13915 declare 13916 Anode : constant Entity_Id := 13917 Associated_Node_For_Itype (Ent); 13918 13919 begin 13920 if Present (Anode) then 13921 13922 -- Enter a link between the associated node of the 13923 -- old Itype and the new Itype, for updating later 13924 -- when node is copied. 13925 13926 NCT_Itype_Assoc.Set (Anode, Node (Elmt)); 13927 end if; 13928 end; 13929 end if; 13930 13931 Next_Elmt (Elmt); 13932 end loop; 13933 13934 NCT_Hash_Tables_Used := True; 13935 NCT_Hash_Table_Setup := True; 13936 end Build_NCT_Hash_Tables; 13937 13938 --------------------------------- 13939 -- Copy_Elist_With_Replacement -- 13940 --------------------------------- 13941 13942 function Copy_Elist_With_Replacement 13943 (Old_Elist : Elist_Id) return Elist_Id 13944 is 13945 M : Elmt_Id; 13946 New_Elist : Elist_Id; 13947 13948 begin 13949 if No (Old_Elist) then 13950 return No_Elist; 13951 13952 else 13953 New_Elist := New_Elmt_List; 13954 13955 M := First_Elmt (Old_Elist); 13956 while Present (M) loop 13957 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist); 13958 Next_Elmt (M); 13959 end loop; 13960 end if; 13961 13962 return New_Elist; 13963 end Copy_Elist_With_Replacement; 13964 13965 --------------------------------- 13966 -- Copy_Itype_With_Replacement -- 13967 --------------------------------- 13968 13969 -- This routine exactly parallels its phase one analog Visit_Itype, 13970 13971 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is 13972 begin 13973 -- Translate Next_Entity, Scope and Etype fields, in case they 13974 -- reference entities that have been mapped into copies. 13975 13976 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype))); 13977 Set_Etype (New_Itype, Assoc (Etype (New_Itype))); 13978 13979 if Present (New_Scope) then 13980 Set_Scope (New_Itype, New_Scope); 13981 else 13982 Set_Scope (New_Itype, Assoc (Scope (New_Itype))); 13983 end if; 13984 13985 -- Copy referenced fields 13986 13987 if Is_Discrete_Type (New_Itype) then 13988 Set_Scalar_Range (New_Itype, 13989 Copy_Node_With_Replacement (Scalar_Range (New_Itype))); 13990 13991 elsif Has_Discriminants (Base_Type (New_Itype)) then 13992 Set_Discriminant_Constraint (New_Itype, 13993 Copy_Elist_With_Replacement 13994 (Discriminant_Constraint (New_Itype))); 13995 13996 elsif Is_Array_Type (New_Itype) then 13997 if Present (First_Index (New_Itype)) then 13998 Set_First_Index (New_Itype, 13999 First (Copy_List_With_Replacement 14000 (List_Containing (First_Index (New_Itype))))); 14001 end if; 14002 14003 if Is_Packed (New_Itype) then 14004 Set_Packed_Array_Impl_Type (New_Itype, 14005 Copy_Node_With_Replacement 14006 (Packed_Array_Impl_Type (New_Itype))); 14007 end if; 14008 end if; 14009 end Copy_Itype_With_Replacement; 14010 14011 -------------------------------- 14012 -- Copy_List_With_Replacement -- 14013 -------------------------------- 14014 14015 function Copy_List_With_Replacement 14016 (Old_List : List_Id) return List_Id 14017 is 14018 New_List : List_Id; 14019 E : Node_Id; 14020 14021 begin 14022 if Old_List = No_List then 14023 return No_List; 14024 14025 else 14026 New_List := Empty_List; 14027 14028 E := First (Old_List); 14029 while Present (E) loop 14030 Append (Copy_Node_With_Replacement (E), New_List); 14031 Next (E); 14032 end loop; 14033 14034 return New_List; 14035 end if; 14036 end Copy_List_With_Replacement; 14037 14038 -------------------------------- 14039 -- Copy_Node_With_Replacement -- 14040 -------------------------------- 14041 14042 function Copy_Node_With_Replacement 14043 (Old_Node : Node_Id) return Node_Id 14044 is 14045 New_Node : Node_Id; 14046 14047 procedure Adjust_Named_Associations 14048 (Old_Node : Node_Id; 14049 New_Node : Node_Id); 14050 -- If a call node has named associations, these are chained through 14051 -- the First_Named_Actual, Next_Named_Actual links. These must be 14052 -- propagated separately to the new parameter list, because these 14053 -- are not syntactic fields. 14054 14055 function Copy_Field_With_Replacement 14056 (Field : Union_Id) return Union_Id; 14057 -- Given Field, which is a field of Old_Node, return a copy of it 14058 -- if it is a syntactic field (i.e. its parent is Node), setting 14059 -- the parent of the copy to poit to New_Node. Otherwise returns 14060 -- the field (possibly mapped if it is an entity). 14061 14062 ------------------------------- 14063 -- Adjust_Named_Associations -- 14064 ------------------------------- 14065 14066 procedure Adjust_Named_Associations 14067 (Old_Node : Node_Id; 14068 New_Node : Node_Id) 14069 is 14070 Old_E : Node_Id; 14071 New_E : Node_Id; 14072 14073 Old_Next : Node_Id; 14074 New_Next : Node_Id; 14075 14076 begin 14077 Old_E := First (Parameter_Associations (Old_Node)); 14078 New_E := First (Parameter_Associations (New_Node)); 14079 while Present (Old_E) loop 14080 if Nkind (Old_E) = N_Parameter_Association 14081 and then Present (Next_Named_Actual (Old_E)) 14082 then 14083 if First_Named_Actual (Old_Node) 14084 = Explicit_Actual_Parameter (Old_E) 14085 then 14086 Set_First_Named_Actual 14087 (New_Node, Explicit_Actual_Parameter (New_E)); 14088 end if; 14089 14090 -- Now scan parameter list from the beginning,to locate 14091 -- next named actual, which can be out of order. 14092 14093 Old_Next := First (Parameter_Associations (Old_Node)); 14094 New_Next := First (Parameter_Associations (New_Node)); 14095 14096 while Nkind (Old_Next) /= N_Parameter_Association 14097 or else Explicit_Actual_Parameter (Old_Next) /= 14098 Next_Named_Actual (Old_E) 14099 loop 14100 Next (Old_Next); 14101 Next (New_Next); 14102 end loop; 14103 14104 Set_Next_Named_Actual 14105 (New_E, Explicit_Actual_Parameter (New_Next)); 14106 end if; 14107 14108 Next (Old_E); 14109 Next (New_E); 14110 end loop; 14111 end Adjust_Named_Associations; 14112 14113 --------------------------------- 14114 -- Copy_Field_With_Replacement -- 14115 --------------------------------- 14116 14117 function Copy_Field_With_Replacement 14118 (Field : Union_Id) return Union_Id 14119 is 14120 begin 14121 if Field = Union_Id (Empty) then 14122 return Field; 14123 14124 elsif Field in Node_Range then 14125 declare 14126 Old_N : constant Node_Id := Node_Id (Field); 14127 New_N : Node_Id; 14128 14129 begin 14130 -- If syntactic field, as indicated by the parent pointer 14131 -- being set, then copy the referenced node recursively. 14132 14133 if Parent (Old_N) = Old_Node then 14134 New_N := Copy_Node_With_Replacement (Old_N); 14135 14136 if New_N /= Old_N then 14137 Set_Parent (New_N, New_Node); 14138 end if; 14139 14140 -- For semantic fields, update possible entity reference 14141 -- from the replacement map. 14142 14143 else 14144 New_N := Assoc (Old_N); 14145 end if; 14146 14147 return Union_Id (New_N); 14148 end; 14149 14150 elsif Field in List_Range then 14151 declare 14152 Old_L : constant List_Id := List_Id (Field); 14153 New_L : List_Id; 14154 14155 begin 14156 -- If syntactic field, as indicated by the parent pointer, 14157 -- then recursively copy the entire referenced list. 14158 14159 if Parent (Old_L) = Old_Node then 14160 New_L := Copy_List_With_Replacement (Old_L); 14161 Set_Parent (New_L, New_Node); 14162 14163 -- For semantic list, just returned unchanged 14164 14165 else 14166 New_L := Old_L; 14167 end if; 14168 14169 return Union_Id (New_L); 14170 end; 14171 14172 -- Anything other than a list or a node is returned unchanged 14173 14174 else 14175 return Field; 14176 end if; 14177 end Copy_Field_With_Replacement; 14178 14179 -- Start of processing for Copy_Node_With_Replacement 14180 14181 begin 14182 if Old_Node <= Empty_Or_Error then 14183 return Old_Node; 14184 14185 elsif Has_Extension (Old_Node) then 14186 return Assoc (Old_Node); 14187 14188 else 14189 New_Node := New_Copy (Old_Node); 14190 14191 -- If the node we are copying is the associated node of a 14192 -- previously copied Itype, then adjust the associated node 14193 -- of the copy of that Itype accordingly. 14194 14195 if Present (Actual_Map) then 14196 declare 14197 E : Elmt_Id; 14198 Ent : Entity_Id; 14199 14200 begin 14201 -- Case of hash table used 14202 14203 if NCT_Hash_Tables_Used then 14204 Ent := NCT_Itype_Assoc.Get (Old_Node); 14205 14206 if Present (Ent) then 14207 Set_Associated_Node_For_Itype (Ent, New_Node); 14208 end if; 14209 14210 -- Case of no hash table used 14211 14212 else 14213 E := First_Elmt (Actual_Map); 14214 while Present (E) loop 14215 if Is_Itype (Node (E)) 14216 and then 14217 Old_Node = Associated_Node_For_Itype (Node (E)) 14218 then 14219 Set_Associated_Node_For_Itype 14220 (Node (Next_Elmt (E)), New_Node); 14221 end if; 14222 14223 E := Next_Elmt (Next_Elmt (E)); 14224 end loop; 14225 end if; 14226 end; 14227 end if; 14228 14229 -- Recursively copy descendents 14230 14231 Set_Field1 14232 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node))); 14233 Set_Field2 14234 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node))); 14235 Set_Field3 14236 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node))); 14237 Set_Field4 14238 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node))); 14239 Set_Field5 14240 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); 14241 14242 -- Adjust Sloc of new node if necessary 14243 14244 if New_Sloc /= No_Location then 14245 Set_Sloc (New_Node, New_Sloc); 14246 14247 -- If we adjust the Sloc, then we are essentially making 14248 -- a completely new node, so the Comes_From_Source flag 14249 -- should be reset to the proper default value. 14250 14251 Nodes.Table (New_Node).Comes_From_Source := 14252 Default_Node.Comes_From_Source; 14253 end if; 14254 14255 -- If the node is call and has named associations, 14256 -- set the corresponding links in the copy. 14257 14258 if (Nkind (Old_Node) = N_Function_Call 14259 or else Nkind (Old_Node) = N_Entry_Call_Statement 14260 or else 14261 Nkind (Old_Node) = N_Procedure_Call_Statement) 14262 and then Present (First_Named_Actual (Old_Node)) 14263 then 14264 Adjust_Named_Associations (Old_Node, New_Node); 14265 end if; 14266 14267 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. 14268 -- The replacement mechanism applies to entities, and is not used 14269 -- here. Eventually we may need a more general graph-copying 14270 -- routine. For now, do a sequential search to find desired node. 14271 14272 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements 14273 and then Present (First_Real_Statement (Old_Node)) 14274 then 14275 declare 14276 Old_F : constant Node_Id := First_Real_Statement (Old_Node); 14277 N1, N2 : Node_Id; 14278 14279 begin 14280 N1 := First (Statements (Old_Node)); 14281 N2 := First (Statements (New_Node)); 14282 14283 while N1 /= Old_F loop 14284 Next (N1); 14285 Next (N2); 14286 end loop; 14287 14288 Set_First_Real_Statement (New_Node, N2); 14289 end; 14290 end if; 14291 end if; 14292 14293 -- All done, return copied node 14294 14295 return New_Node; 14296 end Copy_Node_With_Replacement; 14297 14298 ----------------- 14299 -- Visit_Elist -- 14300 ----------------- 14301 14302 procedure Visit_Elist (E : Elist_Id) is 14303 Elmt : Elmt_Id; 14304 begin 14305 if Present (E) then 14306 Elmt := First_Elmt (E); 14307 14308 while Elmt /= No_Elmt loop 14309 Visit_Node (Node (Elmt)); 14310 Next_Elmt (Elmt); 14311 end loop; 14312 end if; 14313 end Visit_Elist; 14314 14315 ----------------- 14316 -- Visit_Field -- 14317 ----------------- 14318 14319 procedure Visit_Field (F : Union_Id; N : Node_Id) is 14320 begin 14321 if F = Union_Id (Empty) then 14322 return; 14323 14324 elsif F in Node_Range then 14325 14326 -- Copy node if it is syntactic, i.e. its parent pointer is 14327 -- set to point to the field that referenced it (certain 14328 -- Itypes will also meet this criterion, which is fine, since 14329 -- these are clearly Itypes that do need to be copied, since 14330 -- we are copying their parent.) 14331 14332 if Parent (Node_Id (F)) = N then 14333 Visit_Node (Node_Id (F)); 14334 return; 14335 14336 -- Another case, if we are pointing to an Itype, then we want 14337 -- to copy it if its associated node is somewhere in the tree 14338 -- being copied. 14339 14340 -- Note: the exclusion of self-referential copies is just an 14341 -- optimization, since the search of the already copied list 14342 -- would catch it, but it is a common case (Etype pointing 14343 -- to itself for an Itype that is a base type). 14344 14345 elsif Has_Extension (Node_Id (F)) 14346 and then Is_Itype (Entity_Id (F)) 14347 and then Node_Id (F) /= N 14348 then 14349 declare 14350 P : Node_Id; 14351 14352 begin 14353 P := Associated_Node_For_Itype (Node_Id (F)); 14354 while Present (P) loop 14355 if P = Source then 14356 Visit_Node (Node_Id (F)); 14357 return; 14358 else 14359 P := Parent (P); 14360 end if; 14361 end loop; 14362 14363 -- An Itype whose parent is not being copied definitely 14364 -- should NOT be copied, since it does not belong in any 14365 -- sense to the copied subtree. 14366 14367 return; 14368 end; 14369 end if; 14370 14371 elsif F in List_Range and then Parent (List_Id (F)) = N then 14372 Visit_List (List_Id (F)); 14373 return; 14374 end if; 14375 end Visit_Field; 14376 14377 ----------------- 14378 -- Visit_Itype -- 14379 ----------------- 14380 14381 procedure Visit_Itype (Old_Itype : Entity_Id) is 14382 New_Itype : Entity_Id; 14383 E : Elmt_Id; 14384 Ent : Entity_Id; 14385 14386 begin 14387 -- Itypes that describe the designated type of access to subprograms 14388 -- have the structure of subprogram declarations, with signatures, 14389 -- etc. Either we duplicate the signatures completely, or choose to 14390 -- share such itypes, which is fine because their elaboration will 14391 -- have no side effects. 14392 14393 if Ekind (Old_Itype) = E_Subprogram_Type then 14394 return; 14395 end if; 14396 14397 New_Itype := New_Copy (Old_Itype); 14398 14399 -- The new Itype has all the attributes of the old one, and 14400 -- we just copy the contents of the entity. However, the back-end 14401 -- needs different names for debugging purposes, so we create a 14402 -- new internal name for it in all cases. 14403 14404 Set_Chars (New_Itype, New_Internal_Name ('T')); 14405 14406 -- If our associated node is an entity that has already been copied, 14407 -- then set the associated node of the copy to point to the right 14408 -- copy. If we have copied an Itype that is itself the associated 14409 -- node of some previously copied Itype, then we set the right 14410 -- pointer in the other direction. 14411 14412 if Present (Actual_Map) then 14413 14414 -- Case of hash tables used 14415 14416 if NCT_Hash_Tables_Used then 14417 14418 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype)); 14419 14420 if Present (Ent) then 14421 Set_Associated_Node_For_Itype (New_Itype, Ent); 14422 end if; 14423 14424 Ent := NCT_Itype_Assoc.Get (Old_Itype); 14425 if Present (Ent) then 14426 Set_Associated_Node_For_Itype (Ent, New_Itype); 14427 14428 -- If the hash table has no association for this Itype and 14429 -- its associated node, enter one now. 14430 14431 else 14432 NCT_Itype_Assoc.Set 14433 (Associated_Node_For_Itype (Old_Itype), New_Itype); 14434 end if; 14435 14436 -- Case of hash tables not used 14437 14438 else 14439 E := First_Elmt (Actual_Map); 14440 while Present (E) loop 14441 if Associated_Node_For_Itype (Old_Itype) = Node (E) then 14442 Set_Associated_Node_For_Itype 14443 (New_Itype, Node (Next_Elmt (E))); 14444 end if; 14445 14446 if Is_Type (Node (E)) 14447 and then Old_Itype = Associated_Node_For_Itype (Node (E)) 14448 then 14449 Set_Associated_Node_For_Itype 14450 (Node (Next_Elmt (E)), New_Itype); 14451 end if; 14452 14453 E := Next_Elmt (Next_Elmt (E)); 14454 end loop; 14455 end if; 14456 end if; 14457 14458 if Present (Freeze_Node (New_Itype)) then 14459 Set_Is_Frozen (New_Itype, False); 14460 Set_Freeze_Node (New_Itype, Empty); 14461 end if; 14462 14463 -- Add new association to map 14464 14465 if No (Actual_Map) then 14466 Actual_Map := New_Elmt_List; 14467 end if; 14468 14469 Append_Elmt (Old_Itype, Actual_Map); 14470 Append_Elmt (New_Itype, Actual_Map); 14471 14472 if NCT_Hash_Tables_Used then 14473 NCT_Assoc.Set (Old_Itype, New_Itype); 14474 14475 else 14476 NCT_Table_Entries := NCT_Table_Entries + 1; 14477 14478 if NCT_Table_Entries > NCT_Hash_Threshold then 14479 Build_NCT_Hash_Tables; 14480 end if; 14481 end if; 14482 14483 -- If a record subtype is simply copied, the entity list will be 14484 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 14485 14486 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then 14487 Set_Cloned_Subtype (New_Itype, Old_Itype); 14488 end if; 14489 14490 -- Visit descendents that eventually get copied 14491 14492 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype); 14493 14494 if Is_Discrete_Type (Old_Itype) then 14495 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype); 14496 14497 elsif Has_Discriminants (Base_Type (Old_Itype)) then 14498 -- ??? This should involve call to Visit_Field 14499 Visit_Elist (Discriminant_Constraint (Old_Itype)); 14500 14501 elsif Is_Array_Type (Old_Itype) then 14502 if Present (First_Index (Old_Itype)) then 14503 Visit_Field (Union_Id (List_Containing 14504 (First_Index (Old_Itype))), 14505 Old_Itype); 14506 end if; 14507 14508 if Is_Packed (Old_Itype) then 14509 Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)), 14510 Old_Itype); 14511 end if; 14512 end if; 14513 end Visit_Itype; 14514 14515 ---------------- 14516 -- Visit_List -- 14517 ---------------- 14518 14519 procedure Visit_List (L : List_Id) is 14520 N : Node_Id; 14521 begin 14522 if L /= No_List then 14523 N := First (L); 14524 14525 while Present (N) loop 14526 Visit_Node (N); 14527 Next (N); 14528 end loop; 14529 end if; 14530 end Visit_List; 14531 14532 ---------------- 14533 -- Visit_Node -- 14534 ---------------- 14535 14536 procedure Visit_Node (N : Node_Or_Entity_Id) is 14537 14538 -- Start of processing for Visit_Node 14539 14540 begin 14541 -- Handle case of an Itype, which must be copied 14542 14543 if Has_Extension (N) and then Is_Itype (N) then 14544 14545 -- Nothing to do if already in the list. This can happen with an 14546 -- Itype entity that appears more than once in the tree. 14547 -- Note that we do not want to visit descendents in this case. 14548 14549 -- Test for already in list when hash table is used 14550 14551 if NCT_Hash_Tables_Used then 14552 if Present (NCT_Assoc.Get (Entity_Id (N))) then 14553 return; 14554 end if; 14555 14556 -- Test for already in list when hash table not used 14557 14558 else 14559 declare 14560 E : Elmt_Id; 14561 begin 14562 if Present (Actual_Map) then 14563 E := First_Elmt (Actual_Map); 14564 while Present (E) loop 14565 if Node (E) = N then 14566 return; 14567 else 14568 E := Next_Elmt (Next_Elmt (E)); 14569 end if; 14570 end loop; 14571 end if; 14572 end; 14573 end if; 14574 14575 Visit_Itype (N); 14576 end if; 14577 14578 -- Visit descendents 14579 14580 Visit_Field (Field1 (N), N); 14581 Visit_Field (Field2 (N), N); 14582 Visit_Field (Field3 (N), N); 14583 Visit_Field (Field4 (N), N); 14584 Visit_Field (Field5 (N), N); 14585 end Visit_Node; 14586 14587 -- Start of processing for New_Copy_Tree 14588 14589 begin 14590 Actual_Map := Map; 14591 14592 -- See if we should use hash table 14593 14594 if No (Actual_Map) then 14595 NCT_Hash_Tables_Used := False; 14596 14597 else 14598 declare 14599 Elmt : Elmt_Id; 14600 14601 begin 14602 NCT_Table_Entries := 0; 14603 14604 Elmt := First_Elmt (Actual_Map); 14605 while Present (Elmt) loop 14606 NCT_Table_Entries := NCT_Table_Entries + 1; 14607 Next_Elmt (Elmt); 14608 Next_Elmt (Elmt); 14609 end loop; 14610 14611 if NCT_Table_Entries > NCT_Hash_Threshold then 14612 Build_NCT_Hash_Tables; 14613 else 14614 NCT_Hash_Tables_Used := False; 14615 end if; 14616 end; 14617 end if; 14618 14619 -- Hash table set up if required, now start phase one by visiting 14620 -- top node (we will recursively visit the descendents). 14621 14622 Visit_Node (Source); 14623 14624 -- Now the second phase of the copy can start. First we process 14625 -- all the mapped entities, copying their descendents. 14626 14627 if Present (Actual_Map) then 14628 declare 14629 Elmt : Elmt_Id; 14630 New_Itype : Entity_Id; 14631 begin 14632 Elmt := First_Elmt (Actual_Map); 14633 while Present (Elmt) loop 14634 Next_Elmt (Elmt); 14635 New_Itype := Node (Elmt); 14636 Copy_Itype_With_Replacement (New_Itype); 14637 Next_Elmt (Elmt); 14638 end loop; 14639 end; 14640 end if; 14641 14642 -- Now we can copy the actual tree 14643 14644 return Copy_Node_With_Replacement (Source); 14645 end New_Copy_Tree; 14646 14647 ------------------------- 14648 -- New_External_Entity -- 14649 ------------------------- 14650 14651 function New_External_Entity 14652 (Kind : Entity_Kind; 14653 Scope_Id : Entity_Id; 14654 Sloc_Value : Source_Ptr; 14655 Related_Id : Entity_Id; 14656 Suffix : Character; 14657 Suffix_Index : Nat := 0; 14658 Prefix : Character := ' ') return Entity_Id 14659 is 14660 N : constant Entity_Id := 14661 Make_Defining_Identifier (Sloc_Value, 14662 New_External_Name 14663 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 14664 14665 begin 14666 Set_Ekind (N, Kind); 14667 Set_Is_Internal (N, True); 14668 Append_Entity (N, Scope_Id); 14669 Set_Public_Status (N); 14670 14671 if Kind in Type_Kind then 14672 Init_Size_Align (N); 14673 end if; 14674 14675 return N; 14676 end New_External_Entity; 14677 14678 ------------------------- 14679 -- New_Internal_Entity -- 14680 ------------------------- 14681 14682 function New_Internal_Entity 14683 (Kind : Entity_Kind; 14684 Scope_Id : Entity_Id; 14685 Sloc_Value : Source_Ptr; 14686 Id_Char : Character) return Entity_Id 14687 is 14688 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 14689 14690 begin 14691 Set_Ekind (N, Kind); 14692 Set_Is_Internal (N, True); 14693 Append_Entity (N, Scope_Id); 14694 14695 if Kind in Type_Kind then 14696 Init_Size_Align (N); 14697 end if; 14698 14699 return N; 14700 end New_Internal_Entity; 14701 14702 ----------------- 14703 -- Next_Actual -- 14704 ----------------- 14705 14706 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 14707 N : Node_Id; 14708 14709 begin 14710 -- If we are pointing at a positional parameter, it is a member of a 14711 -- node list (the list of parameters), and the next parameter is the 14712 -- next node on the list, unless we hit a parameter association, then 14713 -- we shift to using the chain whose head is the First_Named_Actual in 14714 -- the parent, and then is threaded using the Next_Named_Actual of the 14715 -- Parameter_Association. All this fiddling is because the original node 14716 -- list is in the textual call order, and what we need is the 14717 -- declaration order. 14718 14719 if Is_List_Member (Actual_Id) then 14720 N := Next (Actual_Id); 14721 14722 if Nkind (N) = N_Parameter_Association then 14723 return First_Named_Actual (Parent (Actual_Id)); 14724 else 14725 return N; 14726 end if; 14727 14728 else 14729 return Next_Named_Actual (Parent (Actual_Id)); 14730 end if; 14731 end Next_Actual; 14732 14733 procedure Next_Actual (Actual_Id : in out Node_Id) is 14734 begin 14735 Actual_Id := Next_Actual (Actual_Id); 14736 end Next_Actual; 14737 14738 ----------------------- 14739 -- Normalize_Actuals -- 14740 ----------------------- 14741 14742 -- Chain actuals according to formals of subprogram. If there are no named 14743 -- associations, the chain is simply the list of Parameter Associations, 14744 -- since the order is the same as the declaration order. If there are named 14745 -- associations, then the First_Named_Actual field in the N_Function_Call 14746 -- or N_Procedure_Call_Statement node points to the Parameter_Association 14747 -- node for the parameter that comes first in declaration order. The 14748 -- remaining named parameters are then chained in declaration order using 14749 -- Next_Named_Actual. 14750 14751 -- This routine also verifies that the number of actuals is compatible with 14752 -- the number and default values of formals, but performs no type checking 14753 -- (type checking is done by the caller). 14754 14755 -- If the matching succeeds, Success is set to True and the caller proceeds 14756 -- with type-checking. If the match is unsuccessful, then Success is set to 14757 -- False, and the caller attempts a different interpretation, if there is 14758 -- one. 14759 14760 -- If the flag Report is on, the call is not overloaded, and a failure to 14761 -- match can be reported here, rather than in the caller. 14762 14763 procedure Normalize_Actuals 14764 (N : Node_Id; 14765 S : Entity_Id; 14766 Report : Boolean; 14767 Success : out Boolean) 14768 is 14769 Actuals : constant List_Id := Parameter_Associations (N); 14770 Actual : Node_Id := Empty; 14771 Formal : Entity_Id; 14772 Last : Node_Id := Empty; 14773 First_Named : Node_Id := Empty; 14774 Found : Boolean; 14775 14776 Formals_To_Match : Integer := 0; 14777 Actuals_To_Match : Integer := 0; 14778 14779 procedure Chain (A : Node_Id); 14780 -- Add named actual at the proper place in the list, using the 14781 -- Next_Named_Actual link. 14782 14783 function Reporting return Boolean; 14784 -- Determines if an error is to be reported. To report an error, we 14785 -- need Report to be True, and also we do not report errors caused 14786 -- by calls to init procs that occur within other init procs. Such 14787 -- errors must always be cascaded errors, since if all the types are 14788 -- declared correctly, the compiler will certainly build decent calls. 14789 14790 ----------- 14791 -- Chain -- 14792 ----------- 14793 14794 procedure Chain (A : Node_Id) is 14795 begin 14796 if No (Last) then 14797 14798 -- Call node points to first actual in list 14799 14800 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 14801 14802 else 14803 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 14804 end if; 14805 14806 Last := A; 14807 Set_Next_Named_Actual (Last, Empty); 14808 end Chain; 14809 14810 --------------- 14811 -- Reporting -- 14812 --------------- 14813 14814 function Reporting return Boolean is 14815 begin 14816 if not Report then 14817 return False; 14818 14819 elsif not Within_Init_Proc then 14820 return True; 14821 14822 elsif Is_Init_Proc (Entity (Name (N))) then 14823 return False; 14824 14825 else 14826 return True; 14827 end if; 14828 end Reporting; 14829 14830 -- Start of processing for Normalize_Actuals 14831 14832 begin 14833 if Is_Access_Type (S) then 14834 14835 -- The name in the call is a function call that returns an access 14836 -- to subprogram. The designated type has the list of formals. 14837 14838 Formal := First_Formal (Designated_Type (S)); 14839 else 14840 Formal := First_Formal (S); 14841 end if; 14842 14843 while Present (Formal) loop 14844 Formals_To_Match := Formals_To_Match + 1; 14845 Next_Formal (Formal); 14846 end loop; 14847 14848 -- Find if there is a named association, and verify that no positional 14849 -- associations appear after named ones. 14850 14851 if Present (Actuals) then 14852 Actual := First (Actuals); 14853 end if; 14854 14855 while Present (Actual) 14856 and then Nkind (Actual) /= N_Parameter_Association 14857 loop 14858 Actuals_To_Match := Actuals_To_Match + 1; 14859 Next (Actual); 14860 end loop; 14861 14862 if No (Actual) and Actuals_To_Match = Formals_To_Match then 14863 14864 -- Most common case: positional notation, no defaults 14865 14866 Success := True; 14867 return; 14868 14869 elsif Actuals_To_Match > Formals_To_Match then 14870 14871 -- Too many actuals: will not work 14872 14873 if Reporting then 14874 if Is_Entity_Name (Name (N)) then 14875 Error_Msg_N ("too many arguments in call to&", Name (N)); 14876 else 14877 Error_Msg_N ("too many arguments in call", N); 14878 end if; 14879 end if; 14880 14881 Success := False; 14882 return; 14883 end if; 14884 14885 First_Named := Actual; 14886 14887 while Present (Actual) loop 14888 if Nkind (Actual) /= N_Parameter_Association then 14889 Error_Msg_N 14890 ("positional parameters not allowed after named ones", Actual); 14891 Success := False; 14892 return; 14893 14894 else 14895 Actuals_To_Match := Actuals_To_Match + 1; 14896 end if; 14897 14898 Next (Actual); 14899 end loop; 14900 14901 if Present (Actuals) then 14902 Actual := First (Actuals); 14903 end if; 14904 14905 Formal := First_Formal (S); 14906 while Present (Formal) loop 14907 14908 -- Match the formals in order. If the corresponding actual is 14909 -- positional, nothing to do. Else scan the list of named actuals 14910 -- to find the one with the right name. 14911 14912 if Present (Actual) 14913 and then Nkind (Actual) /= N_Parameter_Association 14914 then 14915 Next (Actual); 14916 Actuals_To_Match := Actuals_To_Match - 1; 14917 Formals_To_Match := Formals_To_Match - 1; 14918 14919 else 14920 -- For named parameters, search the list of actuals to find 14921 -- one that matches the next formal name. 14922 14923 Actual := First_Named; 14924 Found := False; 14925 while Present (Actual) loop 14926 if Chars (Selector_Name (Actual)) = Chars (Formal) then 14927 Found := True; 14928 Chain (Actual); 14929 Actuals_To_Match := Actuals_To_Match - 1; 14930 Formals_To_Match := Formals_To_Match - 1; 14931 exit; 14932 end if; 14933 14934 Next (Actual); 14935 end loop; 14936 14937 if not Found then 14938 if Ekind (Formal) /= E_In_Parameter 14939 or else No (Default_Value (Formal)) 14940 then 14941 if Reporting then 14942 if (Comes_From_Source (S) 14943 or else Sloc (S) = Standard_Location) 14944 and then Is_Overloadable (S) 14945 then 14946 if No (Actuals) 14947 and then 14948 Nkind_In (Parent (N), N_Procedure_Call_Statement, 14949 N_Function_Call, 14950 N_Parameter_Association) 14951 and then Ekind (S) /= E_Function 14952 then 14953 Set_Etype (N, Etype (S)); 14954 14955 else 14956 Error_Msg_Name_1 := Chars (S); 14957 Error_Msg_Sloc := Sloc (S); 14958 Error_Msg_NE 14959 ("missing argument for parameter & " 14960 & "in call to % declared #", N, Formal); 14961 end if; 14962 14963 elsif Is_Overloadable (S) then 14964 Error_Msg_Name_1 := Chars (S); 14965 14966 -- Point to type derivation that generated the 14967 -- operation. 14968 14969 Error_Msg_Sloc := Sloc (Parent (S)); 14970 14971 Error_Msg_NE 14972 ("missing argument for parameter & " 14973 & "in call to % (inherited) #", N, Formal); 14974 14975 else 14976 Error_Msg_NE 14977 ("missing argument for parameter &", N, Formal); 14978 end if; 14979 end if; 14980 14981 Success := False; 14982 return; 14983 14984 else 14985 Formals_To_Match := Formals_To_Match - 1; 14986 end if; 14987 end if; 14988 end if; 14989 14990 Next_Formal (Formal); 14991 end loop; 14992 14993 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 14994 Success := True; 14995 return; 14996 14997 else 14998 if Reporting then 14999 15000 -- Find some superfluous named actual that did not get 15001 -- attached to the list of associations. 15002 15003 Actual := First (Actuals); 15004 while Present (Actual) loop 15005 if Nkind (Actual) = N_Parameter_Association 15006 and then Actual /= Last 15007 and then No (Next_Named_Actual (Actual)) 15008 then 15009 Error_Msg_N ("unmatched actual & in call", 15010 Selector_Name (Actual)); 15011 exit; 15012 end if; 15013 15014 Next (Actual); 15015 end loop; 15016 end if; 15017 15018 Success := False; 15019 return; 15020 end if; 15021 end Normalize_Actuals; 15022 15023 -------------------------------- 15024 -- Note_Possible_Modification -- 15025 -------------------------------- 15026 15027 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 15028 Modification_Comes_From_Source : constant Boolean := 15029 Comes_From_Source (Parent (N)); 15030 15031 Ent : Entity_Id; 15032 Exp : Node_Id; 15033 15034 begin 15035 -- Loop to find referenced entity, if there is one 15036 15037 Exp := N; 15038 loop 15039 Ent := Empty; 15040 15041 if Is_Entity_Name (Exp) then 15042 Ent := Entity (Exp); 15043 15044 -- If the entity is missing, it is an undeclared identifier, 15045 -- and there is nothing to annotate. 15046 15047 if No (Ent) then 15048 return; 15049 end if; 15050 15051 elsif Nkind (Exp) = N_Explicit_Dereference then 15052 declare 15053 P : constant Node_Id := Prefix (Exp); 15054 15055 begin 15056 -- In formal verification mode, keep track of all reads and 15057 -- writes through explicit dereferences. 15058 15059 if GNATprove_Mode then 15060 SPARK_Specific.Generate_Dereference (N, 'm'); 15061 end if; 15062 15063 if Nkind (P) = N_Selected_Component 15064 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 15065 then 15066 -- Case of a reference to an entry formal 15067 15068 Ent := Entry_Formal (Entity (Selector_Name (P))); 15069 15070 elsif Nkind (P) = N_Identifier 15071 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 15072 and then Present (Expression (Parent (Entity (P)))) 15073 and then Nkind (Expression (Parent (Entity (P)))) = 15074 N_Reference 15075 then 15076 -- Case of a reference to a value on which side effects have 15077 -- been removed. 15078 15079 Exp := Prefix (Expression (Parent (Entity (P)))); 15080 goto Continue; 15081 15082 else 15083 return; 15084 end if; 15085 end; 15086 15087 elsif Nkind_In (Exp, N_Type_Conversion, 15088 N_Unchecked_Type_Conversion) 15089 then 15090 Exp := Expression (Exp); 15091 goto Continue; 15092 15093 elsif Nkind_In (Exp, N_Slice, 15094 N_Indexed_Component, 15095 N_Selected_Component) 15096 then 15097 -- Special check, if the prefix is an access type, then return 15098 -- since we are modifying the thing pointed to, not the prefix. 15099 -- When we are expanding, most usually the prefix is replaced 15100 -- by an explicit dereference, and this test is not needed, but 15101 -- in some cases (notably -gnatc mode and generics) when we do 15102 -- not do full expansion, we need this special test. 15103 15104 if Is_Access_Type (Etype (Prefix (Exp))) then 15105 return; 15106 15107 -- Otherwise go to prefix and keep going 15108 15109 else 15110 Exp := Prefix (Exp); 15111 goto Continue; 15112 end if; 15113 15114 -- All other cases, not a modification 15115 15116 else 15117 return; 15118 end if; 15119 15120 -- Now look for entity being referenced 15121 15122 if Present (Ent) then 15123 if Is_Object (Ent) then 15124 if Comes_From_Source (Exp) 15125 or else Modification_Comes_From_Source 15126 then 15127 -- Give warning if pragma unmodified given and we are 15128 -- sure this is a modification. 15129 15130 if Has_Pragma_Unmodified (Ent) and then Sure then 15131 Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent); 15132 end if; 15133 15134 Set_Never_Set_In_Source (Ent, False); 15135 end if; 15136 15137 Set_Is_True_Constant (Ent, False); 15138 Set_Current_Value (Ent, Empty); 15139 Set_Is_Known_Null (Ent, False); 15140 15141 if not Can_Never_Be_Null (Ent) then 15142 Set_Is_Known_Non_Null (Ent, False); 15143 end if; 15144 15145 -- Follow renaming chain 15146 15147 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 15148 and then Present (Renamed_Object (Ent)) 15149 then 15150 Exp := Renamed_Object (Ent); 15151 15152 -- If the entity is the loop variable in an iteration over 15153 -- a container, retrieve container expression to indicate 15154 -- possible modification. 15155 15156 if Present (Related_Expression (Ent)) 15157 and then Nkind (Parent (Related_Expression (Ent))) = 15158 N_Iterator_Specification 15159 then 15160 Exp := Original_Node (Related_Expression (Ent)); 15161 end if; 15162 15163 goto Continue; 15164 15165 -- The expression may be the renaming of a subcomponent of an 15166 -- array or container. The assignment to the subcomponent is 15167 -- a modification of the container. 15168 15169 elsif Comes_From_Source (Original_Node (Exp)) 15170 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 15171 N_Indexed_Component) 15172 then 15173 Exp := Prefix (Original_Node (Exp)); 15174 goto Continue; 15175 end if; 15176 15177 -- Generate a reference only if the assignment comes from 15178 -- source. This excludes, for example, calls to a dispatching 15179 -- assignment operation when the left-hand side is tagged. In 15180 -- GNATprove mode, we need those references also on generated 15181 -- code, as these are used to compute the local effects of 15182 -- subprograms. 15183 15184 if Modification_Comes_From_Source or GNATprove_Mode then 15185 Generate_Reference (Ent, Exp, 'm'); 15186 15187 -- If the target of the assignment is the bound variable 15188 -- in an iterator, indicate that the corresponding array 15189 -- or container is also modified. 15190 15191 if Ada_Version >= Ada_2012 15192 and then Nkind (Parent (Ent)) = N_Iterator_Specification 15193 then 15194 declare 15195 Domain : constant Node_Id := Name (Parent (Ent)); 15196 15197 begin 15198 -- TBD : in the full version of the construct, the 15199 -- domain of iteration can be given by an expression. 15200 15201 if Is_Entity_Name (Domain) then 15202 Generate_Reference (Entity (Domain), Exp, 'm'); 15203 Set_Is_True_Constant (Entity (Domain), False); 15204 Set_Never_Set_In_Source (Entity (Domain), False); 15205 end if; 15206 end; 15207 end if; 15208 end if; 15209 15210 Check_Nested_Access (N, Ent); 15211 end if; 15212 15213 Kill_Checks (Ent); 15214 15215 -- If we are sure this is a modification from source, and we know 15216 -- this modifies a constant, then give an appropriate warning. 15217 15218 if Overlays_Constant (Ent) 15219 and then (Modification_Comes_From_Source and Sure) 15220 then 15221 declare 15222 A : constant Node_Id := Address_Clause (Ent); 15223 begin 15224 if Present (A) then 15225 declare 15226 Exp : constant Node_Id := Expression (A); 15227 begin 15228 if Nkind (Exp) = N_Attribute_Reference 15229 and then Attribute_Name (Exp) = Name_Address 15230 and then Is_Entity_Name (Prefix (Exp)) 15231 then 15232 Error_Msg_Sloc := Sloc (A); 15233 Error_Msg_NE 15234 ("constant& may be modified via address " 15235 & "clause#??", N, Entity (Prefix (Exp))); 15236 end if; 15237 end; 15238 end if; 15239 end; 15240 end if; 15241 15242 return; 15243 end if; 15244 15245 <<Continue>> 15246 null; 15247 end loop; 15248 end Note_Possible_Modification; 15249 15250 ------------------------- 15251 -- Object_Access_Level -- 15252 ------------------------- 15253 15254 -- Returns the static accessibility level of the view denoted by Obj. Note 15255 -- that the value returned is the result of a call to Scope_Depth. Only 15256 -- scope depths associated with dynamic scopes can actually be returned. 15257 -- Since only relative levels matter for accessibility checking, the fact 15258 -- that the distance between successive levels of accessibility is not 15259 -- always one is immaterial (invariant: if level(E2) is deeper than 15260 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 15261 15262 function Object_Access_Level (Obj : Node_Id) return Uint is 15263 function Is_Interface_Conversion (N : Node_Id) return Boolean; 15264 -- Determine whether N is a construct of the form 15265 -- Some_Type (Operand._tag'Address) 15266 -- This construct appears in the context of dispatching calls. 15267 15268 function Reference_To (Obj : Node_Id) return Node_Id; 15269 -- An explicit dereference is created when removing side-effects from 15270 -- expressions for constraint checking purposes. In this case a local 15271 -- access type is created for it. The correct access level is that of 15272 -- the original source node. We detect this case by noting that the 15273 -- prefix of the dereference is created by an object declaration whose 15274 -- initial expression is a reference. 15275 15276 ----------------------------- 15277 -- Is_Interface_Conversion -- 15278 ----------------------------- 15279 15280 function Is_Interface_Conversion (N : Node_Id) return Boolean is 15281 begin 15282 return Nkind (N) = N_Unchecked_Type_Conversion 15283 and then Nkind (Expression (N)) = N_Attribute_Reference 15284 and then Attribute_Name (Expression (N)) = Name_Address; 15285 end Is_Interface_Conversion; 15286 15287 ------------------ 15288 -- Reference_To -- 15289 ------------------ 15290 15291 function Reference_To (Obj : Node_Id) return Node_Id is 15292 Pref : constant Node_Id := Prefix (Obj); 15293 begin 15294 if Is_Entity_Name (Pref) 15295 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 15296 and then Present (Expression (Parent (Entity (Pref)))) 15297 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 15298 then 15299 return (Prefix (Expression (Parent (Entity (Pref))))); 15300 else 15301 return Empty; 15302 end if; 15303 end Reference_To; 15304 15305 -- Local variables 15306 15307 E : Entity_Id; 15308 15309 -- Start of processing for Object_Access_Level 15310 15311 begin 15312 if Nkind (Obj) = N_Defining_Identifier 15313 or else Is_Entity_Name (Obj) 15314 then 15315 if Nkind (Obj) = N_Defining_Identifier then 15316 E := Obj; 15317 else 15318 E := Entity (Obj); 15319 end if; 15320 15321 if Is_Prival (E) then 15322 E := Prival_Link (E); 15323 end if; 15324 15325 -- If E is a type then it denotes a current instance. For this case 15326 -- we add one to the normal accessibility level of the type to ensure 15327 -- that current instances are treated as always being deeper than 15328 -- than the level of any visible named access type (see 3.10.2(21)). 15329 15330 if Is_Type (E) then 15331 return Type_Access_Level (E) + 1; 15332 15333 elsif Present (Renamed_Object (E)) then 15334 return Object_Access_Level (Renamed_Object (E)); 15335 15336 -- Similarly, if E is a component of the current instance of a 15337 -- protected type, any instance of it is assumed to be at a deeper 15338 -- level than the type. For a protected object (whose type is an 15339 -- anonymous protected type) its components are at the same level 15340 -- as the type itself. 15341 15342 elsif not Is_Overloadable (E) 15343 and then Ekind (Scope (E)) = E_Protected_Type 15344 and then Comes_From_Source (Scope (E)) 15345 then 15346 return Type_Access_Level (Scope (E)) + 1; 15347 15348 else 15349 -- Aliased formals take their access level from the point of call. 15350 -- This is smaller than the level of the subprogram itself. 15351 15352 if Is_Formal (E) and then Is_Aliased (E) then 15353 return Type_Access_Level (Etype (E)); 15354 15355 else 15356 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 15357 end if; 15358 end if; 15359 15360 elsif Nkind (Obj) = N_Selected_Component then 15361 if Is_Access_Type (Etype (Prefix (Obj))) then 15362 return Type_Access_Level (Etype (Prefix (Obj))); 15363 else 15364 return Object_Access_Level (Prefix (Obj)); 15365 end if; 15366 15367 elsif Nkind (Obj) = N_Indexed_Component then 15368 if Is_Access_Type (Etype (Prefix (Obj))) then 15369 return Type_Access_Level (Etype (Prefix (Obj))); 15370 else 15371 return Object_Access_Level (Prefix (Obj)); 15372 end if; 15373 15374 elsif Nkind (Obj) = N_Explicit_Dereference then 15375 15376 -- If the prefix is a selected access discriminant then we make a 15377 -- recursive call on the prefix, which will in turn check the level 15378 -- of the prefix object of the selected discriminant. 15379 15380 -- In Ada 2012, if the discriminant has implicit dereference and 15381 -- the context is a selected component, treat this as an object of 15382 -- unknown scope (see below). This is necessary in compile-only mode; 15383 -- otherwise expansion will already have transformed the prefix into 15384 -- a temporary. 15385 15386 if Nkind (Prefix (Obj)) = N_Selected_Component 15387 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 15388 and then 15389 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 15390 and then 15391 (not Has_Implicit_Dereference 15392 (Entity (Selector_Name (Prefix (Obj)))) 15393 or else Nkind (Parent (Obj)) /= N_Selected_Component) 15394 then 15395 return Object_Access_Level (Prefix (Obj)); 15396 15397 -- Detect an interface conversion in the context of a dispatching 15398 -- call. Use the original form of the conversion to find the access 15399 -- level of the operand. 15400 15401 elsif Is_Interface (Etype (Obj)) 15402 and then Is_Interface_Conversion (Prefix (Obj)) 15403 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 15404 then 15405 return Object_Access_Level (Original_Node (Obj)); 15406 15407 elsif not Comes_From_Source (Obj) then 15408 declare 15409 Ref : constant Node_Id := Reference_To (Obj); 15410 begin 15411 if Present (Ref) then 15412 return Object_Access_Level (Ref); 15413 else 15414 return Type_Access_Level (Etype (Prefix (Obj))); 15415 end if; 15416 end; 15417 15418 else 15419 return Type_Access_Level (Etype (Prefix (Obj))); 15420 end if; 15421 15422 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 15423 return Object_Access_Level (Expression (Obj)); 15424 15425 elsif Nkind (Obj) = N_Function_Call then 15426 15427 -- Function results are objects, so we get either the access level of 15428 -- the function or, in the case of an indirect call, the level of the 15429 -- access-to-subprogram type. (This code is used for Ada 95, but it 15430 -- looks wrong, because it seems that we should be checking the level 15431 -- of the call itself, even for Ada 95. However, using the Ada 2005 15432 -- version of the code causes regressions in several tests that are 15433 -- compiled with -gnat95. ???) 15434 15435 if Ada_Version < Ada_2005 then 15436 if Is_Entity_Name (Name (Obj)) then 15437 return Subprogram_Access_Level (Entity (Name (Obj))); 15438 else 15439 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 15440 end if; 15441 15442 -- For Ada 2005, the level of the result object of a function call is 15443 -- defined to be the level of the call's innermost enclosing master. 15444 -- We determine that by querying the depth of the innermost enclosing 15445 -- dynamic scope. 15446 15447 else 15448 Return_Master_Scope_Depth_Of_Call : declare 15449 15450 function Innermost_Master_Scope_Depth 15451 (N : Node_Id) return Uint; 15452 -- Returns the scope depth of the given node's innermost 15453 -- enclosing dynamic scope (effectively the accessibility 15454 -- level of the innermost enclosing master). 15455 15456 ---------------------------------- 15457 -- Innermost_Master_Scope_Depth -- 15458 ---------------------------------- 15459 15460 function Innermost_Master_Scope_Depth 15461 (N : Node_Id) return Uint 15462 is 15463 Node_Par : Node_Id := Parent (N); 15464 15465 begin 15466 -- Locate the nearest enclosing node (by traversing Parents) 15467 -- that Defining_Entity can be applied to, and return the 15468 -- depth of that entity's nearest enclosing dynamic scope. 15469 15470 while Present (Node_Par) loop 15471 case Nkind (Node_Par) is 15472 when N_Component_Declaration | 15473 N_Entry_Declaration | 15474 N_Formal_Object_Declaration | 15475 N_Formal_Type_Declaration | 15476 N_Full_Type_Declaration | 15477 N_Incomplete_Type_Declaration | 15478 N_Loop_Parameter_Specification | 15479 N_Object_Declaration | 15480 N_Protected_Type_Declaration | 15481 N_Private_Extension_Declaration | 15482 N_Private_Type_Declaration | 15483 N_Subtype_Declaration | 15484 N_Function_Specification | 15485 N_Procedure_Specification | 15486 N_Task_Type_Declaration | 15487 N_Body_Stub | 15488 N_Generic_Instantiation | 15489 N_Proper_Body | 15490 N_Implicit_Label_Declaration | 15491 N_Package_Declaration | 15492 N_Single_Task_Declaration | 15493 N_Subprogram_Declaration | 15494 N_Generic_Declaration | 15495 N_Renaming_Declaration | 15496 N_Block_Statement | 15497 N_Formal_Subprogram_Declaration | 15498 N_Abstract_Subprogram_Declaration | 15499 N_Entry_Body | 15500 N_Exception_Declaration | 15501 N_Formal_Package_Declaration | 15502 N_Number_Declaration | 15503 N_Package_Specification | 15504 N_Parameter_Specification | 15505 N_Single_Protected_Declaration | 15506 N_Subunit => 15507 15508 return Scope_Depth 15509 (Nearest_Dynamic_Scope 15510 (Defining_Entity (Node_Par))); 15511 15512 when others => 15513 null; 15514 end case; 15515 15516 Node_Par := Parent (Node_Par); 15517 end loop; 15518 15519 pragma Assert (False); 15520 15521 -- Should never reach the following return 15522 15523 return Scope_Depth (Current_Scope) + 1; 15524 end Innermost_Master_Scope_Depth; 15525 15526 -- Start of processing for Return_Master_Scope_Depth_Of_Call 15527 15528 begin 15529 return Innermost_Master_Scope_Depth (Obj); 15530 end Return_Master_Scope_Depth_Of_Call; 15531 end if; 15532 15533 -- For convenience we handle qualified expressions, even though they 15534 -- aren't technically object names. 15535 15536 elsif Nkind (Obj) = N_Qualified_Expression then 15537 return Object_Access_Level (Expression (Obj)); 15538 15539 -- Ditto for aggregates. They have the level of the temporary that 15540 -- will hold their value. 15541 15542 elsif Nkind (Obj) = N_Aggregate then 15543 return Object_Access_Level (Current_Scope); 15544 15545 -- Otherwise return the scope level of Standard. (If there are cases 15546 -- that fall through to this point they will be treated as having 15547 -- global accessibility for now. ???) 15548 15549 else 15550 return Scope_Depth (Standard_Standard); 15551 end if; 15552 end Object_Access_Level; 15553 15554 --------------------------------- 15555 -- Original_Aspect_Pragma_Name -- 15556 --------------------------------- 15557 15558 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 15559 Item : Node_Id; 15560 Item_Nam : Name_Id; 15561 15562 begin 15563 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); 15564 15565 Item := N; 15566 15567 -- The pragma was generated to emulate an aspect, use the original 15568 -- aspect specification. 15569 15570 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 15571 Item := Corresponding_Aspect (Item); 15572 end if; 15573 15574 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class, 15575 -- Post and Post_Class rewrite their pragma identifier to preserve the 15576 -- original name. 15577 -- ??? this is kludgey 15578 15579 if Nkind (Item) = N_Pragma then 15580 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item))); 15581 15582 else 15583 pragma Assert (Nkind (Item) = N_Aspect_Specification); 15584 Item_Nam := Chars (Identifier (Item)); 15585 end if; 15586 15587 -- Deal with 'Class by converting the name to its _XXX form 15588 15589 if Class_Present (Item) then 15590 if Item_Nam = Name_Invariant then 15591 Item_Nam := Name_uInvariant; 15592 15593 elsif Item_Nam = Name_Post then 15594 Item_Nam := Name_uPost; 15595 15596 elsif Item_Nam = Name_Pre then 15597 Item_Nam := Name_uPre; 15598 15599 elsif Nam_In (Item_Nam, Name_Type_Invariant, 15600 Name_Type_Invariant_Class) 15601 then 15602 Item_Nam := Name_uType_Invariant; 15603 15604 -- Nothing to do for other cases (e.g. a Check that derived from 15605 -- Pre_Class and has the flag set). Also we do nothing if the name 15606 -- is already in special _xxx form. 15607 15608 end if; 15609 end if; 15610 15611 return Item_Nam; 15612 end Original_Aspect_Pragma_Name; 15613 15614 -------------------------------------- 15615 -- Original_Corresponding_Operation -- 15616 -------------------------------------- 15617 15618 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 15619 is 15620 Typ : constant Entity_Id := Find_Dispatching_Type (S); 15621 15622 begin 15623 -- If S is an inherited primitive S2 the original corresponding 15624 -- operation of S is the original corresponding operation of S2 15625 15626 if Present (Alias (S)) 15627 and then Find_Dispatching_Type (Alias (S)) /= Typ 15628 then 15629 return Original_Corresponding_Operation (Alias (S)); 15630 15631 -- If S overrides an inherited subprogram S2 the original corresponding 15632 -- operation of S is the original corresponding operation of S2 15633 15634 elsif Present (Overridden_Operation (S)) then 15635 return Original_Corresponding_Operation (Overridden_Operation (S)); 15636 15637 -- otherwise it is S itself 15638 15639 else 15640 return S; 15641 end if; 15642 end Original_Corresponding_Operation; 15643 15644 ---------------------- 15645 -- Policy_In_Effect -- 15646 ---------------------- 15647 15648 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 15649 function Policy_In_List (List : Node_Id) return Name_Id; 15650 -- Determine the the mode of a policy in a N_Pragma list 15651 15652 -------------------- 15653 -- Policy_In_List -- 15654 -------------------- 15655 15656 function Policy_In_List (List : Node_Id) return Name_Id is 15657 Arg : Node_Id; 15658 Expr : Node_Id; 15659 Prag : Node_Id; 15660 15661 begin 15662 Prag := List; 15663 while Present (Prag) loop 15664 Arg := First (Pragma_Argument_Associations (Prag)); 15665 Expr := Get_Pragma_Arg (Arg); 15666 15667 -- The current Check_Policy pragma matches the requested policy, 15668 -- return the second argument which denotes the policy identifier. 15669 15670 if Chars (Expr) = Policy then 15671 return Chars (Get_Pragma_Arg (Next (Arg))); 15672 end if; 15673 15674 Prag := Next_Pragma (Prag); 15675 end loop; 15676 15677 return No_Name; 15678 end Policy_In_List; 15679 15680 -- Local variables 15681 15682 Kind : Name_Id; 15683 15684 -- Start of processing for Policy_In_Effect 15685 15686 begin 15687 if not Is_Valid_Assertion_Kind (Policy) then 15688 raise Program_Error; 15689 end if; 15690 15691 -- Inspect all policy pragmas that appear within scopes (if any) 15692 15693 Kind := Policy_In_List (Check_Policy_List); 15694 15695 -- Inspect all configuration policy pragmas (if any) 15696 15697 if Kind = No_Name then 15698 Kind := Policy_In_List (Check_Policy_List_Config); 15699 end if; 15700 15701 -- The context lacks policy pragmas, determine the mode based on whether 15702 -- assertions are enabled at the configuration level. This ensures that 15703 -- the policy is preserved when analyzing generics. 15704 15705 if Kind = No_Name then 15706 if Assertions_Enabled_Config then 15707 Kind := Name_Check; 15708 else 15709 Kind := Name_Ignore; 15710 end if; 15711 end if; 15712 15713 return Kind; 15714 end Policy_In_Effect; 15715 15716 ---------------------------------- 15717 -- Predicate_Tests_On_Arguments -- 15718 ---------------------------------- 15719 15720 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 15721 begin 15722 -- Always test predicates on indirect call 15723 15724 if Ekind (Subp) = E_Subprogram_Type then 15725 return True; 15726 15727 -- Do not test predicates on call to generated default Finalize, since 15728 -- we are not interested in whether something we are finalizing (and 15729 -- typically destroying) satisfies its predicates. 15730 15731 elsif Chars (Subp) = Name_Finalize 15732 and then not Comes_From_Source (Subp) 15733 then 15734 return False; 15735 15736 -- Do not test predicates on any internally generated routines 15737 15738 elsif Is_Internal_Name (Chars (Subp)) then 15739 return False; 15740 15741 -- Do not test predicates on call to Init_Proc, since if needed the 15742 -- predicate test will occur at some other point. 15743 15744 elsif Is_Init_Proc (Subp) then 15745 return False; 15746 15747 -- Do not test predicates on call to predicate function, since this 15748 -- would cause infinite recursion. 15749 15750 elsif Ekind (Subp) = E_Function 15751 and then (Is_Predicate_Function (Subp) 15752 or else 15753 Is_Predicate_Function_M (Subp)) 15754 then 15755 return False; 15756 15757 -- For now, no other exceptions 15758 15759 else 15760 return True; 15761 end if; 15762 end Predicate_Tests_On_Arguments; 15763 15764 ----------------------- 15765 -- Private_Component -- 15766 ----------------------- 15767 15768 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 15769 Ancestor : constant Entity_Id := Base_Type (Type_Id); 15770 15771 function Trace_Components 15772 (T : Entity_Id; 15773 Check : Boolean) return Entity_Id; 15774 -- Recursive function that does the work, and checks against circular 15775 -- definition for each subcomponent type. 15776 15777 ---------------------- 15778 -- Trace_Components -- 15779 ---------------------- 15780 15781 function Trace_Components 15782 (T : Entity_Id; 15783 Check : Boolean) return Entity_Id 15784 is 15785 Btype : constant Entity_Id := Base_Type (T); 15786 Component : Entity_Id; 15787 P : Entity_Id; 15788 Candidate : Entity_Id := Empty; 15789 15790 begin 15791 if Check and then Btype = Ancestor then 15792 Error_Msg_N ("circular type definition", Type_Id); 15793 return Any_Type; 15794 end if; 15795 15796 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 15797 if Present (Full_View (Btype)) 15798 and then Is_Record_Type (Full_View (Btype)) 15799 and then not Is_Frozen (Btype) 15800 then 15801 -- To indicate that the ancestor depends on a private type, the 15802 -- current Btype is sufficient. However, to check for circular 15803 -- definition we must recurse on the full view. 15804 15805 Candidate := Trace_Components (Full_View (Btype), True); 15806 15807 if Candidate = Any_Type then 15808 return Any_Type; 15809 else 15810 return Btype; 15811 end if; 15812 15813 else 15814 return Btype; 15815 end if; 15816 15817 elsif Is_Array_Type (Btype) then 15818 return Trace_Components (Component_Type (Btype), True); 15819 15820 elsif Is_Record_Type (Btype) then 15821 Component := First_Entity (Btype); 15822 while Present (Component) 15823 and then Comes_From_Source (Component) 15824 loop 15825 -- Skip anonymous types generated by constrained components 15826 15827 if not Is_Type (Component) then 15828 P := Trace_Components (Etype (Component), True); 15829 15830 if Present (P) then 15831 if P = Any_Type then 15832 return P; 15833 else 15834 Candidate := P; 15835 end if; 15836 end if; 15837 end if; 15838 15839 Next_Entity (Component); 15840 end loop; 15841 15842 return Candidate; 15843 15844 else 15845 return Empty; 15846 end if; 15847 end Trace_Components; 15848 15849 -- Start of processing for Private_Component 15850 15851 begin 15852 return Trace_Components (Type_Id, False); 15853 end Private_Component; 15854 15855 --------------------------- 15856 -- Primitive_Names_Match -- 15857 --------------------------- 15858 15859 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 15860 15861 function Non_Internal_Name (E : Entity_Id) return Name_Id; 15862 -- Given an internal name, returns the corresponding non-internal name 15863 15864 ------------------------ 15865 -- Non_Internal_Name -- 15866 ------------------------ 15867 15868 function Non_Internal_Name (E : Entity_Id) return Name_Id is 15869 begin 15870 Get_Name_String (Chars (E)); 15871 Name_Len := Name_Len - 1; 15872 return Name_Find; 15873 end Non_Internal_Name; 15874 15875 -- Start of processing for Primitive_Names_Match 15876 15877 begin 15878 pragma Assert (Present (E1) and then Present (E2)); 15879 15880 return Chars (E1) = Chars (E2) 15881 or else 15882 (not Is_Internal_Name (Chars (E1)) 15883 and then Is_Internal_Name (Chars (E2)) 15884 and then Non_Internal_Name (E2) = Chars (E1)) 15885 or else 15886 (not Is_Internal_Name (Chars (E2)) 15887 and then Is_Internal_Name (Chars (E1)) 15888 and then Non_Internal_Name (E1) = Chars (E2)) 15889 or else 15890 (Is_Predefined_Dispatching_Operation (E1) 15891 and then Is_Predefined_Dispatching_Operation (E2) 15892 and then Same_TSS (E1, E2)) 15893 or else 15894 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 15895 end Primitive_Names_Match; 15896 15897 ----------------------- 15898 -- Process_End_Label -- 15899 ----------------------- 15900 15901 procedure Process_End_Label 15902 (N : Node_Id; 15903 Typ : Character; 15904 Ent : Entity_Id) 15905 is 15906 Loc : Source_Ptr; 15907 Nam : Node_Id; 15908 Scop : Entity_Id; 15909 15910 Label_Ref : Boolean; 15911 -- Set True if reference to end label itself is required 15912 15913 Endl : Node_Id; 15914 -- Gets set to the operator symbol or identifier that references the 15915 -- entity Ent. For the child unit case, this is the identifier from the 15916 -- designator. For other cases, this is simply Endl. 15917 15918 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 15919 -- N is an identifier node that appears as a parent unit reference in 15920 -- the case where Ent is a child unit. This procedure generates an 15921 -- appropriate cross-reference entry. E is the corresponding entity. 15922 15923 ------------------------- 15924 -- Generate_Parent_Ref -- 15925 ------------------------- 15926 15927 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 15928 begin 15929 -- If names do not match, something weird, skip reference 15930 15931 if Chars (E) = Chars (N) then 15932 15933 -- Generate the reference. We do NOT consider this as a reference 15934 -- for unreferenced symbol purposes. 15935 15936 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 15937 15938 if Style_Check then 15939 Style.Check_Identifier (N, E); 15940 end if; 15941 end if; 15942 end Generate_Parent_Ref; 15943 15944 -- Start of processing for Process_End_Label 15945 15946 begin 15947 -- If no node, ignore. This happens in some error situations, and 15948 -- also for some internally generated structures where no end label 15949 -- references are required in any case. 15950 15951 if No (N) then 15952 return; 15953 end if; 15954 15955 -- Nothing to do if no End_Label, happens for internally generated 15956 -- constructs where we don't want an end label reference anyway. Also 15957 -- nothing to do if Endl is a string literal, which means there was 15958 -- some prior error (bad operator symbol) 15959 15960 Endl := End_Label (N); 15961 15962 if No (Endl) or else Nkind (Endl) = N_String_Literal then 15963 return; 15964 end if; 15965 15966 -- Reference node is not in extended main source unit 15967 15968 if not In_Extended_Main_Source_Unit (N) then 15969 15970 -- Generally we do not collect references except for the extended 15971 -- main source unit. The one exception is the 'e' entry for a 15972 -- package spec, where it is useful for a client to have the 15973 -- ending information to define scopes. 15974 15975 if Typ /= 'e' then 15976 return; 15977 15978 else 15979 Label_Ref := False; 15980 15981 -- For this case, we can ignore any parent references, but we 15982 -- need the package name itself for the 'e' entry. 15983 15984 if Nkind (Endl) = N_Designator then 15985 Endl := Identifier (Endl); 15986 end if; 15987 end if; 15988 15989 -- Reference is in extended main source unit 15990 15991 else 15992 Label_Ref := True; 15993 15994 -- For designator, generate references for the parent entries 15995 15996 if Nkind (Endl) = N_Designator then 15997 15998 -- Generate references for the prefix if the END line comes from 15999 -- source (otherwise we do not need these references) We climb the 16000 -- scope stack to find the expected entities. 16001 16002 if Comes_From_Source (Endl) then 16003 Nam := Name (Endl); 16004 Scop := Current_Scope; 16005 while Nkind (Nam) = N_Selected_Component loop 16006 Scop := Scope (Scop); 16007 exit when No (Scop); 16008 Generate_Parent_Ref (Selector_Name (Nam), Scop); 16009 Nam := Prefix (Nam); 16010 end loop; 16011 16012 if Present (Scop) then 16013 Generate_Parent_Ref (Nam, Scope (Scop)); 16014 end if; 16015 end if; 16016 16017 Endl := Identifier (Endl); 16018 end if; 16019 end if; 16020 16021 -- If the end label is not for the given entity, then either we have 16022 -- some previous error, or this is a generic instantiation for which 16023 -- we do not need to make a cross-reference in this case anyway. In 16024 -- either case we simply ignore the call. 16025 16026 if Chars (Ent) /= Chars (Endl) then 16027 return; 16028 end if; 16029 16030 -- If label was really there, then generate a normal reference and then 16031 -- adjust the location in the end label to point past the name (which 16032 -- should almost always be the semicolon). 16033 16034 Loc := Sloc (Endl); 16035 16036 if Comes_From_Source (Endl) then 16037 16038 -- If a label reference is required, then do the style check and 16039 -- generate an l-type cross-reference entry for the label 16040 16041 if Label_Ref then 16042 if Style_Check then 16043 Style.Check_Identifier (Endl, Ent); 16044 end if; 16045 16046 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 16047 end if; 16048 16049 -- Set the location to point past the label (normally this will 16050 -- mean the semicolon immediately following the label). This is 16051 -- done for the sake of the 'e' or 't' entry generated below. 16052 16053 Get_Decoded_Name_String (Chars (Endl)); 16054 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 16055 16056 else 16057 -- In SPARK mode, no missing label is allowed for packages and 16058 -- subprogram bodies. Detect those cases by testing whether 16059 -- Process_End_Label was called for a body (Typ = 't') or a package. 16060 16061 if Restriction_Check_Required (SPARK_05) 16062 and then (Typ = 't' or else Ekind (Ent) = E_Package) 16063 then 16064 Error_Msg_Node_1 := Endl; 16065 Check_SPARK_05_Restriction 16066 ("`END &` required", Endl, Force => True); 16067 end if; 16068 end if; 16069 16070 -- Now generate the e/t reference 16071 16072 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 16073 16074 -- Restore Sloc, in case modified above, since we have an identifier 16075 -- and the normal Sloc should be left set in the tree. 16076 16077 Set_Sloc (Endl, Loc); 16078 end Process_End_Label; 16079 16080 ---------------- 16081 -- Referenced -- 16082 ---------------- 16083 16084 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 16085 Seen : Boolean := False; 16086 16087 function Is_Reference (N : Node_Id) return Traverse_Result; 16088 -- Determine whether node N denotes a reference to Id. If this is the 16089 -- case, set global flag Seen to True and stop the traversal. 16090 16091 ------------------ 16092 -- Is_Reference -- 16093 ------------------ 16094 16095 function Is_Reference (N : Node_Id) return Traverse_Result is 16096 begin 16097 if Is_Entity_Name (N) 16098 and then Present (Entity (N)) 16099 and then Entity (N) = Id 16100 then 16101 Seen := True; 16102 return Abandon; 16103 else 16104 return OK; 16105 end if; 16106 end Is_Reference; 16107 16108 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 16109 16110 -- Start of processing for Referenced 16111 16112 begin 16113 Inspect_Expression (Expr); 16114 return Seen; 16115 end Referenced; 16116 16117 ------------------------------------ 16118 -- References_Generic_Formal_Type -- 16119 ------------------------------------ 16120 16121 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 16122 16123 function Process (N : Node_Id) return Traverse_Result; 16124 -- Process one node in search for generic formal type 16125 16126 ------------- 16127 -- Process -- 16128 ------------- 16129 16130 function Process (N : Node_Id) return Traverse_Result is 16131 begin 16132 if Nkind (N) in N_Has_Entity then 16133 declare 16134 E : constant Entity_Id := Entity (N); 16135 begin 16136 if Present (E) then 16137 if Is_Generic_Type (E) then 16138 return Abandon; 16139 elsif Present (Etype (E)) 16140 and then Is_Generic_Type (Etype (E)) 16141 then 16142 return Abandon; 16143 end if; 16144 end if; 16145 end; 16146 end if; 16147 16148 return Atree.OK; 16149 end Process; 16150 16151 function Traverse is new Traverse_Func (Process); 16152 -- Traverse tree to look for generic type 16153 16154 begin 16155 if Inside_A_Generic then 16156 return Traverse (N) = Abandon; 16157 else 16158 return False; 16159 end if; 16160 end References_Generic_Formal_Type; 16161 16162 -------------------- 16163 -- Remove_Homonym -- 16164 -------------------- 16165 16166 procedure Remove_Homonym (E : Entity_Id) is 16167 Prev : Entity_Id := Empty; 16168 H : Entity_Id; 16169 16170 begin 16171 if E = Current_Entity (E) then 16172 if Present (Homonym (E)) then 16173 Set_Current_Entity (Homonym (E)); 16174 else 16175 Set_Name_Entity_Id (Chars (E), Empty); 16176 end if; 16177 16178 else 16179 H := Current_Entity (E); 16180 while Present (H) and then H /= E loop 16181 Prev := H; 16182 H := Homonym (H); 16183 end loop; 16184 16185 -- If E is not on the homonym chain, nothing to do 16186 16187 if Present (H) then 16188 Set_Homonym (Prev, Homonym (E)); 16189 end if; 16190 end if; 16191 end Remove_Homonym; 16192 16193 --------------------- 16194 -- Rep_To_Pos_Flag -- 16195 --------------------- 16196 16197 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 16198 begin 16199 return New_Occurrence_Of 16200 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 16201 end Rep_To_Pos_Flag; 16202 16203 -------------------- 16204 -- Require_Entity -- 16205 -------------------- 16206 16207 procedure Require_Entity (N : Node_Id) is 16208 begin 16209 if Is_Entity_Name (N) and then No (Entity (N)) then 16210 if Total_Errors_Detected /= 0 then 16211 Set_Entity (N, Any_Id); 16212 else 16213 raise Program_Error; 16214 end if; 16215 end if; 16216 end Require_Entity; 16217 16218 ------------------------------- 16219 -- Requires_State_Refinement -- 16220 ------------------------------- 16221 16222 function Requires_State_Refinement 16223 (Spec_Id : Entity_Id; 16224 Body_Id : Entity_Id) return Boolean 16225 is 16226 function Mode_Is_Off (Prag : Node_Id) return Boolean; 16227 -- Given pragma SPARK_Mode, determine whether the mode is Off 16228 16229 ----------------- 16230 -- Mode_Is_Off -- 16231 ----------------- 16232 16233 function Mode_Is_Off (Prag : Node_Id) return Boolean is 16234 Mode : Node_Id; 16235 16236 begin 16237 -- The default SPARK mode is On 16238 16239 if No (Prag) then 16240 return False; 16241 end if; 16242 16243 Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 16244 16245 -- Then the pragma lacks an argument, the default mode is On 16246 16247 if No (Mode) then 16248 return False; 16249 else 16250 return Chars (Mode) = Name_Off; 16251 end if; 16252 end Mode_Is_Off; 16253 16254 -- Start of processing for Requires_State_Refinement 16255 16256 begin 16257 -- A package that does not define at least one abstract state cannot 16258 -- possibly require refinement. 16259 16260 if No (Abstract_States (Spec_Id)) then 16261 return False; 16262 16263 -- The package instroduces a single null state which does not merit 16264 -- refinement. 16265 16266 elsif Has_Null_Abstract_State (Spec_Id) then 16267 return False; 16268 16269 -- Check whether the package body is subject to pragma SPARK_Mode. If 16270 -- it is and the mode is Off, the package body is considered to be in 16271 -- regular Ada and does not require refinement. 16272 16273 elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then 16274 return False; 16275 16276 -- The body's SPARK_Mode may be inherited from a similar pragma that 16277 -- appears in the private declarations of the spec. The pragma we are 16278 -- interested appears as the second entry in SPARK_Pragma. 16279 16280 elsif Present (SPARK_Pragma (Spec_Id)) 16281 and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id))) 16282 then 16283 return False; 16284 16285 -- The spec defines at least one abstract state and the body has no way 16286 -- of circumventing the refinement. 16287 16288 else 16289 return True; 16290 end if; 16291 end Requires_State_Refinement; 16292 16293 ------------------------------ 16294 -- Requires_Transient_Scope -- 16295 ------------------------------ 16296 16297 -- A transient scope is required when variable-sized temporaries are 16298 -- allocated in the primary or secondary stack, or when finalization 16299 -- actions must be generated before the next instruction. 16300 16301 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 16302 Typ : constant Entity_Id := Underlying_Type (Id); 16303 16304 -- Start of processing for Requires_Transient_Scope 16305 16306 begin 16307 -- This is a private type which is not completed yet. This can only 16308 -- happen in a default expression (of a formal parameter or of a 16309 -- record component). Do not expand transient scope in this case 16310 16311 if No (Typ) then 16312 return False; 16313 16314 -- Do not expand transient scope for non-existent procedure return 16315 16316 elsif Typ = Standard_Void_Type then 16317 return False; 16318 16319 -- Elementary types do not require a transient scope 16320 16321 elsif Is_Elementary_Type (Typ) then 16322 return False; 16323 16324 -- Generally, indefinite subtypes require a transient scope, since the 16325 -- back end cannot generate temporaries, since this is not a valid type 16326 -- for declaring an object. It might be possible to relax this in the 16327 -- future, e.g. by declaring the maximum possible space for the type. 16328 16329 elsif Is_Indefinite_Subtype (Typ) then 16330 return True; 16331 16332 -- Functions returning tagged types may dispatch on result so their 16333 -- returned value is allocated on the secondary stack. Controlled 16334 -- type temporaries need finalization. 16335 16336 elsif Is_Tagged_Type (Typ) 16337 or else Has_Controlled_Component (Typ) 16338 then 16339 return not Is_Value_Type (Typ); 16340 16341 -- Record type 16342 16343 elsif Is_Record_Type (Typ) then 16344 declare 16345 Comp : Entity_Id; 16346 begin 16347 Comp := First_Entity (Typ); 16348 while Present (Comp) loop 16349 if Ekind (Comp) = E_Component 16350 and then Requires_Transient_Scope (Etype (Comp)) 16351 then 16352 return True; 16353 else 16354 Next_Entity (Comp); 16355 end if; 16356 end loop; 16357 end; 16358 16359 return False; 16360 16361 -- String literal types never require transient scope 16362 16363 elsif Ekind (Typ) = E_String_Literal_Subtype then 16364 return False; 16365 16366 -- Array type. Note that we already know that this is a constrained 16367 -- array, since unconstrained arrays will fail the indefinite test. 16368 16369 elsif Is_Array_Type (Typ) then 16370 16371 -- If component type requires a transient scope, the array does too 16372 16373 if Requires_Transient_Scope (Component_Type (Typ)) then 16374 return True; 16375 16376 -- Otherwise, we only need a transient scope if the size depends on 16377 -- the value of one or more discriminants. 16378 16379 else 16380 return Size_Depends_On_Discriminant (Typ); 16381 end if; 16382 16383 -- All other cases do not require a transient scope 16384 16385 else 16386 return False; 16387 end if; 16388 end Requires_Transient_Scope; 16389 16390 -------------------------- 16391 -- Reset_Analyzed_Flags -- 16392 -------------------------- 16393 16394 procedure Reset_Analyzed_Flags (N : Node_Id) is 16395 16396 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 16397 -- Function used to reset Analyzed flags in tree. Note that we do 16398 -- not reset Analyzed flags in entities, since there is no need to 16399 -- reanalyze entities, and indeed, it is wrong to do so, since it 16400 -- can result in generating auxiliary stuff more than once. 16401 16402 -------------------- 16403 -- Clear_Analyzed -- 16404 -------------------- 16405 16406 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 16407 begin 16408 if not Has_Extension (N) then 16409 Set_Analyzed (N, False); 16410 end if; 16411 16412 return OK; 16413 end Clear_Analyzed; 16414 16415 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 16416 16417 -- Start of processing for Reset_Analyzed_Flags 16418 16419 begin 16420 Reset_Analyzed (N); 16421 end Reset_Analyzed_Flags; 16422 16423 ------------------------ 16424 -- Restore_SPARK_Mode -- 16425 ------------------------ 16426 16427 procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is 16428 begin 16429 SPARK_Mode := Mode; 16430 end Restore_SPARK_Mode; 16431 16432 -------------------------------- 16433 -- Returns_Unconstrained_Type -- 16434 -------------------------------- 16435 16436 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 16437 begin 16438 return Ekind (Subp) = E_Function 16439 and then not Is_Scalar_Type (Etype (Subp)) 16440 and then not Is_Access_Type (Etype (Subp)) 16441 and then not Is_Constrained (Etype (Subp)); 16442 end Returns_Unconstrained_Type; 16443 16444 ---------------------------- 16445 -- Root_Type_Of_Full_View -- 16446 ---------------------------- 16447 16448 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 16449 Rtyp : constant Entity_Id := Root_Type (T); 16450 16451 begin 16452 -- The root type of the full view may itself be a private type. Keep 16453 -- looking for the ultimate derivation parent. 16454 16455 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 16456 return Root_Type_Of_Full_View (Full_View (Rtyp)); 16457 else 16458 return Rtyp; 16459 end if; 16460 end Root_Type_Of_Full_View; 16461 16462 --------------------------- 16463 -- Safe_To_Capture_Value -- 16464 --------------------------- 16465 16466 function Safe_To_Capture_Value 16467 (N : Node_Id; 16468 Ent : Entity_Id; 16469 Cond : Boolean := False) return Boolean 16470 is 16471 begin 16472 -- The only entities for which we track constant values are variables 16473 -- which are not renamings, constants, out parameters, and in out 16474 -- parameters, so check if we have this case. 16475 16476 -- Note: it may seem odd to track constant values for constants, but in 16477 -- fact this routine is used for other purposes than simply capturing 16478 -- the value. In particular, the setting of Known[_Non]_Null. 16479 16480 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 16481 or else 16482 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) 16483 then 16484 null; 16485 16486 -- For conditionals, we also allow loop parameters and all formals, 16487 -- including in parameters. 16488 16489 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then 16490 null; 16491 16492 -- For all other cases, not just unsafe, but impossible to capture 16493 -- Current_Value, since the above are the only entities which have 16494 -- Current_Value fields. 16495 16496 else 16497 return False; 16498 end if; 16499 16500 -- Skip if volatile or aliased, since funny things might be going on in 16501 -- these cases which we cannot necessarily track. Also skip any variable 16502 -- for which an address clause is given, or whose address is taken. Also 16503 -- never capture value of library level variables (an attempt to do so 16504 -- can occur in the case of package elaboration code). 16505 16506 if Treat_As_Volatile (Ent) 16507 or else Is_Aliased (Ent) 16508 or else Present (Address_Clause (Ent)) 16509 or else Address_Taken (Ent) 16510 or else (Is_Library_Level_Entity (Ent) 16511 and then Ekind (Ent) = E_Variable) 16512 then 16513 return False; 16514 end if; 16515 16516 -- OK, all above conditions are met. We also require that the scope of 16517 -- the reference be the same as the scope of the entity, not counting 16518 -- packages and blocks and loops. 16519 16520 declare 16521 E_Scope : constant Entity_Id := Scope (Ent); 16522 R_Scope : Entity_Id; 16523 16524 begin 16525 R_Scope := Current_Scope; 16526 while R_Scope /= Standard_Standard loop 16527 exit when R_Scope = E_Scope; 16528 16529 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 16530 return False; 16531 else 16532 R_Scope := Scope (R_Scope); 16533 end if; 16534 end loop; 16535 end; 16536 16537 -- We also require that the reference does not appear in a context 16538 -- where it is not sure to be executed (i.e. a conditional context 16539 -- or an exception handler). We skip this if Cond is True, since the 16540 -- capturing of values from conditional tests handles this ok. 16541 16542 if Cond then 16543 return True; 16544 end if; 16545 16546 declare 16547 Desc : Node_Id; 16548 P : Node_Id; 16549 16550 begin 16551 Desc := N; 16552 16553 -- Seems dubious that case expressions are not handled here ??? 16554 16555 P := Parent (N); 16556 while Present (P) loop 16557 if Nkind (P) = N_If_Statement 16558 or else Nkind (P) = N_Case_Statement 16559 or else (Nkind (P) in N_Short_Circuit 16560 and then Desc = Right_Opnd (P)) 16561 or else (Nkind (P) = N_If_Expression 16562 and then Desc /= First (Expressions (P))) 16563 or else Nkind (P) = N_Exception_Handler 16564 or else Nkind (P) = N_Selective_Accept 16565 or else Nkind (P) = N_Conditional_Entry_Call 16566 or else Nkind (P) = N_Timed_Entry_Call 16567 or else Nkind (P) = N_Asynchronous_Select 16568 then 16569 return False; 16570 16571 else 16572 Desc := P; 16573 P := Parent (P); 16574 16575 -- A special Ada 2012 case: the original node may be part 16576 -- of the else_actions of a conditional expression, in which 16577 -- case it might not have been expanded yet, and appears in 16578 -- a non-syntactic list of actions. In that case it is clearly 16579 -- not safe to save a value. 16580 16581 if No (P) 16582 and then Is_List_Member (Desc) 16583 and then No (Parent (List_Containing (Desc))) 16584 then 16585 return False; 16586 end if; 16587 end if; 16588 end loop; 16589 end; 16590 16591 -- OK, looks safe to set value 16592 16593 return True; 16594 end Safe_To_Capture_Value; 16595 16596 --------------- 16597 -- Same_Name -- 16598 --------------- 16599 16600 function Same_Name (N1, N2 : Node_Id) return Boolean is 16601 K1 : constant Node_Kind := Nkind (N1); 16602 K2 : constant Node_Kind := Nkind (N2); 16603 16604 begin 16605 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 16606 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 16607 then 16608 return Chars (N1) = Chars (N2); 16609 16610 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 16611 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 16612 then 16613 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 16614 and then Same_Name (Prefix (N1), Prefix (N2)); 16615 16616 else 16617 return False; 16618 end if; 16619 end Same_Name; 16620 16621 ----------------- 16622 -- Same_Object -- 16623 ----------------- 16624 16625 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 16626 N1 : constant Node_Id := Original_Node (Node1); 16627 N2 : constant Node_Id := Original_Node (Node2); 16628 -- We do the tests on original nodes, since we are most interested 16629 -- in the original source, not any expansion that got in the way. 16630 16631 K1 : constant Node_Kind := Nkind (N1); 16632 K2 : constant Node_Kind := Nkind (N2); 16633 16634 begin 16635 -- First case, both are entities with same entity 16636 16637 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 16638 declare 16639 EN1 : constant Entity_Id := Entity (N1); 16640 EN2 : constant Entity_Id := Entity (N2); 16641 begin 16642 if Present (EN1) and then Present (EN2) 16643 and then (Ekind_In (EN1, E_Variable, E_Constant) 16644 or else Is_Formal (EN1)) 16645 and then EN1 = EN2 16646 then 16647 return True; 16648 end if; 16649 end; 16650 end if; 16651 16652 -- Second case, selected component with same selector, same record 16653 16654 if K1 = N_Selected_Component 16655 and then K2 = N_Selected_Component 16656 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 16657 then 16658 return Same_Object (Prefix (N1), Prefix (N2)); 16659 16660 -- Third case, indexed component with same subscripts, same array 16661 16662 elsif K1 = N_Indexed_Component 16663 and then K2 = N_Indexed_Component 16664 and then Same_Object (Prefix (N1), Prefix (N2)) 16665 then 16666 declare 16667 E1, E2 : Node_Id; 16668 begin 16669 E1 := First (Expressions (N1)); 16670 E2 := First (Expressions (N2)); 16671 while Present (E1) loop 16672 if not Same_Value (E1, E2) then 16673 return False; 16674 else 16675 Next (E1); 16676 Next (E2); 16677 end if; 16678 end loop; 16679 16680 return True; 16681 end; 16682 16683 -- Fourth case, slice of same array with same bounds 16684 16685 elsif K1 = N_Slice 16686 and then K2 = N_Slice 16687 and then Nkind (Discrete_Range (N1)) = N_Range 16688 and then Nkind (Discrete_Range (N2)) = N_Range 16689 and then Same_Value (Low_Bound (Discrete_Range (N1)), 16690 Low_Bound (Discrete_Range (N2))) 16691 and then Same_Value (High_Bound (Discrete_Range (N1)), 16692 High_Bound (Discrete_Range (N2))) 16693 then 16694 return Same_Name (Prefix (N1), Prefix (N2)); 16695 16696 -- All other cases, not clearly the same object 16697 16698 else 16699 return False; 16700 end if; 16701 end Same_Object; 16702 16703 --------------- 16704 -- Same_Type -- 16705 --------------- 16706 16707 function Same_Type (T1, T2 : Entity_Id) return Boolean is 16708 begin 16709 if T1 = T2 then 16710 return True; 16711 16712 elsif not Is_Constrained (T1) 16713 and then not Is_Constrained (T2) 16714 and then Base_Type (T1) = Base_Type (T2) 16715 then 16716 return True; 16717 16718 -- For now don't bother with case of identical constraints, to be 16719 -- fiddled with later on perhaps (this is only used for optimization 16720 -- purposes, so it is not critical to do a best possible job) 16721 16722 else 16723 return False; 16724 end if; 16725 end Same_Type; 16726 16727 ---------------- 16728 -- Same_Value -- 16729 ---------------- 16730 16731 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 16732 begin 16733 if Compile_Time_Known_Value (Node1) 16734 and then Compile_Time_Known_Value (Node2) 16735 and then Expr_Value (Node1) = Expr_Value (Node2) 16736 then 16737 return True; 16738 elsif Same_Object (Node1, Node2) then 16739 return True; 16740 else 16741 return False; 16742 end if; 16743 end Same_Value; 16744 16745 ----------------------------- 16746 -- Save_SPARK_Mode_And_Set -- 16747 ----------------------------- 16748 16749 procedure Save_SPARK_Mode_And_Set 16750 (Context : Entity_Id; 16751 Mode : out SPARK_Mode_Type) 16752 is 16753 begin 16754 -- Save the current mode in effect 16755 16756 Mode := SPARK_Mode; 16757 16758 -- Do not consider illegal or partially decorated constructs 16759 16760 if Ekind (Context) = E_Void or else Error_Posted (Context) then 16761 null; 16762 16763 elsif Present (SPARK_Pragma (Context)) then 16764 SPARK_Mode := Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Context)); 16765 end if; 16766 end Save_SPARK_Mode_And_Set; 16767 16768 ------------------------- 16769 -- Scalar_Part_Present -- 16770 ------------------------- 16771 16772 function Scalar_Part_Present (T : Entity_Id) return Boolean is 16773 C : Entity_Id; 16774 16775 begin 16776 if Is_Scalar_Type (T) then 16777 return True; 16778 16779 elsif Is_Array_Type (T) then 16780 return Scalar_Part_Present (Component_Type (T)); 16781 16782 elsif Is_Record_Type (T) or else Has_Discriminants (T) then 16783 C := First_Component_Or_Discriminant (T); 16784 while Present (C) loop 16785 if Scalar_Part_Present (Etype (C)) then 16786 return True; 16787 else 16788 Next_Component_Or_Discriminant (C); 16789 end if; 16790 end loop; 16791 end if; 16792 16793 return False; 16794 end Scalar_Part_Present; 16795 16796 ------------------------ 16797 -- Scope_Is_Transient -- 16798 ------------------------ 16799 16800 function Scope_Is_Transient return Boolean is 16801 begin 16802 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 16803 end Scope_Is_Transient; 16804 16805 ------------------ 16806 -- Scope_Within -- 16807 ------------------ 16808 16809 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is 16810 Scop : Entity_Id; 16811 16812 begin 16813 Scop := Scope1; 16814 while Scop /= Standard_Standard loop 16815 Scop := Scope (Scop); 16816 16817 if Scop = Scope2 then 16818 return True; 16819 end if; 16820 end loop; 16821 16822 return False; 16823 end Scope_Within; 16824 16825 -------------------------- 16826 -- Scope_Within_Or_Same -- 16827 -------------------------- 16828 16829 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is 16830 Scop : Entity_Id; 16831 16832 begin 16833 Scop := Scope1; 16834 while Scop /= Standard_Standard loop 16835 if Scop = Scope2 then 16836 return True; 16837 else 16838 Scop := Scope (Scop); 16839 end if; 16840 end loop; 16841 16842 return False; 16843 end Scope_Within_Or_Same; 16844 16845 -------------------- 16846 -- Set_Convention -- 16847 -------------------- 16848 16849 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 16850 begin 16851 Basic_Set_Convention (E, Val); 16852 16853 if Is_Type (E) 16854 and then Is_Access_Subprogram_Type (Base_Type (E)) 16855 and then Has_Foreign_Convention (E) 16856 then 16857 16858 -- A convention pragma in an instance may apply to the subtype 16859 -- created for a formal, in which case we have already verified 16860 -- that conventions of actual and formal match and there is nothing 16861 -- to flag on the subtype. 16862 16863 if In_Instance then 16864 null; 16865 else 16866 Set_Can_Use_Internal_Rep (E, False); 16867 end if; 16868 end if; 16869 16870 -- If E is an object or component, and the type of E is an anonymous 16871 -- access type with no convention set, then also set the convention of 16872 -- the anonymous access type. We do not do this for anonymous protected 16873 -- types, since protected types always have the default convention. 16874 16875 if Present (Etype (E)) 16876 and then (Is_Object (E) 16877 or else Ekind (E) = E_Component 16878 16879 -- Allow E_Void (happens for pragma Convention appearing 16880 -- in the middle of a record applying to a component) 16881 16882 or else Ekind (E) = E_Void) 16883 then 16884 declare 16885 Typ : constant Entity_Id := Etype (E); 16886 16887 begin 16888 if Ekind_In (Typ, E_Anonymous_Access_Type, 16889 E_Anonymous_Access_Subprogram_Type) 16890 and then not Has_Convention_Pragma (Typ) 16891 then 16892 Basic_Set_Convention (Typ, Val); 16893 Set_Has_Convention_Pragma (Typ); 16894 16895 -- And for the access subprogram type, deal similarly with the 16896 -- designated E_Subprogram_Type if it is also internal (which 16897 -- it always is?) 16898 16899 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 16900 declare 16901 Dtype : constant Entity_Id := Designated_Type (Typ); 16902 begin 16903 if Ekind (Dtype) = E_Subprogram_Type 16904 and then Is_Itype (Dtype) 16905 and then not Has_Convention_Pragma (Dtype) 16906 then 16907 Basic_Set_Convention (Dtype, Val); 16908 Set_Has_Convention_Pragma (Dtype); 16909 end if; 16910 end; 16911 end if; 16912 end if; 16913 end; 16914 end if; 16915 end Set_Convention; 16916 16917 ------------------------ 16918 -- Set_Current_Entity -- 16919 ------------------------ 16920 16921 -- The given entity is to be set as the currently visible definition of its 16922 -- associated name (i.e. the Node_Id associated with its name). All we have 16923 -- to do is to get the name from the identifier, and then set the 16924 -- associated Node_Id to point to the given entity. 16925 16926 procedure Set_Current_Entity (E : Entity_Id) is 16927 begin 16928 Set_Name_Entity_Id (Chars (E), E); 16929 end Set_Current_Entity; 16930 16931 --------------------------- 16932 -- Set_Debug_Info_Needed -- 16933 --------------------------- 16934 16935 procedure Set_Debug_Info_Needed (T : Entity_Id) is 16936 16937 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 16938 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 16939 -- Used to set debug info in a related node if not set already 16940 16941 -------------------------------------- 16942 -- Set_Debug_Info_Needed_If_Not_Set -- 16943 -------------------------------------- 16944 16945 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 16946 begin 16947 if Present (E) and then not Needs_Debug_Info (E) then 16948 Set_Debug_Info_Needed (E); 16949 16950 -- For a private type, indicate that the full view also needs 16951 -- debug information. 16952 16953 if Is_Type (E) 16954 and then Is_Private_Type (E) 16955 and then Present (Full_View (E)) 16956 then 16957 Set_Debug_Info_Needed (Full_View (E)); 16958 end if; 16959 end if; 16960 end Set_Debug_Info_Needed_If_Not_Set; 16961 16962 -- Start of processing for Set_Debug_Info_Needed 16963 16964 begin 16965 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which 16966 -- indicates that Debug_Info_Needed is never required for the entity. 16967 -- Nothing to do if entity comes from a predefined file. Library files 16968 -- are compiled without debug information, but inlined bodies of these 16969 -- routines may appear in user code, and debug information on them ends 16970 -- up complicating debugging the user code. 16971 16972 if No (T) 16973 or else Debug_Info_Off (T) 16974 then 16975 return; 16976 16977 elsif In_Inlined_Body 16978 and then Is_Predefined_File_Name 16979 (Unit_File_Name (Get_Source_Unit (Sloc (T)))) 16980 then 16981 Set_Needs_Debug_Info (T, False); 16982 end if; 16983 16984 -- Set flag in entity itself. Note that we will go through the following 16985 -- circuitry even if the flag is already set on T. That's intentional, 16986 -- it makes sure that the flag will be set in subsidiary entities. 16987 16988 Set_Needs_Debug_Info (T); 16989 16990 -- Set flag on subsidiary entities if not set already 16991 16992 if Is_Object (T) then 16993 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 16994 16995 elsif Is_Type (T) then 16996 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 16997 16998 if Is_Record_Type (T) then 16999 declare 17000 Ent : Entity_Id := First_Entity (T); 17001 begin 17002 while Present (Ent) loop 17003 Set_Debug_Info_Needed_If_Not_Set (Ent); 17004 Next_Entity (Ent); 17005 end loop; 17006 end; 17007 17008 -- For a class wide subtype, we also need debug information 17009 -- for the equivalent type. 17010 17011 if Ekind (T) = E_Class_Wide_Subtype then 17012 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 17013 end if; 17014 17015 elsif Is_Array_Type (T) then 17016 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 17017 17018 declare 17019 Indx : Node_Id := First_Index (T); 17020 begin 17021 while Present (Indx) loop 17022 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 17023 Indx := Next_Index (Indx); 17024 end loop; 17025 end; 17026 17027 -- For a packed array type, we also need debug information for 17028 -- the type used to represent the packed array. Conversely, we 17029 -- also need it for the former if we need it for the latter. 17030 17031 if Is_Packed (T) then 17032 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 17033 end if; 17034 17035 if Is_Packed_Array_Impl_Type (T) then 17036 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 17037 end if; 17038 17039 elsif Is_Access_Type (T) then 17040 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 17041 17042 elsif Is_Private_Type (T) then 17043 Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); 17044 17045 elsif Is_Protected_Type (T) then 17046 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 17047 17048 elsif Is_Scalar_Type (T) then 17049 17050 -- If the subrange bounds are materialized by dedicated constant 17051 -- objects, also include them in the debug info to make sure the 17052 -- debugger can properly use them. 17053 17054 if Present (Scalar_Range (T)) 17055 and then Nkind (Scalar_Range (T)) = N_Range 17056 then 17057 declare 17058 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 17059 High_Bnd : constant Node_Id := Type_High_Bound (T); 17060 17061 begin 17062 if Is_Entity_Name (Low_Bnd) then 17063 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 17064 end if; 17065 17066 if Is_Entity_Name (High_Bnd) then 17067 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 17068 end if; 17069 end; 17070 end if; 17071 end if; 17072 end if; 17073 end Set_Debug_Info_Needed; 17074 17075 ---------------------------- 17076 -- Set_Entity_With_Checks -- 17077 ---------------------------- 17078 17079 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 17080 Val_Actual : Entity_Id; 17081 Nod : Node_Id; 17082 Post_Node : Node_Id; 17083 17084 begin 17085 -- Unconditionally set the entity 17086 17087 Set_Entity (N, Val); 17088 17089 -- The node to post on is the selector in the case of an expanded name, 17090 -- and otherwise the node itself. 17091 17092 if Nkind (N) = N_Expanded_Name then 17093 Post_Node := Selector_Name (N); 17094 else 17095 Post_Node := N; 17096 end if; 17097 17098 -- Check for violation of No_Fixed_IO 17099 17100 if Restriction_Check_Required (No_Fixed_IO) 17101 and then 17102 ((RTU_Loaded (Ada_Text_IO) 17103 and then (Is_RTE (Val, RE_Decimal_IO) 17104 or else 17105 Is_RTE (Val, RE_Fixed_IO))) 17106 17107 or else 17108 (RTU_Loaded (Ada_Wide_Text_IO) 17109 and then (Is_RTE (Val, RO_WT_Decimal_IO) 17110 or else 17111 Is_RTE (Val, RO_WT_Fixed_IO))) 17112 17113 or else 17114 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 17115 and then (Is_RTE (Val, RO_WW_Decimal_IO) 17116 or else 17117 Is_RTE (Val, RO_WW_Fixed_IO)))) 17118 17119 -- A special extra check, don't complain about a reference from within 17120 -- the Ada.Interrupts package itself! 17121 17122 and then not In_Same_Extended_Unit (N, Val) 17123 then 17124 Check_Restriction (No_Fixed_IO, Post_Node); 17125 end if; 17126 17127 -- Remaining checks are only done on source nodes. Note that we test 17128 -- for violation of No_Fixed_IO even on non-source nodes, because the 17129 -- cases for checking violations of this restriction are instantiations 17130 -- where the reference in the instance has Comes_From_Source False. 17131 17132 if not Comes_From_Source (N) then 17133 return; 17134 end if; 17135 17136 -- Check for violation of No_Abort_Statements, which is triggered by 17137 -- call to Ada.Task_Identification.Abort_Task. 17138 17139 if Restriction_Check_Required (No_Abort_Statements) 17140 and then (Is_RTE (Val, RE_Abort_Task)) 17141 17142 -- A special extra check, don't complain about a reference from within 17143 -- the Ada.Task_Identification package itself! 17144 17145 and then not In_Same_Extended_Unit (N, Val) 17146 then 17147 Check_Restriction (No_Abort_Statements, Post_Node); 17148 end if; 17149 17150 if Val = Standard_Long_Long_Integer then 17151 Check_Restriction (No_Long_Long_Integers, Post_Node); 17152 end if; 17153 17154 -- Check for violation of No_Dynamic_Attachment 17155 17156 if Restriction_Check_Required (No_Dynamic_Attachment) 17157 and then RTU_Loaded (Ada_Interrupts) 17158 and then (Is_RTE (Val, RE_Is_Reserved) or else 17159 Is_RTE (Val, RE_Is_Attached) or else 17160 Is_RTE (Val, RE_Current_Handler) or else 17161 Is_RTE (Val, RE_Attach_Handler) or else 17162 Is_RTE (Val, RE_Exchange_Handler) or else 17163 Is_RTE (Val, RE_Detach_Handler) or else 17164 Is_RTE (Val, RE_Reference)) 17165 17166 -- A special extra check, don't complain about a reference from within 17167 -- the Ada.Interrupts package itself! 17168 17169 and then not In_Same_Extended_Unit (N, Val) 17170 then 17171 Check_Restriction (No_Dynamic_Attachment, Post_Node); 17172 end if; 17173 17174 -- Check for No_Implementation_Identifiers 17175 17176 if Restriction_Check_Required (No_Implementation_Identifiers) then 17177 17178 -- We have an implementation defined entity if it is marked as 17179 -- implementation defined, or is defined in a package marked as 17180 -- implementation defined. However, library packages themselves 17181 -- are excluded (we don't want to flag Interfaces itself, just 17182 -- the entities within it). 17183 17184 if (Is_Implementation_Defined (Val) 17185 or else 17186 (Present (Scope (Val)) 17187 and then Is_Implementation_Defined (Scope (Val)))) 17188 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 17189 and then Is_Library_Level_Entity (Val)) 17190 then 17191 Check_Restriction (No_Implementation_Identifiers, Post_Node); 17192 end if; 17193 end if; 17194 17195 -- Do the style check 17196 17197 if Style_Check 17198 and then not Suppress_Style_Checks (Val) 17199 and then not In_Instance 17200 then 17201 if Nkind (N) = N_Identifier then 17202 Nod := N; 17203 elsif Nkind (N) = N_Expanded_Name then 17204 Nod := Selector_Name (N); 17205 else 17206 return; 17207 end if; 17208 17209 -- A special situation arises for derived operations, where we want 17210 -- to do the check against the parent (since the Sloc of the derived 17211 -- operation points to the derived type declaration itself). 17212 17213 Val_Actual := Val; 17214 while not Comes_From_Source (Val_Actual) 17215 and then Nkind (Val_Actual) in N_Entity 17216 and then (Ekind (Val_Actual) = E_Enumeration_Literal 17217 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 17218 and then Present (Alias (Val_Actual)) 17219 loop 17220 Val_Actual := Alias (Val_Actual); 17221 end loop; 17222 17223 -- Renaming declarations for generic actuals do not come from source, 17224 -- and have a different name from that of the entity they rename, so 17225 -- there is no style check to perform here. 17226 17227 if Chars (Nod) = Chars (Val_Actual) then 17228 Style.Check_Identifier (Nod, Val_Actual); 17229 end if; 17230 end if; 17231 17232 Set_Entity (N, Val); 17233 end Set_Entity_With_Checks; 17234 17235 ------------------------ 17236 -- Set_Name_Entity_Id -- 17237 ------------------------ 17238 17239 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 17240 begin 17241 Set_Name_Table_Int (Id, Int (Val)); 17242 end Set_Name_Entity_Id; 17243 17244 --------------------- 17245 -- Set_Next_Actual -- 17246 --------------------- 17247 17248 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 17249 begin 17250 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 17251 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 17252 end if; 17253 end Set_Next_Actual; 17254 17255 ---------------------------------- 17256 -- Set_Optimize_Alignment_Flags -- 17257 ---------------------------------- 17258 17259 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 17260 begin 17261 if Optimize_Alignment = 'S' then 17262 Set_Optimize_Alignment_Space (E); 17263 elsif Optimize_Alignment = 'T' then 17264 Set_Optimize_Alignment_Time (E); 17265 end if; 17266 end Set_Optimize_Alignment_Flags; 17267 17268 ----------------------- 17269 -- Set_Public_Status -- 17270 ----------------------- 17271 17272 procedure Set_Public_Status (Id : Entity_Id) is 17273 S : constant Entity_Id := Current_Scope; 17274 17275 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 17276 -- Determines if E is defined within handled statement sequence or 17277 -- an if statement, returns True if so, False otherwise. 17278 17279 ---------------------- 17280 -- Within_HSS_Or_If -- 17281 ---------------------- 17282 17283 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 17284 N : Node_Id; 17285 begin 17286 N := Declaration_Node (E); 17287 loop 17288 N := Parent (N); 17289 17290 if No (N) then 17291 return False; 17292 17293 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 17294 N_If_Statement) 17295 then 17296 return True; 17297 end if; 17298 end loop; 17299 end Within_HSS_Or_If; 17300 17301 -- Start of processing for Set_Public_Status 17302 17303 begin 17304 -- Everything in the scope of Standard is public 17305 17306 if S = Standard_Standard then 17307 Set_Is_Public (Id); 17308 17309 -- Entity is definitely not public if enclosing scope is not public 17310 17311 elsif not Is_Public (S) then 17312 return; 17313 17314 -- An object or function declaration that occurs in a handled sequence 17315 -- of statements or within an if statement is the declaration for a 17316 -- temporary object or local subprogram generated by the expander. It 17317 -- never needs to be made public and furthermore, making it public can 17318 -- cause back end problems. 17319 17320 elsif Nkind_In (Parent (Id), N_Object_Declaration, 17321 N_Function_Specification) 17322 and then Within_HSS_Or_If (Id) 17323 then 17324 return; 17325 17326 -- Entities in public packages or records are public 17327 17328 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 17329 Set_Is_Public (Id); 17330 17331 -- The bounds of an entry family declaration can generate object 17332 -- declarations that are visible to the back-end, e.g. in the 17333 -- the declaration of a composite type that contains tasks. 17334 17335 elsif Is_Concurrent_Type (S) 17336 and then not Has_Completion (S) 17337 and then Nkind (Parent (Id)) = N_Object_Declaration 17338 then 17339 Set_Is_Public (Id); 17340 end if; 17341 end Set_Public_Status; 17342 17343 ----------------------------- 17344 -- Set_Referenced_Modified -- 17345 ----------------------------- 17346 17347 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 17348 Pref : Node_Id; 17349 17350 begin 17351 -- Deal with indexed or selected component where prefix is modified 17352 17353 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 17354 Pref := Prefix (N); 17355 17356 -- If prefix is access type, then it is the designated object that is 17357 -- being modified, which means we have no entity to set the flag on. 17358 17359 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 17360 return; 17361 17362 -- Otherwise chase the prefix 17363 17364 else 17365 Set_Referenced_Modified (Pref, Out_Param); 17366 end if; 17367 17368 -- Otherwise see if we have an entity name (only other case to process) 17369 17370 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 17371 Set_Referenced_As_LHS (Entity (N), not Out_Param); 17372 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 17373 end if; 17374 end Set_Referenced_Modified; 17375 17376 ---------------------------- 17377 -- Set_Scope_Is_Transient -- 17378 ---------------------------- 17379 17380 procedure Set_Scope_Is_Transient (V : Boolean := True) is 17381 begin 17382 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 17383 end Set_Scope_Is_Transient; 17384 17385 ------------------- 17386 -- Set_Size_Info -- 17387 ------------------- 17388 17389 procedure Set_Size_Info (T1, T2 : Entity_Id) is 17390 begin 17391 -- We copy Esize, but not RM_Size, since in general RM_Size is 17392 -- subtype specific and does not get inherited by all subtypes. 17393 17394 Set_Esize (T1, Esize (T2)); 17395 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 17396 17397 if Is_Discrete_Or_Fixed_Point_Type (T1) 17398 and then 17399 Is_Discrete_Or_Fixed_Point_Type (T2) 17400 then 17401 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 17402 end if; 17403 17404 Set_Alignment (T1, Alignment (T2)); 17405 end Set_Size_Info; 17406 17407 -------------------- 17408 -- Static_Boolean -- 17409 -------------------- 17410 17411 function Static_Boolean (N : Node_Id) return Uint is 17412 begin 17413 Analyze_And_Resolve (N, Standard_Boolean); 17414 17415 if N = Error 17416 or else Error_Posted (N) 17417 or else Etype (N) = Any_Type 17418 then 17419 return No_Uint; 17420 end if; 17421 17422 if Is_OK_Static_Expression (N) then 17423 if not Raises_Constraint_Error (N) then 17424 return Expr_Value (N); 17425 else 17426 return No_Uint; 17427 end if; 17428 17429 elsif Etype (N) = Any_Type then 17430 return No_Uint; 17431 17432 else 17433 Flag_Non_Static_Expr 17434 ("static boolean expression required here", N); 17435 return No_Uint; 17436 end if; 17437 end Static_Boolean; 17438 17439 -------------------- 17440 -- Static_Integer -- 17441 -------------------- 17442 17443 function Static_Integer (N : Node_Id) return Uint is 17444 begin 17445 Analyze_And_Resolve (N, Any_Integer); 17446 17447 if N = Error 17448 or else Error_Posted (N) 17449 or else Etype (N) = Any_Type 17450 then 17451 return No_Uint; 17452 end if; 17453 17454 if Is_OK_Static_Expression (N) then 17455 if not Raises_Constraint_Error (N) then 17456 return Expr_Value (N); 17457 else 17458 return No_Uint; 17459 end if; 17460 17461 elsif Etype (N) = Any_Type then 17462 return No_Uint; 17463 17464 else 17465 Flag_Non_Static_Expr 17466 ("static integer expression required here", N); 17467 return No_Uint; 17468 end if; 17469 end Static_Integer; 17470 17471 -------------------------- 17472 -- Statically_Different -- 17473 -------------------------- 17474 17475 function Statically_Different (E1, E2 : Node_Id) return Boolean is 17476 R1 : constant Node_Id := Get_Referenced_Object (E1); 17477 R2 : constant Node_Id := Get_Referenced_Object (E2); 17478 begin 17479 return Is_Entity_Name (R1) 17480 and then Is_Entity_Name (R2) 17481 and then Entity (R1) /= Entity (R2) 17482 and then not Is_Formal (Entity (R1)) 17483 and then not Is_Formal (Entity (R2)); 17484 end Statically_Different; 17485 17486 -------------------------------------- 17487 -- Subject_To_Loop_Entry_Attributes -- 17488 -------------------------------------- 17489 17490 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 17491 Stmt : Node_Id; 17492 17493 begin 17494 Stmt := N; 17495 17496 -- The expansion mechanism transform a loop subject to at least one 17497 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 17498 -- the conditional part. 17499 17500 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) 17501 and then Nkind (Original_Node (N)) = N_Loop_Statement 17502 then 17503 Stmt := Original_Node (N); 17504 end if; 17505 17506 return 17507 Nkind (Stmt) = N_Loop_Statement 17508 and then Present (Identifier (Stmt)) 17509 and then Present (Entity (Identifier (Stmt))) 17510 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 17511 end Subject_To_Loop_Entry_Attributes; 17512 17513 ----------------------------- 17514 -- Subprogram_Access_Level -- 17515 ----------------------------- 17516 17517 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 17518 begin 17519 if Present (Alias (Subp)) then 17520 return Subprogram_Access_Level (Alias (Subp)); 17521 else 17522 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 17523 end if; 17524 end Subprogram_Access_Level; 17525 17526 ------------------------------- 17527 -- Support_Atomic_Primitives -- 17528 ------------------------------- 17529 17530 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 17531 Size : Int; 17532 17533 begin 17534 -- Verify the alignment of Typ is known 17535 17536 if not Known_Alignment (Typ) then 17537 return False; 17538 end if; 17539 17540 if Known_Static_Esize (Typ) then 17541 Size := UI_To_Int (Esize (Typ)); 17542 17543 -- If the Esize (Object_Size) is unknown at compile time, look at the 17544 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 17545 17546 elsif Known_Static_RM_Size (Typ) then 17547 Size := UI_To_Int (RM_Size (Typ)); 17548 17549 -- Otherwise, the size is considered to be unknown. 17550 17551 else 17552 return False; 17553 end if; 17554 17555 -- Check that the size of the component is 8, 16, 32 or 64 bits and that 17556 -- Typ is properly aligned. 17557 17558 case Size is 17559 when 8 | 16 | 32 | 64 => 17560 return Size = UI_To_Int (Alignment (Typ)) * 8; 17561 when others => 17562 return False; 17563 end case; 17564 end Support_Atomic_Primitives; 17565 17566 ----------------- 17567 -- Trace_Scope -- 17568 ----------------- 17569 17570 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 17571 begin 17572 if Debug_Flag_W then 17573 for J in 0 .. Scope_Stack.Last loop 17574 Write_Str (" "); 17575 end loop; 17576 17577 Write_Str (Msg); 17578 Write_Name (Chars (E)); 17579 Write_Str (" from "); 17580 Write_Location (Sloc (N)); 17581 Write_Eol; 17582 end if; 17583 end Trace_Scope; 17584 17585 ----------------------- 17586 -- Transfer_Entities -- 17587 ----------------------- 17588 17589 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 17590 procedure Set_Public_Status_Of (Id : Entity_Id); 17591 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 17592 -- Set_Public_Status. If successfull and Id denotes a record type, set 17593 -- the Is_Public attribute of its fields. 17594 17595 -------------------------- 17596 -- Set_Public_Status_Of -- 17597 -------------------------- 17598 17599 procedure Set_Public_Status_Of (Id : Entity_Id) is 17600 Field : Entity_Id; 17601 17602 begin 17603 if not Is_Public (Id) then 17604 Set_Public_Status (Id); 17605 17606 -- When the input entity is a public record type, ensure that all 17607 -- its internal fields are also exposed to the linker. The fields 17608 -- of a class-wide type are never made public. 17609 17610 if Is_Public (Id) 17611 and then Is_Record_Type (Id) 17612 and then not Is_Class_Wide_Type (Id) 17613 then 17614 Field := First_Entity (Id); 17615 while Present (Field) loop 17616 Set_Is_Public (Field); 17617 Next_Entity (Field); 17618 end loop; 17619 end if; 17620 end if; 17621 end Set_Public_Status_Of; 17622 17623 -- Local variables 17624 17625 Full_Id : Entity_Id; 17626 Id : Entity_Id; 17627 17628 -- Start of processing for Transfer_Entities 17629 17630 begin 17631 Id := First_Entity (From); 17632 17633 if Present (Id) then 17634 17635 -- Merge the entity chain of the source scope with that of the 17636 -- destination scope. 17637 17638 if Present (Last_Entity (To)) then 17639 Set_Next_Entity (Last_Entity (To), Id); 17640 else 17641 Set_First_Entity (To, Id); 17642 end if; 17643 17644 Set_Last_Entity (To, Last_Entity (From)); 17645 17646 -- Inspect the entities of the source scope and update their Scope 17647 -- attribute. 17648 17649 while Present (Id) loop 17650 Set_Scope (Id, To); 17651 Set_Public_Status_Of (Id); 17652 17653 -- Handle an internally generated full view for a private type 17654 17655 if Is_Private_Type (Id) 17656 and then Present (Full_View (Id)) 17657 and then Is_Itype (Full_View (Id)) 17658 then 17659 Full_Id := Full_View (Id); 17660 17661 Set_Scope (Full_Id, To); 17662 Set_Public_Status_Of (Full_Id); 17663 end if; 17664 17665 Next_Entity (Id); 17666 end loop; 17667 17668 Set_First_Entity (From, Empty); 17669 Set_Last_Entity (From, Empty); 17670 end if; 17671 end Transfer_Entities; 17672 17673 ----------------------- 17674 -- Type_Access_Level -- 17675 ----------------------- 17676 17677 function Type_Access_Level (Typ : Entity_Id) return Uint is 17678 Btyp : Entity_Id; 17679 17680 begin 17681 Btyp := Base_Type (Typ); 17682 17683 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 17684 -- simply use the level where the type is declared. This is true for 17685 -- stand-alone object declarations, and for anonymous access types 17686 -- associated with components the level is the same as that of the 17687 -- enclosing composite type. However, special treatment is needed for 17688 -- the cases of access parameters, return objects of an anonymous access 17689 -- type, and, in Ada 95, access discriminants of limited types. 17690 17691 if Is_Access_Type (Btyp) then 17692 if Ekind (Btyp) = E_Anonymous_Access_Type then 17693 17694 -- If the type is a nonlocal anonymous access type (such as for 17695 -- an access parameter) we treat it as being declared at the 17696 -- library level to ensure that names such as X.all'access don't 17697 -- fail static accessibility checks. 17698 17699 if not Is_Local_Anonymous_Access (Typ) then 17700 return Scope_Depth (Standard_Standard); 17701 17702 -- If this is a return object, the accessibility level is that of 17703 -- the result subtype of the enclosing function. The test here is 17704 -- little complicated, because we have to account for extended 17705 -- return statements that have been rewritten as blocks, in which 17706 -- case we have to find and the Is_Return_Object attribute of the 17707 -- itype's associated object. It would be nice to find a way to 17708 -- simplify this test, but it doesn't seem worthwhile to add a new 17709 -- flag just for purposes of this test. ??? 17710 17711 elsif Ekind (Scope (Btyp)) = E_Return_Statement 17712 or else 17713 (Is_Itype (Btyp) 17714 and then Nkind (Associated_Node_For_Itype (Btyp)) = 17715 N_Object_Declaration 17716 and then Is_Return_Object 17717 (Defining_Identifier 17718 (Associated_Node_For_Itype (Btyp)))) 17719 then 17720 declare 17721 Scop : Entity_Id; 17722 17723 begin 17724 Scop := Scope (Scope (Btyp)); 17725 while Present (Scop) loop 17726 exit when Ekind (Scop) = E_Function; 17727 Scop := Scope (Scop); 17728 end loop; 17729 17730 -- Treat the return object's type as having the level of the 17731 -- function's result subtype (as per RM05-6.5(5.3/2)). 17732 17733 return Type_Access_Level (Etype (Scop)); 17734 end; 17735 end if; 17736 end if; 17737 17738 Btyp := Root_Type (Btyp); 17739 17740 -- The accessibility level of anonymous access types associated with 17741 -- discriminants is that of the current instance of the type, and 17742 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 17743 17744 -- AI-402: access discriminants have accessibility based on the 17745 -- object rather than the type in Ada 2005, so the above paragraph 17746 -- doesn't apply. 17747 17748 -- ??? Needs completion with rules from AI-416 17749 17750 if Ada_Version <= Ada_95 17751 and then Ekind (Typ) = E_Anonymous_Access_Type 17752 and then Present (Associated_Node_For_Itype (Typ)) 17753 and then Nkind (Associated_Node_For_Itype (Typ)) = 17754 N_Discriminant_Specification 17755 then 17756 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 17757 end if; 17758 end if; 17759 17760 -- Return library level for a generic formal type. This is done because 17761 -- RM(10.3.2) says that "The statically deeper relationship does not 17762 -- apply to ... a descendant of a generic formal type". Rather than 17763 -- checking at each point where a static accessibility check is 17764 -- performed to see if we are dealing with a formal type, this rule is 17765 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 17766 -- return extreme values for a formal type; Deepest_Type_Access_Level 17767 -- returns Int'Last. By calling the appropriate function from among the 17768 -- two, we ensure that the static accessibility check will pass if we 17769 -- happen to run into a formal type. More specifically, we should call 17770 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 17771 -- call occurs as part of a static accessibility check and the error 17772 -- case is the case where the type's level is too shallow (as opposed 17773 -- to too deep). 17774 17775 if Is_Generic_Type (Root_Type (Btyp)) then 17776 return Scope_Depth (Standard_Standard); 17777 end if; 17778 17779 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 17780 end Type_Access_Level; 17781 17782 ------------------------------------ 17783 -- Type_Without_Stream_Operation -- 17784 ------------------------------------ 17785 17786 function Type_Without_Stream_Operation 17787 (T : Entity_Id; 17788 Op : TSS_Name_Type := TSS_Null) return Entity_Id 17789 is 17790 BT : constant Entity_Id := Base_Type (T); 17791 Op_Missing : Boolean; 17792 17793 begin 17794 if not Restriction_Active (No_Default_Stream_Attributes) then 17795 return Empty; 17796 end if; 17797 17798 if Is_Elementary_Type (T) then 17799 if Op = TSS_Null then 17800 Op_Missing := 17801 No (TSS (BT, TSS_Stream_Read)) 17802 or else No (TSS (BT, TSS_Stream_Write)); 17803 17804 else 17805 Op_Missing := No (TSS (BT, Op)); 17806 end if; 17807 17808 if Op_Missing then 17809 return T; 17810 else 17811 return Empty; 17812 end if; 17813 17814 elsif Is_Array_Type (T) then 17815 return Type_Without_Stream_Operation (Component_Type (T), Op); 17816 17817 elsif Is_Record_Type (T) then 17818 declare 17819 Comp : Entity_Id; 17820 C_Typ : Entity_Id; 17821 17822 begin 17823 Comp := First_Component (T); 17824 while Present (Comp) loop 17825 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 17826 17827 if Present (C_Typ) then 17828 return C_Typ; 17829 end if; 17830 17831 Next_Component (Comp); 17832 end loop; 17833 17834 return Empty; 17835 end; 17836 17837 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 17838 return Type_Without_Stream_Operation (Full_View (T), Op); 17839 else 17840 return Empty; 17841 end if; 17842 end Type_Without_Stream_Operation; 17843 17844 ---------------------------- 17845 -- Unique_Defining_Entity -- 17846 ---------------------------- 17847 17848 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 17849 begin 17850 return Unique_Entity (Defining_Entity (N)); 17851 end Unique_Defining_Entity; 17852 17853 ------------------- 17854 -- Unique_Entity -- 17855 ------------------- 17856 17857 function Unique_Entity (E : Entity_Id) return Entity_Id is 17858 U : Entity_Id := E; 17859 P : Node_Id; 17860 17861 begin 17862 case Ekind (E) is 17863 when E_Constant => 17864 if Present (Full_View (E)) then 17865 U := Full_View (E); 17866 end if; 17867 17868 when Type_Kind => 17869 if Present (Full_View (E)) then 17870 U := Full_View (E); 17871 end if; 17872 17873 when E_Package_Body => 17874 P := Parent (E); 17875 17876 if Nkind (P) = N_Defining_Program_Unit_Name then 17877 P := Parent (P); 17878 end if; 17879 17880 U := Corresponding_Spec (P); 17881 17882 when E_Subprogram_Body => 17883 P := Parent (E); 17884 17885 if Nkind (P) = N_Defining_Program_Unit_Name then 17886 P := Parent (P); 17887 end if; 17888 17889 P := Parent (P); 17890 17891 if Nkind (P) = N_Subprogram_Body_Stub then 17892 if Present (Library_Unit (P)) then 17893 17894 -- Get to the function or procedure (generic) entity through 17895 -- the body entity. 17896 17897 U := 17898 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P))); 17899 end if; 17900 else 17901 U := Corresponding_Spec (P); 17902 end if; 17903 17904 when Formal_Kind => 17905 if Present (Spec_Entity (E)) then 17906 U := Spec_Entity (E); 17907 end if; 17908 17909 when others => 17910 null; 17911 end case; 17912 17913 return U; 17914 end Unique_Entity; 17915 17916 ----------------- 17917 -- Unique_Name -- 17918 ----------------- 17919 17920 function Unique_Name (E : Entity_Id) return String is 17921 17922 -- Names of E_Subprogram_Body or E_Package_Body entities are not 17923 -- reliable, as they may not include the overloading suffix. Instead, 17924 -- when looking for the name of E or one of its enclosing scope, we get 17925 -- the name of the corresponding Unique_Entity. 17926 17927 function Get_Scoped_Name (E : Entity_Id) return String; 17928 -- Return the name of E prefixed by all the names of the scopes to which 17929 -- E belongs, except for Standard. 17930 17931 --------------------- 17932 -- Get_Scoped_Name -- 17933 --------------------- 17934 17935 function Get_Scoped_Name (E : Entity_Id) return String is 17936 Name : constant String := Get_Name_String (Chars (E)); 17937 begin 17938 if Has_Fully_Qualified_Name (E) 17939 or else Scope (E) = Standard_Standard 17940 then 17941 return Name; 17942 else 17943 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name; 17944 end if; 17945 end Get_Scoped_Name; 17946 17947 -- Start of processing for Unique_Name 17948 17949 begin 17950 if E = Standard_Standard then 17951 return Get_Name_String (Name_Standard); 17952 17953 elsif Scope (E) = Standard_Standard 17954 and then not (Ekind (E) = E_Package or else Is_Subprogram (E)) 17955 then 17956 return Get_Name_String (Name_Standard) & "__" & 17957 Get_Name_String (Chars (E)); 17958 17959 elsif Ekind (E) = E_Enumeration_Literal then 17960 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); 17961 17962 else 17963 return Get_Scoped_Name (Unique_Entity (E)); 17964 end if; 17965 end Unique_Name; 17966 17967 --------------------- 17968 -- Unit_Is_Visible -- 17969 --------------------- 17970 17971 function Unit_Is_Visible (U : Entity_Id) return Boolean is 17972 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 17973 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 17974 17975 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 17976 -- For a child unit, check whether unit appears in a with_clause 17977 -- of a parent. 17978 17979 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 17980 -- Scan the context clause of one compilation unit looking for a 17981 -- with_clause for the unit in question. 17982 17983 ---------------------------- 17984 -- Unit_In_Parent_Context -- 17985 ---------------------------- 17986 17987 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 17988 begin 17989 if Unit_In_Context (Par_Unit) then 17990 return True; 17991 17992 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 17993 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 17994 17995 else 17996 return False; 17997 end if; 17998 end Unit_In_Parent_Context; 17999 18000 --------------------- 18001 -- Unit_In_Context -- 18002 --------------------- 18003 18004 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 18005 Clause : Node_Id; 18006 18007 begin 18008 Clause := First (Context_Items (Comp_Unit)); 18009 while Present (Clause) loop 18010 if Nkind (Clause) = N_With_Clause then 18011 if Library_Unit (Clause) = U then 18012 return True; 18013 18014 -- The with_clause may denote a renaming of the unit we are 18015 -- looking for, eg. Text_IO which renames Ada.Text_IO. 18016 18017 elsif 18018 Renamed_Entity (Entity (Name (Clause))) = 18019 Defining_Entity (Unit (U)) 18020 then 18021 return True; 18022 end if; 18023 end if; 18024 18025 Next (Clause); 18026 end loop; 18027 18028 return False; 18029 end Unit_In_Context; 18030 18031 -- Start of processing for Unit_Is_Visible 18032 18033 begin 18034 -- The currrent unit is directly visible 18035 18036 if Curr = U then 18037 return True; 18038 18039 elsif Unit_In_Context (Curr) then 18040 return True; 18041 18042 -- If the current unit is a body, check the context of the spec 18043 18044 elsif Nkind (Unit (Curr)) = N_Package_Body 18045 or else 18046 (Nkind (Unit (Curr)) = N_Subprogram_Body 18047 and then not Acts_As_Spec (Unit (Curr))) 18048 then 18049 if Unit_In_Context (Library_Unit (Curr)) then 18050 return True; 18051 end if; 18052 end if; 18053 18054 -- If the spec is a child unit, examine the parents 18055 18056 if Is_Child_Unit (Curr_Entity) then 18057 if Nkind (Unit (Curr)) in N_Unit_Body then 18058 return 18059 Unit_In_Parent_Context 18060 (Parent_Spec (Unit (Library_Unit (Curr)))); 18061 else 18062 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 18063 end if; 18064 18065 else 18066 return False; 18067 end if; 18068 end Unit_Is_Visible; 18069 18070 ------------------------------ 18071 -- Universal_Interpretation -- 18072 ------------------------------ 18073 18074 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 18075 Index : Interp_Index; 18076 It : Interp; 18077 18078 begin 18079 -- The argument may be a formal parameter of an operator or subprogram 18080 -- with multiple interpretations, or else an expression for an actual. 18081 18082 if Nkind (Opnd) = N_Defining_Identifier 18083 or else not Is_Overloaded (Opnd) 18084 then 18085 if Etype (Opnd) = Universal_Integer 18086 or else Etype (Opnd) = Universal_Real 18087 then 18088 return Etype (Opnd); 18089 else 18090 return Empty; 18091 end if; 18092 18093 else 18094 Get_First_Interp (Opnd, Index, It); 18095 while Present (It.Typ) loop 18096 if It.Typ = Universal_Integer 18097 or else It.Typ = Universal_Real 18098 then 18099 return It.Typ; 18100 end if; 18101 18102 Get_Next_Interp (Index, It); 18103 end loop; 18104 18105 return Empty; 18106 end if; 18107 end Universal_Interpretation; 18108 18109 --------------- 18110 -- Unqualify -- 18111 --------------- 18112 18113 function Unqualify (Expr : Node_Id) return Node_Id is 18114 begin 18115 -- Recurse to handle unlikely case of multiple levels of qualification 18116 18117 if Nkind (Expr) = N_Qualified_Expression then 18118 return Unqualify (Expression (Expr)); 18119 18120 -- Normal case, not a qualified expression 18121 18122 else 18123 return Expr; 18124 end if; 18125 end Unqualify; 18126 18127 ----------------------- 18128 -- Visible_Ancestors -- 18129 ----------------------- 18130 18131 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 18132 List_1 : Elist_Id; 18133 List_2 : Elist_Id; 18134 Elmt : Elmt_Id; 18135 18136 begin 18137 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 18138 18139 -- Collect all the parents and progenitors of Typ. If the full-view of 18140 -- private parents and progenitors is available then it is used to 18141 -- generate the list of visible ancestors; otherwise their partial 18142 -- view is added to the resulting list. 18143 18144 Collect_Parents 18145 (T => Typ, 18146 List => List_1, 18147 Use_Full_View => True); 18148 18149 Collect_Interfaces 18150 (T => Typ, 18151 Ifaces_List => List_2, 18152 Exclude_Parents => True, 18153 Use_Full_View => True); 18154 18155 -- Join the two lists. Avoid duplications because an interface may 18156 -- simultaneously be parent and progenitor of a type. 18157 18158 Elmt := First_Elmt (List_2); 18159 while Present (Elmt) loop 18160 Append_Unique_Elmt (Node (Elmt), List_1); 18161 Next_Elmt (Elmt); 18162 end loop; 18163 18164 return List_1; 18165 end Visible_Ancestors; 18166 18167 ---------------------- 18168 -- Within_Init_Proc -- 18169 ---------------------- 18170 18171 function Within_Init_Proc return Boolean is 18172 S : Entity_Id; 18173 18174 begin 18175 S := Current_Scope; 18176 while not Is_Overloadable (S) loop 18177 if S = Standard_Standard then 18178 return False; 18179 else 18180 S := Scope (S); 18181 end if; 18182 end loop; 18183 18184 return Is_Init_Proc (S); 18185 end Within_Init_Proc; 18186 18187 ------------------ 18188 -- Within_Scope -- 18189 ------------------ 18190 18191 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 18192 SE : Entity_Id; 18193 begin 18194 SE := Scope (E); 18195 loop 18196 if SE = S then 18197 return True; 18198 elsif SE = Standard_Standard then 18199 return False; 18200 else 18201 SE := Scope (SE); 18202 end if; 18203 end loop; 18204 end Within_Scope; 18205 18206 ---------------- 18207 -- Wrong_Type -- 18208 ---------------- 18209 18210 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 18211 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 18212 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 18213 18214 Matching_Field : Entity_Id; 18215 -- Entity to give a more precise suggestion on how to write a one- 18216 -- element positional aggregate. 18217 18218 function Has_One_Matching_Field return Boolean; 18219 -- Determines if Expec_Type is a record type with a single component or 18220 -- discriminant whose type matches the found type or is one dimensional 18221 -- array whose component type matches the found type. In the case of 18222 -- one discriminant, we ignore the variant parts. That's not accurate, 18223 -- but good enough for the warning. 18224 18225 ---------------------------- 18226 -- Has_One_Matching_Field -- 18227 ---------------------------- 18228 18229 function Has_One_Matching_Field return Boolean is 18230 E : Entity_Id; 18231 18232 begin 18233 Matching_Field := Empty; 18234 18235 if Is_Array_Type (Expec_Type) 18236 and then Number_Dimensions (Expec_Type) = 1 18237 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 18238 then 18239 -- Use type name if available. This excludes multidimensional 18240 -- arrays and anonymous arrays. 18241 18242 if Comes_From_Source (Expec_Type) then 18243 Matching_Field := Expec_Type; 18244 18245 -- For an assignment, use name of target 18246 18247 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 18248 and then Is_Entity_Name (Name (Parent (Expr))) 18249 then 18250 Matching_Field := Entity (Name (Parent (Expr))); 18251 end if; 18252 18253 return True; 18254 18255 elsif not Is_Record_Type (Expec_Type) then 18256 return False; 18257 18258 else 18259 E := First_Entity (Expec_Type); 18260 loop 18261 if No (E) then 18262 return False; 18263 18264 elsif not Ekind_In (E, E_Discriminant, E_Component) 18265 or else Nam_In (Chars (E), Name_uTag, Name_uParent) 18266 then 18267 Next_Entity (E); 18268 18269 else 18270 exit; 18271 end if; 18272 end loop; 18273 18274 if not Covers (Etype (E), Found_Type) then 18275 return False; 18276 18277 elsif Present (Next_Entity (E)) 18278 and then (Ekind (E) = E_Component 18279 or else Ekind (Next_Entity (E)) = E_Discriminant) 18280 then 18281 return False; 18282 18283 else 18284 Matching_Field := E; 18285 return True; 18286 end if; 18287 end if; 18288 end Has_One_Matching_Field; 18289 18290 -- Start of processing for Wrong_Type 18291 18292 begin 18293 -- Don't output message if either type is Any_Type, or if a message 18294 -- has already been posted for this node. We need to do the latter 18295 -- check explicitly (it is ordinarily done in Errout), because we 18296 -- are using ! to force the output of the error messages. 18297 18298 if Expec_Type = Any_Type 18299 or else Found_Type = Any_Type 18300 or else Error_Posted (Expr) 18301 then 18302 return; 18303 18304 -- If one of the types is a Taft-Amendment type and the other it its 18305 -- completion, it must be an illegal use of a TAT in the spec, for 18306 -- which an error was already emitted. Avoid cascaded errors. 18307 18308 elsif Is_Incomplete_Type (Expec_Type) 18309 and then Has_Completion_In_Body (Expec_Type) 18310 and then Full_View (Expec_Type) = Etype (Expr) 18311 then 18312 return; 18313 18314 elsif Is_Incomplete_Type (Etype (Expr)) 18315 and then Has_Completion_In_Body (Etype (Expr)) 18316 and then Full_View (Etype (Expr)) = Expec_Type 18317 then 18318 return; 18319 18320 -- In an instance, there is an ongoing problem with completion of 18321 -- type derived from private types. Their structure is what Gigi 18322 -- expects, but the Etype is the parent type rather than the 18323 -- derived private type itself. Do not flag error in this case. The 18324 -- private completion is an entity without a parent, like an Itype. 18325 -- Similarly, full and partial views may be incorrect in the instance. 18326 -- There is no simple way to insure that it is consistent ??? 18327 18328 -- A similar view discrepancy can happen in an inlined body, for the 18329 -- same reason: inserted body may be outside of the original package 18330 -- and only partial views are visible at the point of insertion. 18331 18332 elsif In_Instance or else In_Inlined_Body then 18333 if Etype (Etype (Expr)) = Etype (Expected_Type) 18334 and then 18335 (Has_Private_Declaration (Expected_Type) 18336 or else Has_Private_Declaration (Etype (Expr))) 18337 and then No (Parent (Expected_Type)) 18338 then 18339 return; 18340 18341 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 18342 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 18343 then 18344 return; 18345 18346 elsif Is_Private_Type (Expected_Type) 18347 and then Present (Full_View (Expected_Type)) 18348 and then Covers (Full_View (Expected_Type), Etype (Expr)) 18349 then 18350 return; 18351 end if; 18352 end if; 18353 18354 -- An interesting special check. If the expression is parenthesized 18355 -- and its type corresponds to the type of the sole component of the 18356 -- expected record type, or to the component type of the expected one 18357 -- dimensional array type, then assume we have a bad aggregate attempt. 18358 18359 if Nkind (Expr) in N_Subexpr 18360 and then Paren_Count (Expr) /= 0 18361 and then Has_One_Matching_Field 18362 then 18363 Error_Msg_N ("positional aggregate cannot have one component", Expr); 18364 if Present (Matching_Field) then 18365 if Is_Array_Type (Expec_Type) then 18366 Error_Msg_NE 18367 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 18368 18369 else 18370 Error_Msg_NE 18371 ("\write instead `& ='> ...`", Expr, Matching_Field); 18372 end if; 18373 end if; 18374 18375 -- Another special check, if we are looking for a pool-specific access 18376 -- type and we found an E_Access_Attribute_Type, then we have the case 18377 -- of an Access attribute being used in a context which needs a pool- 18378 -- specific type, which is never allowed. The one extra check we make 18379 -- is that the expected designated type covers the Found_Type. 18380 18381 elsif Is_Access_Type (Expec_Type) 18382 and then Ekind (Found_Type) = E_Access_Attribute_Type 18383 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 18384 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 18385 and then Covers 18386 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 18387 then 18388 Error_Msg_N -- CODEFIX 18389 ("result must be general access type!", Expr); 18390 Error_Msg_NE -- CODEFIX 18391 ("add ALL to }!", Expr, Expec_Type); 18392 18393 -- Another special check, if the expected type is an integer type, 18394 -- but the expression is of type System.Address, and the parent is 18395 -- an addition or subtraction operation whose left operand is the 18396 -- expression in question and whose right operand is of an integral 18397 -- type, then this is an attempt at address arithmetic, so give 18398 -- appropriate message. 18399 18400 elsif Is_Integer_Type (Expec_Type) 18401 and then Is_RTE (Found_Type, RE_Address) 18402 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) 18403 and then Expr = Left_Opnd (Parent (Expr)) 18404 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 18405 then 18406 Error_Msg_N 18407 ("address arithmetic not predefined in package System", 18408 Parent (Expr)); 18409 Error_Msg_N 18410 ("\possible missing with/use of System.Storage_Elements", 18411 Parent (Expr)); 18412 return; 18413 18414 -- If the expected type is an anonymous access type, as for access 18415 -- parameters and discriminants, the error is on the designated types. 18416 18417 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 18418 if Comes_From_Source (Expec_Type) then 18419 Error_Msg_NE ("expected}!", Expr, Expec_Type); 18420 else 18421 Error_Msg_NE 18422 ("expected an access type with designated}", 18423 Expr, Designated_Type (Expec_Type)); 18424 end if; 18425 18426 if Is_Access_Type (Found_Type) 18427 and then not Comes_From_Source (Found_Type) 18428 then 18429 Error_Msg_NE 18430 ("\\found an access type with designated}!", 18431 Expr, Designated_Type (Found_Type)); 18432 else 18433 if From_Limited_With (Found_Type) then 18434 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 18435 Error_Msg_Qual_Level := 99; 18436 Error_Msg_NE -- CODEFIX 18437 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 18438 Error_Msg_Qual_Level := 0; 18439 else 18440 Error_Msg_NE ("found}!", Expr, Found_Type); 18441 end if; 18442 end if; 18443 18444 -- Normal case of one type found, some other type expected 18445 18446 else 18447 -- If the names of the two types are the same, see if some number 18448 -- of levels of qualification will help. Don't try more than three 18449 -- levels, and if we get to standard, it's no use (and probably 18450 -- represents an error in the compiler) Also do not bother with 18451 -- internal scope names. 18452 18453 declare 18454 Expec_Scope : Entity_Id; 18455 Found_Scope : Entity_Id; 18456 18457 begin 18458 Expec_Scope := Expec_Type; 18459 Found_Scope := Found_Type; 18460 18461 for Levels in Int range 0 .. 3 loop 18462 if Chars (Expec_Scope) /= Chars (Found_Scope) then 18463 Error_Msg_Qual_Level := Levels; 18464 exit; 18465 end if; 18466 18467 Expec_Scope := Scope (Expec_Scope); 18468 Found_Scope := Scope (Found_Scope); 18469 18470 exit when Expec_Scope = Standard_Standard 18471 or else Found_Scope = Standard_Standard 18472 or else not Comes_From_Source (Expec_Scope) 18473 or else not Comes_From_Source (Found_Scope); 18474 end loop; 18475 end; 18476 18477 if Is_Record_Type (Expec_Type) 18478 and then Present (Corresponding_Remote_Type (Expec_Type)) 18479 then 18480 Error_Msg_NE ("expected}!", Expr, 18481 Corresponding_Remote_Type (Expec_Type)); 18482 else 18483 Error_Msg_NE ("expected}!", Expr, Expec_Type); 18484 end if; 18485 18486 if Is_Entity_Name (Expr) 18487 and then Is_Package_Or_Generic_Package (Entity (Expr)) 18488 then 18489 Error_Msg_N ("\\found package name!", Expr); 18490 18491 elsif Is_Entity_Name (Expr) 18492 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) 18493 then 18494 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 18495 Error_Msg_N 18496 ("found procedure name, possibly missing Access attribute!", 18497 Expr); 18498 else 18499 Error_Msg_N 18500 ("\\found procedure name instead of function!", Expr); 18501 end if; 18502 18503 elsif Nkind (Expr) = N_Function_Call 18504 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 18505 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 18506 and then No (Parameter_Associations (Expr)) 18507 then 18508 Error_Msg_N 18509 ("found function name, possibly missing Access attribute!", 18510 Expr); 18511 18512 -- Catch common error: a prefix or infix operator which is not 18513 -- directly visible because the type isn't. 18514 18515 elsif Nkind (Expr) in N_Op 18516 and then Is_Overloaded (Expr) 18517 and then not Is_Immediately_Visible (Expec_Type) 18518 and then not Is_Potentially_Use_Visible (Expec_Type) 18519 and then not In_Use (Expec_Type) 18520 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 18521 then 18522 Error_Msg_N 18523 ("operator of the type is not directly visible!", Expr); 18524 18525 elsif Ekind (Found_Type) = E_Void 18526 and then Present (Parent (Found_Type)) 18527 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 18528 then 18529 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 18530 18531 else 18532 Error_Msg_NE ("\\found}!", Expr, Found_Type); 18533 end if; 18534 18535 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 18536 -- of the same modular type, and (M1 and M2) = 0 was intended. 18537 18538 if Expec_Type = Standard_Boolean 18539 and then Is_Modular_Integer_Type (Found_Type) 18540 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 18541 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 18542 then 18543 declare 18544 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 18545 L : constant Node_Id := Left_Opnd (Op); 18546 R : constant Node_Id := Right_Opnd (Op); 18547 18548 begin 18549 -- The case for the message is when the left operand of the 18550 -- comparison is the same modular type, or when it is an 18551 -- integer literal (or other universal integer expression), 18552 -- which would have been typed as the modular type if the 18553 -- parens had been there. 18554 18555 if (Etype (L) = Found_Type 18556 or else 18557 Etype (L) = Universal_Integer) 18558 and then Is_Integer_Type (Etype (R)) 18559 then 18560 Error_Msg_N 18561 ("\\possible missing parens for modular operation", Expr); 18562 end if; 18563 end; 18564 end if; 18565 18566 -- Reset error message qualification indication 18567 18568 Error_Msg_Qual_Level := 0; 18569 end if; 18570 end Wrong_Type; 18571 18572end Sem_Util; 18573