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