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-2016, 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 Snames; use Snames;
  36 with Stand;  use Stand;
  37 with Uintp;  use Uintp;
  38
  39 package body Sem_Aux is
  40
  41    ----------------------
  42    -- Ancestor_Subtype --
  43    ----------------------
  44
  45    function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
  46    begin
  47       --  If this is first subtype, or is a base type, then there is no
  48       --  ancestor subtype, so we return Empty to indicate this fact.
  49
  50       if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
  51          return Empty;
  52       end if;
  53
  54       declare
  55          D : constant Node_Id := Declaration_Node (Typ);
  56
  57       begin
  58          --  If we have a subtype declaration, get the ancestor subtype
  59
  60          if Nkind (D) = N_Subtype_Declaration then
  61             if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
  62                return Entity (Subtype_Mark (Subtype_Indication (D)));
  63             else
  64                return Entity (Subtype_Indication (D));
  65             end if;
  66
  67          --  If not, then no subtype indication is available
  68
  69          else
  70             return Empty;
  71          end if;
  72       end;
  73    end Ancestor_Subtype;
  74
  75    --------------------
  76    -- Available_View --
  77    --------------------
  78
  79    function Available_View (Ent : Entity_Id) return Entity_Id is
  80    begin
  81       --  Obtain the non-limited view (if available)
  82
  83       if Has_Non_Limited_View (Ent) then
  84          return Get_Full_View (Non_Limited_View (Ent));
  85
  86       --  In all other cases, return entity unchanged
  87
  88       else
  89          return Ent;
  90       end if;
  91    end Available_View;
  92
  93    --------------------
  94    -- Constant_Value --
  95    --------------------
  96
  97    function Constant_Value (Ent : Entity_Id) return Node_Id is
  98       D      : constant Node_Id := Declaration_Node (Ent);
  99       Full_D : Node_Id;
 100
 101    begin
 102       --  If we have no declaration node, then return no constant value. Not
 103       --  clear how this can happen, but it does sometimes and this is the
 104       --  safest approach.
 105
 106       if No (D) then
 107          return Empty;
 108
 109       --  Normal case where a declaration node is present
 110
 111       elsif Nkind (D) = N_Object_Renaming_Declaration then
 112          return Renamed_Object (Ent);
 113
 114       --  If this is a component declaration whose entity is a constant, it is
 115       --  a prival within a protected function (and so has no constant value).
 116
 117       elsif Nkind (D) = N_Component_Declaration then
 118          return Empty;
 119
 120       --  If there is an expression, return it
 121
 122       elsif Present (Expression (D)) then
 123          return Expression (D);
 124
 125       --  For a constant, see if we have a full view
 126
 127       elsif Ekind (Ent) = E_Constant
 128         and then Present (Full_View (Ent))
 129       then
 130          Full_D := Parent (Full_View (Ent));
 131
 132          --  The full view may have been rewritten as an object renaming
 133
 134          if Nkind (Full_D) = N_Object_Renaming_Declaration then
 135             return Name (Full_D);
 136          else
 137             return Expression (Full_D);
 138          end if;
 139
 140       --  Otherwise we have no expression to return
 141
 142       else
 143          return Empty;
 144       end if;
 145    end Constant_Value;
 146
 147    ---------------------------------
 148    -- Corresponding_Unsigned_Type --
 149    ---------------------------------
 150
 151    function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
 152       pragma Assert (Is_Signed_Integer_Type (Typ));
 153       Siz : constant Uint := Esize (Base_Type (Typ));
 154    begin
 155       if Siz = Esize (Standard_Short_Short_Integer) then
 156          return Standard_Short_Short_Unsigned;
 157       elsif Siz = Esize (Standard_Short_Integer) then
 158          return Standard_Short_Unsigned;
 159       elsif Siz = Esize (Standard_Unsigned) then
 160          return Standard_Unsigned;
 161       elsif Siz = Esize (Standard_Long_Integer) then
 162          return Standard_Long_Unsigned;
 163       elsif Siz = Esize (Standard_Long_Long_Integer) then
 164          return Standard_Long_Long_Unsigned;
 165       else
 166          raise Program_Error;
 167       end if;
 168    end Corresponding_Unsigned_Type;
 169
 170    -----------------------------
 171    -- Enclosing_Dynamic_Scope --
 172    -----------------------------
 173
 174    function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
 175       S : Entity_Id;
 176
 177    begin
 178       --  The following test is an error defense against some syntax errors
 179       --  that can leave scopes very messed up.
 180
 181       if Ent = Standard_Standard then
 182          return Ent;
 183       end if;
 184
 185       --  Normal case, search enclosing scopes
 186
 187       --  Note: the test for Present (S) should not be required, it defends
 188       --  against an ill-formed tree.
 189
 190       S := Scope (Ent);
 191       loop
 192          --  If we somehow got an empty value for Scope, the tree must be
 193          --  malformed. Rather than blow up we return Standard in this case.
 194
 195          if No (S) then
 196             return Standard_Standard;
 197
 198          --  Quit if we get to standard or a dynamic scope. We must also
 199          --  handle enclosing scopes that have a full view; required to
 200          --  locate enclosing scopes that are synchronized private types
 201          --  whose full view is a task type.
 202
 203          elsif S = Standard_Standard
 204            or else Is_Dynamic_Scope (S)
 205            or else (Is_Private_Type (S)
 206                      and then Present (Full_View (S))
 207                      and then Is_Dynamic_Scope (Full_View (S)))
 208          then
 209             return S;
 210
 211          --  Otherwise keep climbing
 212
 213          else
 214             S := Scope (S);
 215          end if;
 216       end loop;
 217    end Enclosing_Dynamic_Scope;
 218
 219    ------------------------
 220    -- First_Discriminant --
 221    ------------------------
 222
 223    function First_Discriminant (Typ : Entity_Id) return Entity_Id is
 224       Ent : Entity_Id;
 225
 226    begin
 227       pragma Assert
 228         (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
 229
 230       Ent := First_Entity (Typ);
 231
 232       --  The discriminants are not necessarily contiguous, because access
 233       --  discriminants will generate itypes. They are not the first entities
 234       --  either because the tag must be ahead of them.
 235
 236       if Chars (Ent) = Name_uTag then
 237          Ent := Next_Entity (Ent);
 238       end if;
 239
 240       --  Skip all hidden stored discriminants if any
 241
 242       while Present (Ent) loop
 243          exit when Ekind (Ent) = E_Discriminant
 244            and then not Is_Completely_Hidden (Ent);
 245
 246          Ent := Next_Entity (Ent);
 247       end loop;
 248
 249       --  Call may be on a private type with unknown discriminants, in which
 250       --  case Ent is Empty, and as per the spec, we return Empty in this case.
 251
 252       --  Historical note: The assertion in previous versions that Ent is a
 253       --  discriminant was overly cautious and prevented convenient application
 254       --  of this function in the gnatprove context.
 255
 256       return Ent;
 257    end First_Discriminant;
 258
 259    -------------------------------
 260    -- First_Stored_Discriminant --
 261    -------------------------------
 262
 263    function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
 264       Ent : Entity_Id;
 265
 266       function Has_Completely_Hidden_Discriminant
 267         (Typ : Entity_Id) return Boolean;
 268       --  Scans the Discriminants to see whether any are Completely_Hidden
 269       --  (the mechanism for describing non-specified stored discriminants)
 270       --  Note that the entity list for the type may contain anonymous access
 271       --  types created by expressions that constrain access discriminants.
 272
 273       ----------------------------------------
 274       -- Has_Completely_Hidden_Discriminant --
 275       ----------------------------------------
 276
 277       function Has_Completely_Hidden_Discriminant
 278         (Typ : Entity_Id) return Boolean
 279       is
 280          Ent : Entity_Id;
 281
 282       begin
 283          pragma Assert (Ekind (Typ) = E_Discriminant);
 284
 285          Ent := Typ;
 286          while Present (Ent) loop
 287
 288             --  Skip anonymous types that may be created by expressions
 289             --  used as discriminant constraints on inherited discriminants.
 290
 291             if Is_Itype (Ent) then
 292                null;
 293
 294             elsif Ekind (Ent) = E_Discriminant
 295               and then Is_Completely_Hidden (Ent)
 296             then
 297                return True;
 298             end if;
 299
 300             Ent := Next_Entity (Ent);
 301          end loop;
 302
 303          return False;
 304       end Has_Completely_Hidden_Discriminant;
 305
 306    --  Start of processing for First_Stored_Discriminant
 307
 308    begin
 309       pragma Assert
 310         (Has_Discriminants (Typ)
 311           or else Has_Unknown_Discriminants (Typ));
 312
 313       Ent := First_Entity (Typ);
 314
 315       if Chars (Ent) = Name_uTag then
 316          Ent := Next_Entity (Ent);
 317       end if;
 318
 319       if Has_Completely_Hidden_Discriminant (Ent) then
 320          while Present (Ent) loop
 321             exit when Ekind (Ent) = E_Discriminant
 322               and then Is_Completely_Hidden (Ent);
 323             Ent := Next_Entity (Ent);
 324          end loop;
 325       end if;
 326
 327       pragma Assert (Ekind (Ent) = E_Discriminant);
 328
 329       return Ent;
 330    end First_Stored_Discriminant;
 331
 332    -------------------
 333    -- First_Subtype --
 334    -------------------
 335
 336    function First_Subtype (Typ : Entity_Id) return Entity_Id is
 337       B   : constant Entity_Id := Base_Type (Typ);
 338       F   : constant Node_Id   := Freeze_Node (B);
 339       Ent : Entity_Id;
 340
 341    begin
 342       --  If the base type has no freeze node, it is a type in Standard, and
 343       --  always acts as its own first subtype, except where it is one of the
 344       --  predefined integer types. If the type is formal, it is also a first
 345       --  subtype, and its base type has no freeze node. On the other hand, a
 346       --  subtype of a generic formal is not its own first subtype. Its base
 347       --  type, if anonymous, is attached to the formal type decl. from which
 348       --  the first subtype is obtained.
 349
 350       if No (F) then
 351          if B = Base_Type (Standard_Integer) then
 352             return Standard_Integer;
 353
 354          elsif B = Base_Type (Standard_Long_Integer) then
 355             return Standard_Long_Integer;
 356
 357          elsif B = Base_Type (Standard_Short_Short_Integer) then
 358             return Standard_Short_Short_Integer;
 359
 360          elsif B = Base_Type (Standard_Short_Integer) then
 361             return Standard_Short_Integer;
 362
 363          elsif B = Base_Type (Standard_Long_Long_Integer) then
 364             return Standard_Long_Long_Integer;
 365
 366          elsif Is_Generic_Type (Typ) then
 367             if Present (Parent (B)) then
 368                return Defining_Identifier (Parent (B));
 369             else
 370                return Defining_Identifier (Associated_Node_For_Itype (B));
 371             end if;
 372
 373          else
 374             return B;
 375          end if;
 376
 377       --  Otherwise we check the freeze node, if it has a First_Subtype_Link
 378       --  then we use that link, otherwise (happens with some Itypes), we use
 379       --  the base type itself.
 380
 381       else
 382          Ent := First_Subtype_Link (F);
 383
 384          if Present (Ent) then
 385             return Ent;
 386          else
 387             return B;
 388          end if;
 389       end if;
 390    end First_Subtype;
 391
 392    -------------------------
 393    -- First_Tag_Component --
 394    -------------------------
 395
 396    function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
 397       Comp : Entity_Id;
 398       Ctyp : Entity_Id;
 399
 400    begin
 401       Ctyp := Typ;
 402       pragma Assert (Is_Tagged_Type (Ctyp));
 403
 404       if Is_Class_Wide_Type (Ctyp) then
 405          Ctyp := Root_Type (Ctyp);
 406       end if;
 407
 408       if Is_Private_Type (Ctyp) then
 409          Ctyp := Underlying_Type (Ctyp);
 410
 411          --  If the underlying type is missing then the source program has
 412          --  errors and there is nothing else to do (the full-type declaration
 413          --  associated with the private type declaration is missing).
 414
 415          if No (Ctyp) then
 416             return Empty;
 417          end if;
 418       end if;
 419
 420       Comp := First_Entity (Ctyp);
 421       while Present (Comp) loop
 422          if Is_Tag (Comp) then
 423             return Comp;
 424          end if;
 425
 426          Comp := Next_Entity (Comp);
 427       end loop;
 428
 429       --  No tag component found
 430
 431       return Empty;
 432    end First_Tag_Component;
 433
 434    ---------------------
 435    -- Get_Binary_Nkind --
 436    ---------------------
 437
 438    function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
 439    begin
 440       case Chars (Op) is
 441          when Name_Op_Add =>
 442             return N_Op_Add;
 443          when Name_Op_Concat =>
 444             return N_Op_Concat;
 445          when Name_Op_Expon =>
 446             return N_Op_Expon;
 447          when Name_Op_Subtract =>
 448             return N_Op_Subtract;
 449          when Name_Op_Mod =>
 450             return N_Op_Mod;
 451          when Name_Op_Multiply =>
 452             return N_Op_Multiply;
 453          when Name_Op_Divide =>
 454             return N_Op_Divide;
 455          when Name_Op_Rem =>
 456             return N_Op_Rem;
 457          when Name_Op_And =>
 458             return N_Op_And;
 459          when Name_Op_Eq =>
 460             return N_Op_Eq;
 461          when Name_Op_Ge =>
 462             return N_Op_Ge;
 463          when Name_Op_Gt =>
 464             return N_Op_Gt;
 465          when Name_Op_Le =>
 466             return N_Op_Le;
 467          when Name_Op_Lt =>
 468             return N_Op_Lt;
 469          when Name_Op_Ne =>
 470             return N_Op_Ne;
 471          when Name_Op_Or =>
 472             return N_Op_Or;
 473          when Name_Op_Xor =>
 474             return N_Op_Xor;
 475          when others =>
 476             raise Program_Error;
 477       end case;
 478    end Get_Binary_Nkind;
 479
 480    -------------------
 481    -- Get_Low_Bound --
 482    -------------------
 483
 484    function Get_Low_Bound (E : Entity_Id) return Node_Id is
 485    begin
 486       if Ekind (E) = E_String_Literal_Subtype then
 487          return String_Literal_Low_Bound (E);
 488       else
 489          return Type_Low_Bound (E);
 490       end if;
 491    end Get_Low_Bound;
 492
 493    ------------------
 494    -- Get_Rep_Item --
 495    ------------------
 496
 497    function Get_Rep_Item
 498      (E             : Entity_Id;
 499       Nam           : Name_Id;
 500       Check_Parents : Boolean := True) return Node_Id
 501    is
 502       N : Node_Id;
 503
 504    begin
 505       N := First_Rep_Item (E);
 506       while Present (N) loop
 507
 508          --  Only one of Priority / Interrupt_Priority can be specified, so
 509          --  return whichever one is present to catch illegal duplication.
 510
 511          if Nkind (N) = N_Pragma
 512            and then
 513              (Pragma_Name (N) = Nam
 514                or else (Nam = Name_Priority
 515                          and then Pragma_Name (N) = Name_Interrupt_Priority)
 516                or else (Nam = Name_Interrupt_Priority
 517                          and then Pragma_Name (N) = Name_Priority))
 518          then
 519             if Check_Parents then
 520                return N;
 521
 522             --  If Check_Parents is False, return N if the pragma doesn't
 523             --  appear in the Rep_Item chain of the parent.
 524
 525             else
 526                declare
 527                   Par : constant Entity_Id := Nearest_Ancestor (E);
 528                   --  This node represents the parent type of type E (if any)
 529
 530                begin
 531                   if No (Par) then
 532                      return N;
 533
 534                   elsif not Present_In_Rep_Item (Par, N) then
 535                      return N;
 536                   end if;
 537                end;
 538             end if;
 539
 540          elsif Nkind (N) = N_Attribute_Definition_Clause
 541            and then
 542              (Chars (N) = Nam
 543                or else (Nam = Name_Priority
 544                          and then Chars (N) = Name_Interrupt_Priority))
 545          then
 546             if Check_Parents or else Entity (N) = E then
 547                return N;
 548             end if;
 549
 550          elsif Nkind (N) = N_Aspect_Specification
 551            and then
 552              (Chars (Identifier (N)) = Nam
 553                or else
 554                  (Nam = Name_Priority
 555                    and then Chars (Identifier (N)) = Name_Interrupt_Priority))
 556          then
 557             if Check_Parents then
 558                return N;
 559
 560             elsif Entity (N) = E then
 561                return N;
 562             end if;
 563          end if;
 564
 565          Next_Rep_Item (N);
 566       end loop;
 567
 568       return Empty;
 569    end Get_Rep_Item;
 570
 571    function Get_Rep_Item
 572      (E             : Entity_Id;
 573       Nam1          : Name_Id;
 574       Nam2          : Name_Id;
 575       Check_Parents : Boolean := True) return Node_Id
 576    is
 577       Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
 578       Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
 579
 580       N : Node_Id;
 581
 582    begin
 583       --  Check both Nam1_Item and Nam2_Item are present
 584
 585       if No (Nam1_Item) then
 586          return Nam2_Item;
 587       elsif No (Nam2_Item) then
 588          return Nam1_Item;
 589       end if;
 590
 591       --  Return the first node encountered in the list
 592
 593       N := First_Rep_Item (E);
 594       while Present (N) loop
 595          if N = Nam1_Item or else N = Nam2_Item then
 596             return N;
 597          end if;
 598
 599          Next_Rep_Item (N);
 600       end loop;
 601
 602       return Empty;
 603    end Get_Rep_Item;
 604
 605    --------------------
 606    -- Get_Rep_Pragma --
 607    --------------------
 608
 609    function Get_Rep_Pragma
 610      (E             : Entity_Id;
 611       Nam           : Name_Id;
 612       Check_Parents : Boolean := True) return Node_Id
 613    is
 614       N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents);
 615
 616    begin
 617       if Present (N) and then Nkind (N) = N_Pragma then
 618          return N;
 619       end if;
 620
 621       return Empty;
 622    end Get_Rep_Pragma;
 623
 624    function Get_Rep_Pragma
 625      (E             : Entity_Id;
 626       Nam1          : Name_Id;
 627       Nam2          : Name_Id;
 628       Check_Parents : Boolean := True) return Node_Id
 629    is
 630       Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
 631       Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
 632
 633       N : Node_Id;
 634
 635    begin
 636       --  Check both Nam1_Item and Nam2_Item are present
 637
 638       if No (Nam1_Item) then
 639          return Nam2_Item;
 640       elsif No (Nam2_Item) then
 641          return Nam1_Item;
 642       end if;
 643
 644       --  Return the first node encountered in the list
 645
 646       N := First_Rep_Item (E);
 647       while Present (N) loop
 648          if N = Nam1_Item or else N = Nam2_Item then
 649             return N;
 650          end if;
 651
 652          Next_Rep_Item (N);
 653       end loop;
 654
 655       return Empty;
 656    end Get_Rep_Pragma;
 657
 658    ---------------------
 659    -- Get_Unary_Nkind --
 660    ---------------------
 661
 662    function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
 663    begin
 664       case Chars (Op) is
 665          when Name_Op_Abs =>
 666             return N_Op_Abs;
 667          when Name_Op_Subtract =>
 668             return N_Op_Minus;
 669          when Name_Op_Not =>
 670             return N_Op_Not;
 671          when Name_Op_Add =>
 672             return N_Op_Plus;
 673          when others =>
 674             raise Program_Error;
 675       end case;
 676    end Get_Unary_Nkind;
 677
 678    ---------------------------------
 679    -- Has_External_Tag_Rep_Clause --
 680    ---------------------------------
 681
 682    function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
 683    begin
 684       pragma Assert (Is_Tagged_Type (T));
 685       return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
 686    end Has_External_Tag_Rep_Clause;
 687
 688    ------------------
 689    -- Has_Rep_Item --
 690    ------------------
 691
 692    function Has_Rep_Item
 693      (E             : Entity_Id;
 694       Nam           : Name_Id;
 695       Check_Parents : Boolean := True) return Boolean
 696    is
 697    begin
 698       return Present (Get_Rep_Item (E, Nam, Check_Parents));
 699    end Has_Rep_Item;
 700
 701    function Has_Rep_Item
 702      (E             : Entity_Id;
 703       Nam1          : Name_Id;
 704       Nam2          : Name_Id;
 705       Check_Parents : Boolean := True) return Boolean
 706    is
 707    begin
 708       return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
 709    end Has_Rep_Item;
 710
 711    function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
 712       Item : Node_Id;
 713
 714    begin
 715       pragma Assert
 716         (Nkind_In (N, N_Aspect_Specification,
 717                       N_Attribute_Definition_Clause,
 718                       N_Enumeration_Representation_Clause,
 719                       N_Pragma,
 720                       N_Record_Representation_Clause));
 721
 722       Item := First_Rep_Item (E);
 723       while Present (Item) loop
 724          if Item = N then
 725             return True;
 726          end if;
 727
 728          Item := Next_Rep_Item (Item);
 729       end loop;
 730
 731       return False;
 732    end Has_Rep_Item;
 733
 734    --------------------
 735    -- Has_Rep_Pragma --
 736    --------------------
 737
 738    function Has_Rep_Pragma
 739      (E             : Entity_Id;
 740       Nam           : Name_Id;
 741       Check_Parents : Boolean := True) return Boolean
 742    is
 743    begin
 744       return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
 745    end Has_Rep_Pragma;
 746
 747    function Has_Rep_Pragma
 748      (E             : Entity_Id;
 749       Nam1          : Name_Id;
 750       Nam2          : Name_Id;
 751       Check_Parents : Boolean := True) return Boolean
 752    is
 753    begin
 754       return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
 755    end Has_Rep_Pragma;
 756
 757    --------------------------------
 758    -- Has_Unconstrained_Elements --
 759    --------------------------------
 760
 761    function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
 762       U_T : constant Entity_Id := Underlying_Type (T);
 763    begin
 764       if No (U_T) then
 765          return False;
 766       elsif Is_Record_Type (U_T) then
 767          return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
 768       elsif Is_Array_Type (U_T) then
 769          return Has_Unconstrained_Elements (Component_Type (U_T));
 770       else
 771          return False;
 772       end if;
 773    end Has_Unconstrained_Elements;
 774
 775    ----------------------
 776    -- Has_Variant_Part --
 777    ----------------------
 778
 779    function Has_Variant_Part (Typ : Entity_Id) return Boolean is
 780       FSTyp : Entity_Id;
 781       Decl  : Node_Id;
 782       TDef  : Node_Id;
 783       CList : Node_Id;
 784
 785    begin
 786       if not Is_Type (Typ) then
 787          return False;
 788       end if;
 789
 790       FSTyp := First_Subtype (Typ);
 791
 792       if not Has_Discriminants (FSTyp) then
 793          return False;
 794       end if;
 795
 796       --  Proceed with cautious checks here, return False if tree is not
 797       --  as expected (may be caused by prior errors).
 798
 799       Decl := Declaration_Node (FSTyp);
 800
 801       if Nkind (Decl) /= N_Full_Type_Declaration then
 802          return False;
 803       end if;
 804
 805       TDef := Type_Definition (Decl);
 806
 807       if Nkind (TDef) /= N_Record_Definition then
 808          return False;
 809       end if;
 810
 811       CList := Component_List (TDef);
 812
 813       if Nkind (CList) /= N_Component_List then
 814          return False;
 815       else
 816          return Present (Variant_Part (CList));
 817       end if;
 818    end Has_Variant_Part;
 819
 820    ---------------------
 821    -- In_Generic_Body --
 822    ---------------------
 823
 824    function In_Generic_Body (Id : Entity_Id) return Boolean is
 825       S : Entity_Id;
 826
 827    begin
 828       --  Climb scopes looking for generic body
 829
 830       S := Id;
 831       while Present (S) and then S /= Standard_Standard loop
 832
 833          --  Generic package body
 834
 835          if Ekind (S) = E_Generic_Package
 836            and then In_Package_Body (S)
 837          then
 838             return True;
 839
 840          --  Generic subprogram body
 841
 842          elsif Is_Subprogram (S)
 843            and then Nkind (Unit_Declaration_Node (S)) =
 844                       N_Generic_Subprogram_Declaration
 845          then
 846             return True;
 847          end if;
 848
 849          S := Scope (S);
 850       end loop;
 851
 852       --  False if top of scope stack without finding a generic body
 853
 854       return False;
 855    end In_Generic_Body;
 856
 857    -------------------------------
 858    -- Initialization_Suppressed --
 859    -------------------------------
 860
 861    function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
 862    begin
 863       return Suppress_Initialization (Typ)
 864         or else Suppress_Initialization (Base_Type (Typ));
 865    end Initialization_Suppressed;
 866
 867    ----------------
 868    -- Initialize --
 869    ----------------
 870
 871    procedure Initialize is
 872    begin
 873       Obsolescent_Warnings.Init;
 874    end Initialize;
 875
 876    -------------
 877    -- Is_Body --
 878    -------------
 879
 880    function Is_Body (N : Node_Id) return Boolean is
 881    begin
 882       return
 883         Nkind (N) in N_Body_Stub
 884           or else Nkind_In (N, N_Entry_Body,
 885                                N_Package_Body,
 886                                N_Protected_Body,
 887                                N_Subprogram_Body,
 888                                N_Task_Body);
 889    end Is_Body;
 890
 891    ---------------------
 892    -- Is_By_Copy_Type --
 893    ---------------------
 894
 895    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
 896    begin
 897       --  If Id is a private type whose full declaration has not been seen,
 898       --  we assume for now that it is not a By_Copy type. Clearly this
 899       --  attribute should not be used before the type is frozen, but it is
 900       --  needed to build the associated record of a protected type. Another
 901       --  place where some lookahead for a full view is needed ???
 902
 903       return
 904         Is_Elementary_Type (Ent)
 905           or else (Is_Private_Type (Ent)
 906                      and then Present (Underlying_Type (Ent))
 907                      and then Is_Elementary_Type (Underlying_Type (Ent)));
 908    end Is_By_Copy_Type;
 909
 910    --------------------------
 911    -- Is_By_Reference_Type --
 912    --------------------------
 913
 914    function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
 915       Btype : constant Entity_Id := Base_Type (Ent);
 916
 917    begin
 918       if Error_Posted (Ent) or else Error_Posted (Btype) then
 919          return False;
 920
 921       elsif Is_Private_Type (Btype) then
 922          declare
 923             Utyp : constant Entity_Id := Underlying_Type (Btype);
 924          begin
 925             if No (Utyp) then
 926                return False;
 927             else
 928                return Is_By_Reference_Type (Utyp);
 929             end if;
 930          end;
 931
 932       elsif Is_Incomplete_Type (Btype) then
 933          declare
 934             Ftyp : constant Entity_Id := Full_View (Btype);
 935          begin
 936             --  Return true for a tagged incomplete type built as a shadow
 937             --  entity in Build_Limited_Views. It can appear in the profile
 938             --  of a thunk and the back end needs to know how it is passed.
 939
 940             if No (Ftyp) then
 941                return Is_Tagged_Type (Btype);
 942             else
 943                return Is_By_Reference_Type (Ftyp);
 944             end if;
 945          end;
 946
 947       elsif Is_Concurrent_Type (Btype) then
 948          return True;
 949
 950       elsif Is_Record_Type (Btype) then
 951          if Is_Limited_Record (Btype)
 952            or else Is_Tagged_Type (Btype)
 953            or else Is_Volatile (Btype)
 954          then
 955             return True;
 956
 957          else
 958             declare
 959                C : Entity_Id;
 960
 961             begin
 962                C := First_Component (Btype);
 963                while Present (C) loop
 964
 965                   --  For each component, test if its type is a by reference
 966                   --  type and if its type is volatile. Also test the component
 967                   --  itself for being volatile. This happens for example when
 968                   --  a Volatile aspect is added to a component.
 969
 970                   if Is_By_Reference_Type (Etype (C))
 971                     or else Is_Volatile (Etype (C))
 972                     or else Is_Volatile (C)
 973                   then
 974                      return True;
 975                   end if;
 976
 977                   C := Next_Component (C);
 978                end loop;
 979             end;
 980
 981             return False;
 982          end if;
 983
 984       elsif Is_Array_Type (Btype) then
 985          return
 986            Is_Volatile (Btype)
 987              or else Is_By_Reference_Type (Component_Type (Btype))
 988              or else Is_Volatile (Component_Type (Btype))
 989              or else Has_Volatile_Components (Btype);
 990
 991       else
 992          return False;
 993       end if;
 994    end Is_By_Reference_Type;
 995
 996    -------------------------
 997    -- Is_Definite_Subtype --
 998    -------------------------
 999
