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-2017, 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      => return N_Op_Add;
 442          when Name_Op_Concat   => return N_Op_Concat;
 443          when Name_Op_Expon    => return N_Op_Expon;
 444          when Name_Op_Subtract => return N_Op_Subtract;
 445          when Name_Op_Mod      => return N_Op_Mod;
 446          when Name_Op_Multiply => return N_Op_Multiply;
 447          when Name_Op_Divide   => return N_Op_Divide;
 448          when Name_Op_Rem      => return N_Op_Rem;
 449          when Name_Op_And      => return N_Op_And;
 450          when Name_Op_Eq       => return N_Op_Eq;
 451          when Name_Op_Ge       => return N_Op_Ge;
 452          when Name_Op_Gt       => return N_Op_Gt;
 453          when Name_Op_Le       => return N_Op_Le;
 454          when Name_Op_Lt       => return N_Op_Lt;
 455          when Name_Op_Ne       => return N_Op_Ne;
 456          when Name_Op_Or       => return N_Op_Or;
 457          when Name_Op_Xor      => return N_Op_Xor;
 458          when others           => raise Program_Error;
 459       end case;
 460    end Get_Binary_Nkind;
 461
 462    -----------------------
 463    -- Get_Called_Entity --
 464    -----------------------
 465
 466    function Get_Called_Entity (Call : Node_Id) return Entity_Id is
 467       Nam : constant Node_Id := Name (Call);
 468       Id  : Entity_Id;
 469
 470    begin
 471       if Nkind (Nam) = N_Explicit_Dereference then
 472          Id := Etype (Nam);
 473          pragma Assert (Ekind (Id) = E_Subprogram_Type);
 474
 475       elsif Nkind (Nam) = N_Selected_Component then
 476          Id := Entity (Selector_Name (Nam));
 477
 478       elsif Nkind (Nam) = N_Indexed_Component then
 479          Id := Entity (Selector_Name (Prefix (Nam)));
 480
 481       else
 482          Id := Entity (Nam);
 483       end if;
 484
 485       return Id;
 486    end Get_Called_Entity;
 487
 488    -------------------
 489    -- Get_Low_Bound --
 490    -------------------
 491
 492    function Get_Low_Bound (E : Entity_Id) return Node_Id is
 493    begin
 494       if Ekind (E) = E_String_Literal_Subtype then
 495          return String_Literal_Low_Bound (E);
 496       else
 497          return Type_Low_Bound (E);
 498       end if;
 499    end Get_Low_Bound;
 500
 501    ------------------
 502    -- Get_Rep_Item --
 503    ------------------
 504
 505    function Get_Rep_Item
 506      (E             : Entity_Id;
 507       Nam           : Name_Id;
 508       Check_Parents : Boolean := True) return Node_Id
 509    is
 510       N : Node_Id;
 511
 512    begin
 513       N := First_Rep_Item (E);
 514       while Present (N) loop
 515
 516          --  Only one of Priority / Interrupt_Priority can be specified, so
 517          --  return whichever one is present to catch illegal duplication.
 518
 519          if Nkind (N) = N_Pragma
 520            and then
 521              (Pragma_Name_Unmapped (N) = Nam
 522                or else (Nam = Name_Priority
 523                          and then Pragma_Name (N) =
 524                            Name_Interrupt_Priority)
 525                or else (Nam = Name_Interrupt_Priority
 526                          and then Pragma_Name (N) = Name_Priority))
 527          then
 528             if Check_Parents then
 529                return N;
 530
 531             --  If Check_Parents is False, return N if the pragma doesn't
 532             --  appear in the Rep_Item chain of the parent.
 533
 534             else
 535                declare
 536                   Par : constant Entity_Id := Nearest_Ancestor (E);
 537                   --  This node represents the parent type of type E (if any)
 538
 539                begin
 540                   if No (Par) then
 541                      return N;
 542
 543                   elsif not Present_In_Rep_Item (Par, N) then
 544                      return N;
 545                   end if;
 546                end;
 547             end if;
 548
 549          elsif Nkind (N) = N_Attribute_Definition_Clause
 550            and then
 551              (Chars (N) = Nam
 552                or else (Nam = Name_Priority
 553                          and then Chars (N) = Name_Interrupt_Priority))
 554          then
 555             if Check_Parents or else Entity (N) = E then
 556                return N;
 557             end if;
 558
 559          elsif Nkind (N) = N_Aspect_Specification
 560            and then
 561              (Chars (Identifier (N)) = Nam
 562                or else
 563                  (Nam = Name_Priority
 564                    and then Chars (Identifier (N)) = Name_Interrupt_Priority))
 565          then
 566             if Check_Parents then
 567                return N;
 568
 569             elsif Entity (N) = E then
 570                return N;
 571             end if;
 572          end if;
 573
 574          Next_Rep_Item (N);
 575       end loop;
 576
 577       return Empty;
 578    end Get_Rep_Item;
 579
 580    function Get_Rep_Item
 581      (E             : Entity_Id;
 582       Nam1          : Name_Id;
 583       Nam2          : Name_Id;
 584       Check_Parents : Boolean := True) return Node_Id
 585    is
 586       Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
 587       Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
 588
 589       N : Node_Id;
 590
 591    begin
 592       --  Check both Nam1_Item and Nam2_Item are present
 593
 594       if No (Nam1_Item) then
 595          return Nam2_Item;
 596       elsif No (Nam2_Item) then
 597          return Nam1_Item;
 598       end if;
 599
 600       --  Return the first node encountered in the list
 601
 602       N := First_Rep_Item (E);
 603       while Present (N) loop
 604          if N = Nam1_Item or else N = Nam2_Item then
 605             return N;
 606          end if;
 607
 608          Next_Rep_Item (N);
 609       end loop;
 610
 611       return Empty;
 612    end Get_Rep_Item;
 613
 614    --------------------
 615    -- Get_Rep_Pragma --
 616    --------------------
 617
 618    function Get_Rep_Pragma
 619      (E             : Entity_Id;
 620       Nam           : Name_Id;
 621       Check_Parents : Boolean := True) return Node_Id
 622    is
 623       N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents);
 624
 625    begin
 626       if Present (N) and then Nkind (N) = N_Pragma then
 627          return N;
 628       end if;
 629
 630       return Empty;
 631    end Get_Rep_Pragma;
 632
 633    function Get_Rep_Pragma
 634      (E             : Entity_Id;
 635       Nam1          : Name_Id;
 636       Nam2          : Name_Id;
 637       Check_Parents : Boolean := True) return Node_Id
 638    is
 639       Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
 640       Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
 641
 642       N : Node_Id;
 643
 644    begin
 645       --  Check both Nam1_Item and Nam2_Item are present
 646
 647       if No (Nam1_Item) then
 648          return Nam2_Item;
 649       elsif No (Nam2_Item) then
 650          return Nam1_Item;
 651       end if;
 652
 653       --  Return the first node encountered in the list
 654
 655       N := First_Rep_Item (E);
 656       while Present (N) loop
 657          if N = Nam1_Item or else N = Nam2_Item then
 658             return N;
 659          end if;
 660
 661          Next_Rep_Item (N);
 662       end loop;
 663
 664       return Empty;
 665    end Get_Rep_Pragma;
 666
 667    ---------------------
 668    -- Get_Unary_Nkind --
 669    ---------------------
 670
 671    function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
 672    begin
 673       case Chars (Op) is
 674          when Name_Op_Abs      => return N_Op_Abs;
 675          when Name_Op_Subtract => return N_Op_Minus;
 676          when Name_Op_Not      => return N_Op_Not;
 677          when Name_Op_Add      => return N_Op_Plus;
 678          when others           => raise Program_Error;
 679       end case;
 680    end Get_Unary_Nkind;
 681
 682    ---------------------------------
 683    -- Has_External_Tag_Rep_Clause --
 684    ---------------------------------
 685
 686    function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
 687    begin
 688       pragma Assert (Is_Tagged_Type (T));
 689       return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
 690    end Has_External_Tag_Rep_Clause;
 691
 692    ------------------
 693    -- Has_Rep_Item --
 694    ------------------
 695
 696    function Has_Rep_Item
 697      (E             : Entity_Id;
 698       Nam           : Name_Id;
 699       Check_Parents : Boolean := True) return Boolean
 700    is
 701    begin
 702       return Present (Get_Rep_Item (E, Nam, Check_Parents));
 703    end Has_Rep_Item;
 704
 705    function Has_Rep_Item
 706      (E             : Entity_Id;
 707       Nam1          : Name_Id;
 708       Nam2          : Name_Id;
 709       Check_Parents : Boolean := True) return Boolean
 710    is
 711    begin
 712       return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
 713    end Has_Rep_Item;
 714
 715    function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
 716       Item : Node_Id;
 717
 718    begin
 719       pragma Assert
 720         (Nkind_In (N, N_Aspect_Specification,
 721                       N_Attribute_Definition_Clause,
 722                       N_Enumeration_Representation_Clause,
 723                       N_Pragma,
 724                       N_Record_Representation_Clause));
 725
 726       Item := First_Rep_Item (E);
 727       while Present (Item) loop
 728          if Item = N then
 729             return True;
 730          end if;
 731
 732          Item := Next_Rep_Item (Item);
 733       end loop;
 734
 735       return False;
 736    end Has_Rep_Item;
 737
 738    --------------------
 739    -- Has_Rep_Pragma --
 740    --------------------
 741
 742    function Has_Rep_Pragma
 743      (E             : Entity_Id;
 744       Nam           : Name_Id;
 745       Check_Parents : Boolean := True) return Boolean
 746    is
 747    begin
 748       return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
 749    end Has_Rep_Pragma;
 750
 751    function Has_Rep_Pragma
 752      (E             : Entity_Id;
 753       Nam1          : Name_Id;
 754       Nam2          : Name_Id;
 755       Check_Parents : Boolean := True) return Boolean
 756    is
 757    begin
 758       return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
 759    end Has_Rep_Pragma;
 760
 761    --------------------------------
 762    -- Has_Unconstrained_Elements --
 763    --------------------------------
 764
 765    function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
 766       U_T : constant Entity_Id := Underlying_Type (T);
 767    begin
 768       if No (U_T) then
 769          return False;
 770       elsif Is_Record_Type (U_T) then
 771          return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
 772       elsif Is_Array_Type (U_T) then
 773          return Has_Unconstrained_Elements (Component_Type (U_T));
 774       else
 775          return False;
 776       end if;
 777    end Has_Unconstrained_Elements;
 778
 779    ----------------------
 780    -- Has_Variant_Part --
 781    ----------------------
 782
 783    function Has_Variant_Part (Typ : Entity_Id) return Boolean is
 784       FSTyp : Entity_Id;
 785       Decl  : Node_Id;
 786       TDef  : Node_Id;
 787       CList : Node_Id;
 788
 789    begin
 790       if not Is_Type (Typ) then
 791          return False;
 792       end if;
 793
 794       FSTyp := First_Subtype (Typ);
 795
 796       if not Has_Discriminants (FSTyp) then
 797          return False;
 798       end if;
 799
 800       --  Proceed with cautious checks here, return False if tree is not
 801       --  as expected (may be caused by prior errors).
 802
 803       Decl := Declaration_Node (FSTyp);
 804
 805       if Nkind (Decl) /= N_Full_Type_Declaration then
 806          return False;
 807       end if;
 808
 809       TDef := Type_Definition (Decl);
 810
 811       if Nkind (TDef) /= N_Record_Definition then
 812          return False;
 813       end if;
 814
 815       CList := Component_List (TDef);
 816
 817       if Nkind (CList) /= N_Component_List then
 818          return False;
 819       else
 820          return Present (Variant_Part (CList));
 821       end if;
 822    end Has_Variant_Part;
 823
 824    ---------------------
 825    -- In_Generic_Body --
 826    ---------------------
 827
 828    function In_Generic_Body (Id : Entity_Id) return Boolean is
 829       S : Entity_Id;
 830
 831    begin
 832       --  Climb scopes looking for generic body
 833
 834       S := Id;
 835       while Present (S) and then S /= Standard_Standard loop
 836
 837          --  Generic package body
 838
 839          if Ekind (S) = E_Generic_Package
 840            and then In_Package_Body (S)
 841          then
 842             return True;
 843
 844          --  Generic subprogram body
 845
 846          elsif Is_Subprogram (S)
 847            and then Nkind (Unit_Declaration_Node (S)) =
 848                       N_Generic_Subprogram_Declaration
 849          then
 850             return True;
 851          end if;
 852
 853          S := Scope (S);
 854       end loop;
 855
 856       --  False if top of scope stack without finding a generic body
 857
 858       return False;
 859    end In_Generic_Body;
 860
 861    -------------------------------
 862    -- Initialization_Suppressed --
 863    -------------------------------
 864
 865    function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
 866    begin
 867       return Suppress_Initialization (Typ)
 868         or else Suppress_Initialization (Base_Type (Typ));
 869    end Initialization_Suppressed;
 870
 871    ----------------
 872    -- Initialize --
 873    ----------------
 874
 875    procedure Initialize is
 876    begin
 877       Obsolescent_Warnings.Init;
 878    end Initialize;
 879
 880    -------------
 881    -- Is_Body --
 882    -------------
 883
 884    function Is_Body (N : Node_Id) return Boolean is
 885    begin
 886       return
 887         Nkind (N) in N_Body_Stub
 888           or else Nkind_In (N, N_Entry_Body,
 889                                N_Package_Body,
 890                                N_Protected_Body,
 891                                N_Subprogram_Body,
 892                                N_Task_Body);
 893    end Is_Body;
 894
 895    ---------------------
 896    -- Is_By_Copy_Type --
 897    ---------------------
 898
 899    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
 900    begin
 901       --  If Id is a private type whose full declaration has not been seen,
 902       --  we assume for now that it is not a By_Copy type. Clearly this
 903       --  attribute should not be used before the type is frozen, but it is
 904       --  needed to build the associated record of a protected type. Another
 905       --  place where some lookahead for a full view is needed ???
 906
 907       return
 908         Is_Elementary_Type (Ent)
 909           or else (Is_Private_Type (Ent)
 910                      and then Present (Underlying_Type (Ent))
 911                      and then Is_Elementary_Type (Underlying_Type (Ent)));
 912    end Is_By_Copy_Type;
 913
 914    --------------------------
 915    -- Is_By_Reference_Type --
 916    --------------------------
 917
 918    function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
 919       Btype : constant Entity_Id := Base_Type (Ent);
 920
 921    begin
 922       if Error_Posted (Ent) or else Error_Posted (Btype) then
 923          return False;
 924
 925       elsif Is_Private_Type (Btype) then
 926          declare
 927             Utyp : constant Entity_Id := Underlying_Type (Btype);
 928          begin
 929             if No (Utyp) then
 930                return False;
 931             else
 932                return Is_By_Reference_Type (Utyp);
 933             end if;
 934          end;
 935
 936       elsif Is_Incomplete_Type (Btype) then
 937          declare
 938             Ftyp : constant Entity_Id := Full_View (Btype);
 939          begin
 940             --  Return true for a tagged incomplete type built as a shadow
 941             --  entity in Build_Limited_Views. It can appear in the profile
 942             --  of a thunk and the back end needs to know how it is passed.
 943
 944             if No (Ftyp) then
 945                return Is_Tagged_Type (Btype);
 946             else
 947                return Is_By_Reference_Type (Ftyp);
 948             end if;
 949          end;
 950
 951       elsif Is_Concurrent_Type (Btype) then
 952          return True;
 953
 954       elsif Is_Record_Type (Btype) then
 955          if Is_Limited_Record (Btype)
 956            or else Is_Tagged_Type (Btype)
 957            or else Is_Volatile (Btype)
 958          then
 959             return True;
 960
 961          else
 962             declare
 963                C : Entity_Id;
 964
 965             begin
 966                C := First_Component (Btype);
 967                while Present (C) loop
 968
 969                   --  For each component, test if its type is a by reference
 970                   --  type and if its type is volatile. Also test the component
 971                   --  itself for being volatile. This happens for example when
 972                   --  a Volatile aspect is added to a component.
 973
 974                   if Is_By_Reference_Type (Etype (C))
 975                     or else Is_Volatile (Etype (C))
 976                     or else Is_Volatile (C)
 977                   then
 978                      return True;
 979                   end if;
 980
 981                   C := Next_Component (C);
 982                end loop;
 983             end;
 984
 985             return False;
 986          end if;
 987
 988       elsif Is_Array_Type (Btype) then
 989          return
 990            Is_Volatile (Btype)
 991              or else Is_By_Reference_Type (Component_Type (Btype))
 992              or else Is_Volatile (Component_Type (Btype))
 993              or else Has_Volatile_Components (Btype);
 994
 995       else
 996          return False;
 997       end if;
 998    end Is_By_Reference_Type;
 999
