gcc/ada/sem_aux.adb

   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-2010, 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
  33 with Atree;  use Atree;
  34 with Einfo;  use Einfo;
  35 with Namet;  use Namet;
  36 with Sinfo;  use Sinfo;
  37 with Snames; use Snames;
  38 with Stand;  use Stand;
  39
  40 package 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 Typ = 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 (Typ : Entity_Id) return Entity_Id is
  81    begin
  82       if Is_Incomplete_Type (Typ)
  83         and then Present (Non_Limited_View (Typ))
  84       then
  85          --  The non-limited view may itself be an incomplete type, in which
  86          --  case get its full view.
  87
  88          return Get_Full_View (Non_Limited_View (Typ));
  89
  90       elsif Is_Class_Wide_Type (Typ)
  91         and then Is_Incomplete_Type (Etype (Typ))
  92         and then Present (Non_Limited_View (Etype (Typ)))
  93       then
  94          return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
  95
  96       else
  97          return Typ;
  98       end if;
  99    end Available_View;
 100
 101    --------------------
 102    -- Constant_Value --
 103    --------------------
 104
 105    function Constant_Value (Ent : Entity_Id) return Node_Id is
 106       D      : constant Node_Id := Declaration_Node (Ent);
 107       Full_D : Node_Id;
 108
 109    begin
 110       --  If we have no declaration node, then return no constant value. Not
 111       --  clear how this can happen, but it does sometimes and this is the
 112       --  safest approach.
 113
 114       if No (D) then
 115          return Empty;
 116
 117       --  Normal case where a declaration node is present
 118
 119       elsif Nkind (D) = N_Object_Renaming_Declaration then
 120          return Renamed_Object (Ent);
 121
 122       --  If this is a component declaration whose entity is a constant, it is
 123       --  a prival within a protected function (and so has no constant value).
 124
 125       elsif Nkind (D) = N_Component_Declaration then
 126          return Empty;
 127
 128       --  If there is an expression, return it
 129
 130       elsif Present (Expression (D)) then
 131          return (Expression (D));
 132
 133       --  For a constant, see if we have a full view
 134
 135       elsif Ekind (Ent) = E_Constant
 136         and then Present (Full_View (Ent))
 137       then
 138          Full_D := Parent (Full_View (Ent));
 139
 140          --  The full view may have been rewritten as an object renaming
 141
 142          if Nkind (Full_D) = N_Object_Renaming_Declaration then
 143             return Name (Full_D);
 144          else
 145             return Expression (Full_D);
 146          end if;
 147
 148       --  Otherwise we have no expression to return
 149
 150       else
 151          return Empty;
 152       end if;
 153    end Constant_Value;
 154
 155    -----------------------------
 156    -- Enclosing_Dynamic_Scope --
 157    -----------------------------
 158
 159    function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
 160       S : Entity_Id;
 161
 162    begin
 163       --  The following test is an error defense against some syntax errors
 164       --  that can leave scopes very messed up.
 165
 166       if Ent = Standard_Standard then
 167          return Ent;
 168       end if;
 169
 170       --  Normal case, search enclosing scopes
 171
 172       --  Note: the test for Present (S) should not be required, it defends
 173       --  against an ill-formed tree.
 174
 175       S := Scope (Ent);
 176       loop
 177          --  If we somehow got an empty value for Scope, the tree must be
 178          --  malformed. Rather than blow up we return Standard in this case.
 179
 180          if No (S) then
 181             return Standard_Standard;
 182
 183          --  Quit if we get to standard or a dynamic scope
 184
 185          elsif S = Standard_Standard
 186            or else Is_Dynamic_Scope (S)
 187          then
 188             return S;
 189
 190          --  Otherwise keep climbing
 191
 192          else
 193             S := Scope (S);
 194          end if;
 195       end loop;
 196    end Enclosing_Dynamic_Scope;
 197
 198    ------------------------
 199    -- First_Discriminant --
 200    ------------------------
 201
 202    function First_Discriminant (Typ : Entity_Id) return Entity_Id is
 203       Ent : Entity_Id;
 204
 205    begin
 206       pragma Assert
 207         (Has_Discriminants (Typ)
 208           or else Has_Unknown_Discriminants (Typ));
 209
 210       Ent := First_Entity (Typ);
 211
 212       --  The discriminants are not necessarily contiguous, because access
 213       --  discriminants will generate itypes. They are not the first entities
 214       --  either, because tag and controller record must be ahead of them.
 215
 216       if Chars (Ent) = Name_uTag then
 217          Ent := Next_Entity (Ent);
 218       end if;
 219
 220       if Chars (Ent) = Name_uController then
 221          Ent := Next_Entity (Ent);
 222       end if;
 223
 224       --  Skip all hidden stored discriminants if any
 225
 226       while Present (Ent) loop
 227          exit when Ekind (Ent) = E_Discriminant
 228            and then not Is_Completely_Hidden (Ent);
 229
 230          Ent := Next_Entity (Ent);
 231       end loop;
 232
 233       pragma Assert (Ekind (Ent) = E_Discriminant);
 234
 235       return Ent;
 236    end First_Discriminant;
 237
 238    -------------------------------
 239    -- First_Stored_Discriminant --
 240    -------------------------------
 241
 242    function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
 243       Ent : Entity_Id;
 244
 245       function Has_Completely_Hidden_Discriminant
 246         (Typ : Entity_Id) return Boolean;
 247       --  Scans the Discriminants to see whether any are Completely_Hidden
 248       --  (the mechanism for describing non-specified stored discriminants)
 249
 250       ----------------------------------------
 251       -- Has_Completely_Hidden_Discriminant --
 252       ----------------------------------------
 253
 254       function Has_Completely_Hidden_Discriminant
 255         (Typ : Entity_Id) return Boolean
 256       is
 257          Ent : Entity_Id;
 258
 259       begin
 260          pragma Assert (Ekind (Typ) = E_Discriminant);
 261
 262          Ent := Typ;
 263          while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
 264             if Is_Completely_Hidden (Ent) then
 265                return True;
 266             end if;
 267
 268             Ent := Next_Entity (Ent);
 269          end loop;
 270
 271          return False;
 272       end Has_Completely_Hidden_Discriminant;
 273
 274    --  Start of processing for First_Stored_Discriminant
 275
 276    begin
 277       pragma Assert
 278         (Has_Discriminants (Typ)
 279           or else Has_Unknown_Discriminants (Typ));
 280
 281       Ent := First_Entity (Typ);
 282
 283       if Chars (Ent) = Name_uTag then
 284          Ent := Next_Entity (Ent);
 285       end if;
 286
 287       if Chars (Ent) = Name_uController then
 288          Ent := Next_Entity (Ent);
 289       end if;
 290
 291       if Has_Completely_Hidden_Discriminant (Ent) then
 292
 293          while Present (Ent) loop
 294             exit when Is_Completely_Hidden (Ent);
 295             Ent := Next_Entity (Ent);
 296          end loop;
 297
 298       end if;
 299
 300       pragma Assert (Ekind (Ent) = E_Discriminant);
 301
 302       return Ent;
 303    end First_Stored_Discriminant;
 304
 305    -------------------
 306    -- First_Subtype --
 307    -------------------
 308
 309    function First_Subtype (Typ : Entity_Id) return Entity_Id is
 310       B   : constant Entity_Id := Base_Type (Typ);
 311       F   : constant Node_Id   := Freeze_Node (B);
 312       Ent : Entity_Id;
 313
 314    begin
 315       --  If the base type has no freeze node, it is a type in Standard, and
 316       --  always acts as its own first subtype, except where it is one of the
 317       --  predefined integer types. If the type is formal, it is also a first
 318       --  subtype, and its base type has no freeze node. On the other hand, a
 319       --  subtype of a generic formal is not its own first subtype. Its base
 320       --  type, if anonymous, is attached to the formal type decl. from which
 321       --  the first subtype is obtained.
 322
 323       if No (F) then
 324          if B = Base_Type (Standard_Integer) then
 325             return Standard_Integer;
 326
 327          elsif B = Base_Type (Standard_Long_Integer) then
 328             return Standard_Long_Integer;
 329
 330          elsif B = Base_Type (Standard_Short_Short_Integer) then
 331             return Standard_Short_Short_Integer;
 332
 333          elsif B = Base_Type (Standard_Short_Integer) then
 334             return Standard_Short_Integer;
 335
 336          elsif B = Base_Type (Standard_Long_Long_Integer) then
 337             return Standard_Long_Long_Integer;
 338
 339          elsif Is_Generic_Type (Typ) then
 340             if Present (Parent (B)) then
 341                return Defining_Identifier (Parent (B));
 342             else
 343                return Defining_Identifier (Associated_Node_For_Itype (B));
 344             end if;
 345
 346          else
 347             return B;
 348          end if;
 349
 350       --  Otherwise we check the freeze node, if it has a First_Subtype_Link
 351       --  then we use that link, otherwise (happens with some Itypes), we use
 352       --  the base type itself.
 353
 354       else
 355          Ent := First_Subtype_Link (F);
 356
 357          if Present (Ent) then
 358             return Ent;
 359          else
 360             return B;
 361          end if;
 362       end if;
 363    end First_Subtype;
 364
 365    -------------------------
 366    -- First_Tag_Component --
 367    -------------------------
 368
 369    function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
 370       Comp : Entity_Id;
 371       Ctyp : Entity_Id;
 372
 373    begin
 374       Ctyp := Typ;
 375       pragma Assert (Is_Tagged_Type (Ctyp));
 376
 377       if Is_Class_Wide_Type (Ctyp) then
 378          Ctyp := Root_Type (Ctyp);
 379       end if;
 380
 381       if Is_Private_Type (Ctyp) then
 382          Ctyp := Underlying_Type (Ctyp);
 383
 384          --  If the underlying type is missing then the source program has
 385          --  errors and there is nothing else to do (the full-type declaration
 386          --  associated with the private type declaration is missing).
 387
 388          if No (Ctyp) then
 389             return Empty;
 390          end if;
 391       end if;
 392
 393       Comp := First_Entity (Ctyp);
 394       while Present (Comp) loop
 395          if Is_Tag (Comp) then
 396             return Comp;
 397          end if;
 398
 399          Comp := Next_Entity (Comp);
 400       end loop;
 401
 402       --  No tag component found
 403
 404       return Empty;
 405    end First_Tag_Component;
 406
 407    ----------------
 408    -- Initialize --
 409    ----------------
 410
 411    procedure Initialize is
 412    begin
 413       Obsolescent_Warnings.Init;
 414    end Initialize;
 415
 416    ---------------------
 417    -- Is_By_Copy_Type --
 418    ---------------------
 419
 420    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
 421    begin
 422       --  If Id is a private type whose full declaration has not been seen,
 423       --  we assume for now that it is not a By_Copy type. Clearly this
 424       --  attribute should not be used before the type is frozen, but it is
 425       --  needed to build the associated record of a protected type. Another
 426       --  place where some lookahead for a full view is needed ???
 427
 428       return
 429         Is_Elementary_Type (Ent)
 430           or else (Is_Private_Type (Ent)
 431                      and then Present (Underlying_Type (Ent))
 432                      and then Is_Elementary_Type (Underlying_Type (Ent)));
 433    end Is_By_Copy_Type;
 434
 435    --------------------------
 436    -- Is_By_Reference_Type --
 437    --------------------------
 438
 439    function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
 440       Btype : constant Entity_Id := Base_Type (Ent);
 441
 442    begin
 443       if Error_Posted (Ent)
 444         or else Error_Posted (Btype)
 445       then
 446          return False;
 447
 448       elsif Is_Private_Type (Btype) then
 449          declare
 450             Utyp : constant Entity_Id := Underlying_Type (Btype);
 451          begin
 452             if No (Utyp) then
 453                return False;
 454             else
 455                return Is_By_Reference_Type (Utyp);
 456             end if;
 457          end;
 458
 459       elsif Is_Incomplete_Type (Btype) then
 460          declare
 461             Ftyp : constant Entity_Id := Full_View (Btype);
 462          begin
 463             if No (Ftyp) then
 464                return False;
 465             else
 466                return Is_By_Reference_Type (Ftyp);
 467             end if;
 468          end;
 469
 470       elsif Is_Concurrent_Type (Btype) then
 471          return True;
 472
 473       elsif Is_Record_Type (Btype) then
 474          if Is_Limited_Record (Btype)
 475            or else Is_Tagged_Type (Btype)
 476            or else Is_Volatile (Btype)
 477          then
 478             return True;
 479
 480          else
 481             declare
 482                C : Entity_Id;
 483
 484             begin
 485                C := First_Component (Btype);
 486                while Present (C) loop
 487                   if Is_By_Reference_Type (Etype (C))
 488                     or else Is_Volatile (Etype (C))
 489                   then
 490                      return True;
 491                   end if;
 492
 493                   C := Next_Component (C);
 494                end loop;
 495             end;
 496
 497             return False;
 498          end if;
 499
 500       elsif Is_Array_Type (Btype) then
 501          return
 502            Is_Volatile (Btype)
 503              or else Is_By_Reference_Type (Component_Type (Btype))
 504              or else Is_Volatile (Component_Type (Btype))
 505              or else Has_Volatile_Components (Btype);
 506
 507       else
 508          return False;
 509       end if;
 510    end Is_By_Reference_Type;
 511
 512    ---------------------
 513    -- Is_Derived_Type --
 514    ---------------------
 515
 516    function Is_Derived_Type (Ent : E) return B is
 517       Par : Node_Id;
 518
 519    begin
 520       if Is_Type (Ent)
 521         and then Base_Type (Ent) /= Root_Type (Ent)
 522         and then not Is_Class_Wide_Type (Ent)
 523       then
 524          if not Is_Numeric_Type (Root_Type (Ent)) then
 525             return True;
 526
 527          else
 528             Par := Parent (First_Subtype (Ent));
 529
 530             return Present (Par)
 531               and then Nkind (Par) = N_Full_Type_Declaration
 532               and then Nkind (Type_Definition (Par)) =
 533                          N_Derived_Type_Definition;
 534          end if;
 535
 536       else
 537          return False;
 538       end if;
 539    end Is_Derived_Type;
 540
 541    ---------------------------
 542    -- Is_Indefinite_Subtype --
 543    ---------------------------
 544
 545    function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
 546       K : constant Entity_Kind := Ekind (Ent);
 547
 548    begin
 549       if Is_Constrained (Ent) then
 550          return False;
 551
 552       elsif K in Array_Kind
 553         or else K in Class_Wide_Kind
 554         or else Has_Unknown_Discriminants (Ent)
 555       then
 556          return True;
 557
 558       --  Known discriminants: indefinite if there are no default values
 559
 560       elsif K in Record_Kind
 561         or else Is_Incomplete_Or_Private_Type (Ent)
 562         or else Is_Concurrent_Type (Ent)
 563       then
 564          return (Has_Discriminants (Ent)
 565            and then
 566              No (Discriminant_Default_Value (First_Discriminant (Ent))));
 567
 568       else
 569          return False;
 570       end if;
 571    end Is_Indefinite_Subtype;
 572
 573    --------------------------------
 574    -- Is_Inherently_Limited_Type --
 575    --------------------------------
 576
 577    function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is
 578       Btype : constant Entity_Id := Base_Type (Ent);
 579
 580    begin
 581       if Is_Private_Type (Btype) then
 582          declare
 583             Utyp : constant Entity_Id := Underlying_Type (Btype);
 584          begin
 585             if No (Utyp) then
 586                return False;
 587             else
 588                return Is_Inherently_Limited_Type (Utyp);
 589             end if;
 590          end;
 591
 592       elsif Is_Concurrent_Type (Btype) then
 593          return True;
 594
 595       elsif Is_Record_Type (Btype) then
 596
 597          --  Note that we return True for all limited interfaces, even though
 598          --  (unsynchronized) limited interfaces can have descendants that are
 599          --  nonlimited, because this is a predicate on the type itself, and
 600          --  things like functions with limited interface results need to be
 601          --  handled as build in place even though they might return objects
 602          --  of a type that is not inherently limited.
 603
 604          if Is_Limited_Record (Btype) then
 605             return True;
 606
 607          elsif Is_Class_Wide_Type (Btype) then
 608             return Is_Inherently_Limited_Type (Root_Type (Btype));
 609
 610          else
 611             declare
 612                C : Entity_Id;
 613
 614             begin
 615                C := First_Component (Btype);
 616                while Present (C) loop
 617
 618                   --  Don't consider components with interface types (which can
 619                   --  only occur in the case of a _parent component anyway).
 620                   --  They don't have any components, plus it would cause this
 621                   --  function to return true for nonlimited types derived from
 622                   --  limited intefaces.
 623
 624                   if not Is_Interface (Etype (C))
 625                     and then Is_Inherently_Limited_Type (Etype (C))
 626                   then
 627                      return True;
 628                   end if;
 629
 630                   C := Next_Component (C);
 631                end loop;
 632             end;
 633
 634             return False;
 635          end if;
 636
 637       elsif Is_Array_Type (Btype) then
 638          return Is_Inherently_Limited_Type (Component_Type (Btype));
 639
 640       else
 641          return False;
 642       end if;
 643    end Is_Inherently_Limited_Type;
 644
 645    ---------------------
 646    -- Is_Limited_Type --
 647    ---------------------
 648
 649    function Is_Limited_Type (Ent : Entity_Id) return Boolean is
 650       Btype : constant E := Base_Type (Ent);
 651       Rtype : constant E := Root_Type (Btype);
 652
 653    begin
 654       if not Is_Type (Ent) then
 655          return False;
 656
 657       elsif Ekind (Btype) = E_Limited_Private_Type
 658         or else Is_Limited_Composite (Btype)
 659       then
 660          return True;
 661
 662       elsif Is_Concurrent_Type (Btype) then
 663          return True;
 664
 665          --  The Is_Limited_Record flag normally indicates that the type is
 666          --  limited. The exception is that a type does not inherit limitedness
 667          --  from its interface ancestor. So the type may be derived from a
 668          --  limited interface, but is not limited.
 669
 670       elsif Is_Limited_Record (Ent)
 671         and then not Is_Interface (Ent)
 672       then
 673          return True;
 674
 675       --  Otherwise we will look around to see if there is some other reason
 676       --  for it to be limited, except that if an error was posted on the
 677       --  entity, then just assume it is non-limited, because it can cause
 678       --  trouble to recurse into a murky erroneous entity!
 679
 680       elsif Error_Posted (Ent) then
 681          return False;
 682
 683       elsif Is_Record_Type (Btype) then
 684
 685          if Is_Limited_Interface (Ent) then
 686             return True;
 687
 688          --  AI-419: limitedness is not inherited from a limited interface
 689
 690          elsif Is_Limited_Record (Rtype) then
 691             return not Is_Interface (Rtype)
 692               or else Is_Protected_Interface (Rtype)
 693               or else Is_Synchronized_Interface (Rtype)
 694               or else Is_Task_Interface (Rtype);
 695
 696          elsif Is_Class_Wide_Type (Btype) then
 697             return Is_Limited_Type (Rtype);
 698
 699          else
 700             declare
 701                C : E;
 702
 703             begin
 704                C := First_Component (Btype);
 705                while Present (C) loop
 706                   if Is_Limited_Type (Etype (C)) then
 707                      return True;
 708                   end if;
 709
 710                   C := Next_Component (C);
 711                end loop;
 712             end;
 713
 714             return False;
 715          end if;
 716
 717       elsif Is_Array_Type (Btype) then
 718          return Is_Limited_Type (Component_Type (Btype));
 719
 720       else
 721          return False;
 722       end if;
 723    end Is_Limited_Type;
 724
 725    ---------------------------
 726    -- Nearest_Dynamic_Scope --
 727    ---------------------------
 728
 729    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
 730    begin
 731       if Is_Dynamic_Scope (Ent) then
 732          return Ent;
 733       else
 734          return Enclosing_Dynamic_Scope (Ent);
 735       end if;
 736    end Nearest_Dynamic_Scope;
 737
 738    ------------------------
 739    -- Next_Tag_Component --
 740    ------------------------
 741
 742    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
 743       Comp : Entity_Id;
 744
 745    begin
 746       pragma Assert (Is_Tag (Tag));
 747
 748       --  Loop to look for next tag component
 749
 750       Comp := Next_Entity (Tag);
 751       while Present (Comp) loop
 752          if Is_Tag (Comp) then
 753             pragma Assert (Chars (Comp) /= Name_uTag);
 754             return Comp;
 755          end if;
 756
 757          Comp := Next_Entity (Comp);
 758       end loop;
 759
 760       --  No tag component found
 761
 762       return Empty;
 763    end Next_Tag_Component;
 764
 765    --------------------------
 766    -- Number_Discriminants --
 767    --------------------------
 768
 769    function Number_Discriminants (Typ : Entity_Id) return Pos is
 770       N     : Int;
 771       Discr : Entity_Id;
 772
 773    begin
 774       N := 0;
 775       Discr := First_Discriminant (Typ);
 776       while Present (Discr) loop
 777          N := N + 1;
 778          Discr := Next_Discriminant (Discr);
 779       end loop;
 780
 781       return N;
 782    end Number_Discriminants;
 783
 784    ---------------
 785    -- Tree_Read --
 786    ---------------
 787
 788    procedure Tree_Read is
 789    begin
 790       Obsolescent_Warnings.Tree_Read;
 791    end Tree_Read;
 792
 793    ----------------
 794    -- Tree_Write --
 795    ----------------
 796
 797    procedure Tree_Write is
 798    begin
 799       Obsolescent_Warnings.Tree_Write;
 800    end Tree_Write;
 801
 802    --------------------
 803    -- Ultimate_Alias --
 804    --------------------
 805
 806    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
 807       E : Entity_Id := Prim;
 808
 809    begin
 810       while Present (Alias (E)) loop
 811          pragma Assert (Alias (E) /= E);
 812          E := Alias (E);
 813       end loop;
 814
 815       return E;
 816    end Ultimate_Alias;
 817
 818 end Sem_Aux;