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