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