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