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