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