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 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 (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) or else Has_Unknown_Discriminants (Typ));
 208
 209       Ent := First_Entity (Typ);
 210
 211       --  The discriminants are not necessarily contiguous, because access
 212       --  discriminants will generate itypes. They are not the first entities
 213       --  either, because tag and controller record must be ahead of them.
 214
 215       if Chars (Ent) = Name_uTag then
 216          Ent := Next_Entity (Ent);
 217       end if;
 218
 219       if Chars (Ent) = Name_uController then
 220          Ent := Next_Entity (Ent);
 221       end if;
 222
 223       --  Skip all hidden stored discriminants if any
 224
 225       while Present (Ent) loop
 226          exit when Ekind (Ent) = E_Discriminant
 227            and then not Is_Completely_Hidden (Ent);
 228
 229          Ent := Next_Entity (Ent);
 230       end loop;
 231
 232       pragma Assert (Ekind (Ent) = E_Discriminant);
 233
 234       return Ent;
 235    end First_Discriminant;
 236
 237    -------------------------------
 238    -- First_Stored_Discriminant --
 239    -------------------------------
 240
 241    function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
 242       Ent : Entity_Id;
 243
 244       function Has_Completely_Hidden_Discriminant
 245         (Typ : Entity_Id) return Boolean;
 246       --  Scans the Discriminants to see whether any are Completely_Hidden
 247       --  (the mechanism for describing non-specified stored discriminants)
 248
 249       ----------------------------------------
 250       -- Has_Completely_Hidden_Discriminant --
 251       ----------------------------------------
 252
 253       function Has_Completely_Hidden_Discriminant
 254         (Typ : Entity_Id) return Boolean
 255       is
 256          Ent : Entity_Id;
 257
 258       begin
 259          pragma Assert (Ekind (Typ) = E_Discriminant);
 260
 261          Ent := Typ;
 262          while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
 263             if Is_Completely_Hidden (Ent) then
 264                return True;
 265             end if;
 266
 267             Ent := Next_Entity (Ent);
 268          end loop;
 269
 270          return False;
 271       end Has_Completely_Hidden_Discriminant;
 272
 273    --  Start of processing for First_Stored_Discriminant
 274
 275    begin
 276       pragma Assert
 277         (Has_Discriminants (Typ)
 278           or else Has_Unknown_Discriminants (Typ));
 279
 280       Ent := First_Entity (Typ);
 281
 282       if Chars (Ent) = Name_uTag then
 283          Ent := Next_Entity (Ent);
 284       end if;
 285
 286       if Chars (Ent) = Name_uController then
 287          Ent := Next_Entity (Ent);
 288       end if;
 289
 290       if Has_Completely_Hidden_Discriminant (Ent) then
 291
 292          while Present (Ent) loop
 293             exit when Is_Completely_Hidden (Ent);
 294             Ent := Next_Entity (Ent);
 295          end loop;
 296
 297       end if;
 298
 299       pragma Assert (Ekind (Ent) = E_Discriminant);
 300
 301       return Ent;
 302    end First_Stored_Discriminant;
 303
 304    -------------------
 305    -- First_Subtype --
 306    -------------------
 307
 308    function First_Subtype (Typ : Entity_Id) return Entity_Id is
 309       B   : constant Entity_Id := Base_Type (Typ);
 310       F   : constant Node_Id   := Freeze_Node (B);
 311       Ent : Entity_Id;
 312
 313    begin
 314       --  If the base type has no freeze node, it is a type in Standard, and
 315       --  always acts as its own first subtype, except where it is one of the
 316       --  predefined integer types. If the type is formal, it is also a first
 317       --  subtype, and its base type has no freeze node. On the other hand, a
 318       --  subtype of a generic formal is not its own first subtype. Its base
 319       --  type, if anonymous, is attached to the formal type decl. from which
 320       --  the first subtype is obtained.
 321
 322       if No (F) then
 323          if B = Base_Type (Standard_Integer) then
 324             return Standard_Integer;
 325
 326          elsif B = Base_Type (Standard_Long_Integer) then
 327             return Standard_Long_Integer;
 328
 329          elsif B = Base_Type (Standard_Short_Short_Integer) then
 330             return Standard_Short_Short_Integer;
 331
 332          elsif B = Base_Type (Standard_Short_Integer) then
 333             return Standard_Short_Integer;
 334
 335          elsif B = Base_Type (Standard_Long_Long_Integer) then
 336             return Standard_Long_Long_Integer;
 337
 338          elsif Is_Generic_Type (Typ) then
 339             if Present (Parent (B)) then
 340                return Defining_Identifier (Parent (B));
 341             else
 342                return Defining_Identifier (Associated_Node_For_Itype (B));
 343             end if;
 344
 345          else
 346             return B;
 347          end if;
 348
 349       --  Otherwise we check the freeze node, if it has a First_Subtype_Link
 350       --  then we use that link, otherwise (happens with some Itypes), we use
 351       --  the base type itself.
 352
 353       else
 354          Ent := First_Subtype_Link (F);
 355
 356          if Present (Ent) then
 357             return Ent;
 358          else
 359             return B;
 360          end if;
 361       end if;
 362    end First_Subtype;
 363
 364    -------------------------
 365    -- First_Tag_Component --
 366    -------------------------
 367
 368    function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
 369       Comp : Entity_Id;
 370       Ctyp : Entity_Id;
 371
 372    begin
 373       Ctyp := Typ;
 374       pragma Assert (Is_Tagged_Type (Ctyp));
 375
 376       if Is_Class_Wide_Type (Ctyp) then
 377          Ctyp := Root_Type (Ctyp);
 378       end if;
 379
 380       if Is_Private_Type (Ctyp) then
 381          Ctyp := Underlying_Type (Ctyp);
 382
 383          --  If the underlying type is missing then the source program has
 384          --  errors and there is nothing else to do (the full-type declaration
 385          --  associated with the private type declaration is missing).
 386
 387          if No (Ctyp) then
 388             return Empty;
 389          end if;
 390       end if;
 391
 392       Comp := First_Entity (Ctyp);
 393       while Present (Comp) loop
 394          if Is_Tag (Comp) then
 395             return Comp;
 396          end if;
 397
 398          Comp := Next_Entity (Comp);
 399       end loop;
 400
 401       --  No tag component found
 402
 403       return Empty;
 404    end First_Tag_Component;
 405
 406    -------------------------------
 407    -- Initialization_Suppressed --
 408    -------------------------------
 409
 410    function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
 411    begin
 412       return Suppress_Initialization (Typ)
 413         or else Suppress_Initialization (Base_Type (Typ));
 414    end Initialization_Suppressed;
 415
 416    ----------------
 417    -- Initialize --
 418    ----------------
 419
 420    procedure Initialize is
 421    begin
 422       Obsolescent_Warnings.Init;
 423    end Initialize;
 424
 425    ---------------------
 426    -- Is_By_Copy_Type --
 427    ---------------------
 428
 429    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
 430    begin
 431       --  If Id is a private type whose full declaration has not been seen,
 432       --  we assume for now that it is not a By_Copy type. Clearly this
 433       --  attribute should not be used before the type is frozen, but it is
 434       --  needed to build the associated record of a protected type. Another
 435       --  place where some lookahead for a full view is needed ???
 436
 437       return
 438         Is_Elementary_Type (Ent)
 439           or else (Is_Private_Type (Ent)
 440                      and then Present (Underlying_Type (Ent))
 441                      and then Is_Elementary_Type (Underlying_Type (Ent)));
 442    end Is_By_Copy_Type;
 443
 444    --------------------------
 445    -- Is_By_Reference_Type --
 446    --------------------------
 447
 448    function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
 449       Btype : constant Entity_Id := Base_Type (Ent);
 450
 451    begin
 452       if Error_Posted (Ent)
 453         or else Error_Posted (Btype)
 454       then
 455          return False;
 456
 457       elsif Is_Private_Type (Btype) then
 458          declare
 459             Utyp : constant Entity_Id := Underlying_Type (Btype);
 460          begin
 461             if No (Utyp) then
 462                return False;
 463             else
 464                return Is_By_Reference_Type (Utyp);
 465             end if;
 466          end;
 467
 468       elsif Is_Incomplete_Type (Btype) then
 469          declare
 470             Ftyp : constant Entity_Id := Full_View (Btype);
 471          begin
 472             if No (Ftyp) then
 473                return False;
 474             else
 475                return Is_By_Reference_Type (Ftyp);
 476             end if;
 477          end;
 478
 479       elsif Is_Concurrent_Type (Btype) then
 480          return True;
 481
 482       elsif Is_Record_Type (Btype) then
 483          if Is_Limited_Record (Btype)
 484            or else Is_Tagged_Type (Btype)
 485            or else Is_Volatile (Btype)
 486          then
 487             return True;
 488
 489          else
 490             declare
 491                C : Entity_Id;
 492
 493             begin
 494                C := First_Component (Btype);
 495                while Present (C) loop
 496                   if Is_By_Reference_Type (Etype (C))
 497                     or else Is_Volatile (Etype (C))
 498                   then
 499                      return True;
 500                   end if;
 501
 502                   C := Next_Component (C);
 503                end loop;
 504             end;
 505
 506             return False;
 507          end if;
 508
 509       elsif Is_Array_Type (Btype) then
 510          return
 511            Is_Volatile (Btype)
 512              or else Is_By_Reference_Type (Component_Type (Btype))
 513              or else Is_Volatile (Component_Type (Btype))
 514              or else Has_Volatile_Components (Btype);
 515
 516       else
 517          return False;
 518       end if;
 519    end Is_By_Reference_Type;
 520
 521    ---------------------
 522    -- Is_Derived_Type --
 523    ---------------------
 524
 525    function Is_Derived_Type (Ent : E) return B is
 526       Par : Node_Id;
 527
 528    begin
 529       if Is_Type (Ent)
 530         and then Base_Type (Ent) /= Root_Type (Ent)
 531         and then not Is_Class_Wide_Type (Ent)
 532       then
 533          if not Is_Numeric_Type (Root_Type (Ent)) then
 534             return True;
 535
 536          else
 537             Par := Parent (First_Subtype (Ent));
 538
 539             return Present (Par)
 540               and then Nkind (Par) = N_Full_Type_Declaration
 541               and then Nkind (Type_Definition (Par)) =
 542                          N_Derived_Type_Definition;
 543          end if;
 544
 545       else
 546          return False;
 547       end if;
 548    end Is_Derived_Type;
 549
 550    -----------------------
 551    -- Is_Generic_Formal --
 552    -----------------------
 553
 554    function Is_Generic_Formal (E : Entity_Id) return Boolean is
 555       Kind : Node_Kind;
 556    begin
 557       if No (E) then
 558          return False;
 559       else
 560          Kind := Nkind (Parent (E));
 561          return
 562            Nkind_In (Kind, N_Formal_Object_Declaration,
 563                            N_Formal_Package_Declaration,
 564                            N_Formal_Type_Declaration)
 565              or else Is_Formal_Subprogram (E);
 566       end if;
 567    end Is_Generic_Formal;
 568
 569    ---------------------------
 570    -- Is_Indefinite_Subtype --
 571    ---------------------------
 572
 573    function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
 574       K : constant Entity_Kind := Ekind (Ent);
 575
 576    begin
 577       if Is_Constrained (Ent) then
 578          return False;
 579
 580       elsif K in Array_Kind
 581         or else K in Class_Wide_Kind
 582         or else Has_Unknown_Discriminants (Ent)
 583       then
 584          return True;
 585
 586       --  Known discriminants: indefinite if there are no default values
 587
 588       elsif K in Record_Kind
 589         or else Is_Incomplete_Or_Private_Type (Ent)
 590         or else Is_Concurrent_Type (Ent)
 591       then
 592          return (Has_Discriminants (Ent)
 593            and then
 594              No (Discriminant_Default_Value (First_Discriminant (Ent))));
 595
 596       else
 597          return False;
 598       end if;
 599    end Is_Indefinite_Subtype;
 600
 601    -------------------------------
 602    -- Is_Immutably_Limited_Type --
 603    -------------------------------
 604
 605    function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
 606       Btype : constant Entity_Id := Base_Type (Ent);
 607
 608    begin
 609       if Is_Limited_Record (Btype) then
 610          return True;
 611
 612       elsif Ekind (Btype) = E_Limited_Private_Type
 613         and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
 614       then
 615          return not In_Package_Body (Scope ((Btype)));
 616       end if;
 617
 618       if Is_Private_Type (Btype) then
 619
 620          --  AI05-0063: A type derived from a limited private formal type is
 621          --  not immutably limited in a generic body.
 622
 623          if Is_Derived_Type (Btype)
 624            and then Is_Generic_Type (Etype (Btype))
 625          then
 626             if not Is_Limited_Type (Etype (Btype)) then
 627                return False;
 628
 629             --  A descendant of a limited formal type is not immutably limited
 630             --  in the generic body, or in the body of a generic child.
 631
 632             elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
 633                return not In_Package_Body (Scope (Btype));
 634
 635             else
 636                return False;
 637             end if;
 638
 639          else
 640             declare
 641                Utyp : constant Entity_Id := Underlying_Type (Btype);
 642             begin
 643                if No (Utyp) then
 644                   return False;
 645                else
 646                   return Is_Immutably_Limited_Type (Utyp);
 647                end if;
 648             end;
 649          end if;
 650
 651       elsif Is_Concurrent_Type (Btype) then
 652          return True;
 653
 654       elsif Is_Record_Type (Btype) then
 655
 656          --  Note that we return True for all limited interfaces, even though
 657          --  (unsynchronized) limited interfaces can have descendants that are
 658          --  nonlimited, because this is a predicate on the type itself, and
 659          --  things like functions with limited interface results need to be
 660          --  handled as build in place even though they might return objects
 661          --  of a type that is not inherently limited.
 662
 663          if Is_Class_Wide_Type (Btype) then
 664             return Is_Immutably_Limited_Type (Root_Type (Btype));
 665
 666          else
 667             declare
 668                C : Entity_Id;
 669
 670             begin
 671                C := First_Component (Btype);
 672                while Present (C) loop
 673
 674                   --  Don't consider components with interface types (which can
 675                   --  only occur in the case of a _parent component anyway).
 676                   --  They don't have any components, plus it would cause this
 677                   --  function to return true for nonlimited types derived from
 678                   --  limited interfaces.
 679
 680                   if not Is_Interface (Etype (C))
 681                     and then Is_Immutably_Limited_Type (Etype (C))
 682                   then
 683                      return True;
 684                   end if;
 685
 686                   C := Next_Component (C);
 687                end loop;
 688             end;
 689
 690             return False;
 691          end if;
 692
 693       elsif Is_Array_Type (Btype) then
 694          return Is_Immutably_Limited_Type (Component_Type (Btype));
 695
 696       else
 697          return False;
 698       end if;
 699    end Is_Immutably_Limited_Type;
 700
 701    ---------------------
 702    -- Is_Limited_Type --
 703    ---------------------
 704
 705    function Is_Limited_Type (Ent : Entity_Id) return Boolean is
 706       Btype : constant E := Base_Type (Ent);
 707       Rtype : constant E := Root_Type (Btype);
 708
 709    begin
 710       if not Is_Type (Ent) then
 711          return False;
 712
 713       elsif Ekind (Btype) = E_Limited_Private_Type
 714         or else Is_Limited_Composite (Btype)
 715       then
 716          return True;
 717
 718       elsif Is_Concurrent_Type (Btype) then
 719          return True;
 720
 721          --  The Is_Limited_Record flag normally indicates that the type is
 722          --  limited. The exception is that a type does not inherit limitedness
 723          --  from its interface ancestor. So the type may be derived from a
 724          --  limited interface, but is not limited.
 725
 726       elsif Is_Limited_Record (Ent)
 727         and then not Is_Interface (Ent)
 728       then
 729          return True;
 730
 731       --  Otherwise we will look around to see if there is some other reason
 732       --  for it to be limited, except that if an error was posted on the
 733       --  entity, then just assume it is non-limited, because it can cause
 734       --  trouble to recurse into a murky erroneous entity!
 735
 736       elsif Error_Posted (Ent) then
 737          return False;
 738
 739       elsif Is_Record_Type (Btype) then
 740
 741          if Is_Limited_Interface (Ent) then
 742             return True;
 743
 744          --  AI-419: limitedness is not inherited from a limited interface
 745
 746          elsif Is_Limited_Record (Rtype) then
 747             return not Is_Interface (Rtype)
 748               or else Is_Protected_Interface (Rtype)
 749               or else Is_Synchronized_Interface (Rtype)
 750               or else Is_Task_Interface (Rtype);
 751
 752          elsif Is_Class_Wide_Type (Btype) then
 753             return Is_Limited_Type (Rtype);
 754
 755          else
 756             declare
 757                C : E;
 758
 759             begin
 760                C := First_Component (Btype);
 761                while Present (C) loop
 762                   if Is_Limited_Type (Etype (C)) then
 763                      return True;
 764                   end if;
 765
 766                   C := Next_Component (C);
 767                end loop;
 768             end;
 769
 770             return False;
 771          end if;
 772
 773       elsif Is_Array_Type (Btype) then
 774          return Is_Limited_Type (Component_Type (Btype));
 775
 776       else
 777          return False;
 778       end if;
 779    end Is_Limited_Type;
 780
 781    ----------------------
 782    -- Nearest_Ancestor --
 783    ----------------------
 784
 785    function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
 786          D : constant Node_Id := Declaration_Node (Typ);
 787
 788    begin
 789       --  If we have a subtype declaration, get the ancestor subtype
 790
 791       if Nkind (D) = N_Subtype_Declaration then
 792          if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
 793             return Entity (Subtype_Mark (Subtype_Indication (D)));
 794          else
 795             return Entity (Subtype_Indication (D));
 796          end if;
 797
 798       --  If derived type declaration, find who we are derived from
 799
 800       elsif Nkind (D) = N_Full_Type_Declaration
 801         and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
 802       then
 803          declare
 804             DTD : constant Entity_Id := Type_Definition (D);
 805             SI  : constant Entity_Id := Subtype_Indication (DTD);
 806          begin
 807             if Is_Entity_Name (SI) then
 808                return Entity (SI);
 809             else
 810                return Entity (Subtype_Mark (SI));
 811             end if;
 812          end;
 813
 814       --  Otherwise, nothing useful to return, return Empty
 815
 816       else
 817          return Empty;
 818       end if;
 819    end Nearest_Ancestor;
 820
 821    ---------------------------
 822    -- Nearest_Dynamic_Scope --
 823    ---------------------------
 824
 825    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
 826    begin
 827       if Is_Dynamic_Scope (Ent) then
 828          return Ent;
 829       else
 830          return Enclosing_Dynamic_Scope (Ent);
 831       end if;
 832    end Nearest_Dynamic_Scope;
 833
 834    ------------------------
 835    -- Next_Tag_Component --
 836    ------------------------
 837
 838    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
 839       Comp : Entity_Id;
 840
 841    begin
 842       pragma Assert (Is_Tag (Tag));
 843
 844       --  Loop to look for next tag component
 845
 846       Comp := Next_Entity (Tag);
 847       while Present (Comp) loop
 848          if Is_Tag (Comp) then
 849             pragma Assert (Chars (Comp) /= Name_uTag);
 850             return Comp;
 851          end if;
 852
 853          Comp := Next_Entity (Comp);
 854       end loop;
 855
 856       --  No tag component found
 857
 858       return Empty;
 859    end Next_Tag_Component;
 860
 861    --------------------------
 862    -- Number_Discriminants --
 863    --------------------------
 864
 865    function Number_Discriminants (Typ : Entity_Id) return Pos is
 866       N     : Int;
 867       Discr : Entity_Id;
 868
 869    begin
 870       N := 0;
 871       Discr := First_Discriminant (Typ);
 872       while Present (Discr) loop
 873          N := N + 1;
 874          Discr := Next_Discriminant (Discr);
 875       end loop;
 876
 877       return N;
 878    end Number_Discriminants;
 879
 880    ---------------
 881    -- Tree_Read --
 882    ---------------
 883
 884    procedure Tree_Read is
 885    begin
 886       Obsolescent_Warnings.Tree_Read;
 887    end Tree_Read;
 888
 889    ----------------
 890    -- Tree_Write --
 891    ----------------
 892
 893    procedure Tree_Write is
 894    begin
 895       Obsolescent_Warnings.Tree_Write;
 896    end Tree_Write;
 897
 898    --------------------
 899    -- Ultimate_Alias --
 900    --------------------
 901
 902    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
 903       E : Entity_Id := Prim;
 904
 905    begin
 906       while Present (Alias (E)) loop
 907          pragma Assert (Alias (E) /= E);
 908          E := Alias (E);
 909       end loop;
 910
 911       return E;
 912    end Ultimate_Alias;
 913
 914 end Sem_Aux;