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