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