main/gcc/ada/sem_aux.adb

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