1000    -------------------------
1001    -- Is_Definite_Subtype --
1002    -------------------------
1003
1004    function Is_Definite_Subtype (T : Entity_Id) return Boolean is
1005       pragma Assert (Is_Type (T));
1006       K : constant Entity_Kind := Ekind (T);
1007
1008    begin
1009       if Is_Constrained (T) then
1010          return True;
1011
1012       elsif K in Array_Kind
1013         or else K in Class_Wide_Kind
1014         or else Has_Unknown_Discriminants (T)
1015       then
1016          return False;
1017
1018       --  Known discriminants: definite if there are default values. Note that
1019       --  if any discriminant has a default, they all do.
1020
1021       elsif Has_Discriminants (T) then
1022          return Present (Discriminant_Default_Value (First_Discriminant (T)));
1023
1024       else
1025          return True;
1026       end if;
1027    end Is_Definite_Subtype;
1028
1029    ---------------------
1030    -- Is_Derived_Type --
1031    ---------------------
1032
1033    function Is_Derived_Type (Ent : E) return B is
1034       Par : Node_Id;
1035
1036    begin
1037       if Is_Type (Ent)
1038         and then Base_Type (Ent) /= Root_Type (Ent)
1039         and then not Is_Class_Wide_Type (Ent)
1040
1041         --  An access_to_subprogram whose result type is a limited view can
1042         --  appear in a return statement, without the full view of the result
1043         --  type being available. Do not interpret this as a derived type.
1044
1045         and then Ekind (Ent) /= E_Subprogram_Type
1046       then
1047          if not Is_Numeric_Type (Root_Type (Ent)) then
1048             return True;
1049
1050          else
1051             Par := Parent (First_Subtype (Ent));
1052
1053             return Present (Par)
1054               and then Nkind (Par) = N_Full_Type_Declaration
1055               and then Nkind (Type_Definition (Par)) =
1056                          N_Derived_Type_Definition;
1057          end if;
1058
1059       else
1060          return False;
1061       end if;
1062    end Is_Derived_Type;
1063
1064    -----------------------
1065    -- Is_Generic_Formal --
1066    -----------------------
1067
1068    function Is_Generic_Formal (E : Entity_Id) return Boolean is
1069       Kind : Node_Kind;
1070
1071    begin
1072       if No (E) then
1073          return False;
1074       else
1075          --  Formal derived types are rewritten as private extensions, so
1076          --  examine original node.
1077
1078          Kind := Nkind (Original_Node (Parent (E)));
1079
1080          return
1081            Nkind_In (Kind, N_Formal_Object_Declaration,
1082                            N_Formal_Type_Declaration)
1083              or else Is_Formal_Subprogram (E)
1084              or else
1085                (Ekind (E) = E_Package
1086                  and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
1087                             N_Formal_Package_Declaration);
1088       end if;
1089    end Is_Generic_Formal;
1090
1091    -------------------------------
1092    -- Is_Immutably_Limited_Type --
1093    -------------------------------
1094
1095    function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
1096       Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1097
1098    begin
1099       if Is_Limited_Record (Btype) then
1100          return True;
1101
1102       elsif Ekind (Btype) = E_Limited_Private_Type
1103         and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1104       then
1105          return not In_Package_Body (Scope ((Btype)));
1106
1107       elsif Is_Private_Type (Btype) then
1108
1109          --  AI05-0063: A type derived from a limited private formal type is
1110          --  not immutably limited in a generic body.
1111
1112          if Is_Derived_Type (Btype)
1113            and then Is_Generic_Type (Etype (Btype))
1114          then
1115             if not Is_Limited_Type (Etype (Btype)) then
1116                return False;
1117
1118             --  A descendant of a limited formal type is not immutably limited
1119             --  in the generic body, or in the body of a generic child.
1120
1121             elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1122                return not In_Package_Body (Scope (Btype));
1123
1124             else
1125                return False;
1126             end if;
1127
1128          else
1129             declare
1130                Utyp : constant Entity_Id := Underlying_Type (Btype);
1131             begin
1132                if No (Utyp) then
1133                   return False;
1134                else
1135                   return Is_Immutably_Limited_Type (Utyp);
1136                end if;
1137             end;
1138          end if;
1139
1140       elsif Is_Concurrent_Type (Btype) then
1141          return True;
1142
1143       else
1144          return False;
1145       end if;
1146    end Is_Immutably_Limited_Type;
1147
1148    ---------------------
1149    -- Is_Limited_Type --
1150    ---------------------
1151
1152    function Is_Limited_Type (Ent : Entity_Id) return Boolean is
1153       Btype : constant E := Base_Type (Ent);
1154       Rtype : constant E := Root_Type (Btype);
1155
1156    begin
1157       if not Is_Type (Ent) then
1158          return False;
1159
1160       elsif Ekind (Btype) = E_Limited_Private_Type
1161         or else Is_Limited_Composite (Btype)
1162       then
1163          return True;
1164
1165       elsif Is_Concurrent_Type (Btype) then
1166          return True;
1167
1168          --  The Is_Limited_Record flag normally indicates that the type is
1169          --  limited. The exception is that a type does not inherit limitedness
1170          --  from its interface ancestor. So the type may be derived from a
1171          --  limited interface, but is not limited.
1172
1173       elsif Is_Limited_Record (Ent)
1174         and then not Is_Interface (Ent)
1175       then
1176          return True;
1177
1178       --  Otherwise we will look around to see if there is some other reason
1179       --  for it to be limited, except that if an error was posted on the
1180       --  entity, then just assume it is non-limited, because it can cause
1181       --  trouble to recurse into a murky entity resulting from other errors.
1182
1183       elsif Error_Posted (Ent) then
1184          return False;
1185
1186       elsif Is_Record_Type (Btype) then
1187
1188          if Is_Limited_Interface (Ent) then
1189             return True;
1190
1191          --  AI-419: limitedness is not inherited from a limited interface
1192
1193          elsif Is_Limited_Record (Rtype) then
1194             return not Is_Interface (Rtype)
1195               or else Is_Protected_Interface (Rtype)
1196               or else Is_Synchronized_Interface (Rtype)
1197               or else Is_Task_Interface (Rtype);
1198
1199          elsif Is_Class_Wide_Type (Btype) then
1200             return Is_Limited_Type (Rtype);
1201
1202          else
1203             declare
1204                C : E;
1205
1206             begin
1207                C := First_Component (Btype);
1208                while Present (C) loop
1209                   if Is_Limited_Type (Etype (C)) then
1210                      return True;
1211                   end if;
1212
1213                   C := Next_Component (C);
1214                end loop;
1215             end;
1216
1217             return False;
1218          end if;
1219
1220       elsif Is_Array_Type (Btype) then
1221          return Is_Limited_Type (Component_Type (Btype));
1222
1223       else
1224          return False;
1225       end if;
1226    end Is_Limited_Type;
1227
1228    ---------------------
1229    -- Is_Limited_View --
1230    ---------------------
1231
1232    function Is_Limited_View (Ent : Entity_Id) return Boolean is
1233       Btype : constant Entity_Id := Available_View (Base_Type (Ent));
1234
1235    begin
1236       if Is_Limited_Record (Btype) then
1237          return True;
1238
1239       elsif Ekind (Btype) = E_Limited_Private_Type
1240         and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
1241       then
1242          return not In_Package_Body (Scope ((Btype)));
1243
1244       elsif Is_Private_Type (Btype) then
1245
1246          --  AI05-0063: A type derived from a limited private formal type is
1247          --  not immutably limited in a generic body.
1248
1249          if Is_Derived_Type (Btype)
1250            and then Is_Generic_Type (Etype (Btype))
1251          then
1252             if not Is_Limited_Type (Etype (Btype)) then
1253                return False;
1254
1255             --  A descendant of a limited formal type is not immutably limited
1256             --  in the generic body, or in the body of a generic child.
1257
1258             elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
1259                return not In_Package_Body (Scope (Btype));
1260
1261             else
1262                return False;
1263             end if;
1264
1265          else
1266             declare
1267                Utyp : constant Entity_Id := Underlying_Type (Btype);
1268             begin
1269                if No (Utyp) then
1270                   return False;
1271                else
1272                   return Is_Limited_View (Utyp);
1273                end if;
1274             end;
1275          end if;
1276
1277       elsif Is_Concurrent_Type (Btype) then
1278          return True;
1279
1280       elsif Is_Record_Type (Btype) then
1281
1282          --  Note that we return True for all limited interfaces, even though
1283          --  (unsynchronized) limited interfaces can have descendants that are
1284          --  nonlimited, because this is a predicate on the type itself, and
1285          --  things like functions with limited interface results need to be
1286          --  handled as build in place even though they might return objects
1287          --  of a type that is not inherently limited.
1288
1289          if Is_Class_Wide_Type (Btype) then
1290             return Is_Limited_View (Root_Type (Btype));
1291
1292          else
1293             declare
1294                C : Entity_Id;
1295
1296             begin
1297                C := First_Component (Btype);
1298                while Present (C) loop
1299
1300                   --  Don't consider components with interface types (which can
1301                   --  only occur in the case of a _parent component anyway).
1302                   --  They don't have any components, plus it would cause this
1303                   --  function to return true for nonlimited types derived from
1304                   --  limited interfaces.
1305
1306                   if not Is_Interface (Etype (C))
1307                     and then Is_Limited_View (Etype (C))
1308                   then
1309                      return True;
1310                   end if;
1311
1312                   C := Next_Component (C);
1313                end loop;
1314             end;
1315
1316             return False;
1317          end if;
1318
1319       elsif Is_Array_Type (Btype) then
1320          return Is_Limited_View (Component_Type (Btype));
1321
1322       else
1323          return False;
1324       end if;
1325    end Is_Limited_View;
1326
1327    ----------------------
1328    -- Nearest_Ancestor --
1329    ----------------------
1330
1331    function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1332       D : constant Node_Id := Original_Node (Declaration_Node (Typ));
1333       --  We use the original node of the declaration, because derived
1334       --  types from record subtypes are rewritten as record declarations,
1335       --  and it is the original declaration that carries the ancestor.
1336
1337    begin
1338       --  If we have a subtype declaration, get the ancestor subtype
1339
1340       if Nkind (D) = N_Subtype_Declaration then
1341          if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1342             return Entity (Subtype_Mark (Subtype_Indication (D)));
1343          else
1344             return Entity (Subtype_Indication (D));
1345          end if;
1346
1347       --  If derived type declaration, find who we are derived from
1348
1349       elsif Nkind (D) = N_Full_Type_Declaration
1350         and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1351       then
1352          declare
1353             DTD : constant Entity_Id := Type_Definition (D);
1354             SI  : constant Entity_Id := Subtype_Indication (DTD);
1355          begin
1356             if Is_Entity_Name (SI) then
1357                return Entity (SI);
1358             else
1359                return Entity (Subtype_Mark (SI));
1360             end if;
1361          end;
1362
1363       --  If derived type and private type, get the full view to find who we
1364       --  are derived from.
1365
1366       elsif Is_Derived_Type (Typ)
1367         and then Is_Private_Type (Typ)
1368         and then Present (Full_View (Typ))
1369       then
1370          return Nearest_Ancestor (Full_View (Typ));
1371
1372       --  Otherwise, nothing useful to return, return Empty
1373
1374       else
1375          return Empty;
1376       end if;
1377    end Nearest_Ancestor;
1378
1379    ---------------------------
1380    -- Nearest_Dynamic_Scope --
1381    ---------------------------
1382
1383    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1384    begin
1385       if Is_Dynamic_Scope (Ent) then
1386          return Ent;
1387       else
1388          return Enclosing_Dynamic_Scope (Ent);
1389       end if;
1390    end Nearest_Dynamic_Scope;
1391
1392    ------------------------
1393    -- Next_Tag_Component --
1394    ------------------------
1395
1396    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1397       Comp : Entity_Id;
1398
1399    begin
1400       pragma Assert (Is_Tag (Tag));
1401
1402       --  Loop to look for next tag component
1403
1404       Comp := Next_Entity (Tag);
1405       while Present (Comp) loop
1406          if Is_Tag (Comp) then
1407             pragma Assert (Chars (Comp) /= Name_uTag);
1408             return Comp;
1409          end if;
1410
1411          Comp := Next_Entity (Comp);
1412       end loop;
1413
1414       --  No tag component found
1415
1416       return Empty;
1417    end Next_Tag_Component;
1418
1419    -----------------------
1420    -- Number_Components --
1421    -----------------------
1422
1423    function Number_Components (Typ : Entity_Id) return Nat is
1424       N    : Nat := 0;
1425       Comp : Entity_Id;
1426
1427    begin
1428       --  We do not call Einfo.First_Component_Or_Discriminant, as this
1429       --  function does not skip completely hidden discriminants, which we
1430       --  want to skip here.
1431
1432       if Has_Discriminants (Typ) then
1433          Comp := First_Discriminant (Typ);
1434       else
1435          Comp := First_Component (Typ);
1436       end if;
1437
1438       while Present (Comp) loop
1439          N := N + 1;
1440          Comp := Next_Component_Or_Discriminant (Comp);
1441       end loop;
1442
1443       return N;
1444    end Number_Components;
1445
1446    --------------------------
1447    -- Number_Discriminants --
1448    --------------------------
1449
1450    function Number_Discriminants (Typ : Entity_Id) return Pos is
1451       N     : Nat       := 0;
1452       Discr : Entity_Id := First_Discriminant (Typ);
1453
1454    begin
1455       while Present (Discr) loop
1456          N := N + 1;
1457          Discr := Next_Discriminant (Discr);
1458       end loop;
1459
1460       return N;
1461    end Number_Discriminants;
1462
1463    ----------------------------------------------
1464    -- Object_Type_Has_Constrained_Partial_View --
1465    ----------------------------------------------
1466
1467    function Object_Type_Has_Constrained_Partial_View
1468      (Typ  : Entity_Id;
1469       Scop : Entity_Id) return Boolean
1470    is
1471    begin
1472       return Has_Constrained_Partial_View (Typ)
1473         or else (In_Generic_Body (Scop)
1474                   and then Is_Generic_Type (Base_Type (Typ))
1475                   and then Is_Private_Type (Base_Type (Typ))
1476                   and then not Is_Tagged_Type (Typ)
1477                   and then not (Is_Array_Type (Typ)
1478                                  and then not Is_Constrained (Typ))
1479                   and then Has_Discriminants (Typ));
1480    end Object_Type_Has_Constrained_Partial_View;
1481
1482    ------------------
1483    -- Package_Body --
1484    ------------------
1485
1486    function Package_Body (E : Entity_Id) return Node_Id is
1487       N : Node_Id;
1488
1489    begin
1490       if Ekind (E) = E_Package_Body then
1491          N := Parent (E);
1492
1493          if Nkind (N) = N_Defining_Program_Unit_Name then
1494             N := Parent (N);
1495          end if;
1496
1497       else
1498          N := Package_Spec (E);
1499
1500          if Present (Corresponding_Body (N)) then
1501             N := Parent (Corresponding_Body (N));
1502
1503             if Nkind (N) = N_Defining_Program_Unit_Name then
1504                N := Parent (N);
1505             end if;
1506          else
1507             N := Empty;
1508          end if;
1509       end if;
1510
1511       return N;
1512    end Package_Body;
1513
1514    ------------------
1515    -- Package_Spec --
1516    ------------------
1517
1518    function Package_Spec (E : Entity_Id) return Node_Id is
1519    begin
1520       return Parent (Package_Specification (E));
1521    end Package_Spec;
1522
1523    ---------------------------
1524    -- Package_Specification --
1525    ---------------------------
1526
1527    function Package_Specification (E : Entity_Id) return Node_Id is
1528       N : Node_Id;
1529
1530    begin
1531       N := Parent (E);
1532
1533       if Nkind (N) = N_Defining_Program_Unit_Name then
1534          N := Parent (N);
1535       end if;
1536
1537       return N;
1538    end Package_Specification;
1539
1540    ---------------------
1541    -- Subprogram_Body --
1542    ---------------------
1543
1544    function Subprogram_Body (E : Entity_Id) return Node_Id is
1545       Body_E : constant Entity_Id := Subprogram_Body_Entity (E);
1546
1547    begin
1548       if No (Body_E) then
1549          return Empty;
1550       else
1551          return Parent (Subprogram_Specification (Body_E));
1552       end if;
1553    end Subprogram_Body;
1554
1555    ----------------------------
1556    -- Subprogram_Body_Entity --
1557    ----------------------------
1558
1559    function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
1560       N : constant Node_Id := Parent (Subprogram_Specification (E));
1561       --  Declaration for E
1562
1563    begin
1564       --  If this declaration is not a subprogram body, then it must be a
1565       --  subprogram declaration or body stub, from which we can retrieve the
1566       --  entity for the corresponding subprogram body if any, or an abstract
1567       --  subprogram declaration, for which we return Empty.
1568
1569       case Nkind (N) is
1570          when N_Subprogram_Body =>
1571             return E;
1572
1573          when N_Subprogram_Body_Stub
1574             | N_Subprogram_Declaration
1575          =>
1576             return Corresponding_Body (N);
1577
1578          when others =>
1579             return Empty;
1580       end case;
1581    end Subprogram_Body_Entity;
1582
1583    ---------------------
1584    -- Subprogram_Spec --
1585    ---------------------
1586
1587    function Subprogram_Spec (E : Entity_Id) return Node_Id is
1588       N : constant Node_Id := Parent (Subprogram_Specification (E));
1589       --  Declaration for E
1590
1591    begin
1592       --  This declaration is either subprogram declaration or a subprogram
1593       --  body, in which case return Empty.
1594
1595       if Nkind (N) = N_Subprogram_Declaration then
1596          return N;
1597       else
1598          return Empty;
1599       end if;
1600    end Subprogram_Spec;
1601
1602    ------------------------------
1603    -- Subprogram_Specification --
1604    ------------------------------
1605
1606    function Subprogram_Specification (E : Entity_Id) return Node_Id is
1607       N : Node_Id;
1608
1609    begin
1610       N := Parent (E);
1611
1612       if Nkind (N) = N_Defining_Program_Unit_Name then
1613          N := Parent (N);
1614       end if;
1615
1616       --  If the Parent pointer of E is not a subprogram specification node
1617       --  (going through an intermediate N_Defining_Program_Unit_Name node
1618       --  for subprogram units), then E is an inherited operation. Its parent
1619       --  points to the type derivation that produces the inheritance: that's
1620       --  the node that generates the subprogram specification. Its alias
1621       --  is the parent subprogram, and that one points to a subprogram
1622       --  declaration, or to another type declaration if this is a hierarchy
1623       --  of derivations.
1624
1625       if Nkind (N) not in N_Subprogram_Specification then
1626          pragma Assert (Present (Alias (E)));
1627          N := Subprogram_Specification (Alias (E));
1628       end if;
1629
1630       return N;
1631    end Subprogram_Specification;
1632
1633    ---------------
1634    -- Tree_Read --
1635    ---------------
1636
1637    procedure Tree_Read is
1638    begin
1639       Obsolescent_Warnings.Tree_Read;
1640    end Tree_Read;
1641
1642    ----------------
1643    -- Tree_Write --
1644    ----------------
1645
1646    procedure Tree_Write is
1647    begin
1648       Obsolescent_Warnings.Tree_Write;
1649    end Tree_Write;
1650
1651    --------------------
1652    -- Ultimate_Alias --
1653    --------------------
1654
1655    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1656       E : Entity_Id := Prim;
1657
1658    begin
1659       while Present (Alias (E)) loop
1660          pragma Assert (Alias (E) /= E);
1661          E := Alias (E);
1662       end loop;
1663
1664       return E;
1665    end Ultimate_Alias;
1666
1667    --------------------------
1668    -- Unit_Declaration_Node --
1669    --------------------------
1670
1671    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1672       N : Node_Id := Parent (Unit_Id);
1673
1674    begin
1675       --  Predefined operators do not have a full function declaration
1676
1677       if Ekind (Unit_Id) = E_Operator then
1678          return N;
1679       end if;
1680
1681       --  Isn't there some better way to express the following ???
1682
1683       while Nkind (N) /= N_Abstract_Subprogram_Declaration
1684         and then Nkind (N) /= N_Entry_Body
1685         and then Nkind (N) /= N_Entry_Declaration
1686         and then Nkind (N) /= N_Formal_Package_Declaration
1687         and then Nkind (N) /= N_Function_Instantiation
1688         and then Nkind (N) /= N_Generic_Package_Declaration
1689         and then Nkind (N) /= N_Generic_Subprogram_Declaration
1690         and then Nkind (N) /= N_Package_Declaration
1691         and then Nkind (N) /= N_Package_Body
1692         and then Nkind (N) /= N_Package_Instantiation
1693         and then Nkind (N) /= N_Package_Renaming_Declaration
1694         and then Nkind (N) /= N_Procedure_Instantiation
1695         and then Nkind (N) /= N_Protected_Body
1696         and then Nkind (N) /= N_Protected_Type_Declaration
1697         and then Nkind (N) /= N_Subprogram_Declaration
1698         and then Nkind (N) /= N_Subprogram_Body
1699         and then Nkind (N) /= N_Subprogram_Body_Stub
1700         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1701         and then Nkind (N) /= N_Task_Body
1702         and then Nkind (N) /= N_Task_Type_Declaration
1703         and then Nkind (N) not in N_Formal_Subprogram_Declaration
1704         and then Nkind (N) not in N_Generic_Renaming_Declaration
1705       loop
1706          N := Parent (N);
1707
1708          --  We don't use Assert here, because that causes an infinite loop
1709          --  when assertions are turned off. Better to crash.
1710
1711          if No (N) then
1712             raise Program_Error;
1713          end if;
1714       end loop;
1715
1716       return N;
1717    end Unit_Declaration_Node;
1718
1719 end Sem_Aux;