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