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