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-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Atree;    use Atree;
  35 with Casing;   use Casing;
  36 with Einfo;    use Einfo;
  37 with Hostparm;
  38 with Lib;      use Lib;
  39 with Nlists;   use Nlists;
  40 with Output;   use Output;
  41 with Sinfo;    use Sinfo;
  42 with Sinput;   use Sinput;
  43
  44 package body Uname is
  45
  46    -------------------
  47    -- Get_Body_Name --
  48    -------------------
  49
  50    function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
  51    begin
  52       Get_Name_String (N);
  53
  54       pragma Assert (Name_Len > 2
  55                        and then Name_Buffer (Name_Len - 1) = '%'
  56                        and then Name_Buffer (Name_Len) = 's');
  57
  58       Name_Buffer (Name_Len) := 'b';
  59       return Name_Find;
  60    end Get_Body_Name;
  61
  62    -----------------------------------
  63    -- Get_External_Unit_Name_String --
  64    -----------------------------------
  65
  66    procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
  67       Pcount : Natural;
  68       Newlen : Natural;
  69
  70    begin
  71       --  Get unit name and eliminate trailing %s or %b
  72
  73       Get_Name_String (N);
  74       Name_Len := Name_Len - 2;
  75
  76       --  Find number of components
  77
  78       Pcount := 0;
  79       for J in 1 .. Name_Len loop
  80          if Name_Buffer (J) = '.' then
  81             Pcount := Pcount + 1;
  82          end if;
  83       end loop;
  84
  85       --  If simple name, nothing to do
  86
  87       if Pcount = 0 then
  88          return;
  89       end if;
  90
  91       --  If name has multiple components, replace dots by double underscore
  92
  93       Newlen := Name_Len + Pcount;
  94
  95       for J in reverse 1 .. Name_Len loop
  96          if Name_Buffer (J) = '.' then
  97             Name_Buffer (Newlen) := '_';
  98             Name_Buffer (Newlen - 1) := '_';
  99             Newlen := Newlen - 2;
 100
 101          else
 102             Name_Buffer (Newlen) := Name_Buffer (J);
 103             Newlen := Newlen - 1;
 104          end if;
 105       end loop;
 106
 107       Name_Len := Name_Len + Pcount;
 108    end Get_External_Unit_Name_String;
 109
 110    --------------------------
 111    -- Get_Parent_Body_Name --
 112    --------------------------
 113
 114    function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
 115    begin
 116       Get_Name_String (N);
 117
 118       while Name_Buffer (Name_Len) /= '.' loop
 119          pragma Assert (Name_Len > 1); -- not a child or subunit name
 120          Name_Len := Name_Len - 1;
 121       end loop;
 122
 123       Name_Buffer (Name_Len) := '%';
 124       Name_Len := Name_Len + 1;
 125       Name_Buffer (Name_Len) := 'b';
 126       return Name_Find;
 127
 128    end Get_Parent_Body_Name;
 129
 130    --------------------------
 131    -- Get_Parent_Spec_Name --
 132    --------------------------
 133
 134    function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
 135    begin
 136       Get_Name_String (N);
 137
 138       while Name_Buffer (Name_Len) /= '.' loop
 139          if Name_Len = 1 then
 140             return No_Unit_Name;
 141          else
 142             Name_Len := Name_Len - 1;
 143          end if;
 144       end loop;
 145
 146       Name_Buffer (Name_Len) := '%';
 147       Name_Len := Name_Len + 1;
 148       Name_Buffer (Name_Len) := 's';
 149       return Name_Find;
 150
 151    end Get_Parent_Spec_Name;
 152
 153    -------------------
 154    -- Get_Spec_Name --
 155    -------------------
 156
 157    function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
 158    begin
 159       Get_Name_String (N);
 160
 161       pragma Assert (Name_Len > 2
 162                        and then Name_Buffer (Name_Len - 1) = '%'
 163                        and then Name_Buffer (Name_Len) = 'b');
 164
 165       Name_Buffer (Name_Len) := 's';
 166       return Name_Find;
 167    end Get_Spec_Name;
 168
 169    -------------------
 170    -- Get_Unit_Name --
 171    -------------------
 172
 173    function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
 174
 175       Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
 176       --  Buffer used to build name of unit. Note that we cannot use the
 177       --  Name_Buffer in package Name_Table because we use it to read
 178       --  component names.
 179
 180       Unit_Name_Length : Natural := 0;
 181       --  Length of name stored in Unit_Name_Buffer
 182
 183       Node : Node_Id;
 184       --  Program unit node
 185
 186       procedure Add_Char (C : Character);
 187       --  Add a single character to stored unit name
 188
 189       procedure Add_Name (Name : Name_Id);
 190       --  Add the characters of a names table entry to stored unit name
 191
 192       procedure Add_Node_Name (Node : Node_Id);
 193       --  Recursive procedure adds characters associated with Node
 194
 195       function Get_Parent (Node : Node_Id) return Node_Id;
 196       --  Get parent compilation unit of a stub
 197
 198       --------------
 199       -- Add_Char --
 200       --------------
 201
 202       procedure Add_Char (C : Character) is
 203       begin
 204          --  Should really check for max length exceeded here???
 205          Unit_Name_Length := Unit_Name_Length + 1;
 206          Unit_Name_Buffer (Unit_Name_Length) := C;
 207       end Add_Char;
 208
 209       --------------
 210       -- Add_Name --
 211       --------------
 212
 213       procedure Add_Name (Name : Name_Id) is
 214       begin
 215          Get_Name_String (Name);
 216
 217          for J in 1 .. Name_Len loop
 218             Add_Char (Name_Buffer (J));
 219          end loop;
 220       end Add_Name;
 221
 222       -------------------
 223       -- Add_Node_Name --
 224       -------------------
 225
 226       procedure Add_Node_Name (Node : Node_Id) is
 227          Kind : constant Node_Kind := Nkind (Node);
 228
 229       begin
 230          --  Just ignore an error node (someone else will give a message)
 231
 232          if Node = Error then
 233             return;
 234
 235          --  Otherwise see what kind of node we have
 236
 237          else
 238             case Kind is
 239
 240                when N_Identifier                      |
 241                     N_Defining_Identifier             |
 242                     N_Defining_Operator_Symbol        =>
 243
 244                   --  Note: it is of course an error to have a defining
 245                   --  operator symbol at this point, but this is not where
 246                   --  the error is signalled, so we handle it nicely here!
 247
 248                   Add_Name (Chars (Node));
 249
 250                when N_Defining_Program_Unit_Name      =>
 251                   Add_Node_Name (Name (Node));
 252                   Add_Char ('.');
 253                   Add_Node_Name (Defining_Identifier (Node));
 254
 255                when N_Selected_Component              |
 256                     N_Expanded_Name                   =>
 257                   Add_Node_Name (Prefix (Node));
 258                   Add_Char ('.');
 259                   Add_Node_Name (Selector_Name (Node));
 260
 261                when N_Subprogram_Specification        |
 262                     N_Package_Specification           =>
 263                   Add_Node_Name (Defining_Unit_Name (Node));
 264
 265                when N_Subprogram_Body                 |
 266                     N_Subprogram_Declaration          |
 267                     N_Package_Declaration             |
 268                     N_Generic_Declaration             =>
 269                   Add_Node_Name (Specification (Node));
 270
 271                when N_Generic_Instantiation           =>
 272                   Add_Node_Name (Defining_Unit_Name (Node));
 273
 274                when N_Package_Body                    =>
 275                   Add_Node_Name (Defining_Unit_Name (Node));
 276
 277                when N_Task_Body                       |
 278                     N_Protected_Body                  =>
 279                   Add_Node_Name (Defining_Identifier (Node));
 280
 281                when N_Package_Renaming_Declaration    =>
 282                   Add_Node_Name (Defining_Unit_Name (Node));
 283
 284                when N_Subprogram_Renaming_Declaration =>
 285                   Add_Node_Name (Specification (Node));
 286
 287                when N_Generic_Renaming_Declaration   =>
 288                   Add_Node_Name (Defining_Unit_Name (Node));
 289
 290                when N_Subprogram_Body_Stub            =>
 291                   Add_Node_Name (Get_Parent (Node));
 292                   Add_Char ('.');
 293                   Add_Node_Name (Specification (Node));
 294
 295                when N_Compilation_Unit                =>
 296                   Add_Node_Name (Unit (Node));
 297
 298                when N_Package_Body_Stub               =>
 299                   Add_Node_Name (Get_Parent (Node));
 300                   Add_Char ('.');
 301                   Add_Node_Name (Defining_Identifier (Node));
 302
 303                when N_Task_Body_Stub                  |
 304                     N_Protected_Body_Stub             =>
 305                   Add_Node_Name (Get_Parent (Node));
 306                   Add_Char ('.');
 307                   Add_Node_Name (Defining_Identifier (Node));
 308
 309                when N_Subunit                         =>
 310                   Add_Node_Name (Name (Node));
 311                   Add_Char ('.');
 312                   Add_Node_Name (Proper_Body (Node));
 313
 314                when N_With_Clause                     =>
 315                   Add_Node_Name (Name (Node));
 316
 317                when N_Pragma                          =>
 318                   Add_Node_Name (Expression (First
 319                     (Pragma_Argument_Associations (Node))));
 320
 321                --  Tasks and protected stuff appear only in an error context,
 322                --  but the error has been posted elsewhere, so we deal nicely
 323                --  with these error situations here, and produce a reasonable
 324                --  unit name using the defining identifier.
 325
 326                when N_Task_Type_Declaration           |
 327                     N_Single_Task_Declaration         |
 328                     N_Protected_Type_Declaration      |
 329                     N_Single_Protected_Declaration    =>
 330                   Add_Node_Name (Defining_Identifier (Node));
 331
 332                when others =>
 333                   raise Program_Error;
 334
 335             end case;
 336          end if;
 337       end Add_Node_Name;
 338
 339       ----------------
 340       -- Get_Parent --
 341       ----------------
 342
 343       function Get_Parent (Node : Node_Id) return Node_Id is
 344          N : Node_Id := Node;
 345
 346       begin
 347          while Nkind (N) /= N_Compilation_Unit loop
 348             N := Parent (N);
 349          end loop;
 350
 351          return N;
 352       end Get_Parent;
 353
 354    -------------------------------------------
 355    -- Start of Processing for Get_Unit_Name --
 356    -------------------------------------------
 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_Subprogram_Declaration          |
 387               N_Package_Declaration             |
 388               N_With_Clause                     |
 389               N_Pragma                          |
 390               N_Generic_Instantiation           |
 391               N_Package_Renaming_Declaration    |
 392               N_Subprogram_Renaming_Declaration |
 393               N_Generic_Renaming_Declaration    |
 394               N_Single_Task_Declaration         |
 395               N_Single_Protected_Declaration    |
 396               N_Task_Type_Declaration           |
 397               N_Protected_Type_Declaration      =>
 398
 399             Add_Char ('s');
 400
 401          when N_Subprogram_Body                 |
 402               N_Package_Body                    |
 403               N_Subunit                         |
 404               N_Body_Stub                       |
 405               N_Task_Body                       |
 406               N_Protected_Body                  |
 407               N_Identifier                      |
 408               N_Selected_Component              =>
 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)), Mixed_Case);
 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    -- Is_Body_Name --
 477    ------------------
 478
 479    function Is_Body_Name (N : Unit_Name_Type) return Boolean is
 480    begin
 481       Get_Name_String (N);
 482       return Name_Len > 2
 483         and then Name_Buffer (Name_Len - 1) = '%'
 484         and then Name_Buffer (Name_Len) = 'b';
 485    end Is_Body_Name;
 486
 487    -------------------
 488    -- Is_Child_Name --
 489    -------------------
 490
 491    function Is_Child_Name (N : Unit_Name_Type) return Boolean is
 492       J : Natural;
 493
 494    begin
 495       Get_Name_String (N);
 496       J := Name_Len;
 497
 498       while Name_Buffer (J) /= '.' loop
 499          if J = 1 then
 500             return False; -- not a child or subunit name
 501          else
 502             J := J - 1;
 503          end if;
 504       end loop;
 505
 506       return True;
 507    end Is_Child_Name;
 508
 509    ------------------
 510    -- Is_Spec_Name --
 511    ------------------
 512
 513    function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
 514    begin
 515       Get_Name_String (N);
 516       return Name_Len > 2
 517         and then Name_Buffer (Name_Len - 1) = '%'
 518         and then Name_Buffer (Name_Len) = 's';
 519    end Is_Spec_Name;
 520
 521    -----------------------
 522    -- Name_To_Unit_Name --
 523    -----------------------
 524
 525    function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
 526    begin
 527       Get_Name_String (N);
 528       Name_Buffer (Name_Len + 1) := '%';
 529       Name_Buffer (Name_Len + 2) := 's';
 530       Name_Len := Name_Len + 2;
 531       return Name_Find;
 532    end Name_To_Unit_Name;
 533
 534    ---------------
 535    -- New_Child --
 536    ---------------
 537
 538    function New_Child
 539      (Old  : Unit_Name_Type;
 540       Newp : Unit_Name_Type) return Unit_Name_Type
 541    is
 542       P : Natural;
 543
 544    begin
 545       Get_Name_String (Old);
 546
 547       declare
 548          Child : constant String := Name_Buffer (1 .. Name_Len);
 549
 550       begin
 551          Get_Name_String (Newp);
 552          Name_Len := Name_Len - 2;
 553
 554          P := Child'Last;
 555          while Child (P) /= '.' loop
 556             P := P - 1;
 557          end loop;
 558
 559          while P <= Child'Last loop
 560             Name_Len := Name_Len + 1;
 561             Name_Buffer (Name_Len) := Child (P);
 562             P := P + 1;
 563          end loop;
 564
 565          return Name_Find;
 566       end;
 567    end New_Child;
 568
 569    --------------
 570    -- Uname_Ge --
 571    --------------
 572
 573    function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
 574    begin
 575       return Left = Right or else Uname_Gt (Left, Right);
 576    end Uname_Ge;
 577
 578    --------------
 579    -- Uname_Gt --
 580    --------------
 581
 582    function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
 583    begin
 584       return Left /= Right and then not Uname_Lt (Left, Right);
 585    end Uname_Gt;
 586
 587    --------------
 588    -- Uname_Le --
 589    --------------
 590
 591    function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
 592    begin
 593       return Left = Right or else Uname_Lt (Left, Right);
 594    end Uname_Le;
 595
 596    --------------
 597    -- Uname_Lt --
 598    --------------
 599
 600    function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
 601       Left_Name    : String (1 .. Hostparm.Max_Name_Length);
 602       Left_Length  : Natural;
 603       Right_Name   : String renames Name_Buffer;
 604       Right_Length : Natural renames Name_Len;
 605       J            : Natural;
 606
 607    begin
 608       pragma Warnings (Off, Right_Length);
 609       --  Suppress warnings on Right_Length, used in pragma Assert
 610
 611       if Left = Right then
 612          return False;
 613       end if;
 614
 615       Get_Name_String (Left);
 616       Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
 617       Left_Length := Name_Len;
 618       Get_Name_String (Right);
 619       J := 1;
 620
 621       loop
 622          exit when Left_Name (J) = '%';
 623
 624          if Right_Name (J) = '%' then
 625             return False; -- left name is longer
 626          end if;
 627
 628          pragma Assert (J <= Left_Length and then J <= Right_Length);
 629
 630          if Left_Name (J) /= Right_Name (J) then
 631             return Left_Name (J) < Right_Name (J); -- parent names different
 632          end if;
 633
 634          J := J + 1;
 635       end loop;
 636
 637       --  Come here pointing to % in left name
 638
 639       if Right_Name (J) /= '%' then
 640          return True; -- right name is longer
 641       end if;
 642
 643       --  Here the parent names are the same and specs sort low. If neither is
 644       --  a spec, then we are comparing the same name and we want a result of
 645       --  False in any case.
 646
 647       return Left_Name (J + 1) = 's';
 648    end Uname_Lt;
 649
 650    ---------------------
 651    -- Write_Unit_Name --
 652    ---------------------
 653
 654    procedure Write_Unit_Name (N : Unit_Name_Type) is
 655    begin
 656       Get_Unit_Name_String (N);
 657       Write_Str (Name_Buffer (1 .. Name_Len));
 658    end Write_Unit_Name;
 659
 660 end Uname;