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-2014, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- As a special exception,  if other files  instantiate  generics from this --
  22 -- unit, or you link  this unit with other files  to produce an executable, --
  23 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  24 -- covered  by the  GNU  General  Public  License.  This exception does not --
  25 -- however invalidate  any other reasons why  the executable file  might be --
  26 -- covered by the  GNU Public License.                                      --
  27 --                                                                          --
  28 -- GNAT was originally developed  by the GNAT team at  New York University. --
  29 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with Atree;  use Atree;
  34 with Einfo;  use Einfo;
  35 with Sinfo;  use Sinfo;
  36 with Snames; use Snames;
  37 with Stand;  use Stand;
  38 with Uintp;  use Uintp;
  39
  40 package body Sem_Aux is
  41
  42    ----------------------
  43    -- Ancestor_Subtype --
  44    ----------------------
  45
  46    function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
  47    begin
  48       --  If this is first subtype, or is a base type, then there is no
  49       --  ancestor subtype, so we return Empty to indicate this fact.
  50
  51       if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
  52          return Empty;
  53       end if;
  54
  55       declare
  56          D : constant Node_Id := Declaration_Node (Typ);
  57
  58       begin
  59          --  If we have a subtype declaration, get the ancestor subtype
  60
  61          if Nkind (D) = N_Subtype_Declaration then
  62             if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
  63                return Entity (Subtype_Mark (Subtype_Indication (D)));
  64             else
  65                return Entity (Subtype_Indication (D));
  66             end if;
  67
  68          --  If not, then no subtype indication is available
  69
  70          else
  71             return Empty;
  72          end if;
  73       end;
  74    end Ancestor_Subtype;
  75
  76    --------------------
  77    -- Available_View --
  78    --------------------
  79
  80    function Available_View (Ent : Entity_Id) return Entity_Id is
  81    begin
  82       --  Obtain the non-limited (non-abstract) view of a state or variable
  83
  84       if Ekind (Ent) = E_Abstract_State
  85         and then Present (Non_Limited_View (Ent))
  86       then
  87          return Non_Limited_View (Ent);
  88
  89       --  The non-limited view of an incomplete type may itself be incomplete
  90       --  in which case obtain its full view.
  91
  92       elsif Is_Incomplete_Type (Ent)
  93         and then Present (Non_Limited_View (Ent))
  94       then
  95          return Get_Full_View (Non_Limited_View (Ent));
  96
  97       --  If it is class_wide, check whether the specific type comes from a
  98       --  limited_with.
  99
 100       elsif Is_Class_Wide_Type (Ent)
 101         and then Is_Incomplete_Type (Etype (Ent))
 102         and then From_Limited_With (Etype (Ent))
 103         and then Present (Non_Limited_View (Etype (Ent)))
 104       then
 105          return Class_Wide_Type (Non_Limited_View (Etype (Ent)));
 106
 107       --  In all other cases, return entity unchanged
 108
 109       else
 110          return Ent;
 111       end if;
 112    end Available_View;
 113
 114    --------------------
 115    -- Constant_Value --
 116    --------------------
 117
 118    function Constant_Value (Ent : Entity_Id) return Node_Id is
 119       D      : constant Node_Id := Declaration_Node (Ent);
 120       Full_D : Node_Id;
 121
 122    begin
 123       --  If we have no declaration node, then return no constant value. Not
 124       --  clear how this can happen, but it does sometimes and this is the
 125       --  safest approach.
 126
 127       if No (D) then
 128          return Empty;
 129
 130       --  Normal case where a declaration node is present
 131
 132       elsif Nkind (D) = N_Object_Renaming_Declaration then
 133          return Renamed_Object (Ent);
 134
 135       --  If this is a component declaration whose entity is a constant, it is
 136       --  a prival within a protected function (and so has no constant value).
 137
 138       elsif Nkind (D) = N_Component_Declaration then
 139          return Empty;
 140
 141       --  If there is an expression, return it
 142
 143       elsif Present (Expression (D)) then
 144          return (Expression (D));
 145
 146       --  For a constant, see if we have a full view
 147
 148       elsif Ekind (Ent) = E_Constant
 149         and then Present (Full_View (Ent))
 150       then
 151          Full_D := Parent (Full_View (Ent));
 152
 153          --  The full view may have been rewritten as an object renaming
 154
 155          if Nkind (Full_D) = N_Object_Renaming_Declaration then
 156             return Name (Full_D);
 157          else
 158             return Expression (Full_D);
 159          end if;
 160
 161       --  Otherwise we have no expression to return
 162
 163       else
 164          return Empty;
 165       end if;
 166    end Constant_Value;
 167
 168    ---------------------------------
 169    -- Corresponding_Unsigned_Type --
 170    ---------------------------------
 171
 172    function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
 173       pragma Assert (Is_Signed_Integer_Type (Typ));
 174       Siz : constant Uint := Esize (Base_Type (Typ));
 175    begin
 176       if Siz = Esize (Standard_Short_Short_Integer) then
 177          return Standard_Short_Short_Unsigned;
 178       elsif Siz = Esize (Standard_Short_Integer) then
 179          return Standard_Short_Unsigned;
 180       elsif Siz = Esize (Standard_Unsigned) then
 181          return Standard_Unsigned;
 182       elsif Siz = Esize (Standard_Long_Integer) then
 183          return Standard_Long_Unsigned;
 184       elsif Siz = Esize (Standard_Long_Long_Integer) then
 185          return Standard_Long_Long_Unsigned;
 186       else
 187          raise Program_Error;
 188       end if;
 189    end Corresponding_Unsigned_Type;
 190
 191    -----------------------------
 192    -- Enclosing_Dynamic_Scope --
 193    -----------------------------
 194
 195    function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
 196       S : Entity_Id;
 197
 198    begin
 199       --  The following test is an error defense against some syntax errors
 200       --  that can leave scopes very messed up.
 201
 202       if Ent = Standard_Standard then
 203          return Ent;
 204       end if;
 205
 206       --  Normal case, search enclosing scopes
 207
 208       --  Note: the test for Present (S) should not be required, it defends
 209       --  against an ill-formed tree.
 210
 211       S := Scope (Ent);
 212       loop
 213          --  If we somehow got an empty value for Scope, the tree must be
 214          --  malformed. Rather than blow up we return Standard in this case.
 215
 216          if No (S) then
 217             return Standard_Standard;
 218
 219          --  Quit if we get to standard or a dynamic scope. We must also
 220          --  handle enclosing scopes that have a full view; required to
 221          --  locate enclosing scopes that are synchronized private types
 222          --  whose full view is a task type.
 223
 224          elsif S = Standard_Standard
 225            or else Is_Dynamic_Scope (S)
 226            or else (Is_Private_Type (S)
 227                      and then Present (Full_View (S))
 228                      and then Is_Dynamic_Scope (Full_View (S)))
 229          then
 230             return S;
 231
 232          --  Otherwise keep climbing
 233
 234          else
 235             S := Scope (S);
 236          end if;
 237       end loop;
 238    end Enclosing_Dynamic_Scope;
 239
 240    ------------------------
 241    -- First_Discriminant --
 242    ------------------------
 243
 244    function First_Discriminant (Typ : Entity_Id) return Entity_Id is
 245       Ent : Entity_Id;
 246
 247    begin
 248       pragma Assert
 249         (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
 250
 251       Ent := First_Entity (Typ);
 252
 253       --  The discriminants are not necessarily contiguous, because access
 254       --  discriminants will generate itypes. They are not the first entities
 255       --  either because the tag must be ahead of them.
 256
 257       if Chars (Ent) = Name_uTag then
 258          Ent := Next_Entity (Ent);
 259       end if;
 260
 261       --  Skip all hidden stored discriminants if any
 262
 263       while Present (Ent) loop
 264          exit when Ekind (Ent) = E_Discriminant
 265            and then not Is_Completely_Hidden (Ent);
 266
 267          Ent := Next_Entity (Ent);
 268       end loop;
 269
 270       pragma Assert (Ekind (Ent) = E_Discriminant);
 271
 272       return Ent;
 273    end First_Discriminant;
 274
 275    -------------------------------
 276    -- First_Stored_Discriminant --
 277    -------------------------------
 278
 279    function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
 280       Ent : Entity_Id;
 281
 282       function Has_Completely_Hidden_Discriminant
 283         (Typ : Entity_Id) return Boolean;
 284       --  Scans the Discriminants to see whether any are Completely_Hidden
 285       --  (the mechanism for describing non-specified stored discriminants)
 286
 287       ----------------------------------------
 288       -- Has_Completely_Hidden_Discriminant --
 289       ----------------------------------------
 290
 291       function Has_Completely_Hidden_Discriminant
 292         (Typ : Entity_Id) return Boolean
 293       is
 294          Ent : Entity_Id;
 295
 296       begin
 297          pragma Assert (Ekind (Typ) = E_Discriminant);
 298
 299          Ent := Typ;
 300          while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
 301             if Is_Completely_Hidden (Ent) then
 302                return True;
 303             end if;
 304
 305             Ent := Next_Entity (Ent);
 306          end loop;
 307
 308          return False;
 309       end Has_Completely_Hidden_Discriminant;
 310
 311    --  Start of processing for First_Stored_Discriminant
 312
 313    begin
 314       pragma Assert
 315         (Has_Discriminants (Typ)
 316           or else Has_Unknown_Discriminants (Typ));
 317
 318       Ent := First_Entity (Typ);
 319
 320       if Chars (Ent) = Name_uTag then
 321          Ent := Next_Entity (Ent);
 322       end if;
 323
 324       if Has_Completely_Hidden_Discriminant (Ent) then
 325          while Present (Ent) loop
 326             exit when Is_Completely_Hidden (Ent);
 327             Ent := Next_Entity (Ent);
 328          end loop;
 329       end if;
 330
 331       pragma Assert (Ekind (Ent) = E_Discriminant);
 332
 333       return Ent;
 334    end First_Stored_Discriminant;
 335
 336    -------------------
 337    -- First_Subtype --
 338    -------------------
 339
 340    function First_Subtype (Typ : Entity_Id) return Entity_Id is
 341       B   : constant Entity_Id := Base_Type (Typ);
 342       F   : constant Node_Id   := Freeze_Node (B);
 343       Ent : Entity_Id;
 344
 345    begin
 346       --  If the base type has no freeze node, it is a type in Standard, and
 347       --  always acts as its own first subtype, except where it is one of the
 348       --  predefined integer types. If the type is formal, it is also a first
 349       --  subtype, and its base type has no freeze node. On the other hand, a
 350       --  subtype of a generic formal is not its own first subtype. Its base
 351       --  type, if anonymous, is attached to the formal type decl. from which
 352       --  the first subtype is obtained.
 353
 354       if No (F) then
 355          if B = Base_Type (Standard_Integer) then
 356             return Standard_Integer;
 357
 358          elsif B = Base_Type (Standard_Long_Integer) then
 359             return Standard_Long_Integer;
 360
 361          elsif B = Base_Type (Standard_Short_Short_Integer) then
 362             return Standard_Short_Short_Integer;
 363
 364          elsif B = Base_Type (Standard_Short_Integer) then
 365             return Standard_Short_Integer;
 366
 367          elsif B = Base_Type (Standard_Long_Long_Integer) then
 368             return Standard_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          Comp := 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_Rep_Item --
 440    ------------------
 441
 442    function Get_Rep_Item
 443      (E             : Entity_Id;
 444       Nam           : Name_Id;
 445       Check_Parents : Boolean := True) return Node_Id
 446    is
 447       N : Node_Id;
 448
 449    begin
 450       N := First_Rep_Item (E);
 451       while Present (N) loop
 452
 453          --  Only one of Priority / Interrupt_Priority can be specified, so
 454          --  return whichever one is present to catch illegal duplication.
 455
 456          if Nkind (N) = N_Pragma
 457            and then
 458              (Pragma_Name (N) = Nam
 459                or else (Nam = Name_Priority
 460                          and then Pragma_Name (N) = Name_Interrupt_Priority)
 461                or else (Nam = Name_Interrupt_Priority
 462                          and then Pragma_Name (N) = Name_Priority))
 463          then
 464             if Check_Parents then
 465                return N;
 466
 467             --  If Check_Parents is False, return N if the pragma doesn't
 468             --  appear in the Rep_Item chain of the parent.
 469
 470             else
 471                declare
 472                   Par : constant Entity_Id := Nearest_Ancestor (E);
 473                   --  This node represents the parent type of type E (if any)
 474
 475                begin
 476                   if No (Par) then
 477                      return N;
 478
 479                   elsif not Present_In_Rep_Item (Par, N) then
 480                      return N;
 481                   end if;
 482                end;
 483             end if;
 484
 485          elsif Nkind (N) = N_Attribute_Definition_Clause
 486            and then
 487              (Chars (N) = Nam
 488                or else (Nam = Name_Priority
 489                          and then Chars (N) = Name_Interrupt_Priority))
 490          then
 491             if Check_Parents or else Entity (N) = E then
 492                return N;
 493             end if;
 494
 495          elsif Nkind (N) = N_Aspect_Specification
 496            and then
 497              (Chars (Identifier (N)) = Nam
 498                or else
 499                  (Nam = Name_Priority
 500                    and then Chars (Identifier (N)) = Name_Interrupt_Priority))
 501          then
 502             if Check_Parents then
 503                return N;
 504
 505             elsif Entity (N) = E then
 506                return N;
 507             end if;
 508          end if;
 509
 510          Next_Rep_Item (N);
 511       end loop;
 512
 513       return Empty;
 514    end Get_Rep_Item;
 515
 516    function Get_Rep_Item
 517      (E             : Entity_Id;
 518       Nam1          : Name_Id;
 519       Nam2          : Name_Id;
 520       Check_Parents : Boolean := True) return Node_Id
 521    is
 522       Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
 523       Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
 524
 525       N : Node_Id;
 526
 527    begin
 528       --  Check both Nam1_Item and Nam2_Item are present
 529
 530       if No (Nam1_Item) then
 531          return Nam2_Item;
 532       elsif No (Nam2_Item) then
 533          return Nam1_Item;
 534       end if;
 535
 536       --  Return the first node encountered in the list
 537
 538       N := First_Rep_Item (E);
 539       while Present (N) loop
 540          if N = Nam1_Item or else N = Nam2_Item then
 541             return N;
 542          end if;
 543
 544          Next_Rep_Item (N);
 545       end loop;
 546
 547       return Empty;
 548    end Get_Rep_Item;
 549
 550    --------------------
 551    -- Get_Rep_Pragma --
 552    --------------------
 553
 554    function Get_Rep_Pragma
 555      (E             : Entity_Id;
 556       Nam           : Name_Id;
 557       Check_Parents : Boolean := True) return Node_Id
 558    is
 559       N : Node_Id;
 560
 561    begin
 562       N := Get_Rep_Item (E, Nam, Check_Parents);
 563
 564       if Present (N) and then Nkind (N) = N_Pragma then
 565          return N;
 566       end if;
 567
 568       return Empty;
 569    end Get_Rep_Pragma;
 570
 571    function Get_Rep_Pragma
 572      (E             : Entity_Id;
 573       Nam1          : Name_Id;
 574       Nam2          : Name_Id;
 575       Check_Parents : Boolean := True) return Node_Id
 576    is
 577       Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
 578       Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
 579
 580       N : Node_Id;
 581
 582    begin
 583       --  Check both Nam1_Item and Nam2_Item are present
 584
 585       if No (Nam1_Item) then
 586          return Nam2_Item;
 587       elsif No (Nam2_Item) then
 588          return Nam1_Item;
 589       end if;
 590
 591       --  Return the first node encountered in the list
 592
 593       N := First_Rep_Item (E);
 594       while Present (N) loop
 595          if N = Nam1_Item or else N = Nam2_Item then
 596             return N;
 597          end if;
 598
 599          Next_Rep_Item (N);
 600       end loop;
 601
 602       return Empty;
 603    end Get_Rep_Pragma;
 604
 605    ------------------
 606    -- Has_Rep_Item --
 607    ------------------
 608
 609    function Has_Rep_Item
 610      (E             : Entity_Id;
 611       Nam           : Name_Id;
 612       Check_Parents : Boolean := True) return Boolean
 613    is
 614    begin
 615       return Present (Get_Rep_Item (E, Nam, Check_Parents));
 616    end Has_Rep_Item;
 617
 618    function Has_Rep_Item
 619      (E             : Entity_Id;
 620       Nam1          : Name_Id;
 621       Nam2          : Name_Id;
 622       Check_Parents : Boolean := True) return Boolean
 623    is
 624    begin
 625       return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
 626    end Has_Rep_Item;
 627
 628    --------------------
 629    -- Has_Rep_Pragma --
 630    --------------------
 631
 632    function Has_Rep_Pragma
 633      (E             : Entity_Id;
 634       Nam           : Name_Id;
 635       Check_Parents : Boolean := True) return Boolean
 636    is
 637    begin
 638       return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
 639    end Has_Rep_Pragma;
 640
 641    function Has_Rep_Pragma
 642      (E             : Entity_Id;
 643       Nam1          : Name_Id;
 644       Nam2          : Name_Id;
 645       Check_Parents : Boolean := True) return Boolean
 646    is
 647    begin
 648       return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
 649    end Has_Rep_Pragma;
 650
 651    --------------------------------
 652    -- Has_Unconstrained_Elements --
 653    --------------------------------
 654
 655    function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
 656       U_T : constant Entity_Id := Underlying_Type (T);
 657    begin
 658       if No (U_T) then
 659          return False;
 660       elsif Is_Record_Type (U_T) then
 661          return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
 662       elsif Is_Array_Type (U_T) then
 663          return Has_Unconstrained_Elements (Component_Type (U_T));
 664       else
 665          return False;
 666       end if;
 667    end Has_Unconstrained_Elements;
 668
 669    ----------------------
 670    -- Has_Variant_Part --
 671    ----------------------
 672
 673    function Has_Variant_Part (Typ : Entity_Id) return Boolean is
 674       FSTyp : Entity_Id;
 675       Decl  : Node_Id;
 676       TDef  : Node_Id;
 677       CList : Node_Id;
 678
 679    begin
 680       if not Is_Type (Typ) then
 681          return False;
 682       end if;
 683
 684       FSTyp := First_Subtype (Typ);
 685
 686       if not Has_Discriminants (FSTyp) then
 687          return False;
 688       end if;
 689
 690       --  Proceed with cautious checks here, return False if tree is not
 691       --  as expected (may be caused by prior errors).
 692
 693       Decl := Declaration_Node (FSTyp);
 694
 695       if Nkind (Decl) /= N_Full_Type_Declaration then
 696          return False;
 697       end if;
 698
 699       TDef := Type_Definition (Decl);
 700
 701       if Nkind (TDef) /= N_Record_Definition then
 702          return False;
 703       end if;
 704
 705       CList := Component_List (TDef);
 706
 707       if Nkind (CList) /= N_Component_List then
 708          return False;
 709       else
 710          return Present (Variant_Part (CList));
 711       end if;
 712    end Has_Variant_Part;
 713
 714    ---------------------
 715    -- In_Generic_Body --
 716    ---------------------
 717
 718    function In_Generic_Body (Id : Entity_Id) return Boolean is
 719       S : Entity_Id;
 720
 721    begin
 722       --  Climb scopes looking for generic body
 723
 724       S := Id;
 725       while Present (S) and then S /= Standard_Standard loop
 726
 727          --  Generic package body
 728
 729          if Ekind (S) = E_Generic_Package
 730            and then In_Package_Body (S)
 731          then
 732             return True;
 733
 734          --  Generic subprogram body
 735
 736          elsif Is_Subprogram (S)
 737            and then Nkind (Unit_Declaration_Node (S))
 738                       = N_Generic_Subprogram_Declaration
 739          then
 740             return True;
 741          end if;
 742
 743          S := Scope (S);
 744       end loop;
 745
 746       --  False if top of scope stack without finding a generic body
 747
 748       return False;
 749    end In_Generic_Body;
 750
 751    -------------------------------
 752    -- Initialization_Suppressed --
 753    -------------------------------
 754
 755    function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
 756    begin
 757       return Suppress_Initialization (Typ)
 758         or else Suppress_Initialization (Base_Type (Typ));
 759    end Initialization_Suppressed;
 760
 761    ----------------
 762    -- Initialize --
 763    ----------------
 764
 765    procedure Initialize is
 766    begin
 767       Obsolescent_Warnings.Init;
 768    end Initialize;
 769
 770    -------------
 771    -- Is_Body --
 772    -------------
 773
 774    function Is_Body (N : Node_Id) return Boolean is
 775    begin
 776       return
 777         Nkind (N) in N_Body_Stub
 778           or else Nkind_In (N, N_Entry_Body,
 779                                N_Package_Body,
 780                                N_Protected_Body,
 781                                N_Subprogram_Body,
 782                                N_Task_Body);
 783    end Is_Body;
 784
 785    ---------------------
 786    -- Is_By_Copy_Type --
 787    ---------------------
 788
 789    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
 790    begin
 791       --  If Id is a private type whose full declaration has not been seen,
 792       --  we assume for now that it is not a By_Copy type. Clearly this
 793       --  attribute should not be used before the type is frozen, but it is
 794       --  needed to build the associated record of a protected type. Another
 795       --  place where some lookahead for a full view is needed ???
 796
 797       return
 798         Is_Elementary_Type (Ent)
 799           or else (Is_Private_Type (Ent)
 800                      and then Present (Underlying_Type (Ent))
 801                      and then Is_Elementary_Type (Underlying_Type (Ent)));
 802    end Is_By_Copy_Type;
 803
 804    --------------------------
 805    -- Is_By_Reference_Type --
 806    --------------------------
 807
 808    function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
 809       Btype : constant Entity_Id := Base_Type (Ent);
 810
 811    begin
 812       if Error_Posted (Ent) or else Error_Posted (Btype) then
 813          return False;
 814
 815       elsif Is_Private_Type (Btype) then
 816          declare
 817             Utyp : constant Entity_Id := Underlying_Type (Btype);
 818          begin
 819             if No (Utyp) then
 820                return False;
 821             else
 822                return Is_By_Reference_Type (Utyp);
 823             end if;
 824          end;
 825
 826       elsif Is_Incomplete_Type (Btype) then
 827          declare
 828             Ftyp : constant Entity_Id := Full_View (Btype);
 829          begin
 830             if No (Ftyp) then
 831                return False;
 832             else
 833                return Is_By_Reference_Type (Ftyp);
 834             end if;
 835          end;
 836
 837       elsif Is_Concurrent_Type (Btype) then
 838          return True;
 839
 840       elsif Is_Record_Type (Btype) then
 841          if Is_Limited_Record (Btype)
 842            or else Is_Tagged_Type (Btype)
 843            or else Is_Volatile (Btype)
 844          then
 845             return True;
 846
 847          else
 848             declare
 849                C : Entity_Id;
 850
 851             begin
 852                C := First_Component (Btype);
 853                while Present (C) loop
 854
 855                   --  For each component, test if its type is a by reference
 856                   --  type and if its type is volatile. Also test the component
 857                   --  itself for being volatile. This happens for example when
 858                   --  a Volatile aspect is added to a component.
 859
 860                   if Is_By_Reference_Type (Etype (C))
 861                     or else Is_Volatile (Etype (C))
 862                     or else Is_Volatile (C)
 863                   then
 864                      return True;
 865                   end if;
 866
 867                   C := Next_Component (C);
 868                end loop;
 869             end;
 870
 871             return False;
 872          end if;
 873
 874       elsif Is_Array_Type (Btype) then
 875          return
 876            Is_Volatile (Btype)
 877              or else Is_By_Reference_Type (Component_Type (Btype))
 878              or else Is_Volatile (Component_Type (Btype))
 879              or else Has_Volatile_Components (Btype);
 880
 881       else
 882          return False;
 883       end if;
 884    end Is_By_Reference_Type;
 885
 886    ---------------------
 887    -- Is_Derived_Type --
 888    ---------------------
 889
 890    function Is_Derived_Type (Ent : E) return B is
 891       Par : Node_Id;
 892
 893    begin
 894       if Is_Type (Ent)
 895         and then Base_Type (Ent) /= Root_Type (Ent)
 896         and then not Is_Class_Wide_Type (Ent)
 897       then
 898          if not Is_Numeric_Type (Root_Type (Ent)) then
 899             return True;
 900
 901          else
 902             Par := Parent (First_Subtype (Ent));
 903
 904             return Present (Par)
 905               and then Nkind (Par) = N_Full_Type_Declaration
 906               and then Nkind (Type_Definition (Par)) =
 907                          N_Derived_Type_Definition;
 908          end if;
 909
 910       else
 911          return False;
 912       end if;
 913    end Is_Derived_Type;
 914
 915    -----------------------
 916    -- Is_Generic_Formal --
 917    -----------------------
 918
 919    function Is_Generic_Formal (E : Entity_Id) return Boolean is
 920       Kind : Node_Kind;
 921    begin
 922       if No (E) then
 923          return False;
 924       else
 925          Kind := Nkind (Parent (E));
 926          return
 927            Nkind_In (Kind, N_Formal_Object_Declaration,
 928                            N_Formal_Package_Declaration,
 929                            N_Formal_Type_Declaration)
 930              or else Is_Formal_Subprogram (E);
 931       end if;
 932    end Is_Generic_Formal;
 933
 934    -------------------------------
 935    -- Is_Immutably_Limited_Type --
 936    -------------------------------
 937
 938    function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
 939       Btype : constant Entity_Id := Available_View (Base_Type (Ent));
 940
 941    begin
 942       if Is_Limited_Record (Btype) then
 943          return True;
 944
 945       elsif Ekind (Btype) = E_Limited_Private_Type
 946         and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
 947       then
 948          return not In_Package_Body (Scope ((Btype)));
 949
 950       elsif Is_Private_Type (Btype) then
 951
 952          --  AI05-0063: A type derived from a limited private formal type is
 953          --  not immutably limited in a generic body.
 954
 955          if Is_Derived_Type (Btype)
 956            and then Is_Generic_Type (Etype (Btype))
 957          then
 958             if not Is_Limited_Type (Etype (Btype)) then
 959                return False;
 960
 961             --  A descendant of a limited formal type is not immutably limited
 962             --  in the generic body, or in the body of a generic child.
 963
 964             elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
 965                return not In_Package_Body (Scope (Btype));
 966
 967             else
 968                return False;
 969             end if;
 970
 971          else
 972             declare
 973                Utyp : constant Entity_Id := Underlying_Type (Btype);
 974             begin
 975                if No (Utyp) then
 976                   return False;
 977                else
 978                   return Is_Immutably_Limited_Type (Utyp);
 979                end if;
 980             end;
 981          end if;
 982
 983       elsif Is_Concurrent_Type (Btype) then
 984          return True;
 985
 986       else
 987          return False;
 988       end if;
 989    end Is_Immutably_Limited_Type;
 990
 991    ---------------------------
 992    -- Is_Indefinite_Subtype --
 993    ---------------------------
 994
 995    function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
 996       K : constant Entity_Kind := Ekind (Ent);
 997
 998    begin
 999       if Is_Constrained (Ent) then
1000          return False;
1001
1002       elsif K in Array_Kind
1003         or else K in Class_Wide_Kind
1004         or else Has_Unknown_Discriminants (Ent)
1005       then
1006          return True;
1007
1008       --  Known discriminants: indefinite if there are no default values
1009
1010       elsif K in Record_Kind
1011         or else Is_Incomplete_Or_Private_Type (Ent)
1012         or else Is_Concurrent_Type (Ent)
1013       then
1014          return (Has_Discriminants (Ent)
1015            and then
1016              No (Discriminant_Default_Value (First_Discriminant (Ent))));
1017
1018       else
1019          return False;
1020       end if;
1021    end Is_Indefinite_Subtype;
1022
1023    ---------------------
1024    -- Is_Limited_Type --
1025    ---------------------
1026
1027    function Is_Limited_Type (Ent : Entity_Id) return Boolean is
1028       Btype : constant E := Base_Type (Ent);
1029       Rtype : constant E := Root_Type (Btype);
1030
1031    begin
1032       if not Is_Type (Ent) then
1033          return False;
1034
1035       elsif Ekind (Btype) = E_Limited_Private_Type
1036         or else Is_Limited_Composite (Btype)
1037       then
1038          return True;
1039
1040       elsif Is_Concurrent_Type (Btype) then
1041          return True;
1042
1043          --  The Is_Limited_Record flag normally indicates that the type is
1044          --  limited. The exception is that a type does not inherit limitedness
1045          --  from its interface ancestor. So the type may be derived from a
1046          --  limited interface, but is not limited.
1047
1048       elsif Is_Limited_Record (Ent)
1049         and then not Is_Interface (Ent)
1050       then
1051          return True;
1052
1053       --  Otherwise we will look around to see if there is some other reason
1054       --  for it to be limited, except that if an error was posted on the
1055       --  entity, then just assume it is non-limited, because it can cause
1056       --  trouble to recurse into a murky entity resulting from other errors.
1057
1058       elsif Error_Posted (Ent) then
1059          return False;
1060
1061       elsif Is_Record_Type (Btype) then
1062
1063          if Is_Limited_Interface (Ent) then
1064             return True;
1065
1066          --  AI-419: limitedness is not inherited from a limited interface
1067
1068          elsif Is_Limited_Record (Rtype) then
1069             return not Is_Interface (Rtype)
1070               or else Is_Protected_Interface (Rtype)
1071               or else Is_Synchronized_Interface (Rtype)
1072               or else Is_Task_Interface (Rtype);
1073
1074          elsif Is_Class_Wide_Type (Btype) then
1075             return Is_Limited_Type (Rtype);
1076
1077          else
1078             declare
1079                C : E;
1080
1081             begin
1082                C := First_Component (Btype);
1083                while Present (C) loop
1084                   if Is_Limited_Type (Etype (C)) then
1085                      return True;
1086                   end if;
1087
1088                   C := 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_Limited_View --
1105    ---------------------
1106
1107    function Is_Limited_View (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             declare
1142                Utyp : constant Entity_Id := Underlying_Type (Btype);
1143             begin
1144                if No (Utyp) then
1145                   return False;
1146                else
1147                   return Is_Limited_View (Utyp);
1148                end if;
1149             end;
1150          end if;
1151
1152       elsif Is_Concurrent_Type (Btype) then
1153          return True;
1154
1155       elsif Is_Record_Type (Btype) then
1156
1157          --  Note that we return True for all limited interfaces, even though
1158          --  (unsynchronized) limited interfaces can have descendants that are
1159          --  nonlimited, because this is a predicate on the type itself, and
1160          --  things like functions with limited interface results need to be
1161          --  handled as build in place even though they might return objects
1162          --  of a type that is not inherently limited.
1163
1164          if Is_Class_Wide_Type (Btype) then
1165             return Is_Limited_View (Root_Type (Btype));
1166
1167          else
1168             declare
1169                C : Entity_Id;
1170
1171             begin
1172                C := First_Component (Btype);
1173                while Present (C) loop
1174
1175                   --  Don't consider components with interface types (which can
1176                   --  only occur in the case of a _parent component anyway).
1177                   --  They don't have any components, plus it would cause this
1178                   --  function to return true for nonlimited types derived from
1179                   --  limited interfaces.
1180
1181                   if not Is_Interface (Etype (C))
1182                     and then Is_Limited_View (Etype (C))
1183                   then
1184                      return True;
1185                   end if;
1186
1187                   C := Next_Component (C);
1188                end loop;
1189             end;
1190
1191             return False;
1192          end if;
1193
1194       elsif Is_Array_Type (Btype) then
1195          return Is_Limited_View (Component_Type (Btype));
1196
1197       else
1198          return False;
1199       end if;
1200    end Is_Limited_View;
1201
1202    ----------------------
1203    -- Nearest_Ancestor --
1204    ----------------------
1205
1206    function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
1207       D : constant Node_Id := Declaration_Node (Typ);
1208
1209    begin
1210       --  If we have a subtype declaration, get the ancestor subtype
1211
1212       if Nkind (D) = N_Subtype_Declaration then
1213          if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
1214             return Entity (Subtype_Mark (Subtype_Indication (D)));
1215          else
1216             return Entity (Subtype_Indication (D));
1217          end if;
1218
1219       --  If derived type declaration, find who we are derived from
1220
1221       elsif Nkind (D) = N_Full_Type_Declaration
1222         and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
1223       then
1224          declare
1225             DTD : constant Entity_Id := Type_Definition (D);
1226             SI  : constant Entity_Id := Subtype_Indication (DTD);
1227          begin
1228             if Is_Entity_Name (SI) then
1229                return Entity (SI);
1230             else
1231                return Entity (Subtype_Mark (SI));
1232             end if;
1233          end;
1234
1235       --  If derived type and private type, get the full view to find who we
1236       --  are derived from.
1237
1238       elsif Is_Derived_Type (Typ)
1239         and then Is_Private_Type (Typ)
1240         and then Present (Full_View (Typ))
1241       then
1242          return Nearest_Ancestor (Full_View (Typ));
1243
1244       --  Otherwise, nothing useful to return, return Empty
1245
1246       else
1247          return Empty;
1248       end if;
1249    end Nearest_Ancestor;
1250
1251    ---------------------------
1252    -- Nearest_Dynamic_Scope --
1253    ---------------------------
1254
1255    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
1256    begin
1257       if Is_Dynamic_Scope (Ent) then
1258          return Ent;
1259       else
1260          return Enclosing_Dynamic_Scope (Ent);
1261       end if;
1262    end Nearest_Dynamic_Scope;
1263
1264    ------------------------
1265    -- Next_Tag_Component --
1266    ------------------------
1267
1268    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
1269       Comp : Entity_Id;
1270
1271    begin
1272       pragma Assert (Is_Tag (Tag));
1273
1274       --  Loop to look for next tag component
1275
1276       Comp := Next_Entity (Tag);
1277       while Present (Comp) loop
1278          if Is_Tag (Comp) then
1279             pragma Assert (Chars (Comp) /= Name_uTag);
1280             return Comp;
1281          end if;
1282
1283          Comp := Next_Entity (Comp);
1284       end loop;
1285
1286       --  No tag component found
1287
1288       return Empty;
1289    end Next_Tag_Component;
1290
1291    --------------------------
1292    -- Number_Discriminants --
1293    --------------------------
1294
1295    function Number_Discriminants (Typ : Entity_Id) return Pos is
1296       N     : Int;
1297       Discr : Entity_Id;
1298
1299    begin
1300       N := 0;
1301       Discr := First_Discriminant (Typ);
1302       while Present (Discr) loop
1303          N := N + 1;
1304          Discr := Next_Discriminant (Discr);
1305       end loop;
1306
1307       return N;
1308    end Number_Discriminants;
1309
1310    ----------------------------------------------
1311    -- Object_Type_Has_Constrained_Partial_View --
1312    ----------------------------------------------
1313
1314    function Object_Type_Has_Constrained_Partial_View
1315      (Typ  : Entity_Id;
1316       Scop : Entity_Id) return Boolean
1317    is
1318    begin
1319       return Has_Constrained_Partial_View (Typ)
1320         or else (In_Generic_Body (Scop)
1321                   and then Is_Generic_Type (Base_Type (Typ))
1322                   and then Is_Private_Type (Base_Type (Typ))
1323                   and then not Is_Tagged_Type (Typ)
1324                   and then not (Is_Array_Type (Typ)
1325                                  and then not Is_Constrained (Typ))
1326                   and then Has_Discriminants (Typ));
1327    end Object_Type_Has_Constrained_Partial_View;
1328
1329    ---------------------------
1330    -- Package_Specification --
1331    ---------------------------
1332
1333    function Package_Specification (Pack_Id : Entity_Id) return Node_Id is
1334       N : Node_Id;
1335
1336    begin
1337       N := Parent (Pack_Id);
1338       while Nkind (N) /= N_Package_Specification loop
1339          N := Parent (N);
1340
1341          if No (N) then
1342             raise Program_Error;
1343          end if;
1344       end loop;
1345
1346       return N;
1347    end Package_Specification;
1348
1349    ---------------
1350    -- Tree_Read --
1351    ---------------
1352
1353    procedure Tree_Read is
1354    begin
1355       Obsolescent_Warnings.Tree_Read;
1356    end Tree_Read;
1357
1358    ----------------
1359    -- Tree_Write --
1360    ----------------
1361
1362    procedure Tree_Write is
1363    begin
1364       Obsolescent_Warnings.Tree_Write;
1365    end Tree_Write;
1366
1367    --------------------
1368    -- Ultimate_Alias --
1369    --------------------
1370
1371    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
1372       E : Entity_Id := Prim;
1373
1374    begin
1375       while Present (Alias (E)) loop
1376          pragma Assert (Alias (E) /= E);
1377          E := Alias (E);
1378       end loop;
1379
1380       return E;
1381    end Ultimate_Alias;
1382
1383    --------------------------
1384    -- Unit_Declaration_Node --
1385    --------------------------
1386
1387    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
1388       N : Node_Id := Parent (Unit_Id);
1389
1390    begin
1391       --  Predefined operators do not have a full function declaration
1392
1393       if Ekind (Unit_Id) = E_Operator then
1394          return N;
1395       end if;
1396
1397       --  Isn't there some better way to express the following ???
1398
1399       while Nkind (N) /= N_Abstract_Subprogram_Declaration
1400         and then Nkind (N) /= N_Formal_Package_Declaration
1401         and then Nkind (N) /= N_Function_Instantiation
1402         and then Nkind (N) /= N_Generic_Package_Declaration
1403         and then Nkind (N) /= N_Generic_Subprogram_Declaration
1404         and then Nkind (N) /= N_Package_Declaration
1405         and then Nkind (N) /= N_Package_Body
1406         and then Nkind (N) /= N_Package_Instantiation
1407         and then Nkind (N) /= N_Package_Renaming_Declaration
1408         and then Nkind (N) /= N_Procedure_Instantiation
1409         and then Nkind (N) /= N_Protected_Body
1410         and then Nkind (N) /= N_Subprogram_Declaration
1411         and then Nkind (N) /= N_Subprogram_Body
1412         and then Nkind (N) /= N_Subprogram_Body_Stub
1413         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
1414         and then Nkind (N) /= N_Task_Body
1415         and then Nkind (N) /= N_Task_Type_Declaration
1416         and then Nkind (N) not in N_Formal_Subprogram_Declaration
1417         and then Nkind (N) not in N_Generic_Renaming_Declaration
1418       loop
1419          N := Parent (N);
1420
1421          --  We don't use Assert here, because that causes an infinite loop
1422          --  when assertions are turned off. Better to crash.
1423
1424          if No (N) then
1425             raise Program_Error;
1426          end if;
1427       end loop;
1428
1429       return N;
1430    end Unit_Declaration_Node;
1431
1432 end Sem_Aux;