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