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