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 --                                                                          --
  10 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Atree;    use Atree;
  36 with Casing;   use Casing;
  37 with Einfo;    use Einfo;
  38 with Hostparm;
  39 with Lib;      use Lib;
  40 with Namet;    use Namet;
  41 with Nlists;   use Nlists;
  42 with Output;   use Output;
  43 with Sinfo;    use Sinfo;
  44 with Sinput;   use Sinput;
  45
  46 package body Uname is
  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_Name; -- not a child or subunit 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 : 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
 242                when N_Identifier                      |
 243                     N_Defining_Identifier             |
 244                     N_Defining_Operator_Symbol        =>
 245
 246                   --  Note: it is of course an error to have a defining
 247                   --  operator symbol at this point, but this is not where
 248                   --  the error is signalled, so we handle it nicely here!
 249
 250                   Add_Name (Chars (Node));
 251
 252                when N_Defining_Program_Unit_Name      =>
 253                   Add_Node_Name (Name (Node));
 254                   Add_Char ('.');
 255                   Add_Node_Name (Defining_Identifier (Node));
 256
 257                when N_Selected_Component              |
 258                     N_Expanded_Name                   =>
 259                   Add_Node_Name (Prefix (Node));
 260                   Add_Char ('.');
 261                   Add_Node_Name (Selector_Name (Node));
 262
 263                when N_Subprogram_Specification        |
 264                     N_Package_Specification           =>
 265                   Add_Node_Name (Defining_Unit_Name (Node));
 266
 267                when N_Subprogram_Body                 |
 268                     N_Subprogram_Declaration          |
 269                     N_Package_Declaration             |
 270                     N_Generic_Declaration             =>
 271                   Add_Node_Name (Specification (Node));
 272
 273                when N_Generic_Instantiation           =>
 274                   Add_Node_Name (Defining_Unit_Name (Node));
 275
 276                when N_Package_Body                    =>
 277                   Add_Node_Name (Defining_Unit_Name (Node));
 278
 279                when N_Task_Body                       |
 280                     N_Protected_Body                  =>
 281                   Add_Node_Name (Defining_Identifier (Node));
 282
 283                when N_Package_Renaming_Declaration    =>
 284                   Add_Node_Name (Defining_Unit_Name (Node));
 285
 286                when N_Subprogram_Renaming_Declaration =>
 287                   Add_Node_Name (Specification (Node));
 288
 289                when N_Generic_Renaming_Declaration   =>
 290                   Add_Node_Name (Defining_Unit_Name (Node));
 291
 292                when N_Subprogram_Body_Stub            =>
 293                   Add_Node_Name (Get_Parent (Node));
 294                   Add_Char ('.');
 295                   Add_Node_Name (Specification (Node));
 296
 297                when N_Compilation_Unit                =>
 298                   Add_Node_Name (Unit (Node));
 299
 300                when N_Package_Body_Stub               =>
 301                   Add_Node_Name (Get_Parent (Node));
 302                   Add_Char ('.');
 303                   Add_Node_Name (Defining_Identifier (Node));
 304
 305                when N_Task_Body_Stub                  |
 306                     N_Protected_Body_Stub             =>
 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_Task_Type_Declaration           |
 329                     N_Single_Task_Declaration         |
 330                     N_Protected_Type_Declaration      |
 331                     N_Single_Protected_Declaration    =>
 332                   Add_Node_Name (Defining_Identifier (Node));
 333
 334                when others =>
 335                   raise Program_Error;
 336
 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    --------------------------------------------
 357    --  Start of Processing for Get_Unit_Name --
 358    --------------------------------------------
 359
 360    begin
 361       Node := N;
 362
 363       --  If we have Defining_Identifier, find the associated unit node
 364
 365       if Nkind (Node) = N_Defining_Identifier then
 366          Node := Declaration_Node (Node);
 367
 368       --  If an expanded name, it is an already analyzed child unit, find
 369       --  unit node.
 370
 371       elsif Nkind (Node) = N_Expanded_Name then
 372          Node := Declaration_Node (Entity (Node));
 373       end if;
 374
 375       if Nkind (Node) = N_Package_Specification
 376         or else Nkind (Node) in N_Subprogram_Specification
 377       then
 378          Node := Parent (Node);
 379       end if;
 380
 381       --  Node points to the unit, so get its name and add proper suffix
 382
 383       Add_Node_Name (Node);
 384       Add_Char ('%');
 385
 386       case Nkind (Node) is
 387          when N_Generic_Declaration             |
 388               N_Subprogram_Declaration          |
 389               N_Package_Declaration             |
 390               N_With_Clause                     |
 391               N_Pragma                          |
 392               N_Generic_Instantiation           |
 393               N_Package_Renaming_Declaration    |
 394               N_Subprogram_Renaming_Declaration |
 395               N_Generic_Renaming_Declaration    |
 396               N_Single_Task_Declaration         |
 397               N_Single_Protected_Declaration    |
 398               N_Task_Type_Declaration           |
 399               N_Protected_Type_Declaration      =>
 400
 401             Add_Char ('s');
 402
 403          when N_Subprogram_Body                 |
 404               N_Package_Body                    |
 405               N_Subunit                         |
 406               N_Body_Stub                       |
 407               N_Task_Body                       |
 408               N_Protected_Body                  |
 409               N_Identifier                      |
 410               N_Selected_Component              =>
 411
 412             Add_Char ('b');
 413
 414          when others =>
 415             raise Program_Error;
 416       end case;
 417
 418       Name_Buffer (1 .. Unit_Name_Length) :=
 419         Unit_Name_Buffer (1 .. Unit_Name_Length);
 420       Name_Len := Unit_Name_Length;
 421       return Name_Find;
 422
 423    end Get_Unit_Name;
 424
 425    --------------------------
 426    -- Get_Unit_Name_String --
 427    --------------------------
 428
 429    procedure Get_Unit_Name_String (N : Unit_Name_Type) is
 430       Unit_Is_Body : Boolean;
 431
 432    begin
 433       Get_Decoded_Name_String (N);
 434       Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
 435       Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);
 436
 437       --  A special fudge, normally we don't have operator symbols present,
 438       --  since it is always an error to do so. However, if we do, at this
 439       --  stage it has the form:
 440
 441       --    "and"
 442
 443       --  and the %s or %b has already been eliminated so put 2 chars back
 444
 445       if Name_Buffer (1) = '"' then
 446          Name_Len := Name_Len + 2;
 447       end if;
 448
 449       --  Now adjust the %s or %b to (spec) or (body)
 450
 451       if Unit_Is_Body then
 452          Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
 453       else
 454          Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
 455       end if;
 456
 457       for J in 1 .. Name_Len loop
 458          if Name_Buffer (J) = '-' then
 459             Name_Buffer (J) := '.';
 460          end if;
 461       end loop;
 462
 463       Name_Len := Name_Len + (7 - 2);
 464    end Get_Unit_Name_String;
 465
 466    ------------------
 467    -- Is_Body_Name --
 468    ------------------
 469
 470    function Is_Body_Name (N : Unit_Name_Type) return Boolean is
 471    begin
 472       Get_Name_String (N);
 473       return Name_Len > 2
 474         and then Name_Buffer (Name_Len - 1) = '%'
 475         and then Name_Buffer (Name_Len) = 'b';
 476    end Is_Body_Name;
 477
 478    -------------------
 479    -- Is_Child_Name --
 480    -------------------
 481
 482    function Is_Child_Name (N : Unit_Name_Type) return Boolean is
 483       J : Natural;
 484
 485    begin
 486       Get_Name_String (N);
 487       J := Name_Len;
 488
 489       while Name_Buffer (J) /= '.' loop
 490          if J = 1 then
 491             return False; -- not a child or subunit name
 492          else
 493             J := J - 1;
 494          end if;
 495       end loop;
 496
 497       return True;
 498    end Is_Child_Name;
 499
 500    ------------------
 501    -- Is_Spec_Name --
 502    ------------------
 503
 504    function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
 505    begin
 506       Get_Name_String (N);
 507       return Name_Len > 2
 508         and then Name_Buffer (Name_Len - 1) = '%'
 509         and then Name_Buffer (Name_Len) = 's';
 510    end Is_Spec_Name;
 511
 512    -----------------------
 513    -- Name_To_Unit_Name --
 514    -----------------------
 515
 516    function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
 517    begin
 518       Get_Name_String (N);
 519       Name_Buffer (Name_Len + 1) := '%';
 520       Name_Buffer (Name_Len + 2) := 's';
 521       Name_Len := Name_Len + 2;
 522       return Name_Find;
 523    end Name_To_Unit_Name;
 524
 525    ---------------
 526    -- New_Child --
 527    ---------------
 528
 529    function New_Child
 530      (Old  : Unit_Name_Type;
 531       Newp : Unit_Name_Type)
 532       return Unit_Name_Type
 533    is
 534       P : Natural;
 535
 536    begin
 537       Get_Name_String (Old);
 538
 539       declare
 540          Child : String := Name_Buffer (1 .. Name_Len);
 541
 542       begin
 543          Get_Name_String (Newp);
 544          Name_Len := Name_Len - 2;
 545
 546          P := Child'Last;
 547          while Child (P) /= '.' loop
 548             P := P - 1;
 549          end loop;
 550
 551          while P <= Child'Last loop
 552             Name_Len := Name_Len + 1;
 553             Name_Buffer (Name_Len) := Child (P);
 554             P := P + 1;
 555          end loop;
 556
 557          return Name_Find;
 558       end;
 559    end New_Child;
 560
 561    --------------
 562    -- Uname_Ge --
 563    --------------
 564
 565    function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
 566    begin
 567       return Left = Right or else Uname_Gt (Left, Right);
 568    end Uname_Ge;
 569
 570    --------------
 571    -- Uname_Gt --
 572    --------------
 573
 574    function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
 575    begin
 576       return Left /= Right and then not Uname_Lt (Left, Right);
 577    end Uname_Gt;
 578
 579    --------------
 580    -- Uname_Le --
 581    --------------
 582
 583    function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
 584    begin
 585       return Left = Right or else Uname_Lt (Left, Right);
 586    end Uname_Le;
 587
 588    --------------
 589    -- Uname_Lt --
 590    --------------
 591
 592    function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
 593       Left_Name    : String (1 .. Hostparm.Max_Name_Length);
 594       Left_Length  : Natural;
 595       Right_Name   : String renames Name_Buffer;
 596       Right_Length : Natural renames Name_Len;
 597       J            : Natural;
 598
 599    begin
 600       pragma Warnings (Off, Right_Length);
 601       --  Suppress warnings on Right_Length, used in pragma Assert
 602
 603       if Left = Right then
 604          return False;
 605       end if;
 606
 607       Get_Name_String (Left);
 608       Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
 609       Left_Length := Name_Len;
 610       Get_Name_String (Right);
 611       J := 1;
 612
 613       loop
 614          exit when Left_Name (J) = '%';
 615
 616          if Right_Name (J) = '%' then
 617             return False; -- left name is longer
 618          end if;
 619
 620          pragma Assert (J <= Left_Length and then J <= Right_Length);
 621
 622          if Left_Name (J) /= Right_Name (J) then
 623             return Left_Name (J) < Right_Name (J); -- parent names different
 624          end if;
 625
 626          J := J + 1;
 627       end loop;
 628
 629       --  Come here pointing to % in left name
 630
 631       if Right_Name (J) /= '%' then
 632          return True; -- right name is longer
 633       end if;
 634
 635       --  Here the parent names are the same and specs sort low. If neither is
 636       --  a spec, then we are comparing the same name and we want a result of
 637       --  False in any case.
 638
 639       return Left_Name (J + 1) = 's';
 640    end Uname_Lt;
 641
 642    ---------------------
 643    -- Write_Unit_Name --
 644    ---------------------
 645
 646    procedure Write_Unit_Name (N : Unit_Name_Type) is
 647    begin
 648       Get_Unit_Name_String (N);
 649       Write_Str (Name_Buffer (1 .. Name_Len));
 650    end Write_Unit_Name;
 651
 652 end Uname;