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