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-2008, 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 Typ = 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 constant, it is
 123       --  a prival within a protected function. It does not have a constant
 124       --  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 is a
 174       --  defence 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
 185
 186          elsif S = Standard_Standard
 187            or else Is_Dynamic_Scope (S)
 188          then
 189             return S;
 190
 191          --  Otherwise keep climbing
 192
 193          else
 194             S := Scope (S);
 195          end if;
 196       end loop;
 197    end Enclosing_Dynamic_Scope;
 198
 199    ------------------------
 200    -- First_Discriminant --
 201    ------------------------
 202
 203    function First_Discriminant (Typ : Entity_Id) return Entity_Id is
 204       Ent : Entity_Id;
 205
 206    begin
 207       pragma Assert
 208         (Has_Discriminants (Typ)
 209           or else Has_Unknown_Discriminants (Typ));
 210
 211       Ent := First_Entity (Typ);
 212
 213       --  The discriminants are not necessarily contiguous, because access
 214       --  discriminants will generate itypes. They are not the first entities
 215       --  either, because tag and controller record must be ahead of them.
 216
 217       if Chars (Ent) = Name_uTag then
 218          Ent := Next_Entity (Ent);
 219       end if;
 220
 221       if Chars (Ent) = Name_uController then
 222          Ent := Next_Entity (Ent);
 223       end if;
 224
 225       --  Skip all hidden stored discriminants if any
 226
 227       while Present (Ent) loop
 228          exit when Ekind (Ent) = E_Discriminant
 229            and then not Is_Completely_Hidden (Ent);
 230
 231          Ent := Next_Entity (Ent);
 232       end loop;
 233
 234       pragma Assert (Ekind (Ent) = E_Discriminant);
 235
 236       return Ent;
 237    end First_Discriminant;
 238
 239    -------------------------------
 240    -- First_Stored_Discriminant --
 241    -------------------------------
 242
 243    function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
 244       Ent : Entity_Id;
 245
 246       function Has_Completely_Hidden_Discriminant
 247         (Typ : Entity_Id) return Boolean;
 248       --  Scans the Discriminants to see whether any are Completely_Hidden
 249       --  (the mechanism for describing non-specified stored discriminants)
 250
 251       ----------------------------------------
 252       -- Has_Completely_Hidden_Discriminant --
 253       ----------------------------------------
 254
 255       function Has_Completely_Hidden_Discriminant
 256         (Typ : Entity_Id) return Boolean
 257       is
 258          Ent : Entity_Id;
 259
 260       begin
 261          pragma Assert (Ekind (Typ) = E_Discriminant);
 262
 263          Ent := Typ;
 264          while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
 265             if Is_Completely_Hidden (Ent) then
 266                return True;
 267             end if;
 268
 269             Ent := Next_Entity (Ent);
 270          end loop;
 271
 272          return False;
 273       end Has_Completely_Hidden_Discriminant;
 274
 275    --  Start of processing for First_Stored_Discriminant
 276
 277    begin
 278       pragma Assert
 279         (Has_Discriminants (Typ)
 280           or else Has_Unknown_Discriminants (Typ));
 281
 282       Ent := First_Entity (Typ);
 283
 284       if Chars (Ent) = Name_uTag then
 285          Ent := Next_Entity (Ent);
 286       end if;
 287
 288       if Chars (Ent) = Name_uController then
 289          Ent := Next_Entity (Ent);
 290       end if;
 291
 292       if Has_Completely_Hidden_Discriminant (Ent) then
 293
 294          while Present (Ent) loop
 295             exit when Is_Completely_Hidden (Ent);
 296             Ent := Next_Entity (Ent);
 297          end loop;
 298
 299       end if;
 300
 301       pragma Assert (Ekind (Ent) = E_Discriminant);
 302
 303       return Ent;
 304    end First_Stored_Discriminant;
 305
 306    -------------------
 307    -- First_Subtype --
 308    -------------------
 309
 310    function First_Subtype (Typ : Entity_Id) return Entity_Id is
 311       B   : constant Entity_Id := Base_Type (Typ);
 312       F   : constant Node_Id   := Freeze_Node (B);
 313       Ent : Entity_Id;
 314
 315    begin
 316       --  If the base type has no freeze node, it is a type in standard,
 317       --  and always acts as its own first subtype unless it is one of the
 318       --  predefined integer types. If the type is formal, it is also a first
 319       --  subtype, and its base type has no freeze node. On the other hand, a
 320       --  subtype of a generic formal is not its own first_subtype. Its base
 321       --  type, if anonymous, is attached to the formal type decl. from which
 322       --  the first subtype is obtained.
 323
 324       if No (F) then
 325
 326          if B = Base_Type (Standard_Integer) then
 327             return Standard_Integer;
 328
 329          elsif B = Base_Type (Standard_Long_Integer) then
 330             return Standard_Long_Integer;
 331
 332          elsif B = Base_Type (Standard_Short_Short_Integer) then
 333             return Standard_Short_Short_Integer;
 334
 335          elsif B = Base_Type (Standard_Short_Integer) then
 336             return Standard_Short_Integer;
 337
 338          elsif B = Base_Type (Standard_Long_Long_Integer) then
 339             return Standard_Long_Long_Integer;
 340
 341          elsif Is_Generic_Type (Typ) then
 342             if Present (Parent (B)) then
 343                return Defining_Identifier (Parent (B));
 344             else
 345                return Defining_Identifier (Associated_Node_For_Itype (B));
 346             end if;
 347
 348          else
 349             return B;
 350          end if;
 351
 352       --  Otherwise we check the freeze node, if it has a First_Subtype_Link
 353       --  then we use that link, otherwise (happens with some Itypes), we use
 354       --  the base type itself.
 355
 356       else
 357          Ent := First_Subtype_Link (F);
 358
 359          if Present (Ent) then
 360             return Ent;
 361          else
 362             return B;
 363          end if;
 364       end if;
 365    end First_Subtype;
 366
 367    -------------------------
 368    -- First_Tag_Component --
 369    -------------------------
 370
 371    function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
 372       Comp : Entity_Id;
 373       Ctyp : Entity_Id;
 374
 375    begin
 376       Ctyp := Typ;
 377       pragma Assert (Is_Tagged_Type (Ctyp));
 378
 379       if Is_Class_Wide_Type (Ctyp) then
 380          Ctyp := Root_Type (Ctyp);
 381       end if;
 382
 383       if Is_Private_Type (Ctyp) then
 384          Ctyp := Underlying_Type (Ctyp);
 385
 386          --  If the underlying type is missing then the source program has
 387          --  errors and there is nothing else to do (the full-type declaration
 388          --  associated with the private type declaration is missing).
 389
 390          if No (Ctyp) then
 391             return Empty;
 392          end if;
 393       end if;
 394
 395       Comp := First_Entity (Ctyp);
 396       while Present (Comp) loop
 397          if Is_Tag (Comp) then
 398             return Comp;
 399          end if;
 400
 401          Comp := Next_Entity (Comp);
 402       end loop;
 403
 404       --  No tag component found
 405
 406       return Empty;
 407    end First_Tag_Component;
 408
 409    ----------------
 410    -- Initialize --
 411    ----------------
 412
 413    procedure Initialize is
 414    begin
 415       Obsolescent_Warnings.Init;
 416    end Initialize;
 417
 418    ---------------------
 419    -- Is_By_Copy_Type --
 420    ---------------------
 421
 422    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
 423    begin
 424       --  If Id is a private type whose full declaration has not been seen,
 425       --  we assume for now that it is not a By_Copy type. Clearly this
 426       --  attribute should not be used before the type is frozen, but it is
 427       --  needed to build the associated record of a protected type. Another
 428       --  place where some lookahead for a full view is needed ???
 429
 430       return
 431         Is_Elementary_Type (Ent)
 432           or else (Is_Private_Type (Ent)
 433                      and then Present (Underlying_Type (Ent))
 434                      and then Is_Elementary_Type (Underlying_Type (Ent)));
 435    end Is_By_Copy_Type;
 436
 437    --------------------------
 438    -- Is_By_Reference_Type --
 439    --------------------------
 440
 441    function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
 442       Btype : constant Entity_Id := Base_Type (Ent);
 443
 444    begin
 445       if Error_Posted (Ent)
 446         or else Error_Posted (Btype)
 447       then
 448          return False;
 449
 450       elsif Is_Private_Type (Btype) then
 451          declare
 452             Utyp : constant Entity_Id := Underlying_Type (Btype);
 453          begin
 454             if No (Utyp) then
 455                return False;
 456             else
 457                return Is_By_Reference_Type (Utyp);
 458             end if;
 459          end;
 460
 461       elsif Is_Incomplete_Type (Btype) then
 462          declare
 463             Ftyp : constant Entity_Id := Full_View (Btype);
 464          begin
 465             if No (Ftyp) then
 466                return False;
 467             else
 468                return Is_By_Reference_Type (Ftyp);
 469             end if;
 470          end;
 471
 472       elsif Is_Concurrent_Type (Btype) then
 473          return True;
 474
 475       elsif Is_Record_Type (Btype) then
 476          if Is_Limited_Record (Btype)
 477            or else Is_Tagged_Type (Btype)
 478            or else Is_Volatile (Btype)
 479          then
 480             return True;
 481
 482          else
 483             declare
 484                C : Entity_Id;
 485
 486             begin
 487                C := First_Component (Btype);
 488                while Present (C) loop
 489                   if Is_By_Reference_Type (Etype (C))
 490                     or else Is_Volatile (Etype (C))
 491                   then
 492                      return True;
 493                   end if;
 494
 495                   C := Next_Component (C);
 496                end loop;
 497             end;
 498
 499             return False;
 500          end if;
 501
 502       elsif Is_Array_Type (Btype) then
 503          return
 504            Is_Volatile (Btype)
 505              or else Is_By_Reference_Type (Component_Type (Btype))
 506              or else Is_Volatile (Component_Type (Btype))
 507              or else Has_Volatile_Components (Btype);
 508
 509       else
 510          return False;
 511       end if;
 512    end Is_By_Reference_Type;
 513
 514    ---------------------
 515    -- Is_Derived_Type --
 516    ---------------------
 517
 518    function Is_Derived_Type (Ent : E) return B is
 519       Par : Node_Id;
 520
 521    begin
 522       if Is_Type (Ent)
 523         and then Base_Type (Ent) /= Root_Type (Ent)
 524         and then not Is_Class_Wide_Type (Ent)
 525       then
 526          if not Is_Numeric_Type (Root_Type (Ent)) then
 527             return True;
 528
 529          else
 530             Par := Parent (First_Subtype (Ent));
 531
 532             return Present (Par)
 533               and then Nkind (Par) = N_Full_Type_Declaration
 534               and then Nkind (Type_Definition (Par)) =
 535                          N_Derived_Type_Definition;
 536          end if;
 537
 538       else
 539          return False;
 540       end if;
 541    end Is_Derived_Type;
 542
 543    ---------------------------
 544    -- Is_Indefinite_Subtype --
 545    ---------------------------
 546
 547    function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
 548       K : constant Entity_Kind := Ekind (Ent);
 549
 550    begin
 551       if Is_Constrained (Ent) then
 552          return False;
 553
 554       elsif K in Array_Kind
 555         or else K in Class_Wide_Kind
 556         or else Has_Unknown_Discriminants (Ent)
 557       then
 558          return True;
 559
 560       --  Known discriminants: indefinite if there are no default values
 561
 562       elsif K in Record_Kind
 563         or else Is_Incomplete_Or_Private_Type (Ent)
 564         or else Is_Concurrent_Type (Ent)
 565       then
 566          return (Has_Discriminants (Ent)
 567            and then
 568              No (Discriminant_Default_Value (First_Discriminant (Ent))));
 569
 570       else
 571          return False;
 572       end if;
 573    end Is_Indefinite_Subtype;
 574
 575    --------------------------------
 576    -- Is_Inherently_Limited_Type --
 577    --------------------------------
 578
 579    function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is
 580       Btype : constant Entity_Id := Base_Type (Ent);
 581
 582    begin
 583       if Is_Private_Type (Btype) then
 584          declare
 585             Utyp : constant Entity_Id := Underlying_Type (Btype);
 586          begin
 587             if No (Utyp) then
 588                return False;
 589             else
 590                return Is_Inherently_Limited_Type (Utyp);
 591             end if;
 592          end;
 593
 594       elsif Is_Concurrent_Type (Btype) then
 595          return True;
 596
 597       elsif Is_Record_Type (Btype) then
 598          if Is_Limited_Record (Btype) then
 599             return not Is_Interface (Btype)
 600               or else Is_Protected_Interface (Btype)
 601               or else Is_Synchronized_Interface (Btype)
 602               or else Is_Task_Interface (Btype);
 603
 604          elsif Is_Class_Wide_Type (Btype) then
 605             return Is_Inherently_Limited_Type (Root_Type (Btype));
 606
 607          else
 608             declare
 609                C : Entity_Id;
 610
 611             begin
 612                C := First_Component (Btype);
 613                while Present (C) loop
 614                   if Is_Inherently_Limited_Type (Etype (C)) then
 615                      return True;
 616                   end if;
 617
 618                   C := Next_Component (C);
 619                end loop;
 620             end;
 621
 622             return False;
 623          end if;
 624
 625       elsif Is_Array_Type (Btype) then
 626          return Is_Inherently_Limited_Type (Component_Type (Btype));
 627
 628       else
 629          return False;
 630       end if;
 631    end Is_Inherently_Limited_Type;
 632
 633    ---------------------
 634    -- Is_Limited_Type --
 635    ---------------------
 636
 637    function Is_Limited_Type (Ent : Entity_Id) return Boolean is
 638       Btype : constant E := Base_Type (Ent);
 639       Rtype : constant E := Root_Type (Btype);
 640
 641    begin
 642       if not Is_Type (Ent) then
 643          return False;
 644
 645       elsif Ekind (Btype) = E_Limited_Private_Type
 646         or else Is_Limited_Composite (Btype)
 647       then
 648          return True;
 649
 650       elsif Is_Concurrent_Type (Btype) then
 651          return True;
 652
 653          --  The Is_Limited_Record flag normally indicates that the type is
 654          --  limited. The exception is that a type does not inherit limitedness
 655          --  from its interface ancestor. So the type may be derived from a
 656          --  limited interface, but is not limited.
 657
 658       elsif Is_Limited_Record (Ent)
 659         and then not Is_Interface (Ent)
 660       then
 661          return True;
 662
 663       --  Otherwise we will look around to see if there is some other reason
 664       --  for it to be limited, except that if an error was posted on the
 665       --  entity, then just assume it is non-limited, because it can cause
 666       --  trouble to recurse into a murky erroneous entity!
 667
 668       elsif Error_Posted (Ent) then
 669          return False;
 670
 671       elsif Is_Record_Type (Btype) then
 672
 673          if Is_Limited_Interface (Ent) then
 674             return True;
 675
 676          --  AI-419: limitedness is not inherited from a limited interface
 677
 678          elsif Is_Limited_Record (Rtype) then
 679             return not Is_Interface (Rtype)
 680               or else Is_Protected_Interface (Rtype)
 681               or else Is_Synchronized_Interface (Rtype)
 682               or else Is_Task_Interface (Rtype);
 683
 684          elsif Is_Class_Wide_Type (Btype) then
 685             return Is_Limited_Type (Rtype);
 686
 687          else
 688             declare
 689                C : E;
 690
 691             begin
 692                C := First_Component (Btype);
 693                while Present (C) loop
 694                   if Is_Limited_Type (Etype (C)) then
 695                      return True;
 696                   end if;
 697
 698                   C := Next_Component (C);
 699                end loop;
 700             end;
 701
 702             return False;
 703          end if;
 704
 705       elsif Is_Array_Type (Btype) then
 706          return Is_Limited_Type (Component_Type (Btype));
 707
 708       else
 709          return False;
 710       end if;
 711    end Is_Limited_Type;
 712
 713    ---------------------------
 714    -- Nearest_Dynamic_Scope --
 715    ---------------------------
 716
 717    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
 718    begin
 719       if Is_Dynamic_Scope (Ent) then
 720          return Ent;
 721       else
 722          return Enclosing_Dynamic_Scope (Ent);
 723       end if;
 724    end Nearest_Dynamic_Scope;
 725
 726    ------------------------
 727    -- Next_Tag_Component --
 728    ------------------------
 729
 730    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
 731       Comp : Entity_Id;
 732
 733    begin
 734       pragma Assert (Is_Tag (Tag));
 735
 736       --  Loop to look for next tag component
 737
 738       Comp := Next_Entity (Tag);
 739       while Present (Comp) loop
 740          if Is_Tag (Comp) then
 741             pragma Assert (Chars (Comp) /= Name_uTag);
 742             return Comp;
 743          end if;
 744
 745          Comp := Next_Entity (Comp);
 746       end loop;
 747
 748       --  No tag component found
 749
 750       return Empty;
 751    end Next_Tag_Component;
 752
 753    --------------------------
 754    -- Number_Discriminants --
 755    --------------------------
 756
 757    function Number_Discriminants (Typ : Entity_Id) return Pos is
 758       N     : Int;
 759       Discr : Entity_Id;
 760
 761    begin
 762       N := 0;
 763       Discr := First_Discriminant (Typ);
 764       while Present (Discr) loop
 765          N := N + 1;
 766          Discr := Next_Discriminant (Discr);
 767       end loop;
 768
 769       return N;
 770    end Number_Discriminants;
 771
 772    ---------------
 773    -- Tree_Read --
 774    ---------------
 775
 776    procedure Tree_Read is
 777    begin
 778       Obsolescent_Warnings.Tree_Read;
 779    end Tree_Read;
 780
 781    ----------------
 782    -- Tree_Write --
 783    ----------------
 784
 785    procedure Tree_Write is
 786    begin
 787       Obsolescent_Warnings.Tree_Write;
 788    end Tree_Write;
 789
 790 end Sem_Aux;