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