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-2019, 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 => return N_Op_Add; 442 when Name_Op_Concat => return N_Op_Concat; 443 when Name_Op_Expon => return N_Op_Expon; 444 when Name_Op_Subtract => return N_Op_Subtract; 445 when Name_Op_Mod => return N_Op_Mod; 446 when Name_Op_Multiply => return N_Op_Multiply; 447 when Name_Op_Divide => return N_Op_Divide; 448 when Name_Op_Rem => return N_Op_Rem; 449 when Name_Op_And => return N_Op_And; 450 when Name_Op_Eq => return N_Op_Eq; 451 when Name_Op_Ge => return N_Op_Ge; 452 when Name_Op_Gt => return N_Op_Gt; 453 when Name_Op_Le => return N_Op_Le; 454 when Name_Op_Lt => return N_Op_Lt; 455 when Name_Op_Ne => return N_Op_Ne; 456 when Name_Op_Or => return N_Op_Or; 457 when Name_Op_Xor => return N_Op_Xor; 458 when others => raise Program_Error; 459 end case; 460 end Get_Binary_Nkind; 461 462 ----------------------- 463 -- Get_Called_Entity -- 464 ----------------------- 465 466 function Get_Called_Entity (Call : Node_Id) return Entity_Id is 467 Nam : constant Node_Id := Name (Call); 468 Id : Entity_Id; 469 470 begin 471 if Nkind (Nam) = N_Explicit_Dereference then 472 Id := Etype (Nam); 473 pragma Assert (Ekind (Id) = E_Subprogram_Type); 474 475 elsif Nkind (Nam) = N_Selected_Component then 476 Id := Entity (Selector_Name (Nam)); 477 478 elsif Nkind (Nam) = N_Indexed_Component then 479 Id := Entity (Selector_Name (Prefix (Nam))); 480 481 else 482 Id := Entity (Nam); 483 end if; 484 485 return Id; 486 end Get_Called_Entity; 487 488 ------------------- 489 -- Get_Low_Bound -- 490 ------------------- 491 492 function Get_Low_Bound (E : Entity_Id) return Node_Id is 493 begin 494 if Ekind (E) = E_String_Literal_Subtype then 495 return String_Literal_Low_Bound (E); 496 else 497 return Type_Low_Bound (E); 498 end if; 499 end Get_Low_Bound; 500 501 ------------------ 502 -- Get_Rep_Item -- 503 ------------------ 504 505 function Get_Rep_Item 506 (E : Entity_Id; 507 Nam : Name_Id; 508 Check_Parents : Boolean := True) return Node_Id 509 is 510 N : Node_Id; 511 512 begin 513 N := First_Rep_Item (E); 514 while Present (N) loop 515 516 -- Only one of Priority / Interrupt_Priority can be specified, so 517 -- return whichever one is present to catch illegal duplication. 518 519 if Nkind (N) = N_Pragma 520 and then 521 (Pragma_Name_Unmapped (N) = Nam 522 or else (Nam = Name_Priority 523 and then Pragma_Name (N) = 524 Name_Interrupt_Priority) 525 or else (Nam = Name_Interrupt_Priority 526 and then Pragma_Name (N) = Name_Priority)) 527 then 528 if Check_Parents then 529 return N; 530 531 -- If Check_Parents is False, return N if the pragma doesn't 532 -- appear in the Rep_Item chain of the parent. 533 534 else 535 declare 536 Par : constant Entity_Id := Nearest_Ancestor (E); 537 -- This node represents the parent type of type E (if any) 538 539 begin 540 if No (Par) then 541 return N; 542 543 elsif not Present_In_Rep_Item (Par, N) then 544 return N; 545 end if; 546 end; 547 end if; 548 549 elsif Nkind (N) = N_Attribute_Definition_Clause 550 and then 551 (Chars (N) = Nam 552 or else (Nam = Name_Priority 553 and then Chars (N) = Name_Interrupt_Priority)) 554 then 555 if Check_Parents or else Entity (N) = E then 556 return N; 557 end if; 558 559 elsif Nkind (N) = N_Aspect_Specification 560 and then 561 (Chars (Identifier (N)) = Nam 562 or else 563 (Nam = Name_Priority 564 and then Chars (Identifier (N)) = Name_Interrupt_Priority)) 565 then 566 if Check_Parents then 567 return N; 568 569 elsif Entity (N) = E then 570 return N; 571 end if; 572 end if; 573 574 Next_Rep_Item (N); 575 end loop; 576 577 return Empty; 578 end Get_Rep_Item; 579 580 function Get_Rep_Item 581 (E : Entity_Id; 582 Nam1 : Name_Id; 583 Nam2 : Name_Id; 584 Check_Parents : Boolean := True) return Node_Id 585 is 586 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); 587 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); 588 589 N : Node_Id; 590 591 begin 592 -- Check both Nam1_Item and Nam2_Item are present 593 594 if No (Nam1_Item) then 595 return Nam2_Item; 596 elsif No (Nam2_Item) then 597 return Nam1_Item; 598 end if; 599 600 -- Return the first node encountered in the list 601 602 N := First_Rep_Item (E); 603 while Present (N) loop 604 if N = Nam1_Item or else N = Nam2_Item then 605 return N; 606 end if; 607 608 Next_Rep_Item (N); 609 end loop; 610 611 return Empty; 612 end Get_Rep_Item; 613 614 -------------------- 615 -- Get_Rep_Pragma -- 616 -------------------- 617 618 function Get_Rep_Pragma 619 (E : Entity_Id; 620 Nam : Name_Id; 621 Check_Parents : Boolean := True) return Node_Id 622 is 623 N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents); 624 625 begin 626 if Present (N) and then Nkind (N) = N_Pragma then 627 return N; 628 end if; 629 630 return Empty; 631 end Get_Rep_Pragma; 632 633 function Get_Rep_Pragma 634 (E : Entity_Id; 635 Nam1 : Name_Id; 636 Nam2 : Name_Id; 637 Check_Parents : Boolean := True) return Node_Id 638 is 639 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); 640 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); 641 642 N : Node_Id; 643 644 begin 645 -- Check both Nam1_Item and Nam2_Item are present 646 647 if No (Nam1_Item) then 648 return Nam2_Item; 649 elsif No (Nam2_Item) then 650 return Nam1_Item; 651 end if; 652 653 -- Return the first node encountered in the list 654 655 N := First_Rep_Item (E); 656 while Present (N) loop 657 if N = Nam1_Item or else N = Nam2_Item then 658 return N; 659 end if; 660 661 Next_Rep_Item (N); 662 end loop; 663 664 return Empty; 665 end Get_Rep_Pragma; 666 667 --------------------- 668 -- Get_Unary_Nkind -- 669 --------------------- 670 671 function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is 672 begin 673 case Chars (Op) is 674 when Name_Op_Abs => return N_Op_Abs; 675 when Name_Op_Subtract => return N_Op_Minus; 676 when Name_Op_Not => return N_Op_Not; 677 when Name_Op_Add => return N_Op_Plus; 678 when others => raise Program_Error; 679 end case; 680 end Get_Unary_Nkind; 681 682 --------------------------------- 683 -- Has_External_Tag_Rep_Clause -- 684 --------------------------------- 685 686 function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is 687 begin 688 pragma Assert (Is_Tagged_Type (T)); 689 return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False); 690 end Has_External_Tag_Rep_Clause; 691 692 ------------------ 693 -- Has_Rep_Item -- 694 ------------------ 695 696 function Has_Rep_Item 697 (E : Entity_Id; 698 Nam : Name_Id; 699 Check_Parents : Boolean := True) return Boolean 700 is 701 begin 702 return Present (Get_Rep_Item (E, Nam, Check_Parents)); 703 end Has_Rep_Item; 704 705 function Has_Rep_Item 706 (E : Entity_Id; 707 Nam1 : Name_Id; 708 Nam2 : Name_Id; 709 Check_Parents : Boolean := True) return Boolean 710 is 711 begin 712 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); 713 end Has_Rep_Item; 714 715 function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is 716 Item : Node_Id; 717 718 begin 719 pragma Assert 720 (Nkind_In (N, N_Aspect_Specification, 721 N_Attribute_Definition_Clause, 722 N_Enumeration_Representation_Clause, 723 N_Pragma, 724 N_Record_Representation_Clause)); 725 726 Item := First_Rep_Item (E); 727 while Present (Item) loop 728 if Item = N then 729 return True; 730 end if; 731 732 Item := Next_Rep_Item (Item); 733 end loop; 734 735 return False; 736 end Has_Rep_Item; 737 738 -------------------- 739 -- Has_Rep_Pragma -- 740 -------------------- 741 742 function Has_Rep_Pragma 743 (E : Entity_Id; 744 Nam : Name_Id; 745 Check_Parents : Boolean := True) return Boolean 746 is 747 begin 748 return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); 749 end Has_Rep_Pragma; 750 751 function Has_Rep_Pragma 752 (E : Entity_Id; 753 Nam1 : Name_Id; 754 Nam2 : Name_Id; 755 Check_Parents : Boolean := True) return Boolean 756 is 757 begin 758 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); 759 end Has_Rep_Pragma; 760 761 -------------------------------- 762 -- Has_Unconstrained_Elements -- 763 -------------------------------- 764 765 function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is 766 U_T : constant Entity_Id := Underlying_Type (T); 767 begin 768 if No (U_T) then 769 return False; 770 elsif Is_Record_Type (U_T) then 771 return Has_Discriminants (U_T) and then not Is_Constrained (U_T); 772 elsif Is_Array_Type (U_T) then 773 return Has_Unconstrained_Elements (Component_Type (U_T)); 774 else 775 return False; 776 end if; 777 end Has_Unconstrained_Elements; 778 779 ---------------------- 780 -- Has_Variant_Part -- 781 ---------------------- 782 783 function Has_Variant_Part (Typ : Entity_Id) return Boolean is 784 FSTyp : Entity_Id; 785 Decl : Node_Id; 786 TDef : Node_Id; 787 CList : Node_Id; 788 789 begin 790 if not Is_Type (Typ) then 791 return False; 792 end if; 793 794 FSTyp := First_Subtype (Typ); 795 796 if not Has_Discriminants (FSTyp) then 797 return False; 798 end if; 799 800 -- Proceed with cautious checks here, return False if tree is not 801 -- as expected (may be caused by prior errors). 802 803 Decl := Declaration_Node (FSTyp); 804 805 if Nkind (Decl) /= N_Full_Type_Declaration then 806 return False; 807 end if; 808 809 TDef := Type_Definition (Decl); 810 811 if Nkind (TDef) /= N_Record_Definition then 812 return False; 813 end if; 814 815 CList := Component_List (TDef); 816 817 if Nkind (CList) /= N_Component_List then 818 return False; 819 else 820 return Present (Variant_Part (CList)); 821 end if; 822 end Has_Variant_Part; 823 824 --------------------- 825 -- In_Generic_Body -- 826 --------------------- 827 828 function In_Generic_Body (Id : Entity_Id) return Boolean is 829 S : Entity_Id; 830 831 begin 832 -- Climb scopes looking for generic body 833 834 S := Id; 835 while Present (S) and then S /= Standard_Standard loop 836 837 -- Generic package body 838 839 if Ekind (S) = E_Generic_Package 840 and then In_Package_Body (S) 841 then 842 return True; 843 844 -- Generic subprogram body 845 846 elsif Is_Subprogram (S) 847 and then Nkind (Unit_Declaration_Node (S)) = 848 N_Generic_Subprogram_Declaration 849 then 850 return True; 851 end if; 852 853 S := Scope (S); 854 end loop; 855 856 -- False if top of scope stack without finding a generic body 857 858 return False; 859 end In_Generic_Body; 860 861 ------------------------------- 862 -- Initialization_Suppressed -- 863 ------------------------------- 864 865 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is 866 begin 867 return Suppress_Initialization (Typ) 868 or else Suppress_Initialization (Base_Type (Typ)); 869 end Initialization_Suppressed; 870 871 ---------------- 872 -- Initialize -- 873 ---------------- 874 875 procedure Initialize is 876 begin 877 Obsolescent_Warnings.Init; 878 end Initialize; 879 880 ------------- 881 -- Is_Body -- 882 ------------- 883 884 function Is_Body (N : Node_Id) return Boolean is 885 begin 886 return 887 Nkind (N) in N_Body_Stub 888 or else Nkind_In (N, N_Entry_Body, 889 N_Package_Body, 890 N_Protected_Body, 891 N_Subprogram_Body, 892 N_Task_Body); 893 end Is_Body; 894 895 --------------------- 896 -- Is_By_Copy_Type -- 897 --------------------- 898 899 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is 900 begin 901 -- If Id is a private type whose full declaration has not been seen, 902 -- we assume for now that it is not a By_Copy type. Clearly this 903 -- attribute should not be used before the type is frozen, but it is 904 -- needed to build the associated record of a protected type. Another 905 -- place where some lookahead for a full view is needed ??? 906 907 return 908 Is_Elementary_Type (Ent) 909 or else (Is_Private_Type (Ent) 910 and then Present (Underlying_Type (Ent)) 911 and then Is_Elementary_Type (Underlying_Type (Ent))); 912 end Is_By_Copy_Type; 913 914 -------------------------- 915 -- Is_By_Reference_Type -- 916 -------------------------- 917 918 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is 919 Btype : constant Entity_Id := Base_Type (Ent); 920 921 begin 922 if Error_Posted (Ent) or else Error_Posted (Btype) then 923 return False; 924 925 elsif Is_Private_Type (Btype) then 926 declare 927 Utyp : constant Entity_Id := Underlying_Type (Btype); 928 begin 929 if No (Utyp) then 930 return False; 931 else 932 return Is_By_Reference_Type (Utyp); 933 end if; 934 end; 935 936 elsif Is_Incomplete_Type (Btype) then 937 declare 938 Ftyp : constant Entity_Id := Full_View (Btype); 939 begin 940 -- Return true for a tagged incomplete type built as a shadow 941 -- entity in Build_Limited_Views. It can appear in the profile 942 -- of a thunk and the back end needs to know how it is passed. 943 944 if No (Ftyp) then 945 return Is_Tagged_Type (Btype); 946 else 947 return Is_By_Reference_Type (Ftyp); 948 end if; 949 end; 950 951 elsif Is_Concurrent_Type (Btype) then 952 return True; 953 954 elsif Is_Record_Type (Btype) then 955 if Is_Limited_Record (Btype) 956 or else Is_Tagged_Type (Btype) 957 or else Is_Volatile (Btype) 958 then 959 return True; 960 961 else 962 declare 963 C : Entity_Id; 964 965 begin 966 C := First_Component (Btype); 967 while Present (C) loop 968 969 -- For each component, test if its type is a by reference 970 -- type and if its type is volatile. Also test the component 971 -- itself for being volatile. This happens for example when 972 -- a Volatile aspect is added to a component. 973 974 if Is_By_Reference_Type (Etype (C)) 975 or else Is_Volatile (Etype (C)) 976 or else Is_Volatile (C) 977 then 978 return True; 979 end if; 980 981 C := Next_Component (C); 982 end loop; 983 end; 984 985 return False; 986 end if; 987 988 elsif Is_Array_Type (Btype) then 989 return 990 Is_Volatile (Btype) 991 or else Is_By_Reference_Type (Component_Type (Btype)) 992 or else Is_Volatile (Component_Type (Btype)) 993 or else Has_Volatile_Components (Btype); 994 995 else 996 return False; 997 end if; 998 end Is_By_Reference_Type; 999 1000 ------------------------- 1001 -- Is_Definite_Subtype -- 1002 ------------------------- 1003 1004 function Is_Definite_Subtype (T : Entity_Id) return Boolean is 1005 pragma Assert (Is_Type (T)); 1006 K : constant Entity_Kind := Ekind (T); 1007 1008 begin 1009 if Is_Constrained (T) then 1010 return True; 1011 1012 elsif K in Array_Kind 1013 or else K in Class_Wide_Kind 1014 or else Has_Unknown_Discriminants (T) 1015 then 1016 return False; 1017 1018 -- Known discriminants: definite if there are default values. Note that 1019 -- if any discriminant has a default, they all do. 1020 1021 elsif Has_Discriminants (T) then 1022 return Present (Discriminant_Default_Value (First_Discriminant (T))); 1023 1024 else 1025 return True; 1026 end if; 1027 end Is_Definite_Subtype; 1028 1029 --------------------- 1030 -- Is_Derived_Type -- 1031 --------------------- 1032 1033 function Is_Derived_Type (Ent : E) return B is 1034 Par : Node_Id; 1035 1036 begin 1037 if Is_Type (Ent) 1038 and then Base_Type (Ent) /= Root_Type (Ent) 1039 and then not Is_Class_Wide_Type (Ent) 1040 1041 -- An access_to_subprogram whose result type is a limited view can 1042 -- appear in a return statement, without the full view of the result 1043 -- type being available. Do not interpret this as a derived type. 1044 1045 and then Ekind (Ent) /= E_Subprogram_Type 1046 then 1047 if not Is_Numeric_Type (Root_Type (Ent)) then 1048 return True; 1049 1050 else 1051 Par := Parent (First_Subtype (Ent)); 1052 1053 return Present (Par) 1054 and then Nkind (Par) = N_Full_Type_Declaration 1055 and then Nkind (Type_Definition (Par)) = 1056 N_Derived_Type_Definition; 1057 end if; 1058 1059 else 1060 return False; 1061 end if; 1062 end Is_Derived_Type; 1063 1064 ----------------------- 1065 -- Is_Generic_Formal -- 1066 ----------------------- 1067 1068 function Is_Generic_Formal (E : Entity_Id) return Boolean is 1069 Kind : Node_Kind; 1070 1071 begin 1072 if No (E) then 1073 return False; 1074 else 1075 -- Formal derived types are rewritten as private extensions, so 1076 -- examine original node. 1077 1078 Kind := Nkind (Original_Node (Parent (E))); 1079 1080 return 1081 Nkind_In (Kind, N_Formal_Object_Declaration, 1082 N_Formal_Type_Declaration) 1083 or else Is_Formal_Subprogram (E) 1084 or else 1085 (Ekind (E) = E_Package 1086 and then Nkind (Original_Node (Unit_Declaration_Node (E))) = 1087 N_Formal_Package_Declaration); 1088 end if; 1089 end Is_Generic_Formal; 1090 1091 ------------------------------- 1092 -- Is_Immutably_Limited_Type -- 1093 ------------------------------- 1094 1095 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is 1096 Btype : constant Entity_Id := Available_View (Base_Type (Ent)); 1097 1098 begin 1099 if Is_Limited_Record (Btype) then 1100 return True; 1101 1102 elsif Ekind (Btype) = E_Limited_Private_Type 1103 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration 1104 then 1105 return not In_Package_Body (Scope ((Btype))); 1106 1107 elsif Is_Private_Type (Btype) then 1108 1109 -- AI05-0063: A type derived from a limited private formal type is 1110 -- not immutably limited in a generic body. 1111 1112 if Is_Derived_Type (Btype) 1113 and then Is_Generic_Type (Etype (Btype)) 1114 then 1115 if not Is_Limited_Type (Etype (Btype)) then 1116 return False; 1117 1118 -- A descendant of a limited formal type is not immutably limited 1119 -- in the generic body, or in the body of a generic child. 1120 1121 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then 1122 return not In_Package_Body (Scope (Btype)); 1123 1124 else 1125 return False; 1126 end if; 1127 1128 else 1129 declare 1130 Utyp : constant Entity_Id := Underlying_Type (Btype); 1131 begin 1132 if No (Utyp) then 1133 return False; 1134 else 1135 return Is_Immutably_Limited_Type (Utyp); 1136 end if; 1137 end; 1138 end if; 1139 1140 elsif Is_Concurrent_Type (Btype) then 1141 return True; 1142 1143 else 1144 return False; 1145 end if; 1146 end Is_Immutably_Limited_Type; 1147 1148 --------------------- 1149 -- Is_Limited_Type -- 1150 --------------------- 1151 1152 function Is_Limited_Type (Ent : Entity_Id) return Boolean is 1153 Btype : constant E := Base_Type (Ent); 1154 Rtype : constant E := Root_Type (Btype); 1155 1156 begin 1157 if not Is_Type (Ent) then 1158 return False; 1159 1160 elsif Ekind (Btype) = E_Limited_Private_Type 1161 or else Is_Limited_Composite (Btype) 1162 then 1163 return True; 1164 1165 elsif Is_Concurrent_Type (Btype) then 1166 return True; 1167 1168 -- The Is_Limited_Record flag normally indicates that the type is 1169 -- limited. The exception is that a type does not inherit limitedness 1170 -- from its interface ancestor. So the type may be derived from a 1171 -- limited interface, but is not limited. 1172 1173 elsif Is_Limited_Record (Ent) 1174 and then not Is_Interface (Ent) 1175 then 1176 return True; 1177 1178 -- Otherwise we will look around to see if there is some other reason 1179 -- for it to be limited, except that if an error was posted on the 1180 -- entity, then just assume it is non-limited, because it can cause 1181 -- trouble to recurse into a murky entity resulting from other errors. 1182 1183 elsif Error_Posted (Ent) then 1184 return False; 1185 1186 elsif Is_Record_Type (Btype) then 1187 1188 if Is_Limited_Interface (Ent) then 1189 return True; 1190 1191 -- AI-419: limitedness is not inherited from a limited interface 1192 1193 elsif Is_Limited_Record (Rtype) then 1194 return not Is_Interface (Rtype) 1195 or else Is_Protected_Interface (Rtype) 1196 or else Is_Synchronized_Interface (Rtype) 1197 or else Is_Task_Interface (Rtype); 1198 1199 elsif Is_Class_Wide_Type (Btype) then 1200 return Is_Limited_Type (Rtype); 1201 1202 else 1203 declare 1204 C : E; 1205 1206 begin 1207 C := First_Component (Btype); 1208 while Present (C) loop 1209 if Is_Limited_Type (Etype (C)) then 1210 return True; 1211 end if; 1212 1213 C := Next_Component (C); 1214 end loop; 1215 end; 1216 1217 return False; 1218 end if; 1219 1220 elsif Is_Array_Type (Btype) then 1221 return Is_Limited_Type (Component_Type (Btype)); 1222 1223 else 1224 return False; 1225 end if; 1226 end Is_Limited_Type; 1227 1228 --------------------- 1229 -- Is_Limited_View -- 1230 --------------------- 1231 1232 function Is_Limited_View (Ent : Entity_Id) return Boolean is 1233 Btype : constant Entity_Id := Available_View (Base_Type (Ent)); 1234 1235 begin 1236 if Is_Limited_Record (Btype) then 1237 return True; 1238 1239 elsif Ekind (Btype) = E_Limited_Private_Type 1240 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration 1241 then 1242 return not In_Package_Body (Scope ((Btype))); 1243 1244 elsif Is_Private_Type (Btype) then 1245 1246 -- AI05-0063: A type derived from a limited private formal type is 1247 -- not immutably limited in a generic body. 1248 1249 if Is_Derived_Type (Btype) 1250 and then Is_Generic_Type (Etype (Btype)) 1251 then 1252 if not Is_Limited_Type (Etype (Btype)) then 1253 return False; 1254 1255 -- A descendant of a limited formal type is not immutably limited 1256 -- in the generic body, or in the body of a generic child. 1257 1258 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then 1259 return not In_Package_Body (Scope (Btype)); 1260 1261 else 1262 return False; 1263 end if; 1264 1265 else 1266 declare 1267 Utyp : constant Entity_Id := Underlying_Type (Btype); 1268 begin 1269 if No (Utyp) then 1270 return False; 1271 else 1272 return Is_Limited_View (Utyp); 1273 end if; 1274 end; 1275 end if; 1276 1277 elsif Is_Concurrent_Type (Btype) then 1278 return True; 1279 1280 elsif Is_Record_Type (Btype) then 1281 1282 -- Note that we return True for all limited interfaces, even though 1283 -- (unsynchronized) limited interfaces can have descendants that are 1284 -- nonlimited, because this is a predicate on the type itself, and 1285 -- things like functions with limited interface results need to be 1286 -- handled as build in place even though they might return objects 1287 -- of a type that is not inherently limited. 1288 1289 if Is_Class_Wide_Type (Btype) then 1290 return Is_Limited_View (Root_Type (Btype)); 1291 1292 else 1293 declare 1294 C : Entity_Id; 1295 1296 begin 1297 C := First_Component (Btype); 1298 while Present (C) loop 1299 1300 -- Don't consider components with interface types (which can 1301 -- only occur in the case of a _parent component anyway). 1302 -- They don't have any components, plus it would cause this 1303 -- function to return true for nonlimited types derived from 1304 -- limited interfaces. 1305 1306 if not Is_Interface (Etype (C)) 1307 and then Is_Limited_View (Etype (C)) 1308 then 1309 return True; 1310 end if; 1311 1312 C := Next_Component (C); 1313 end loop; 1314 end; 1315 1316 return False; 1317 end if; 1318 1319 elsif Is_Array_Type (Btype) then 1320 return Is_Limited_View (Component_Type (Btype)); 1321 1322 else 1323 return False; 1324 end if; 1325 end Is_Limited_View; 1326 1327 ---------------------- 1328 -- Nearest_Ancestor -- 1329 ---------------------- 1330 1331 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is 1332 D : constant Node_Id := Original_Node (Declaration_Node (Typ)); 1333 -- We use the original node of the declaration, because derived 1334 -- types from record subtypes are rewritten as record declarations, 1335 -- and it is the original declaration that carries the ancestor. 1336 1337 begin 1338 -- If we have a subtype declaration, get the ancestor subtype 1339 1340 if Nkind (D) = N_Subtype_Declaration then 1341 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then 1342 return Entity (Subtype_Mark (Subtype_Indication (D))); 1343 else 1344 return Entity (Subtype_Indication (D)); 1345 end if; 1346 1347 -- If derived type declaration, find who we are derived from 1348 1349 elsif Nkind (D) = N_Full_Type_Declaration 1350 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition 1351 then 1352 declare 1353 DTD : constant Entity_Id := Type_Definition (D); 1354 SI : constant Entity_Id := Subtype_Indication (DTD); 1355 begin 1356 if Is_Entity_Name (SI) then 1357 return Entity (SI); 1358 else 1359 return Entity (Subtype_Mark (SI)); 1360 end if; 1361 end; 1362 1363 -- If derived type and private type, get the full view to find who we 1364 -- are derived from. 1365 1366 elsif Is_Derived_Type (Typ) 1367 and then Is_Private_Type (Typ) 1368 and then Present (Full_View (Typ)) 1369 then 1370 return Nearest_Ancestor (Full_View (Typ)); 1371 1372 -- Otherwise, nothing useful to return, return Empty 1373 1374 else 1375 return Empty; 1376 end if; 1377 end Nearest_Ancestor; 1378 1379 --------------------------- 1380 -- Nearest_Dynamic_Scope -- 1381 --------------------------- 1382 1383 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is 1384 begin 1385 if Is_Dynamic_Scope (Ent) then 1386 return Ent; 1387 else 1388 return Enclosing_Dynamic_Scope (Ent); 1389 end if; 1390 end Nearest_Dynamic_Scope; 1391 1392 ------------------------ 1393 -- Next_Tag_Component -- 1394 ------------------------ 1395 1396 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is 1397 Comp : Entity_Id; 1398 1399 begin 1400 pragma Assert (Is_Tag (Tag)); 1401 1402 -- Loop to look for next tag component 1403 1404 Comp := Next_Entity (Tag); 1405 while Present (Comp) loop 1406 if Is_Tag (Comp) then 1407 pragma Assert (Chars (Comp) /= Name_uTag); 1408 return Comp; 1409 end if; 1410 1411 Comp := Next_Entity (Comp); 1412 end loop; 1413 1414 -- No tag component found 1415 1416 return Empty; 1417 end Next_Tag_Component; 1418 1419 ----------------------- 1420 -- Number_Components -- 1421 ----------------------- 1422 1423 function Number_Components (Typ : Entity_Id) return Nat is 1424 N : Nat := 0; 1425 Comp : Entity_Id; 1426 1427 begin 1428 -- We do not call Einfo.First_Component_Or_Discriminant, as this 1429 -- function does not skip completely hidden discriminants, which we 1430 -- want to skip here. 1431 1432 if Has_Discriminants (Typ) then 1433 Comp := First_Discriminant (Typ); 1434 else 1435 Comp := First_Component (Typ); 1436 end if; 1437 1438 while Present (Comp) loop 1439 N := N + 1; 1440 Comp := Next_Component_Or_Discriminant (Comp); 1441 end loop; 1442 1443 return N; 1444 end Number_Components; 1445 1446 -------------------------- 1447 -- Number_Discriminants -- 1448 -------------------------- 1449 1450 function Number_Discriminants (Typ : Entity_Id) return Pos is 1451 N : Nat := 0; 1452 Discr : Entity_Id := First_Discriminant (Typ); 1453 1454 begin 1455 while Present (Discr) loop 1456 N := N + 1; 1457 Discr := Next_Discriminant (Discr); 1458 end loop; 1459 1460 return N; 1461 end Number_Discriminants; 1462 1463 ---------------------------------------------- 1464 -- Object_Type_Has_Constrained_Partial_View -- 1465 ---------------------------------------------- 1466 1467 function Object_Type_Has_Constrained_Partial_View 1468 (Typ : Entity_Id; 1469 Scop : Entity_Id) return Boolean 1470 is 1471 begin 1472 return Has_Constrained_Partial_View (Typ) 1473 or else (In_Generic_Body (Scop) 1474 and then Is_Generic_Type (Base_Type (Typ)) 1475 and then (Is_Private_Type (Base_Type (Typ)) 1476 or else Is_Derived_Type (Base_Type (Typ))) 1477 and then not Is_Tagged_Type (Typ) 1478 and then not (Is_Array_Type (Typ) 1479 and then not Is_Constrained (Typ)) 1480 and then Has_Discriminants (Typ)); 1481 end Object_Type_Has_Constrained_Partial_View; 1482 1483 ------------------ 1484 -- Package_Body -- 1485 ------------------ 1486 1487 function Package_Body (E : Entity_Id) return Node_Id is 1488 N : Node_Id; 1489 1490 begin 1491 if Ekind (E) = E_Package_Body then 1492 N := Parent (E); 1493 1494 if Nkind (N) = N_Defining_Program_Unit_Name then 1495 N := Parent (N); 1496 end if; 1497 1498 else 1499 N := Package_Spec (E); 1500 1501 if Present (Corresponding_Body (N)) then 1502 N := Parent (Corresponding_Body (N)); 1503 1504 if Nkind (N) = N_Defining_Program_Unit_Name then 1505 N := Parent (N); 1506 end if; 1507 else 1508 N := Empty; 1509 end if; 1510 end if; 1511 1512 return N; 1513 end Package_Body; 1514 1515 ------------------ 1516 -- Package_Spec -- 1517 ------------------ 1518 1519 function Package_Spec (E : Entity_Id) return Node_Id is 1520 begin 1521 return Parent (Package_Specification (E)); 1522 end Package_Spec; 1523 1524 --------------------------- 1525 -- Package_Specification -- 1526 --------------------------- 1527 1528 function Package_Specification (E : Entity_Id) return Node_Id is 1529 N : Node_Id; 1530 1531 begin 1532 N := Parent (E); 1533 1534 if Nkind (N) = N_Defining_Program_Unit_Name then 1535 N := Parent (N); 1536 end if; 1537 1538 return N; 1539 end Package_Specification; 1540 1541 --------------------- 1542 -- Subprogram_Body -- 1543 --------------------- 1544 1545 function Subprogram_Body (E : Entity_Id) return Node_Id is 1546 Body_E : constant Entity_Id := Subprogram_Body_Entity (E); 1547 1548 begin 1549 if No (Body_E) then 1550 return Empty; 1551 else 1552 return Parent (Subprogram_Specification (Body_E)); 1553 end if; 1554 end Subprogram_Body; 1555 1556 ---------------------------- 1557 -- Subprogram_Body_Entity -- 1558 ---------------------------- 1559 1560 function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is 1561 N : constant Node_Id := Parent (Subprogram_Specification (E)); 1562 -- Declaration for E 1563 1564 begin 1565 -- If this declaration is not a subprogram body, then it must be a 1566 -- subprogram declaration or body stub, from which we can retrieve the 1567 -- entity for the corresponding subprogram body if any, or an abstract 1568 -- subprogram declaration, for which we return Empty. 1569 1570 case Nkind (N) is 1571 when N_Subprogram_Body => 1572 return E; 1573 1574 when N_Subprogram_Body_Stub 1575 | N_Subprogram_Declaration 1576 => 1577 return Corresponding_Body (N); 1578 1579 when others => 1580 return Empty; 1581 end case; 1582 end Subprogram_Body_Entity; 1583 1584 --------------------- 1585 -- Subprogram_Spec -- 1586 --------------------- 1587 1588 function Subprogram_Spec (E : Entity_Id) return Node_Id is 1589 N : constant Node_Id := Parent (Subprogram_Specification (E)); 1590 -- Declaration for E 1591 1592 begin 1593 -- This declaration is either subprogram declaration or a subprogram 1594 -- body, in which case return Empty. 1595 1596 if Nkind (N) = N_Subprogram_Declaration then 1597 return N; 1598 else 1599 return Empty; 1600 end if; 1601 end Subprogram_Spec; 1602 1603 ------------------------------ 1604 -- Subprogram_Specification -- 1605 ------------------------------ 1606 1607 function Subprogram_Specification (E : Entity_Id) return Node_Id is 1608 N : Node_Id; 1609 1610 begin 1611 N := Parent (E); 1612 1613 if Nkind (N) = N_Defining_Program_Unit_Name then 1614 N := Parent (N); 1615 end if; 1616 1617 -- If the Parent pointer of E is not a subprogram specification node 1618 -- (going through an intermediate N_Defining_Program_Unit_Name node 1619 -- for subprogram units), then E is an inherited operation. Its parent 1620 -- points to the type derivation that produces the inheritance: that's 1621 -- the node that generates the subprogram specification. Its alias 1622 -- is the parent subprogram, and that one points to a subprogram 1623 -- declaration, or to another type declaration if this is a hierarchy 1624 -- of derivations. 1625 1626 if Nkind (N) not in N_Subprogram_Specification then 1627 pragma Assert (Present (Alias (E))); 1628 N := Subprogram_Specification (Alias (E)); 1629 end if; 1630 1631 return N; 1632 end Subprogram_Specification; 1633 1634 --------------- 1635 -- Tree_Read -- 1636 --------------- 1637 1638 procedure Tree_Read is 1639 begin 1640 Obsolescent_Warnings.Tree_Read; 1641 end Tree_Read; 1642 1643 ---------------- 1644 -- Tree_Write -- 1645 ---------------- 1646 1647 procedure Tree_Write is 1648 begin 1649 Obsolescent_Warnings.Tree_Write; 1650 end Tree_Write; 1651 1652 -------------------- 1653 -- Ultimate_Alias -- 1654 -------------------- 1655 1656 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is 1657 E : Entity_Id := Prim; 1658 1659 begin 1660 while Present (Alias (E)) loop 1661 pragma Assert (Alias (E) /= E); 1662 E := Alias (E); 1663 end loop; 1664 1665 return E; 1666 end Ultimate_Alias; 1667 1668 -------------------------- 1669 -- Unit_Declaration_Node -- 1670 -------------------------- 1671 1672 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is 1673 N : Node_Id := Parent (Unit_Id); 1674 1675 begin 1676 -- Predefined operators do not have a full function declaration 1677 1678 if Ekind (Unit_Id) = E_Operator then 1679 return N; 1680 end if; 1681 1682 -- Isn't there some better way to express the following ??? 1683 1684 while Nkind (N) /= N_Abstract_Subprogram_Declaration 1685 and then Nkind (N) /= N_Entry_Body 1686 and then Nkind (N) /= N_Entry_Declaration 1687 and then Nkind (N) /= N_Formal_Package_Declaration 1688 and then Nkind (N) /= N_Function_Instantiation 1689 and then Nkind (N) /= N_Generic_Package_Declaration 1690 and then Nkind (N) /= N_Generic_Subprogram_Declaration 1691 and then Nkind (N) /= N_Package_Declaration 1692 and then Nkind (N) /= N_Package_Body 1693 and then Nkind (N) /= N_Package_Instantiation 1694 and then Nkind (N) /= N_Package_Renaming_Declaration 1695 and then Nkind (N) /= N_Procedure_Instantiation 1696 and then Nkind (N) /= N_Protected_Body 1697 and then Nkind (N) /= N_Protected_Type_Declaration 1698 and then Nkind (N) /= N_Subprogram_Declaration 1699 and then Nkind (N) /= N_Subprogram_Body 1700 and then Nkind (N) /= N_Subprogram_Body_Stub 1701 and then Nkind (N) /= N_Subprogram_Renaming_Declaration 1702 and then Nkind (N) /= N_Task_Body 1703 and then Nkind (N) /= N_Task_Type_Declaration 1704 and then Nkind (N) not in N_Formal_Subprogram_Declaration 1705 and then Nkind (N) not in N_Generic_Renaming_Declaration 1706 loop 1707 N := Parent (N); 1708 1709 -- We don't use Assert here, because that causes an infinite loop 1710 -- when assertions are turned off. Better to crash. 1711 1712 if No (N) then 1713 raise Program_Error; 1714 end if; 1715 end loop; 1716 1717 return N; 1718 end Unit_Declaration_Node; 1719 1720end Sem_Aux; 1721