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