1000    function Is_Definite_Subtype (T : Entity_Id) return Boolean is
1001       pragma Assert (Is_Type (T));
1002       K : constant Entity_Kind := Ekind (T);
1003
1004    begin
1005       if Is_Constrained (T) then
1006          return True;
1007
1008       elsif K in Array_Kind
1009         or else K in Class_Wide_Kind
1010         or else Has_Unknown_Discriminants (T)
1011       then
1012          return False;
1013
1014       --  Known discriminants: definite if there are default values. Note that
1015       --  if any discriminant has a default, they all do.
1016
1017       elsif Has_Discriminants (T) then
1018          return Present (Discriminant_Default_Value (First_Discriminant (T)));
1019
1020       else
1021          return True;
1022       end if;
1023    end Is_Definite_Subtype;
1024
1025    ---------------------
1026    -- Is_Derived_Type --
1027    ---------------------
1028
1029    function Is_Derived_Type (Ent : E) return B is
1030       Par : Node_Id;
1031
1032    begin
1033       if Is_Type (Ent)
1034         and then Base_Type (Ent) /= Root_Type (Ent)
1035         and then not Is_Class_Wide_Type (Ent)
1036
1037         --  An access_to_subprogram whose result type is a limited view can
1038         --  appear in a return statement, without the full view of the result
1039         --  type being available. Do not interpret this as a derived type.
1040
1041         and then Ekind (Ent) /= E_Subprogram_Type
1042       then
1043          if not Is_Numeric_Type (Root_Type (Ent)) then
1044             return True;
1045
1046          else
1047             Par := Parent (First_Subtype (Ent));
1048
1049             return Present (Par)
1050               and then Nkind (Par) = N_Full_Type_Declaration
1051               and then Nkind (Type_Definition (Par)) =
1052                          N_Derived_Type_Definition;
1053          end if;
1054
1055       else
1056          return False;
1057       end if;
1058    end Is_Derived_Type;
1059
1060    -----------------------
1061    -- Is_Generic_Formal --
1062    -----------------------
1063
1064    function Is_Generic_Formal (E : Entity_Id) return Boolean is
1065       Kind : Node_Kind;
1066    begin
1067       if No (E) then
1068          return False;
1069       else
1070          Kind := Nkind (Parent (E));
1071          return
1072            Nkind_In (Kind, N_Formal_Object_Declaration,
1073                            N_Formal_Package_Declaration,
1074                            N_Formal_Type_Declaration)
1075              or else Is_Formal_Subprogram (E);
1076       end if;
1077    end Is_Generic_Formal;
1078
1079    -------------------------------
1080    -- Is_Immutably_Limited_Type --
1081    -------------------------------
1082
1083    function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
1084       Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1085
1086    begin
1087       if Is_Limited_Record (Btype) then
1088          return True;
1089
1090       elsif Ekind (Btype) = E_Limited_Private_Type
1091         and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1092       then
1093          return not In_Package_Body (Scope ((Btype)));
1094
1095       elsif Is_Private_Type (Btype) then
1096
1097          --  AI05-0063: A type derived from a limited private formal type is
1098          --  not immutably limited in a generic body.
1099
1100          if Is_Derived_Type (Btype)
1101            and then Is_Generic_Type (Etype (Btype))
1102          then
1103             if not Is_Limited_Type (Etype (Btype)) then
1104                return False;
1105
1106             --  A descendant of a limited formal type is not immutably limited
1107             --  in the generic body, or in the body of a generic child.
1108
1109             elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1110                return not In_Package_Body (Scope (Btype));
1111
1112             else
1113                return False;
1114             end if;
1115
1116          else
1117             declare
1118                Utyp : constant Entity_Id := Underlying_Type (Btype);
1119             begin
1120                if No (Utyp) then
1121                   return False;
1122                else
1123                   return Is_Immutably_Limited_Type (Utyp);
1124                end if;
1125             end;
1126          end if;
1127
1128       elsif Is_Concurrent_Type (Btype) then
1129          return True;
1130
1131       else
1132          return False;
1133       end if;
1134    end Is_Immutably_Limited_Type;
1135
1136    ---------------------
1137    -- Is_Limited_Type --
1138    ---------------------
1139
1140    function Is_Limited_Type (Ent : Entity_Id) return Boolean is
1141       Btype : constant E := Base_Type (Ent);
1142       Rtype : constant E := Root_Type (Btype);
1143
1144    begin
1145       if not Is_Type (Ent) then
1146          return False;
1147
1148       elsif Ekind (Btype) = E_Limited_Private_Type
1149         or else Is_Limited_Composite (Btype)
1150       then
1151          return True;
1152
1153       elsif Is_Concurrent_Type (Btype) then
1154          return True;
1155
1156          --  The Is_Limited_Record flag normally indicates that the type is
1157          --  limited. The exception is that a type does not inherit limitedness
1158          --  from its interface ancestor. So the type may be derived from a
1159          --  limited interface, but is not limited.
1160
1161       elsif Is_Limited_Record (Ent)
1162         and then not Is_Interface (Ent)
1163       then
1164          return True;
1165
1166       --  Otherwise we will look around to see if there is some other reason
1167       --  for it to be limited, except that if an error was posted on the
1168       --  entity, then just assume it is non-limited, because it can cause
1169       --  trouble to recurse into a murky entity resulting from other errors.
1170
1171       elsif Error_Posted (Ent) then
1172          return False;
1173
1174       elsif Is_Record_Type (Btype) then
1175
1176          if Is_Limited_Interface (Ent) then
1177             return True;
1178
1179          --  AI-419: limitedness is not inherited from a limited interface
1180
1181          elsif Is_Limited_Record (Rtype) then
1182             return not Is_Interface (Rtype)
1183               or else Is_Protected_Interface (Rtype)
1184               or else Is_Synchronized_Interface (Rtype)
1185               or else Is_Task_Interface (Rtype);
1186
1187          elsif Is_Class_Wide_Type (Btype) then
1188             return Is_Limited_Type (Rtype);
1189
1190          else
1191             declare
1192                C : E;
1193
1194             begin
1195                C := First_Component (Btype);
1196                while Present (C) loop
1197                   if Is_Limited_Type (Etype (C)) then
1198                      return True;
1199                   end if;
1200
1201                   C := Next_Component (C);
1202                end loop;
1203             end;
1204
1205             return False;
1206          end if;
1207
1208       elsif Is_Array_Type (Btype) then
1209          return Is_Limited_Type (Component_Type (Btype));
1210
1211       else
1212          return False;
1213       end if;
1214    end Is_Limited_Type;
1215
1216    ---------------------
1217    -- Is_Limited_View --
1218    ---------------------
1219
1220    function Is_Limited_View (Ent : Entity_Id) return Boolean is
1221       Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1222
1223    begin
1224       if Is_Limited_Record (Btype) then
1225          return True;
1226
1227       elsif Ekind (Btype) = E_Limited_Private_Type
1228         and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1229       then
1230          return not In_Package_Body (Scope ((Btype)));
1231
1232       elsif Is_Private_Type (Btype) then
1233
1234          --  AI05-0063: A type derived from a limited private formal type is
1235          --  not immutably limited in a generic body.
1236
1237          if Is_Derived_Type (Btype)
1238            and then Is_Generic_Type (Etype (Btype))
1239          then
1240             if not Is_Limited_Type (Etype (Btype)) then
1241                return False;
1242
1243             --  A descendant of a limited formal type is not immutably limited
1244             --  in the generic body, or in the body of a generic child.
1245
1246             elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1247                return not In_Package_Body (Scope (Btype));
1248
1249             else
1250                return False;
1251             end if;
1252
1253          else
1254             declare
1255                Utyp : constant Entity_Id := Underlying_Type (Btype);
1256             begin
1257                if No (Utyp) then
1258                   return False;
1259                else
1260                   return Is_Limited_View (Utyp);
1261                end if;
1262             end;
1263          end if;
1264
1265       elsif Is_Concurrent_Type (Btype) then
1266          return True;
1267
1268       elsif Is_Record_Type (Btype) then
1269
1270          --  Note that we return True for all limited interfaces, even though
1271          --  (unsynchronized) limited interfaces can have descendants that are
1272          --  nonlimited, because this is a predicate on the type itself, and
1273          --  things like functions with limited interface results need to be
1274          --  handled as build in place even though they might return objects
1275          --  of a type that is not inherently limited.
1276
1277          if Is_Class_Wide_Type (Btype) then
1278             return Is_Limited_View (Root_Type (Btype));
1279
1280          else
1281             declare
1282                C : Entity_Id;
1283
1284             begin
1285                C := First_Component (Btype);
1286                while Present (C) loop
1287
1288                   --  Don't consider components with interface types (which can
1289                   --  only occur in the case of a _parent component anyway).
1290                   --  They don't have any components, plus it would cause this
1291                   --  function to return true for nonlimited types derived from
1292                   --  limited interfaces.
1293
1294                   if not Is_Interface (Etype (C))
1295                     and then Is_Limited_View (Etype (C))
1296                   then
1297                      return True;
1298                   end if;
1299
1300                   C := Next_Component (C);
1301                end loop;
1302             end;
1303
1304             return False;
1305          end if;
1306
1307       elsif Is_Array_Type (Btype) then
1308          return Is_Limited_View (Component_Type (Btype));
1309
1310       else
1311          return False;
1312       end if;
1313    end Is_Limited_View;
1314
1315    ----------------------
1316    -- Nearest_Ancestor --
1317    ----------------------
1318
1319    function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1320       D : constant Node_Id := Declaration_Node (Typ);
1321
1322    begin
1323       --  If we have a subtype declaration, get the ancestor subtype
1324
1325       if Nkind (D) = N_Subtype_Declaration then
1326          if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1327             return Entity (Subtype_Mark (Subtype_Indication (D)));
1328          else
1329             return Entity (Subtype_Indication (D));
1330          end if;
1331
1332       --  If derived type declaration, find who we are derived from
1333
1334       elsif Nkind (D) = N_Full_Type_Declaration
1335         and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1336       then
1337          declare
1338             DTD : constant Entity_Id := Type_Definition (D);
1339             SI  : constant Entity_Id := Subtype_Indication (DTD);
1340          begin
1341             if Is_Entity_Name (SI) then
1342                return Entity (SI);
1343             else
1344                return Entity (Subtype_Mark (SI));
1345             end if;
1346          end;
1347
1348       --  If derived type and private type, get the full view to find who we
1349       --  are derived from.
1350
1351       elsif Is_Derived_Type (Typ)
1352         and then Is_Private_Type (Typ)
1353         and then Present (Full_View (Typ))
1354       then
1355          return Nearest_Ancestor (Full_View (Typ));
1356
1357       --  Otherwise, nothing useful to return, return Empty
1358
1359       else
1360          return Empty;
1361       end if;
1362    end Nearest_Ancestor;
1363
1364    ---------------------------
1365    -- Nearest_Dynamic_Scope --
1366    ---------------------------
1367
1368    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1369    begin
1370       if Is_Dynamic_Scope (Ent) then
1371          return Ent;
1372       else
1373          return Enclosing_Dynamic_Scope (Ent);
1374       end if;
1375    end Nearest_Dynamic_Scope;
1376
1377    ------------------------
1378    -- Next_Tag_Component --
1379    ------------------------
1380
1381    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1382       Comp : Entity_Id;
1383
1384    begin
1385       pragma Assert (Is_Tag (Tag));
1386
1387       --  Loop to look for next tag component
1388
1389       Comp := Next_Entity (Tag);
1390       while Present (Comp) loop
1391          if Is_Tag (Comp) then
1392             pragma Assert (Chars (Comp) /= Name_uTag);
1393             return Comp;
1394          end if;
1395
1396          Comp := Next_Entity (Comp);
1397       end loop;
1398
1399       --  No tag component found
1400
1401       return Empty;
1402    end Next_Tag_Component;
1403
1404    -----------------------
1405    -- Number_Components --
1406    -----------------------
1407
1408    function Number_Components (Typ : Entity_Id) return Nat is
1409       N    : Nat := 0;
1410       Comp : Entity_Id;
1411
1412    begin
1413       --  We do not call Einfo.First_Component_Or_Discriminant, as this
1414       --  function does not skip completely hidden discriminants, which we
1415       --  want to skip here.
1416
1417       if Has_Discriminants (Typ) then
1418          Comp := First_Discriminant (Typ);
1419       else
1420          Comp := First_Component (Typ);
1421       end if;
1422
1423       while Present (Comp) loop
1424          N := N + 1;
1425          Comp := Next_Component_Or_Discriminant (Comp);
1426       end loop;
1427
1428       return N;
1429    end Number_Components;
1430
1431    --------------------------
1432    -- Number_Discriminants --
1433    --------------------------
1434
1435    function Number_Discriminants (Typ : Entity_Id) return Pos is
1436       N     : Nat       := 0;
1437       Discr : Entity_Id := First_Discriminant (Typ);
1438
1439    begin
1440       while Present (Discr) loop
1441          N := N + 1;
1442          Discr := Next_Discriminant (Discr);
1443       end loop;
1444
1445       return N;
1446    end Number_Discriminants;
1447
1448    ----------------------------------------------
1449    -- Object_Type_Has_Constrained_Partial_View --
1450    ----------------------------------------------
1451
1452    function Object_Type_Has_Constrained_Partial_View
1453      (Typ  : Entity_Id;
1454       Scop : Entity_Id) return Boolean
1455    is
1456    begin
1457       return Has_Constrained_Partial_View (Typ)
1458         or else (In_Generic_Body (Scop)
1459                   and then Is_Generic_Type (Base_Type (Typ))
1460                   and then Is_Private_Type (Base_Type (Typ))
1461                   and then not Is_Tagged_Type (Typ)
1462                   and then not (Is_Array_Type (Typ)
1463                                  and then not Is_Constrained (Typ))
1464                   and then Has_Discriminants (Typ));
1465    end Object_Type_Has_Constrained_Partial_View;
1466
1467    ------------------
1468    -- Package_Body --
1469    ------------------
1470
1471    function Package_Body (E : Entity_Id) return Node_Id is
1472       N : Node_Id;
1473
1474    begin
1475       if Ekind (E) = E_Package_Body then
1476          N := Parent (E);
1477
1478          if Nkind (N) = N_Defining_Program_Unit_Name then
1479             N := Parent (N);
1480          end if;
1481
1482       else
1483          N := Package_Spec (E);
1484
1485          if Present (Corresponding_Body (N)) then
1486             N := Parent (Corresponding_Body (N));
1487
1488             if Nkind (N) = N_Defining_Program_Unit_Name then
1489                N := Parent (N);
1490             end if;
1491          else
1492             N := Empty;
1493          end if;
1494       end if;
1495
1496       return N;
1497    end Package_Body;
1498
1499    ------------------
1500    -- Package_Spec --
1501    ------------------
1502
1503    function Package_Spec (E : Entity_Id) return Node_Id is
1504    begin
1505       return Parent (Package_Specification (E));
1506    end Package_Spec;
1507
1508    ---------------------------
1509    -- Package_Specification --
1510    ---------------------------
1511
1512    function Package_Specification (E : Entity_Id) return Node_Id is
1513       N : Node_Id;
1514
1515    begin
1516       N := Parent (E);
1517
1518       if Nkind (N) = N_Defining_Program_Unit_Name then
1519          N := Parent (N);
1520       end if;
1521
1522       return N;
1523    end Package_Specification;
1524
1525    ---------------------
1526    -- Subprogram_Body --
1527    ---------------------
1528
1529    function Subprogram_Body (E : Entity_Id) return Node_Id is
1530       Body_E : constant Entity_Id := Subprogram_Body_Entity (E);
1531
1532    begin
1533       if No (Body_E) then
1534          return Empty;
1535       else
1536          return Parent (Subprogram_Specification (Body_E));
1537       end if;
1538    end Subprogram_Body;
1539
1540    ----------------------------
1541    -- Subprogram_Body_Entity --
1542    ----------------------------
1543
1544    function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
1545       N : constant Node_Id := Parent (Subprogram_Specification (E));
1546       --  Declaration for E
1547
1548    begin
1549       --  If this declaration is not a subprogram body, then it must be a
1550       --  subprogram declaration or body stub, from which we can retrieve the
1551       --  entity for the corresponding subprogram body if any, or an abstract
1552       --  subprogram declaration, for which we return Empty.
1553
1554       case Nkind (N) is
1555          when N_Subprogram_Body =>
1556             return E;
1557
1558          when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1559             return Corresponding_Body (N);
1560
1561          when others =>
1562             return Empty;
1563       end case;
1564    end Subprogram_Body_Entity;
1565
1566    ---------------------
1567    -- Subprogram_Spec --
1568    ---------------------
1569
1570    function Subprogram_Spec (E : Entity_Id) return Node_Id is
1571       N : constant Node_Id := Parent (Subprogram_Specification (E));
1572       --  Declaration for E
1573
1574    begin
1575       --  This declaration is either subprogram declaration or a subprogram
1576       --  body, in which case return Empty.
1577
1578       if Nkind (N) = N_Subprogram_Declaration then
1579          return N;
1580       else
1581          return Empty;
1582       end if;
1583    end Subprogram_Spec;
1584
1585    ------------------------------
1586    -- Subprogram_Specification --
1587    ------------------------------
1588
1589    function Subprogram_Specification (E : Entity_Id) return Node_Id is
1590       N : Node_Id;
1591
1592    begin
1593       N := Parent (E);
1594
1595       if Nkind (N) = N_Defining_Program_Unit_Name then
1596          N := Parent (N);
1597       end if;
1598
1599       --  If the Parent pointer of E is not a subprogram specification node
1600       --  (going through an intermediate N_Defining_Program_Unit_Name node
1601       --  for subprogram units), then E is an inherited operation. Its parent
1602       --  points to the type derivation that produces the inheritance: that's
1603       --  the node that generates the subprogram specification. Its alias
1604       --  is the parent subprogram, and that one points to a subprogram
1605       --  declaration, or to another type declaration if this is a hierarchy
1606       --  of derivations.
1607
1608       if Nkind (N) not in N_Subprogram_Specification then
1609          pragma Assert (Present (Alias (E)));
1610          N := Subprogram_Specification (Alias (E));
1611       end if;
1612
1613       return N;
1614    end Subprogram_Specification;
1615
1616    ---------------
1617    -- Tree_Read --
1618    ---------------
1619
1620    procedure Tree_Read is
1621    begin
1622       Obsolescent_Warnings.Tree_Read;
1623    end Tree_Read;
1624
1625    ----------------
1626    -- Tree_Write --
1627    ----------------
1628
1629    procedure Tree_Write is
1630    begin
1631       Obsolescent_Warnings.Tree_Write;
1632    end Tree_Write;
1633
1634    --------------------
1635    -- Ultimate_Alias --
1636    --------------------
1637
1638    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1639       E : Entity_Id := Prim;
1640
1641    begin
1642       while Present (Alias (E)) loop
1643          pragma Assert (Alias (E) /= E);
1644          E := Alias (E);
1645       end loop;
1646
1647       return E;
1648    end Ultimate_Alias;
1649
1650    --------------------------
1651    -- Unit_Declaration_Node --
1652    --------------------------
1653
1654    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1655       N : Node_Id := Parent (Unit_Id);
1656
1657    begin
1658       --  Predefined operators do not have a full function declaration
1659
1660       if Ekind (Unit_Id) = E_Operator then
1661          return N;
1662       end if;
1663
1664       --  Isn't there some better way to express the following ???
1665
1666       while Nkind (N) /= N_Abstract_Subprogram_Declaration
1667         and then Nkind (N) /= N_Entry_Body
1668         and then Nkind (N) /= N_Entry_Declaration
1669         and then Nkind (N) /= N_Formal_Package_Declaration
1670         and then Nkind (N) /= N_Function_Instantiation
1671         and then Nkind (N) /= N_Generic_Package_Declaration
1672         and then Nkind (N) /= N_Generic_Subprogram_Declaration
1673         and then Nkind (N) /= N_Package_Declaration
1674         and then Nkind (N) /= N_Package_Body
1675         and then Nkind (N) /= N_Package_Instantiation
1676         and then Nkind (N) /= N_Package_Renaming_Declaration
1677         and then Nkind (N) /= N_Procedure_Instantiation
1678         and then Nkind (N) /= N_Protected_Body
1679         and then Nkind (N) /= N_Subprogram_Declaration
1680         and then Nkind (N) /= N_Subprogram_Body
1681         and then Nkind (N) /= N_Subprogram_Body_Stub
1682         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1683         and then Nkind (N) /= N_Task_Body
1684         and then Nkind (N) /= N_Task_Type_Declaration
1685         and then Nkind (N) not in N_Formal_Subprogram_Declaration
1686         and then Nkind (N) not in N_Generic_Renaming_Declaration
1687       loop
1688          N := Parent (N);
1689
1690          --  We don't use Assert here, because that causes an infinite loop
1691          --  when assertions are turned off. Better to crash.
1692
1693          if No (N) then
1694             raise Program_Error;
1695          end if;
1696       end loop;
1697
1698       return N;
1699    end Unit_Declaration_Node;
1700
1701 end Sem_Aux;