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