1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ A U X -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, 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 Atree; use Atree; 27with Einfo; use Einfo; 28with Einfo.Entities; use Einfo.Entities; 29with Einfo.Utils; use Einfo.Utils; 30with Nlists; use Nlists; 31with Sinfo; use Sinfo; 32with Sinfo.Nodes; use Sinfo.Nodes; 33with Sinfo.Utils; use Sinfo.Utils; 34with Snames; use Snames; 35with Stand; use Stand; 36with Uintp; use Uintp; 37 38package body Sem_Aux is 39 40 ---------------------- 41 -- Ancestor_Subtype -- 42 ---------------------- 43 44 function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is 45 begin 46 -- If this is first subtype, or is a base type, then there is no 47 -- ancestor subtype, so we return Empty to indicate this fact. 48 49 if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then 50 return Empty; 51 end if; 52 53 declare 54 D : constant Node_Id := Declaration_Node (Typ); 55 56 begin 57 -- If we have a subtype declaration, get the ancestor subtype 58 59 if Nkind (D) = N_Subtype_Declaration then 60 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then 61 return Entity (Subtype_Mark (Subtype_Indication (D))); 62 else 63 return Entity (Subtype_Indication (D)); 64 end if; 65 66 -- If not, then no subtype indication is available 67 68 else 69 return Empty; 70 end if; 71 end; 72 end Ancestor_Subtype; 73 74 -------------------- 75 -- Available_View -- 76 -------------------- 77 78 function Available_View (Ent : Entity_Id) return Entity_Id is 79 begin 80 -- Obtain the non-limited view (if available) 81 82 if Has_Non_Limited_View (Ent) then 83 return Get_Full_View (Non_Limited_View (Ent)); 84 85 -- In all other cases, return entity unchanged 86 87 else 88 return Ent; 89 end if; 90 end Available_View; 91 92 -------------------- 93 -- Constant_Value -- 94 -------------------- 95 96 function Constant_Value (Ent : Entity_Id) return Node_Id is 97 D : constant Node_Id := Declaration_Node (Ent); 98 Full_D : Node_Id; 99 100 begin 101 -- If we have no declaration node, then return no constant value. Not 102 -- clear how this can happen, but it does sometimes and this is the 103 -- safest approach. 104 105 if No (D) then 106 return Empty; 107 108 -- Normal case where a declaration node is present 109 110 elsif Nkind (D) = N_Object_Renaming_Declaration then 111 return Renamed_Object (Ent); 112 113 -- If this is a component declaration whose entity is a constant, it is 114 -- a prival within a protected function (and so has no constant value). 115 116 elsif Nkind (D) = N_Component_Declaration then 117 return Empty; 118 119 -- If there is an expression, return it 120 121 elsif Present (Expression (D)) then 122 return Expression (D); 123 124 -- For a constant, see if we have a full view 125 126 elsif Ekind (Ent) = E_Constant 127 and then Present (Full_View (Ent)) 128 then 129 Full_D := Parent (Full_View (Ent)); 130 131 -- The full view may have been rewritten as an object renaming 132 133 if Nkind (Full_D) = N_Object_Renaming_Declaration then 134 return Name (Full_D); 135 else 136 return Expression (Full_D); 137 end if; 138 139 -- Otherwise we have no expression to return 140 141 else 142 return Empty; 143 end if; 144 end Constant_Value; 145 146 --------------------------------- 147 -- Corresponding_Unsigned_Type -- 148 --------------------------------- 149 150 function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is 151 pragma Assert (Is_Signed_Integer_Type (Typ)); 152 Siz : constant Uint := Esize (Base_Type (Typ)); 153 begin 154 if Siz = Esize (Standard_Short_Short_Integer) then 155 return Standard_Short_Short_Unsigned; 156 elsif Siz = Esize (Standard_Short_Integer) then 157 return Standard_Short_Unsigned; 158 elsif Siz = Esize (Standard_Unsigned) then 159 return Standard_Unsigned; 160 elsif Siz = Esize (Standard_Long_Integer) then 161 return Standard_Long_Unsigned; 162 elsif Siz = Esize (Standard_Long_Long_Integer) then 163 return Standard_Long_Long_Unsigned; 164 elsif Siz = Esize (Standard_Long_Long_Long_Integer) then 165 return Standard_Long_Long_Long_Unsigned; 166 else 167 raise Program_Error; 168 end if; 169 end Corresponding_Unsigned_Type; 170 171 ----------------------------- 172 -- Enclosing_Dynamic_Scope -- 173 ----------------------------- 174 175 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is 176 S : Entity_Id; 177 178 begin 179 -- The following test is an error defense against some syntax errors 180 -- that can leave scopes very messed up. 181 182 if Ent = Standard_Standard then 183 return Ent; 184 end if; 185 186 -- Normal case, search enclosing scopes 187 188 -- Note: the test for Present (S) should not be required, it defends 189 -- against an ill-formed tree. 190 191 S := Scope (Ent); 192 loop 193 -- If we somehow got an empty value for Scope, the tree must be 194 -- malformed. Rather than blow up we return Standard in this case. 195 196 if No (S) then 197 return Standard_Standard; 198 199 -- Quit if we get to standard or a dynamic scope. We must also 200 -- handle enclosing scopes that have a full view; required to 201 -- locate enclosing scopes that are synchronized private types 202 -- whose full view is a task type. 203 204 elsif S = Standard_Standard 205 or else Is_Dynamic_Scope (S) 206 or else (Is_Private_Type (S) 207 and then Present (Full_View (S)) 208 and then Is_Dynamic_Scope (Full_View (S))) 209 then 210 return S; 211 212 -- Otherwise keep climbing 213 214 else 215 S := Scope (S); 216 end if; 217 end loop; 218 end Enclosing_Dynamic_Scope; 219 220 ------------------------ 221 -- First_Discriminant -- 222 ------------------------ 223 224 function First_Discriminant (Typ : Entity_Id) return Entity_Id is 225 Ent : Entity_Id; 226 227 begin 228 pragma Assert 229 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); 230 231 Ent := First_Entity (Typ); 232 233 -- The discriminants are not necessarily contiguous, because access 234 -- discriminants will generate itypes. They are not the first entities 235 -- either because the tag must be ahead of them. 236 237 if Chars (Ent) = Name_uTag then 238 Next_Entity (Ent); 239 end if; 240 241 -- Skip all hidden stored discriminants if any 242 243 while Present (Ent) loop 244 exit when Ekind (Ent) = E_Discriminant 245 and then not Is_Completely_Hidden (Ent); 246 247 Next_Entity (Ent); 248 end loop; 249 250 -- Call may be on a private type with unknown discriminants, in which 251 -- case Ent is Empty, and as per the spec, we return Empty in this case. 252 253 -- Historical note: The assertion in previous versions that Ent is a 254 -- discriminant was overly cautious and prevented convenient application 255 -- of this function in the gnatprove context. 256 257 return Ent; 258 end First_Discriminant; 259 260 ------------------------------- 261 -- First_Stored_Discriminant -- 262 ------------------------------- 263 264 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is 265 Ent : Entity_Id; 266 267 function Has_Completely_Hidden_Discriminant 268 (Typ : Entity_Id) return Boolean; 269 -- Scans the Discriminants to see whether any are Completely_Hidden 270 -- (the mechanism for describing non-specified stored discriminants) 271 -- Note that the entity list for the type may contain anonymous access 272 -- types created by expressions that constrain access discriminants. 273 274 ---------------------------------------- 275 -- Has_Completely_Hidden_Discriminant -- 276 ---------------------------------------- 277 278 function Has_Completely_Hidden_Discriminant 279 (Typ : Entity_Id) return Boolean 280 is 281 Ent : Entity_Id; 282 283 begin 284 pragma Assert (Ekind (Typ) = E_Discriminant); 285 286 Ent := Typ; 287 while Present (Ent) loop 288 289 -- Skip anonymous types that may be created by expressions 290 -- used as discriminant constraints on inherited discriminants. 291 292 if Is_Itype (Ent) then 293 null; 294 295 elsif Ekind (Ent) = E_Discriminant 296 and then Is_Completely_Hidden (Ent) 297 then 298 return True; 299 end if; 300 301 Next_Entity (Ent); 302 end loop; 303 304 return False; 305 end Has_Completely_Hidden_Discriminant; 306 307 -- Start of processing for First_Stored_Discriminant 308 309 begin 310 pragma Assert 311 (Has_Discriminants (Typ) 312 or else Has_Unknown_Discriminants (Typ)); 313 314 Ent := First_Entity (Typ); 315 316 if Chars (Ent) = Name_uTag then 317 Next_Entity (Ent); 318 end if; 319 320 if Has_Completely_Hidden_Discriminant (Ent) then 321 while Present (Ent) loop 322 exit when Ekind (Ent) = E_Discriminant 323 and then Is_Completely_Hidden (Ent); 324 Next_Entity (Ent); 325 end loop; 326 end if; 327 328 pragma Assert (Ekind (Ent) = E_Discriminant); 329 330 return Ent; 331 end First_Stored_Discriminant; 332 333 ------------------- 334 -- First_Subtype -- 335 ------------------- 336 337 function First_Subtype (Typ : Entity_Id) return Entity_Id is 338 B : constant Entity_Id := Base_Type (Typ); 339 F : Node_Id := Freeze_Node (B); 340 Ent : Entity_Id; 341 342 begin 343 -- The freeze node of a ghost type might have been rewritten in a null 344 -- statement by the time gigi calls First_Subtype on the corresponding 345 -- type. 346 347 if Nkind (F) = N_Null_Statement then 348 F := Original_Node (F); 349 end if; 350 351 -- If the base type has no freeze node, it is a type in Standard, and 352 -- always acts as its own first subtype, except where it is one of the 353 -- predefined integer types. If the type is formal, it is also a first 354 -- subtype, and its base type has no freeze node. On the other hand, a 355 -- subtype of a generic formal is not its own first subtype. Its base 356 -- type, if anonymous, is attached to the formal type declaration from 357 -- which the first subtype is obtained. 358 359 if No (F) then 360 if B = Base_Type (Standard_Integer) then 361 return Standard_Integer; 362 363 elsif B = Base_Type (Standard_Long_Integer) then 364 return Standard_Long_Integer; 365 366 elsif B = Base_Type (Standard_Short_Short_Integer) then 367 return Standard_Short_Short_Integer; 368 369 elsif B = Base_Type (Standard_Short_Integer) then 370 return Standard_Short_Integer; 371 372 elsif B = Base_Type (Standard_Long_Long_Integer) then 373 return Standard_Long_Long_Integer; 374 375 elsif B = Base_Type (Standard_Long_Long_Long_Integer) then 376 return Standard_Long_Long_Long_Integer; 377 378 elsif Is_Generic_Type (Typ) then 379 if Present (Parent (B)) then 380 return Defining_Identifier (Parent (B)); 381 else 382 return Defining_Identifier (Associated_Node_For_Itype (B)); 383 end if; 384 385 else 386 return B; 387 end if; 388 389 -- Otherwise we check the freeze node, if it has a First_Subtype_Link 390 -- then we use that link, otherwise (happens with some Itypes), we use 391 -- the base type itself. 392 393 else 394 Ent := First_Subtype_Link (F); 395 396 if Present (Ent) then 397 return Ent; 398 else 399 return B; 400 end if; 401 end if; 402 end First_Subtype; 403 404 ------------------------- 405 -- First_Tag_Component -- 406 ------------------------- 407 408 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is 409 Comp : Entity_Id; 410 Ctyp : Entity_Id; 411 412 begin 413 Ctyp := Typ; 414 pragma Assert (Is_Tagged_Type (Ctyp)); 415 416 if Is_Class_Wide_Type (Ctyp) then 417 Ctyp := Root_Type (Ctyp); 418 end if; 419 420 if Is_Private_Type (Ctyp) then 421 Ctyp := Underlying_Type (Ctyp); 422 423 -- If the underlying type is missing then the source program has 424 -- errors and there is nothing else to do (the full-type declaration 425 -- associated with the private type declaration is missing). 426 427 if No (Ctyp) then 428 return Empty; 429 end if; 430 end if; 431 432 Comp := First_Entity (Ctyp); 433 while Present (Comp) loop 434 if Is_Tag (Comp) then 435 return Comp; 436 end if; 437 438 Next_Entity (Comp); 439 end loop; 440 441 -- No tag component found 442 443 return Empty; 444 end First_Tag_Component; 445 446 ----------------------- 447 -- Get_Called_Entity -- 448 ----------------------- 449 450 function Get_Called_Entity (Call : Node_Id) return Entity_Id is 451 Nam : constant Node_Id := Name (Call); 452 Id : Entity_Id; 453 454 begin 455 if Nkind (Nam) = N_Explicit_Dereference then 456 Id := Etype (Nam); 457 pragma Assert (Ekind (Id) = E_Subprogram_Type); 458 459 elsif Nkind (Nam) = N_Selected_Component then 460 Id := Entity (Selector_Name (Nam)); 461 462 elsif Nkind (Nam) = N_Indexed_Component then 463 Id := Entity (Selector_Name (Prefix (Nam))); 464 465 else 466 Id := Entity (Nam); 467 end if; 468 469 return Id; 470 end Get_Called_Entity; 471 472 ------------------ 473 -- Get_Rep_Item -- 474 ------------------ 475 476 function Get_Rep_Item 477 (E : Entity_Id; 478 Nam : Name_Id; 479 Check_Parents : Boolean := True) return Node_Id 480 is 481 N : Node_Id; 482 483 begin 484 N := First_Rep_Item (E); 485 while Present (N) loop 486 487 -- Only one of Priority / Interrupt_Priority can be specified, so 488 -- return whichever one is present to catch illegal duplication. 489 490 if Nkind (N) = N_Pragma 491 and then 492 (Pragma_Name_Unmapped (N) = Nam 493 or else (Nam = Name_Priority 494 and then Pragma_Name (N) = 495 Name_Interrupt_Priority) 496 or else (Nam = Name_Interrupt_Priority 497 and then Pragma_Name (N) = Name_Priority)) 498 then 499 if Check_Parents then 500 return N; 501 502 -- If Check_Parents is False, return N if the pragma doesn't 503 -- appear in the Rep_Item chain of the parent. 504 505 else 506 declare 507 Par : constant Entity_Id := Nearest_Ancestor (E); 508 -- This node represents the parent type of type E (if any) 509 510 begin 511 if No (Par) then 512 return N; 513 514 elsif not Present_In_Rep_Item (Par, N) then 515 return N; 516 end if; 517 end; 518 end if; 519 520 elsif Nkind (N) = N_Attribute_Definition_Clause 521 and then 522 (Chars (N) = Nam 523 or else (Nam = Name_Priority 524 and then Chars (N) = Name_Interrupt_Priority)) 525 then 526 if Check_Parents or else Entity (N) = E then 527 return N; 528 end if; 529 530 elsif Nkind (N) = N_Aspect_Specification 531 and then 532 (Chars (Identifier (N)) = Nam 533 or else 534 (Nam = Name_Priority 535 and then Chars (Identifier (N)) = Name_Interrupt_Priority)) 536 then 537 if Check_Parents then 538 return N; 539 540 elsif Entity (N) = E then 541 return N; 542 end if; 543 544 -- A Ghost-related aspect, if disabled, may have been replaced by a 545 -- null statement. 546 547 elsif Nkind (N) = N_Null_Statement then 548 N := Original_Node (N); 549 end if; 550 551 Next_Rep_Item (N); 552 end loop; 553 554 return Empty; 555 end Get_Rep_Item; 556 557 function Get_Rep_Item 558 (E : Entity_Id; 559 Nam1 : Name_Id; 560 Nam2 : Name_Id; 561 Check_Parents : Boolean := True) return Node_Id 562 is 563 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); 564 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); 565 566 N : Node_Id; 567 568 begin 569 -- Check both Nam1_Item and Nam2_Item are present 570 571 if No (Nam1_Item) then 572 return Nam2_Item; 573 elsif No (Nam2_Item) then 574 return Nam1_Item; 575 end if; 576 577 -- Return the first node encountered in the list 578 579 N := First_Rep_Item (E); 580 while Present (N) loop 581 if N = Nam1_Item or else N = Nam2_Item then 582 return N; 583 end if; 584 585 Next_Rep_Item (N); 586 end loop; 587 588 return Empty; 589 end Get_Rep_Item; 590 591 -------------------- 592 -- Get_Rep_Pragma -- 593 -------------------- 594 595 function Get_Rep_Pragma 596 (E : Entity_Id; 597 Nam : Name_Id; 598 Check_Parents : Boolean := True) return Node_Id 599 is 600 N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents); 601 602 begin 603 if Present (N) and then Nkind (N) = N_Pragma then 604 return N; 605 end if; 606 607 return Empty; 608 end Get_Rep_Pragma; 609 610 function Get_Rep_Pragma 611 (E : Entity_Id; 612 Nam1 : Name_Id; 613 Nam2 : Name_Id; 614 Check_Parents : Boolean := True) return Node_Id 615 is 616 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); 617 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); 618 619 N : Node_Id; 620 621 begin 622 -- Check both Nam1_Item and Nam2_Item are present 623 624 if No (Nam1_Item) then 625 return Nam2_Item; 626 elsif No (Nam2_Item) then 627 return Nam1_Item; 628 end if; 629 630 -- Return the first node encountered in the list 631 632 N := First_Rep_Item (E); 633 while Present (N) loop 634 if N = Nam1_Item or else N = Nam2_Item then 635 return N; 636 end if; 637 638 Next_Rep_Item (N); 639 end loop; 640 641 return Empty; 642 end Get_Rep_Pragma; 643 644 --------------------------------- 645 -- Has_External_Tag_Rep_Clause -- 646 --------------------------------- 647 648 function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is 649 begin 650 pragma Assert (Is_Tagged_Type (T)); 651 return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False); 652 end Has_External_Tag_Rep_Clause; 653 654 ------------------ 655 -- Has_Rep_Item -- 656 ------------------ 657 658 function Has_Rep_Item 659 (E : Entity_Id; 660 Nam : Name_Id; 661 Check_Parents : Boolean := True) return Boolean 662 is 663 begin 664 return Present (Get_Rep_Item (E, Nam, Check_Parents)); 665 end Has_Rep_Item; 666 667 function Has_Rep_Item 668 (E : Entity_Id; 669 Nam1 : Name_Id; 670 Nam2 : Name_Id; 671 Check_Parents : Boolean := True) return Boolean 672 is 673 begin 674 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); 675 end Has_Rep_Item; 676 677 -------------------- 678 -- Has_Rep_Pragma -- 679 -------------------- 680 681 function Has_Rep_Pragma 682 (E : Entity_Id; 683 Nam : Name_Id; 684 Check_Parents : Boolean := True) return Boolean 685 is 686 begin 687 return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); 688 end Has_Rep_Pragma; 689 690 function Has_Rep_Pragma 691 (E : Entity_Id; 692 Nam1 : Name_Id; 693 Nam2 : Name_Id; 694 Check_Parents : Boolean := True) return Boolean 695 is 696 begin 697 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); 698 end Has_Rep_Pragma; 699 700 -------------------------------- 701 -- Has_Unconstrained_Elements -- 702 -------------------------------- 703 704 function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is 705 U_T : constant Entity_Id := Underlying_Type (T); 706 begin 707 if No (U_T) then 708 return False; 709 elsif Is_Record_Type (U_T) then 710 return Has_Discriminants (U_T) and then not Is_Constrained (U_T); 711 elsif Is_Array_Type (U_T) then 712 return Has_Unconstrained_Elements (Component_Type (U_T)); 713 else 714 return False; 715 end if; 716 end Has_Unconstrained_Elements; 717 718 ---------------------- 719 -- Has_Variant_Part -- 720 ---------------------- 721 722 function Has_Variant_Part (Typ : Entity_Id) return Boolean is 723 FSTyp : Entity_Id; 724 Decl : Node_Id; 725 TDef : Node_Id; 726 CList : Node_Id; 727 728 begin 729 if not Is_Type (Typ) then 730 return False; 731 end if; 732 733 FSTyp := First_Subtype (Typ); 734 735 if not Has_Discriminants (FSTyp) then 736 return False; 737 end if; 738 739 -- Proceed with cautious checks here, return False if tree is not 740 -- as expected (may be caused by prior errors). 741 742 Decl := Declaration_Node (FSTyp); 743 744 if Nkind (Decl) /= N_Full_Type_Declaration then 745 return False; 746 end if; 747 748 TDef := Type_Definition (Decl); 749 750 if Nkind (TDef) /= N_Record_Definition then 751 return False; 752 end if; 753 754 CList := Component_List (TDef); 755 756 if Nkind (CList) /= N_Component_List then 757 return False; 758 else 759 return Present (Variant_Part (CList)); 760 end if; 761 end Has_Variant_Part; 762 763 --------------------- 764 -- In_Generic_Body -- 765 --------------------- 766 767 function In_Generic_Body (Id : Entity_Id) return Boolean is 768 S : Entity_Id; 769 770 begin 771 -- Climb scopes looking for generic body 772 773 S := Id; 774 while Present (S) and then S /= Standard_Standard loop 775 776 -- Generic package body 777 778 if Ekind (S) = E_Generic_Package 779 and then In_Package_Body (S) 780 then 781 return True; 782 783 -- Generic subprogram body 784 785 elsif Is_Subprogram (S) 786 and then Nkind (Unit_Declaration_Node (S)) = 787 N_Generic_Subprogram_Declaration 788 then 789 return True; 790 end if; 791 792 S := Scope (S); 793 end loop; 794 795 -- False if top of scope stack without finding a generic body 796 797 return False; 798 end In_Generic_Body; 799 800 ------------------------------- 801 -- Initialization_Suppressed -- 802 ------------------------------- 803 804 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is 805 begin 806 return Suppress_Initialization (Typ) 807 or else Suppress_Initialization (Base_Type (Typ)); 808 end Initialization_Suppressed; 809 810 ---------------- 811 -- Initialize -- 812 ---------------- 813 814 procedure Initialize is 815 begin 816 Obsolescent_Warnings.Init; 817 end Initialize; 818 819 ------------- 820 -- Is_Body -- 821 ------------- 822 823 function Is_Body (N : Node_Id) return Boolean is 824 begin 825 return Nkind (N) in 826 N_Body_Stub | N_Entry_Body | N_Package_Body | N_Protected_Body | 827 N_Subprogram_Body | N_Task_Body; 828 end Is_Body; 829 830 --------------------- 831 -- Is_By_Copy_Type -- 832 --------------------- 833 834 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is 835 begin 836 -- If Id is a private type whose full declaration has not been seen, 837 -- we assume for now that it is not a By_Copy type. Clearly this 838 -- attribute should not be used before the type is frozen, but it is 839 -- needed to build the associated record of a protected type. Another 840 -- place where some lookahead for a full view is needed ??? 841 842 return 843 Is_Elementary_Type (Ent) 844 or else (Is_Private_Type (Ent) 845 and then Present (Underlying_Type (Ent)) 846 and then Is_Elementary_Type (Underlying_Type (Ent))); 847 end Is_By_Copy_Type; 848 849 -------------------------- 850 -- Is_By_Reference_Type -- 851 -------------------------- 852 853 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is 854 Btype : constant Entity_Id := Base_Type (Ent); 855 856 begin 857 if Is_Private_Type (Btype) then 858 declare 859 Utyp : constant Entity_Id := Underlying_Type (Btype); 860 begin 861 if No (Utyp) then 862 return False; 863 else 864 return Is_By_Reference_Type (Utyp); 865 end if; 866 end; 867 868 elsif Is_Incomplete_Type (Btype) then 869 declare 870 Ftyp : constant Entity_Id := Full_View (Btype); 871 begin 872 -- Return true for a tagged incomplete type built as a shadow 873 -- entity in Build_Limited_Views. It can appear in the profile 874 -- of a thunk and the back end needs to know how it is passed. 875 876 if No (Ftyp) then 877 return Is_Tagged_Type (Btype); 878 else 879 return Is_By_Reference_Type (Ftyp); 880 end if; 881 end; 882 883 elsif Is_Concurrent_Type (Btype) then 884 return True; 885 886 elsif Is_Record_Type (Btype) then 887 if Is_Limited_Record (Btype) 888 or else Is_Tagged_Type (Btype) 889 or else Is_Volatile (Btype) 890 then 891 return True; 892 893 else 894 declare 895 C : Entity_Id; 896 897 begin 898 C := First_Component (Btype); 899 while Present (C) loop 900 901 -- For each component, test if its type is a by reference 902 -- type and if its type is volatile. Also test the component 903 -- itself for being volatile. This happens for example when 904 -- a Volatile aspect is added to a component. 905 906 if Is_By_Reference_Type (Etype (C)) 907 or else Is_Volatile (Etype (C)) 908 or else Is_Volatile (C) 909 then 910 return True; 911 end if; 912 913 Next_Component (C); 914 end loop; 915 end; 916 917 return False; 918 end if; 919 920 elsif Is_Array_Type (Btype) then 921 return 922 Is_Volatile (Btype) 923 or else Is_By_Reference_Type (Component_Type (Btype)) 924 or else Is_Volatile (Component_Type (Btype)) 925 or else Has_Volatile_Components (Btype); 926 927 else 928 return False; 929 end if; 930 end Is_By_Reference_Type; 931 932 ------------------------- 933 -- Is_Definite_Subtype -- 934 ------------------------- 935 936 function Is_Definite_Subtype (T : Entity_Id) return Boolean is 937 pragma Assert (Is_Type (T)); 938 K : constant Entity_Kind := Ekind (T); 939 940 begin 941 if Is_Constrained (T) then 942 return True; 943 944 elsif K in Array_Kind 945 or else K in Class_Wide_Kind 946 or else Has_Unknown_Discriminants (T) 947 then 948 return False; 949 950 -- Known discriminants: definite if there are default values. Note that 951 -- if any discriminant has a default, they all do. 952 953 elsif Has_Discriminants (T) then 954 return Present (Discriminant_Default_Value (First_Discriminant (T))); 955 956 else 957 return True; 958 end if; 959 end Is_Definite_Subtype; 960 961 --------------------- 962 -- Is_Derived_Type -- 963 --------------------- 964 965 function Is_Derived_Type (Ent : E) return B is 966 Par : Node_Id; 967 968 begin 969 if Is_Type (Ent) 970 and then Base_Type (Ent) /= Root_Type (Ent) 971 and then not Is_Class_Wide_Type (Ent) 972 973 -- An access_to_subprogram whose result type is a limited view can 974 -- appear in a return statement, without the full view of the result 975 -- type being available. Do not interpret this as a derived type. 976 977 and then Ekind (Ent) /= E_Subprogram_Type 978 then 979 if not Is_Numeric_Type (Root_Type (Ent)) then 980 return True; 981 982 else 983 Par := Parent (First_Subtype (Ent)); 984 985 return Present (Par) 986 and then Nkind (Par) = N_Full_Type_Declaration 987 and then Nkind (Type_Definition (Par)) = 988 N_Derived_Type_Definition; 989 end if; 990 991 else 992 return False; 993 end if; 994 end Is_Derived_Type; 995 996 ----------------------- 997 -- Is_Generic_Formal -- 998 ----------------------- 999 1000 function Is_Generic_Formal (E : Entity_Id) return Boolean is 1001 Kind : Node_Kind; 1002 1003 begin 1004 if No (E) then 1005 return False; 1006 else 1007 -- Formal derived types are rewritten as private extensions, so 1008 -- examine original node. 1009 1010 Kind := Nkind (Original_Node (Parent (E))); 1011 1012 return 1013 Kind in N_Formal_Object_Declaration | N_Formal_Type_Declaration 1014 or else Is_Formal_Subprogram (E) 1015 or else 1016 (Ekind (E) = E_Package 1017 and then Nkind (Original_Node (Unit_Declaration_Node (E))) = 1018 N_Formal_Package_Declaration); 1019 end if; 1020 end Is_Generic_Formal; 1021 1022 ------------------------------- 1023 -- Is_Immutably_Limited_Type -- 1024 ------------------------------- 1025 1026 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is 1027 Btype : constant Entity_Id := Available_View (Base_Type (Ent)); 1028 1029 begin 1030 if Is_Limited_Record (Btype) then 1031 return True; 1032 1033 elsif Ekind (Btype) = E_Limited_Private_Type 1034 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration 1035 then 1036 return not In_Package_Body (Scope ((Btype))); 1037 1038 elsif Is_Private_Type (Btype) then 1039 1040 -- AI05-0063: A type derived from a limited private formal type is 1041 -- not immutably limited in a generic body. 1042 1043 if Is_Derived_Type (Btype) 1044 and then Is_Generic_Type (Etype (Btype)) 1045 then 1046 if not Is_Limited_Type (Etype (Btype)) then 1047 return False; 1048 1049 -- A descendant of a limited formal type is not immutably limited 1050 -- in the generic body, or in the body of a generic child. 1051 1052 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then 1053 return not In_Package_Body (Scope (Btype)); 1054 1055 else 1056 return False; 1057 end if; 1058 1059 else 1060 declare 1061 Utyp : constant Entity_Id := Underlying_Type (Btype); 1062 begin 1063 if No (Utyp) then 1064 return False; 1065 else 1066 return Is_Immutably_Limited_Type (Utyp); 1067 end if; 1068 end; 1069 end if; 1070 1071 elsif Is_Concurrent_Type (Btype) then 1072 return True; 1073 1074 else 1075 return False; 1076 end if; 1077 end Is_Immutably_Limited_Type; 1078 1079 --------------------- 1080 -- Is_Limited_Type -- 1081 --------------------- 1082 1083 function Is_Limited_Type (Ent : Entity_Id) return Boolean is 1084 Btype : Entity_Id; 1085 Rtype : Entity_Id; 1086 1087 begin 1088 if not Is_Type (Ent) then 1089 return False; 1090 end if; 1091 1092 Btype := Base_Type (Ent); 1093 Rtype := Root_Type (Btype); 1094 1095 if Ekind (Btype) = E_Limited_Private_Type 1096 or else Is_Limited_Composite (Btype) 1097 then 1098 return True; 1099 1100 elsif Is_Concurrent_Type (Btype) then 1101 return True; 1102 1103 -- The Is_Limited_Record flag normally indicates that the type is 1104 -- limited. The exception is that a type does not inherit limitedness 1105 -- from its interface ancestor. So the type may be derived from a 1106 -- limited interface, but is not limited. 1107 1108 elsif Is_Limited_Record (Ent) 1109 and then not Is_Interface (Ent) 1110 then 1111 return True; 1112 1113 -- Otherwise we will look around to see if there is some other reason 1114 -- for it to be limited, except that if an error was posted on the 1115 -- entity, then just assume it is non-limited, because it can cause 1116 -- trouble to recurse into a murky entity resulting from other errors. 1117 1118 elsif Error_Posted (Ent) then 1119 return False; 1120 1121 elsif Is_Record_Type (Btype) then 1122 1123 if Is_Limited_Interface (Ent) then 1124 return True; 1125 1126 -- AI-419: limitedness is not inherited from a limited interface 1127 1128 elsif Is_Limited_Record (Rtype) then 1129 return not Is_Interface (Rtype) 1130 or else Is_Protected_Interface (Rtype) 1131 or else Is_Synchronized_Interface (Rtype) 1132 or else Is_Task_Interface (Rtype); 1133 1134 elsif Is_Class_Wide_Type (Btype) then 1135 return Is_Limited_Type (Rtype); 1136 1137 else 1138 declare 1139 C : E; 1140 1141 begin 1142 C := First_Component (Btype); 1143 while Present (C) loop 1144 if Is_Limited_Type (Etype (C)) then 1145 return True; 1146 end if; 1147 1148 Next_Component (C); 1149 end loop; 1150 end; 1151 1152 return False; 1153 end if; 1154 1155 elsif Is_Array_Type (Btype) then 1156 return Is_Limited_Type (Component_Type (Btype)); 1157 1158 else 1159 return False; 1160 end if; 1161 end Is_Limited_Type; 1162 1163 --------------------- 1164 -- Is_Limited_View -- 1165 --------------------- 1166 1167 function Is_Limited_View (Ent : Entity_Id) return Boolean is 1168 Btype : constant Entity_Id := Available_View (Base_Type (Ent)); 1169 1170 begin 1171 if Is_Limited_Record (Btype) then 1172 return True; 1173 1174 elsif Ekind (Btype) = E_Limited_Private_Type 1175 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration 1176 then 1177 return not In_Package_Body (Scope ((Btype))); 1178 1179 elsif Is_Private_Type (Btype) then 1180 1181 -- AI05-0063: A type derived from a limited private formal type is 1182 -- not immutably limited in a generic body. 1183 1184 if Is_Derived_Type (Btype) 1185 and then Is_Generic_Type (Etype (Btype)) 1186 then 1187 if not Is_Limited_Type (Etype (Btype)) then 1188 return False; 1189 1190 -- A descendant of a limited formal type is not immutably limited 1191 -- in the generic body, or in the body of a generic child. 1192 1193 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then 1194 return not In_Package_Body (Scope (Btype)); 1195 1196 else 1197 return False; 1198 end if; 1199 1200 else 1201 declare 1202 Utyp : constant Entity_Id := Underlying_Type (Btype); 1203 begin 1204 if No (Utyp) then 1205 return False; 1206 else 1207 return Is_Limited_View (Utyp); 1208 end if; 1209 end; 1210 end if; 1211 1212 elsif Is_Concurrent_Type (Btype) then 1213 return True; 1214 1215 elsif Is_Record_Type (Btype) then 1216 1217 -- Note that we return True for all limited interfaces, even though 1218 -- (unsynchronized) limited interfaces can have descendants that are 1219 -- nonlimited, because this is a predicate on the type itself, and 1220 -- things like functions with limited interface results need to be 1221 -- handled as build in place even though they might return objects 1222 -- of a type that is not inherently limited. 1223 1224 if Is_Class_Wide_Type (Btype) then 1225 return Is_Limited_View (Root_Type (Btype)); 1226 1227 else 1228 declare 1229 C : Entity_Id; 1230 1231 begin 1232 C := First_Component (Btype); 1233 while Present (C) loop 1234 1235 -- Don't consider components with interface types (which can 1236 -- only occur in the case of a _parent component anyway). 1237 -- They don't have any components, plus it would cause this 1238 -- function to return true for nonlimited types derived from 1239 -- limited interfaces. 1240 1241 if not Is_Interface (Etype (C)) 1242 and then Is_Limited_View (Etype (C)) 1243 then 1244 return True; 1245 end if; 1246 1247 Next_Component (C); 1248 end loop; 1249 end; 1250 1251 return False; 1252 end if; 1253 1254 elsif Is_Array_Type (Btype) then 1255 return Is_Limited_View (Component_Type (Btype)); 1256 1257 else 1258 return False; 1259 end if; 1260 end Is_Limited_View; 1261 1262 ------------------------------- 1263 -- Is_Record_Or_Limited_Type -- 1264 ------------------------------- 1265 1266 function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean is 1267 begin 1268 return Is_Record_Type (Typ) or else Is_Limited_Type (Typ); 1269 end Is_Record_Or_Limited_Type; 1270 1271 ---------------------- 1272 -- Nearest_Ancestor -- 1273 ---------------------- 1274 1275 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is 1276 D : constant Node_Id := Original_Node (Declaration_Node (Typ)); 1277 -- We use the original node of the declaration, because derived 1278 -- types from record subtypes are rewritten as record declarations, 1279 -- and it is the original declaration that carries the ancestor. 1280 1281 begin 1282 -- If we have a subtype declaration, get the ancestor subtype 1283 1284 if Nkind (D) = N_Subtype_Declaration then 1285 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then 1286 return Entity (Subtype_Mark (Subtype_Indication (D))); 1287 else 1288 return Entity (Subtype_Indication (D)); 1289 end if; 1290 1291 -- If derived type declaration, find who we are derived from 1292 1293 elsif Nkind (D) = N_Full_Type_Declaration 1294 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition 1295 then 1296 declare 1297 DTD : constant Entity_Id := Type_Definition (D); 1298 SI : constant Entity_Id := Subtype_Indication (DTD); 1299 begin 1300 if Is_Entity_Name (SI) then 1301 return Entity (SI); 1302 else 1303 return Entity (Subtype_Mark (SI)); 1304 end if; 1305 end; 1306 1307 -- If this is a concurrent declaration with a nonempty interface list, 1308 -- get the first progenitor. Account for case of a record type created 1309 -- for a concurrent type (which is the only case that seems to occur 1310 -- in practice). 1311 1312 elsif Nkind (D) = N_Full_Type_Declaration 1313 and then (Is_Concurrent_Type (Defining_Identifier (D)) 1314 or else Is_Concurrent_Record_Type (Defining_Identifier (D))) 1315 and then Is_Non_Empty_List (Interface_List (Type_Definition (D))) 1316 then 1317 return Entity (First (Interface_List (Type_Definition (D)))); 1318 1319 -- If derived type and private type, get the full view to find who we 1320 -- are derived from. 1321 1322 elsif Is_Derived_Type (Typ) 1323 and then Is_Private_Type (Typ) 1324 and then Present (Full_View (Typ)) 1325 then 1326 return Nearest_Ancestor (Full_View (Typ)); 1327 1328 -- Otherwise, nothing useful to return, return Empty 1329 1330 else 1331 return Empty; 1332 end if; 1333 end Nearest_Ancestor; 1334 1335 --------------------------- 1336 -- Nearest_Dynamic_Scope -- 1337 --------------------------- 1338 1339 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is 1340 begin 1341 if Is_Dynamic_Scope (Ent) then 1342 return Ent; 1343 else 1344 return Enclosing_Dynamic_Scope (Ent); 1345 end if; 1346 end Nearest_Dynamic_Scope; 1347 1348 ------------------------ 1349 -- Next_Tag_Component -- 1350 ------------------------ 1351 1352 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is 1353 Comp : Entity_Id; 1354 1355 begin 1356 pragma Assert (Is_Tag (Tag)); 1357 1358 -- Loop to look for next tag component 1359 1360 Comp := Next_Entity (Tag); 1361 while Present (Comp) loop 1362 if Is_Tag (Comp) then 1363 pragma Assert (Chars (Comp) /= Name_uTag); 1364 return Comp; 1365 end if; 1366 1367 Next_Entity (Comp); 1368 end loop; 1369 1370 -- No tag component found 1371 1372 return Empty; 1373 end Next_Tag_Component; 1374 1375 -------------------------- 1376 -- Number_Discriminants -- 1377 -------------------------- 1378 1379 function Number_Discriminants (Typ : Entity_Id) return Pos is 1380 N : Nat := 0; 1381 Discr : Entity_Id := First_Discriminant (Typ); 1382 1383 begin 1384 while Present (Discr) loop 1385 N := N + 1; 1386 Next_Discriminant (Discr); 1387 end loop; 1388 1389 return N; 1390 end Number_Discriminants; 1391 1392 ---------------------------------------------- 1393 -- Object_Type_Has_Constrained_Partial_View -- 1394 ---------------------------------------------- 1395 1396 function Object_Type_Has_Constrained_Partial_View 1397 (Typ : Entity_Id; 1398 Scop : Entity_Id) return Boolean 1399 is 1400 begin 1401 return Has_Constrained_Partial_View (Typ) 1402 or else (In_Generic_Body (Scop) 1403 and then Is_Generic_Type (Base_Type (Typ)) 1404 and then (Is_Private_Type (Base_Type (Typ)) 1405 or else Is_Derived_Type (Base_Type (Typ))) 1406 and then not Is_Tagged_Type (Typ) 1407 and then not (Is_Array_Type (Typ) 1408 and then not Is_Constrained (Typ)) 1409 and then Has_Discriminants (Typ)); 1410 end Object_Type_Has_Constrained_Partial_View; 1411 1412 ------------------ 1413 -- Package_Body -- 1414 ------------------ 1415 1416 function Package_Body (E : Entity_Id) return Node_Id is 1417 Body_Decl : Node_Id; 1418 Body_Id : constant Opt_E_Package_Body_Id := 1419 Corresponding_Body (Package_Spec (E)); 1420 1421 begin 1422 if Present (Body_Id) then 1423 Body_Decl := Parent (Body_Id); 1424 1425 if Nkind (Body_Decl) = N_Defining_Program_Unit_Name then 1426 Body_Decl := Parent (Body_Decl); 1427 end if; 1428 1429 pragma Assert (Nkind (Body_Decl) = N_Package_Body); 1430 1431 return Body_Decl; 1432 else 1433 return Empty; 1434 end if; 1435 end Package_Body; 1436 1437 ------------------ 1438 -- Package_Spec -- 1439 ------------------ 1440 1441 function Package_Spec (E : Entity_Id) return Node_Id is 1442 begin 1443 return Parent (Package_Specification (E)); 1444 end Package_Spec; 1445 1446 --------------------------- 1447 -- Package_Specification -- 1448 --------------------------- 1449 1450 function Package_Specification (E : Entity_Id) return Node_Id is 1451 N : Node_Id; 1452 1453 begin 1454 pragma Assert (Is_Package_Or_Generic_Package (E)); 1455 1456 N := Parent (E); 1457 1458 if Nkind (N) = N_Defining_Program_Unit_Name then 1459 N := Parent (N); 1460 end if; 1461 1462 pragma Assert (Nkind (N) = N_Package_Specification); 1463 1464 return N; 1465 end Package_Specification; 1466 1467 --------------------- 1468 -- Subprogram_Body -- 1469 --------------------- 1470 1471 function Subprogram_Body (E : Entity_Id) return Node_Id is 1472 Body_E : constant Entity_Id := Subprogram_Body_Entity (E); 1473 1474 begin 1475 if No (Body_E) then 1476 return Empty; 1477 else 1478 return Parent (Subprogram_Specification (Body_E)); 1479 end if; 1480 end Subprogram_Body; 1481 1482 ---------------------------- 1483 -- Subprogram_Body_Entity -- 1484 ---------------------------- 1485 1486 function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is 1487 N : constant Node_Id := Parent (Subprogram_Specification (E)); 1488 -- Declaration for E 1489 1490 begin 1491 -- If this declaration is not a subprogram body, then it must be a 1492 -- subprogram declaration or body stub, from which we can retrieve the 1493 -- entity for the corresponding subprogram body if any, or an abstract 1494 -- subprogram declaration, for which we return Empty. 1495 1496 case Nkind (N) is 1497 when N_Subprogram_Body => 1498 return E; 1499 1500 when N_Subprogram_Body_Stub 1501 | N_Subprogram_Declaration 1502 => 1503 return Corresponding_Body (N); 1504 1505 when others => 1506 return Empty; 1507 end case; 1508 end Subprogram_Body_Entity; 1509 1510 --------------------- 1511 -- Subprogram_Spec -- 1512 --------------------- 1513 1514 function Subprogram_Spec (E : Entity_Id) return Node_Id is 1515 N : constant Node_Id := Parent (Subprogram_Specification (E)); 1516 -- Declaration for E 1517 1518 begin 1519 -- This declaration is either subprogram declaration or a subprogram 1520 -- body, in which case return Empty. 1521 1522 if Nkind (N) = N_Subprogram_Declaration then 1523 return N; 1524 else 1525 return Empty; 1526 end if; 1527 end Subprogram_Spec; 1528 1529 ------------------------------ 1530 -- Subprogram_Specification -- 1531 ------------------------------ 1532 1533 function Subprogram_Specification (E : Entity_Id) return Node_Id is 1534 N : Node_Id; 1535 1536 begin 1537 N := Parent (E); 1538 1539 if Nkind (N) = N_Defining_Program_Unit_Name then 1540 N := Parent (N); 1541 end if; 1542 1543 -- If the Parent pointer of E is not a subprogram specification node 1544 -- (going through an intermediate N_Defining_Program_Unit_Name node 1545 -- for subprogram units), then E is an inherited operation. Its parent 1546 -- points to the type derivation that produces the inheritance: that's 1547 -- the node that generates the subprogram specification. Its alias 1548 -- is the parent subprogram, and that one points to a subprogram 1549 -- declaration, or to another type declaration if this is a hierarchy 1550 -- of derivations. 1551 1552 if Nkind (N) not in N_Subprogram_Specification then 1553 pragma Assert (Present (Alias (E))); 1554 N := Subprogram_Specification (Alias (E)); 1555 end if; 1556 1557 return N; 1558 end Subprogram_Specification; 1559 1560 -------------------- 1561 -- Ultimate_Alias -- 1562 -------------------- 1563 1564 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is 1565 E : Entity_Id := Prim; 1566 1567 begin 1568 while Present (Alias (E)) loop 1569 pragma Assert (Alias (E) /= E); 1570 E := Alias (E); 1571 end loop; 1572 1573 return E; 1574 end Ultimate_Alias; 1575 1576 -------------------------- 1577 -- Unit_Declaration_Node -- 1578 -------------------------- 1579 1580 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is 1581 N : Node_Id := Parent (Unit_Id); 1582 1583 begin 1584 -- Predefined operators do not have a full function declaration 1585 1586 if Ekind (Unit_Id) = E_Operator then 1587 return N; 1588 end if; 1589 1590 -- Isn't there some better way to express the following ??? 1591 1592 while Nkind (N) /= N_Abstract_Subprogram_Declaration 1593 and then Nkind (N) /= N_Entry_Body 1594 and then Nkind (N) /= N_Entry_Declaration 1595 and then Nkind (N) /= N_Formal_Package_Declaration 1596 and then Nkind (N) /= N_Function_Instantiation 1597 and then Nkind (N) /= N_Generic_Package_Declaration 1598 and then Nkind (N) /= N_Generic_Subprogram_Declaration 1599 and then Nkind (N) /= N_Package_Declaration 1600 and then Nkind (N) /= N_Package_Body 1601 and then Nkind (N) /= N_Package_Instantiation 1602 and then Nkind (N) /= N_Package_Renaming_Declaration 1603 and then Nkind (N) /= N_Procedure_Instantiation 1604 and then Nkind (N) /= N_Protected_Body 1605 and then Nkind (N) /= N_Protected_Type_Declaration 1606 and then Nkind (N) /= N_Subprogram_Declaration 1607 and then Nkind (N) /= N_Subprogram_Body 1608 and then Nkind (N) /= N_Subprogram_Body_Stub 1609 and then Nkind (N) /= N_Subprogram_Renaming_Declaration 1610 and then Nkind (N) /= N_Task_Body 1611 and then Nkind (N) /= N_Task_Type_Declaration 1612 and then Nkind (N) not in N_Formal_Subprogram_Declaration 1613 and then Nkind (N) not in N_Generic_Renaming_Declaration 1614 loop 1615 N := Parent (N); 1616 1617 -- We don't use Assert here, because that causes an infinite loop 1618 -- when assertions are turned off. Better to crash. 1619 1620 if No (N) then 1621 raise Program_Error; 1622 end if; 1623 end loop; 1624 1625 return N; 1626 end Unit_Declaration_Node; 1627 1628end Sem_Aux; 1629