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