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