gcc/ada/uname.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                U N A M E                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Atree;    use Atree;
  33 with Casing;   use Casing;
  34 with Einfo;    use Einfo;
  35 with Hostparm;
  36 with Lib;      use Lib;
  37 with Nlists;   use Nlists;
  38 with Output;   use Output;
  39 with Sinfo;    use Sinfo;
  40 with Sinput;   use Sinput;
  41
  42 package body Uname is
  43
  44    function Has_Prefix (X, Prefix : String) return Boolean;
  45    --  True if Prefix is at the beginning of X. For example,
  46    --  Has_Prefix("a-filename.ads", Prefix => "a-") is True.
  47
  48    -------------------
  49    -- Get_Body_Name --
  50    -------------------
  51
  52    function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
  53    begin
  54       Get_Name_String (N);
  55
  56       pragma Assert (Name_Len > 2
  57                        and then Name_Buffer (Name_Len - 1) = '%'
  58                        and then Name_Buffer (Name_Len) = 's');
  59
  60       Name_Buffer (Name_Len) := 'b';
  61       return Name_Find;
  62    end Get_Body_Name;
  63
  64    -----------------------------------
  65    -- Get_External_Unit_Name_String --
  66    -----------------------------------
  67
  68    procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
  69       Pcount : Natural;
  70       Newlen : Natural;
  71
  72    begin
  73       --  Get unit name and eliminate trailing %s or %b
  74
  75       Get_Name_String (N);
  76       Name_Len := Name_Len - 2;
  77
  78       --  Find number of components
  79
  80       Pcount := 0;
  81       for J in 1 .. Name_Len loop
  82          if Name_Buffer (J) = '.' then
  83             Pcount := Pcount + 1;
  84          end if;
  85       end loop;
  86
  87       --  If simple name, nothing to do
  88
  89       if Pcount = 0 then
  90          return;
  91       end if;
  92
  93       --  If name has multiple components, replace dots by double underscore
  94
  95       Newlen := Name_Len + Pcount;
  96
  97       for J in reverse 1 .. Name_Len loop
  98          if Name_Buffer (J) = '.' then
  99             Name_Buffer (Newlen) := '_';
 100             Name_Buffer (Newlen - 1) := '_';
 101             Newlen := Newlen - 2;
 102
 103          else
 104             Name_Buffer (Newlen) := Name_Buffer (J);
 105             Newlen := Newlen - 1;
 106          end if;
 107       end loop;
 108
 109       Name_Len := Name_Len + Pcount;
 110    end Get_External_Unit_Name_String;
 111
 112    --------------------------
 113    -- Get_Parent_Body_Name --
 114    --------------------------
 115
 116    function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
 117    begin
 118       Get_Name_String (N);
 119
 120       while Name_Buffer (Name_Len) /= '.' loop
 121          pragma Assert (Name_Len > 1); -- not a child or subunit name
 122          Name_Len := Name_Len - 1;
 123       end loop;
 124
 125       Name_Buffer (Name_Len) := '%';
 126       Name_Len := Name_Len + 1;
 127       Name_Buffer (Name_Len) := 'b';
 128       return Name_Find;
 129
 130    end Get_Parent_Body_Name;
 131
 132    --------------------------
 133    -- Get_Parent_Spec_Name --
 134    --------------------------
 135
 136    function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
 137    begin
 138       Get_Name_String (N);
 139
 140       while Name_Buffer (Name_Len) /= '.' loop
 141          if Name_Len = 1 then
 142             return No_Unit_Name;
 143          else
 144             Name_Len := Name_Len - 1;
 145          end if;
 146       end loop;
 147
 148       Name_Buffer (Name_Len) := '%';
 149       Name_Len := Name_Len + 1;
 150       Name_Buffer (Name_Len) := 's';
 151       return Name_Find;
 152
 153    end Get_Parent_Spec_Name;
 154
 155    -------------------
 156    -- Get_Spec_Name --
 157    -------------------
 158
 159    function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
 160    begin
 161       Get_Name_String (N);
 162
 163       pragma Assert (Name_Len > 2
 164                        and then Name_Buffer (Name_Len - 1) = '%'
 165                        and then Name_Buffer (Name_Len) = 'b');
 166
 167       Name_Buffer (Name_Len) := 's';
 168       return Name_Find;
 169    end Get_Spec_Name;
 170
 171    -------------------
 172    -- Get_Unit_Name --
 173    -------------------
 174
 175    function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
 176
 177       Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
 178       --  Buffer used to build name of unit. Note that we cannot use the
 179       --  Name_Buffer in package Name_Table because we use it to read
 180       --  component names.
 181
 182       Unit_Name_Length : Natural := 0;
 183       --  Length of name stored in Unit_Name_Buffer
 184
 185       Node : Node_Id;
 186       --  Program unit node
 187
 188       procedure Add_Char (C : Character);
 189       --  Add a single character to stored unit name
 190
 191       procedure Add_Name (Name : Name_Id);
 192       --  Add the characters of a names table entry to stored unit name
 193
 194       procedure Add_Node_Name (Node : Node_Id);
 195       --  Recursive procedure adds characters associated with Node
 196
 197       function Get_Parent (Node : Node_Id) return Node_Id;
 198       --  Get parent compilation unit of a stub
 199
 200       --------------
 201       -- Add_Char --
 202       --------------
 203
 204       procedure Add_Char (C : Character) is
 205       begin
 206          --  Should really check for max length exceeded here???
 207          Unit_Name_Length := Unit_Name_Length + 1;
 208          Unit_Name_Buffer (Unit_Name_Length) := C;
 209       end Add_Char;
 210
 211       --------------
 212       -- Add_Name --
 213       --------------
 214
 215       procedure Add_Name (Name : Name_Id) is
 216       begin
 217          Get_Name_String (Name);
 218
 219          for J in 1 .. Name_Len loop
 220             Add_Char (Name_Buffer (J));
 221          end loop;
 222       end Add_Name;
 223
 224       -------------------
 225       -- Add_Node_Name --
 226       -------------------
 227
 228       procedure Add_Node_Name (Node : Node_Id) is
 229          Kind : constant Node_Kind := Nkind (Node);
 230
 231       begin
 232          --  Just ignore an error node (someone else will give a message)
 233
 234          if Node = Error then
 235             return;
 236
 237          --  Otherwise see what kind of node we have
 238
 239          else
 240             case Kind is
 241                when N_Defining_Identifier
 242                   | N_Defining_Operator_Symbol
 243                   | N_Identifier
 244                =>
 245                   --  Note: it is of course an error to have a defining
 246                   --  operator symbol at this point, but this is not where
 247                   --  the error is signalled, so we handle it nicely here.
 248
 249                   Add_Name (Chars (Node));
 250
 251                when N_Defining_Program_Unit_Name =>
 252                   Add_Node_Name (Name (Node));
 253                   Add_Char ('.');
 254                   Add_Node_Name (Defining_Identifier (Node));
 255
 256                when N_Expanded_Name
 257                   | N_Selected_Component
 258                =>
 259                   Add_Node_Name (Prefix (Node));
 260                   Add_Char ('.');
 261                   Add_Node_Name (Selector_Name (Node));
 262
 263                when N_Package_Specification
 264                   | N_Subprogram_Specification
 265                =>
 266                   Add_Node_Name (Defining_Unit_Name (Node));
 267
 268                when N_Generic_Declaration
 269                   | N_Package_Declaration
 270                   | N_Subprogram_Body
 271                   | N_Subprogram_Declaration
 272                =>
 273                   Add_Node_Name (Specification (Node));
 274
 275                when N_Generic_Instantiation =>
 276                   Add_Node_Name (Defining_Unit_Name (Node));
 277
 278                when N_Package_Body =>
 279                   Add_Node_Name (Defining_Unit_Name (Node));
 280
 281                when N_Protected_Body
 282                   | N_Task_Body
 283                =>
 284                   Add_Node_Name (Defining_Identifier (Node));
 285
 286                when N_Package_Renaming_Declaration =>
 287                   Add_Node_Name (Defining_Unit_Name (Node));
 288
 289                when N_Subprogram_Renaming_Declaration =>
 290                   Add_Node_Name (Specification (Node));
 291
 292                when N_Generic_Renaming_Declaration =>
 293                   Add_Node_Name (Defining_Unit_Name (Node));
 294
 295                when N_Subprogram_Body_Stub =>
 296                   Add_Node_Name (Get_Parent (Node));
 297                   Add_Char ('.');
 298                   Add_Node_Name (Specification (Node));
 299
 300                when N_Compilation_Unit =>
 301                   Add_Node_Name (Unit (Node));
 302
 303                when N_Package_Body_Stub
 304                   | N_Protected_Body_Stub
 305                   | N_Task_Body_Stub
 306                =>
 307                   Add_Node_Name (Get_Parent (Node));
 308                   Add_Char ('.');
 309                   Add_Node_Name (Defining_Identifier (Node));
 310
 311                when N_Subunit =>
 312                   Add_Node_Name (Name (Node));
 313                   Add_Char ('.');
 314                   Add_Node_Name (Proper_Body (Node));
 315
 316                when N_With_Clause =>
 317                   Add_Node_Name (Name (Node));
 318
 319                when N_Pragma =>
 320                   Add_Node_Name (Expression (First
 321                     (Pragma_Argument_Associations (Node))));
 322
 323                --  Tasks and protected stuff appear only in an error context,
 324                --  but the error has been posted elsewhere, so we deal nicely
 325                --  with these error situations here, and produce a reasonable
 326                --  unit name using the defining identifier.
 327
 328                when N_Protected_Type_Declaration
 329                   | N_Single_Protected_Declaration
 330                   | N_Single_Task_Declaration
 331                   | N_Task_Type_Declaration
 332                =>
 333                   Add_Node_Name (Defining_Identifier (Node));
 334
 335                when others =>
 336                   raise Program_Error;
 337             end case;
 338          end if;
 339       end Add_Node_Name;
 340
 341       ----------------
 342       -- Get_Parent --
 343       ----------------
 344
 345       function Get_Parent (Node : Node_Id) return Node_Id is
 346          N : Node_Id := Node;
 347
 348       begin
 349          while Nkind (N) /= N_Compilation_Unit loop
 350             N := Parent (N);
 351          end loop;
 352
 353          return N;
 354       end Get_Parent;
 355
 356    --  Start of processing for Get_Unit_Name
 357
 358    begin
 359       Node := N;
 360
 361       --  If we have Defining_Identifier, find the associated unit node
 362
 363       if Nkind (Node) = N_Defining_Identifier then
 364          Node := Declaration_Node (Node);
 365
 366       --  If an expanded name, it is an already analyzed child unit, find
 367       --  unit node.
 368
 369       elsif Nkind (Node) = N_Expanded_Name then
 370          Node := Declaration_Node (Entity (Node));
 371       end if;
 372
 373       if Nkind (Node) = N_Package_Specification
 374         or else Nkind (Node) in N_Subprogram_Specification
 375       then
 376          Node := Parent (Node);
 377       end if;
 378
 379       --  Node points to the unit, so get its name and add proper suffix
 380
 381       Add_Node_Name (Node);
 382       Add_Char ('%');
 383
 384       case Nkind (Node) is
 385          when N_Generic_Declaration
 386             | N_Generic_Instantiation
 387             | N_Generic_Renaming_Declaration
 388             | N_Package_Declaration
 389             | N_Package_Renaming_Declaration
 390             | N_Pragma
 391             | N_Protected_Type_Declaration
 392             | N_Single_Protected_Declaration
 393             | N_Single_Task_Declaration
 394             | N_Subprogram_Declaration
 395             | N_Subprogram_Renaming_Declaration
 396             | N_Task_Type_Declaration
 397             | N_With_Clause
 398          =>
 399             Add_Char ('s');
 400
 401          when N_Body_Stub
 402             | N_Identifier
 403             | N_Package_Body
 404             | N_Protected_Body
 405             | N_Selected_Component
 406             | N_Subprogram_Body
 407             | N_Subunit
 408             | N_Task_Body
 409          =>
 410             Add_Char ('b');
 411
 412          when others =>
 413             raise Program_Error;
 414       end case;
 415
 416       Name_Buffer (1 .. Unit_Name_Length) :=
 417         Unit_Name_Buffer (1 .. Unit_Name_Length);
 418       Name_Len := Unit_Name_Length;
 419       return Name_Find;
 420
 421    end Get_Unit_Name;
 422
 423    --------------------------
 424    -- Get_Unit_Name_String --
 425    --------------------------
 426
 427    procedure Get_Unit_Name_String
 428      (N      : Unit_Name_Type;
 429       Suffix : Boolean := True)
 430    is
 431       Unit_Is_Body : Boolean;
 432
 433    begin
 434       Get_Decoded_Name_String (N);
 435       Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
 436       Set_Casing (Identifier_Casing (Source_Index (Main_Unit)));
 437
 438       --  A special fudge, normally we don't have operator symbols present,
 439       --  since it is always an error to do so. However, if we do, at this
 440       --  stage it has the form:
 441
 442       --    "and"
 443
 444       --  and the %s or %b has already been eliminated so put 2 chars back
 445
 446       if Name_Buffer (1) = '"' then
 447          Name_Len := Name_Len + 2;
 448       end if;
 449
 450       --  Now adjust the %s or %b to (spec) or (body)
 451
 452       if Suffix then
 453          if Unit_Is_Body then
 454             Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
 455          else
 456             Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
 457          end if;
 458       end if;
 459
 460       for J in 1 .. Name_Len loop
 461          if Name_Buffer (J) = '-' then
 462             Name_Buffer (J) := '.';
 463          end if;
 464       end loop;
 465
 466       --  Adjust Name_Len
 467
 468       if Suffix then
 469          Name_Len := Name_Len + (7 - 2);
 470       else
 471          Name_Len := Name_Len - 2;
 472       end if;
 473    end Get_Unit_Name_String;
 474
 475    ----------------
 476    -- Has_Prefix --
 477    ----------------
 478
 479    function Has_Prefix (X, Prefix : String) return Boolean is
 480    begin
 481       if X'Length >= Prefix'Length then
 482          declare
 483             Slice : String renames
 484                       X (X'First .. X'First + Prefix'Length - 1);
 485          begin
 486             return Slice = Prefix;
 487          end;
 488       end if;
 489       return False;
 490    end Has_Prefix;
 491
 492    ------------------
 493    -- Is_Body_Name --
 494    ------------------
 495
 496    function Is_Body_Name (N : Unit_Name_Type) return Boolean is
 497    begin
 498       Get_Name_String (N);
 499       return Name_Len > 2
 500         and then Name_Buffer (Name_Len - 1) = '%'
 501         and then Name_Buffer (Name_Len) = 'b';
 502    end Is_Body_Name;
 503
 504    -------------------
 505    -- Is_Child_Name --
 506    -------------------
 507
 508    function Is_Child_Name (N : Unit_Name_Type) return Boolean is
 509       J : Natural;
 510
 511    begin
 512       Get_Name_String (N);
 513       J := Name_Len;
 514
 515       while Name_Buffer (J) /= '.' loop
 516          if J = 1 then
 517             return False; -- not a child or subunit name
 518          else
 519             J := J - 1;
 520          end if;
 521       end loop;
 522
 523       return True;
 524    end Is_Child_Name;
 525
 526    ---------------------------
 527    -- Is_Internal_Unit_Name --
 528    ---------------------------
 529
 530    function Is_Internal_Unit_Name
 531      (Name               : String;
 532       Renamings_Included : Boolean := True) return Boolean
 533    is
 534       Gnat : constant String := "gnat";
 535
 536    begin
 537       if Name = Gnat then
 538          return True;
 539       end if;
 540
 541       if Has_Prefix (Name, Prefix => Gnat & ".") then
 542          return True;
 543       end if;
 544
 545       return Is_Predefined_Unit_Name (Name, Renamings_Included);
 546    end Is_Internal_Unit_Name;
 547
 548    -----------------------------
 549    -- Is_Predefined_Unit_Name --
 550    -----------------------------
 551
 552    function Is_Predefined_Unit_Name
 553      (Name               : String;
 554       Renamings_Included : Boolean := True) return Boolean
 555    is
 556       Ada        : constant String := "ada";
 557       Interfaces : constant String := "interfaces";
 558       System     : constant String := "system";
 559
 560    begin
 561       if Name = Ada
 562         or else Name = Interfaces
 563         or else Name = System
 564       then
 565          return True;
 566       end if;
 567
 568       if Has_Prefix (Name, Prefix => Ada & ".")
 569         or else Has_Prefix (Name, Prefix => Interfaces & ".")
 570         or else Has_Prefix (Name, Prefix => System & ".")
 571       then
 572          return True;
 573       end if;
 574
 575       if not Renamings_Included then
 576          return False;
 577       end if;
 578
 579       --  The following are the predefined renamings
 580
 581       return
 582         Name = "calendar"
 583           or else Name = "machine_code"
 584           or else Name = "unchecked_conversion"
 585           or else Name = "unchecked_deallocation"
 586           or else Name = "direct_io"
 587           or else Name = "io_exceptions"
 588           or else Name = "sequential_io"
 589           or else Name = "text_io";
 590    end Is_Predefined_Unit_Name;
 591
 592    ------------------
 593    -- Is_Spec_Name --
 594    ------------------
 595
 596    function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
 597    begin
 598       Get_Name_String (N);
 599       return Name_Len > 2
 600         and then Name_Buffer (Name_Len - 1) = '%'
 601         and then Name_Buffer (Name_Len) = 's';
 602    end Is_Spec_Name;
 603
 604    -----------------------
 605    -- Name_To_Unit_Name --
 606    -----------------------
 607
 608    function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
 609    begin
 610       Get_Name_String (N);
 611       Name_Buffer (Name_Len + 1) := '%';
 612       Name_Buffer (Name_Len + 2) := 's';
 613       Name_Len := Name_Len + 2;
 614       return Name_Find;
 615    end Name_To_Unit_Name;
 616
 617    ---------------
 618    -- New_Child --
 619    ---------------
 620
 621    function New_Child
 622      (Old  : Unit_Name_Type;
 623       Newp : Unit_Name_Type) return Unit_Name_Type
 624    is
 625       P : Natural;
 626
 627    begin
 628       Get_Name_String (Old);
 629
 630       declare
 631          Child : constant String := Name_Buffer (1 .. Name_Len);
 632
 633       begin
 634          Get_Name_String (Newp);
 635          Name_Len := Name_Len - 2;
 636
 637          P := Child'Last;
 638          while Child (P) /= '.' loop
 639             P := P - 1;
 640          end loop;
 641
 642          while P <= Child'Last loop
 643             Name_Len := Name_Len + 1;
 644             Name_Buffer (Name_Len) := Child (P);
 645             P := P + 1;
 646          end loop;
 647
 648          return Name_Find;
 649       end;
 650    end New_Child;
 651
 652    --------------
 653    -- Uname_Ge --
 654    --------------
 655
 656    function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
 657    begin
 658       return Left = Right or else Uname_Gt (Left, Right);
 659    end Uname_Ge;
 660
 661    --------------
 662    -- Uname_Gt --
 663    --------------
 664
 665    function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
 666    begin
 667       return Left /= Right and then not Uname_Lt (Left, Right);
 668    end Uname_Gt;
 669
 670    --------------
 671    -- Uname_Le --
 672    --------------
 673
 674    function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
 675    begin
 676       return Left = Right or else Uname_Lt (Left, Right);
 677    end Uname_Le;
 678
 679    --------------
 680    -- Uname_Lt --
 681    --------------
 682
 683    function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
 684       Left_Name    : String (1 .. Hostparm.Max_Name_Length);
 685       Left_Length  : Natural;
 686       Right_Name   : String renames Name_Buffer;
 687       Right_Length : Natural renames Name_Len;
 688       J            : Natural;
 689
 690    begin
 691       pragma Warnings (Off, Right_Length);
 692       --  Suppress warnings on Right_Length, used in pragma Assert
 693
 694       if Left = Right then
 695          return False;
 696       end if;
 697
 698       Get_Name_String (Left);
 699       Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
 700       Left_Length := Name_Len;
 701       Get_Name_String (Right);
 702       J := 1;
 703
 704       loop
 705          exit when Left_Name (J) = '%';
 706
 707          if Right_Name (J) = '%' then
 708             return False; -- left name is longer
 709          end if;
 710
 711          pragma Assert (J <= Left_Length and then J <= Right_Length);
 712
 713          if Left_Name (J) /= Right_Name (J) then
 714             return Left_Name (J) < Right_Name (J); -- parent names different
 715          end if;
 716
 717          J := J + 1;
 718       end loop;
 719
 720       --  Come here pointing to % in left name
 721
 722       if Right_Name (J) /= '%' then
 723          return True; -- right name is longer
 724       end if;
 725
 726       --  Here the parent names are the same and specs sort low. If neither is
 727       --  a spec, then we are comparing the same name and we want a result of
 728       --  False in any case.
 729
 730       return Left_Name (J + 1) = 's';
 731    end Uname_Lt;
 732
 733    ---------------------
 734    -- Write_Unit_Name --
 735    ---------------------
 736
 737    procedure Write_Unit_Name (N : Unit_Name_Type) is
 738    begin
 739       Get_Unit_Name_String (N);
 740       Write_Str (Name_Buffer (1 .. Name_Len));
 741    end Write_Unit_Name;
 742
 743 end Uname;