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-2024, 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.  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;          use Atree;
  27 with Casing;         use Casing;
  28 with Einfo;          use Einfo;
  29 with Einfo.Utils;    use Einfo.Utils;
  30 with Hostparm;
  31 with Lib;            use Lib;
  32 with Nlists;         use Nlists;
  33 with Output;         use Output;
  34 with Sinfo;          use Sinfo;
  35 with Sinfo.Nodes;    use Sinfo.Nodes;
  36 with Sinfo.Utils;    use Sinfo.Utils;
  37 with Sinput;         use Sinput;
  38
  39 package body Uname is
  40
  41    function Has_Prefix (X, Prefix : String) return Boolean;
  42    --  True if Prefix is at the beginning of X. For example,
  43    --  Has_Prefix("a-filename.ads", Prefix => "a-") is True.
  44
  45    -------------------
  46    -- Get_Body_Name --
  47    -------------------
  48
  49    function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
  50       Buffer : Bounded_String;
  51    begin
  52       Append (Buffer, N);
  53       pragma Assert (Is_Spec_Name (N));
  54       Buffer.Chars (Buffer.Length) := 'b';
  55       return Name_Find (Buffer);
  56    end Get_Body_Name;
  57
  58    -----------------------------------
  59    -- Get_External_Unit_Name_String --
  60    -----------------------------------
  61
  62    procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
  63       Pcount : Natural;
  64       Newlen : Natural;
  65
  66    begin
  67       --  Get unit name and eliminate trailing %s or %b
  68
  69       Get_Name_String (N);
  70       Name_Len := Name_Len - 2;
  71
  72       --  Find number of components
  73
  74       Pcount := 0;
  75       for J in 1 .. Name_Len loop
  76          if Name_Buffer (J) = '.' then
  77             Pcount := Pcount + 1;
  78          end if;
  79       end loop;
  80
  81       --  If simple name, nothing to do
  82
  83       if Pcount = 0 then
  84          return;
  85       end if;
  86
  87       --  If name has multiple components, replace dots by double underscore
  88
  89       Newlen := Name_Len + Pcount;
  90
  91       for J in reverse 1 .. Name_Len loop
  92          if Name_Buffer (J) = '.' then
  93             Name_Buffer (Newlen) := '_';
  94             Name_Buffer (Newlen - 1) := '_';
  95             Newlen := Newlen - 2;
  96
  97          else
  98             Name_Buffer (Newlen) := Name_Buffer (J);
  99             Newlen := Newlen - 1;
 100          end if;
 101       end loop;
 102
 103       Name_Len := Name_Len + Pcount;
 104    end Get_External_Unit_Name_String;
 105
 106    --------------------------
 107    -- Get_Parent_Body_Name --
 108    --------------------------
 109
 110    function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
 111       Buffer : Bounded_String;
 112    begin
 113       Append (Buffer, N);
 114
 115       while Buffer.Chars (Buffer.Length) /= '.' loop
 116          pragma Assert (Buffer.Length > 1); -- not a child or subunit name
 117          Buffer.Length := Buffer.Length - 1;
 118       end loop;
 119
 120       Buffer.Chars (Buffer.Length) := '%';
 121       Append (Buffer, 'b');
 122
 123       return Name_Find (Buffer);
 124    end Get_Parent_Body_Name;
 125
 126    --------------------------
 127    -- Get_Parent_Spec_Name --
 128    --------------------------
 129
 130    function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
 131       Buffer : Bounded_String;
 132    begin
 133       Append (Buffer, N);
 134
 135       while Buffer.Chars (Buffer.Length) /= '.' loop
 136          if Buffer.Length = 1 then
 137             return No_Unit_Name;
 138          else
 139             Buffer.Length := Buffer.Length - 1;
 140          end if;
 141       end loop;
 142
 143       Buffer.Chars (Buffer.Length) := '%';
 144       Append (Buffer, 's');
 145
 146       return Name_Find (Buffer);
 147    end Get_Parent_Spec_Name;
 148
 149    -------------------
 150    -- Get_Spec_Name --
 151    -------------------
 152
 153    function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
 154       Buffer : Bounded_String;
 155    begin
 156       Append (Buffer, N);
 157       pragma Assert (Is_Body_Name (N));
 158       Buffer.Chars (Buffer.Length) := 's';
 159       return Name_Find (Buffer);
 160    end Get_Spec_Name;
 161
 162    -------------------
 163    -- Get_Unit_Name --
 164    -------------------
 165
 166    function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
 167
 168       Unit_Name_Buffer : Bounded_String;
 169       --  Buffer used to build name of unit
 170
 171       Node : Node_Id;
 172       --  Program unit node
 173
 174       procedure Add_Char (C : Character);
 175       --  Add a single character to stored unit name
 176
 177       procedure Add_Name (Name : Name_Id);
 178       --  Add the characters of a names table entry to stored unit name
 179
 180       procedure Add_Node_Name (Node : Node_Id);
 181       --  Recursive procedure adds characters associated with Node
 182
 183       function Get_Parent (Node : Node_Id) return Node_Id;
 184       --  Get parent compilation unit of a stub
 185
 186       --------------
 187       -- Add_Char --
 188       --------------
 189
 190       procedure Add_Char (C : Character) is
 191       begin
 192          Append (Unit_Name_Buffer, C);
 193       end Add_Char;
 194
 195       --------------
 196       -- Add_Name --
 197       --------------
 198
 199       procedure Add_Name (Name : Name_Id) is
 200       begin
 201          Append (Unit_Name_Buffer, Name);
 202       end Add_Name;
 203
 204       -------------------
 205       -- Add_Node_Name --
 206       -------------------
 207
 208       procedure Add_Node_Name (Node : Node_Id) is
 209       begin
 210          --  Just ignore an error node (someone else will give a message)
 211
 212          if Node = Error then
 213             return;
 214
 215          --  Otherwise see what kind of node we have
 216
 217          else
 218             case Nkind (Node) is
 219                when N_Defining_Identifier
 220                   | N_Defining_Operator_Symbol
 221                   | N_Identifier
 222                =>
 223                   --  Note: it is of course an error to have a defining
 224                   --  operator symbol at this point, but this is not where
 225                   --  the error is signalled, so we handle it nicely here.
 226
 227                   Add_Name (Chars (Node));
 228
 229                when N_Defining_Program_Unit_Name =>
 230                   Add_Node_Name (Name (Node));
 231                   Add_Char ('.');
 232                   Add_Node_Name (Defining_Identifier (Node));
 233
 234                when N_Expanded_Name
 235                   | N_Selected_Component
 236                =>
 237                   Add_Node_Name (Prefix (Node));
 238                   Add_Char ('.');
 239                   Add_Node_Name (Selector_Name (Node));
 240
 241                when N_Package_Specification
 242                   | N_Subprogram_Specification
 243                =>
 244                   Add_Node_Name (Defining_Unit_Name (Node));
 245
 246                when N_Generic_Declaration
 247                   | N_Package_Declaration
 248                   | N_Subprogram_Body
 249                   | N_Subprogram_Declaration
 250                =>
 251                   Add_Node_Name (Specification (Node));
 252
 253                when N_Generic_Instantiation =>
 254                   Add_Node_Name (Defining_Unit_Name (Node));
 255
 256                when N_Package_Body =>
 257                   Add_Node_Name (Defining_Unit_Name (Node));
 258
 259                when N_Protected_Body
 260                   | N_Task_Body
 261                =>
 262                   Add_Node_Name (Defining_Identifier (Node));
 263
 264                when N_Package_Renaming_Declaration =>
 265                   Add_Node_Name (Defining_Unit_Name (Node));
 266
 267                when N_Subprogram_Renaming_Declaration =>
 268                   Add_Node_Name (Specification (Node));
 269
 270                when N_Generic_Renaming_Declaration =>
 271                   Add_Node_Name (Defining_Unit_Name (Node));
 272
 273                when N_Subprogram_Body_Stub =>
 274                   Add_Node_Name (Get_Parent (Node));
 275                   Add_Char ('.');
 276                   Add_Node_Name (Specification (Node));
 277
 278                when N_Compilation_Unit =>
 279                   Add_Node_Name (Unit (Node));
 280
 281                when N_Package_Body_Stub
 282                   | N_Protected_Body_Stub
 283                   | N_Task_Body_Stub
 284                =>
 285                   Add_Node_Name (Get_Parent (Node));
 286                   Add_Char ('.');
 287                   Add_Node_Name (Defining_Identifier (Node));
 288
 289                when N_Subunit =>
 290                   Add_Node_Name (Name (Node));
 291                   Add_Char ('.');
 292                   Add_Node_Name (Proper_Body (Node));
 293
 294                when N_With_Clause =>
 295                   Add_Node_Name (Name (Node));
 296
 297                when N_Pragma =>
 298                   Add_Node_Name (Expression (First
 299                     (Pragma_Argument_Associations (Node))));
 300
 301                --  Tasks and protected stuff appear only in an error context,
 302                --  but the error has been posted elsewhere, so we deal nicely
 303                --  with these error situations here, and produce a reasonable
 304                --  unit name using the defining identifier.
 305
 306                when N_Protected_Type_Declaration
 307                   | N_Single_Protected_Declaration
 308                   | N_Single_Task_Declaration
 309                   | N_Task_Type_Declaration
 310                =>
 311                   Add_Node_Name (Defining_Identifier (Node));
 312
 313                when others =>
 314                   raise Program_Error;
 315             end case;
 316          end if;
 317       end Add_Node_Name;
 318
 319       ----------------
 320       -- Get_Parent --
 321       ----------------
 322
 323       function Get_Parent (Node : Node_Id) return Node_Id is
 324          N : Node_Id := Node;
 325
 326       begin
 327          while Nkind (N) /= N_Compilation_Unit loop
 328             N := Parent (N);
 329          end loop;
 330
 331          return N;
 332       end Get_Parent;
 333
 334    --  Start of processing for Get_Unit_Name
 335
 336    begin
 337       Node := N;
 338
 339       --  If we have Defining_Identifier, find the associated unit node
 340
 341       if Nkind (Node) = N_Defining_Identifier then
 342          Node := Declaration_Node (Node);
 343
 344       --  If an expanded name, it is an already analyzed child unit, find
 345       --  unit node.
 346
 347       elsif Nkind (Node) = N_Expanded_Name then
 348          Node := Declaration_Node (Entity (Node));
 349       end if;
 350
 351       if Nkind (Node) in N_Package_Specification
 352                        | N_Subprogram_Specification
 353       then
 354          Node := Parent (Node);
 355       end if;
 356
 357       --  Node points to the unit, so get its name and add proper suffix
 358
 359       Add_Node_Name (Node);
 360       Add_Char ('%');
 361
 362       case Nkind (Node) is
 363          when N_Generic_Declaration
 364             | N_Generic_Instantiation
 365             | N_Generic_Renaming_Declaration
 366             | N_Package_Declaration
 367             | N_Package_Renaming_Declaration
 368             | N_Pragma
 369             | N_Protected_Type_Declaration
 370             | N_Single_Protected_Declaration
 371             | N_Single_Task_Declaration
 372             | N_Subprogram_Declaration
 373             | N_Subprogram_Renaming_Declaration
 374             | N_Task_Type_Declaration
 375             | N_With_Clause
 376          =>
 377             Add_Char ('s');
 378
 379          when N_Body_Stub
 380             | N_Identifier
 381             | N_Package_Body
 382             | N_Protected_Body
 383             | N_Selected_Component
 384             | N_Subprogram_Body
 385             | N_Subunit
 386             | N_Task_Body
 387          =>
 388             Add_Char ('b');
 389
 390          when others =>
 391             raise Program_Error;
 392       end case;
 393
 394       return Name_Find (Unit_Name_Buffer);
 395    end Get_Unit_Name;
 396
 397    --------------------------
 398    -- Get_Unit_Name_String --
 399    --------------------------
 400
 401    procedure Get_Unit_Name_String
 402      (Buf    : in out Bounded_String;
 403       N      : Unit_Name_Type;
 404       Suffix : Boolean := True)
 405    is
 406    begin
 407       Buf.Length := 0;
 408       Append_Decoded (Buf, N);
 409       pragma Assert (Buf.Chars (1) /= '"');
 410       pragma Assert (Is_Body_Name (N) or else Is_Spec_Name (N));
 411
 412       --  Buf always ends with "%s" or "%b", which we either remove, or replace
 413       --  with " (spec)" or " (body)". Set_Casing of Buf after checking for
 414       --  (lower case) 's'/'b', and before appending (lower case) "spec" or
 415       --  "body".
 416
 417       declare
 418          S : constant String :=
 419            (if Buf.Chars (Buf.Length) = 's' then " (spec)" else " (body)");
 420       begin
 421          Buf.Length := Buf.Length - 2; -- remove "%s" or "%b"
 422          Set_Casing (Buf, Identifier_Casing (Source_Index (Main_Unit)));
 423
 424          if Suffix then
 425             Append (Buf, S);
 426          end if;
 427       end;
 428
 429       for J in 1 .. Buf.Length loop
 430          if Buf.Chars (J) = '-' then
 431             Buf.Chars (J) := '.';
 432          end if;
 433       end loop;
 434    end Get_Unit_Name_String;
 435
 436    ----------------
 437    -- Has_Prefix --
 438    ----------------
 439
 440    function Has_Prefix (X, Prefix : String) return Boolean is
 441    begin
 442       if X'Length >= Prefix'Length then
 443          declare
 444             Slice : String renames
 445                       X (X'First .. X'First + Prefix'Length - 1);
 446          begin
 447             return Slice = Prefix;
 448          end;
 449       end if;
 450       return False;
 451    end Has_Prefix;
 452
 453    ------------------
 454    -- Is_Body_Name --
 455    ------------------
 456
 457    function Is_Body_Name (N : Unit_Name_Type) return Boolean is
 458       Buffer : Bounded_String;
 459    begin
 460       Append (Buffer, N);
 461       pragma Assert
 462         (Buffer.Length > 2 and then Buffer.Chars (Buffer.Length - 1) = '%');
 463       return Buffer.Chars (Buffer.Length) = 'b';
 464    end Is_Body_Name;
 465
 466    -------------------
 467    -- Is_Child_Name --
 468    -------------------
 469
 470    function Is_Child_Name (N : Unit_Name_Type) return Boolean is
 471       Buffer : Bounded_String;
 472
 473    begin
 474       Append (Buffer, N);
 475
 476       while Buffer.Chars (Buffer.Length) /= '.' loop
 477          if Buffer.Length = 1 then
 478             return False; -- not a child or subunit name
 479          else
 480             Buffer.Length := Buffer.Length - 1;
 481          end if;
 482       end loop;
 483
 484       return True;
 485    end Is_Child_Name;
 486
 487    ---------------------------
 488    -- Is_Internal_Unit_Name --
 489    ---------------------------
 490
 491    function Is_Internal_Unit_Name
 492      (Name               : String;
 493       Renamings_Included : Boolean := True) return Boolean
 494    is
 495       Gnat : constant String := "gnat";
 496
 497    begin
 498       if Name = Gnat then
 499          return True;
 500       end if;
 501
 502       if Has_Prefix (Name, Prefix => Gnat & ".") then
 503          return True;
 504       end if;
 505
 506       return Is_Predefined_Unit_Name (Name, Renamings_Included);
 507    end Is_Internal_Unit_Name;
 508
 509    -----------------------------
 510    -- Is_Predefined_Unit_Name --
 511    -----------------------------
 512
 513    function Is_Predefined_Unit_Name
 514      (Name               : String;
 515       Renamings_Included : Boolean := True) return Boolean
 516    is
 517       Ada        : constant String := "ada";
 518       Interfaces : constant String := "interfaces";
 519       System     : constant String := "system";
 520
 521    begin
 522       if Name in Ada | Interfaces | System then
 523          return True;
 524       end if;
 525
 526       if Has_Prefix (Name, Prefix => Ada & ".")
 527         or else Has_Prefix (Name, Prefix => Interfaces & ".")
 528         or else Has_Prefix (Name, Prefix => System & ".")
 529       then
 530          return True;
 531       end if;
 532
 533       if not Renamings_Included then
 534          return False;
 535       end if;
 536
 537       --  The following are the predefined renamings
 538
 539       return Name in "calendar"
 540         | "machine_code"
 541         | "unchecked_conversion"
 542         | "unchecked_deallocation"
 543         | "direct_io"
 544         | "io_exceptions"
 545         | "sequential_io"
 546         | "text_io";
 547    end Is_Predefined_Unit_Name;
 548
 549    ------------------
 550    -- Is_Spec_Name --
 551    ------------------
 552
 553    function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
 554       Buffer : Bounded_String;
 555    begin
 556       Append (Buffer, N);
 557       pragma Assert
 558         (Buffer.Length > 2 and then Buffer.Chars (Buffer.Length - 1) = '%');
 559       return Buffer.Chars (Buffer.Length) = 's';
 560    end Is_Spec_Name;
 561
 562    -----------------------
 563    -- Name_To_Unit_Name --
 564    -----------------------
 565
 566    function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
 567       Buffer : Bounded_String;
 568    begin
 569       Append (Buffer, N);
 570       Append (Buffer, "%s");
 571       return Name_Find (Buffer);
 572    end Name_To_Unit_Name;
 573
 574    ---------------
 575    -- New_Child --
 576    ---------------
 577
 578    function New_Child
 579      (Old  : Unit_Name_Type;
 580       Newp : Unit_Name_Type) return Unit_Name_Type
 581    is
 582       P : Natural;
 583
 584    begin
 585       Get_Name_String (Old);
 586
 587       declare
 588          Child : constant String := Name_Buffer (1 .. Name_Len);
 589
 590       begin
 591          Get_Name_String (Newp);
 592          Name_Len := Name_Len - 2;
 593
 594          P := Child'Last;
 595          while Child (P) /= '.' loop
 596             P := P - 1;
 597          end loop;
 598
 599          while P <= Child'Last loop
 600             Name_Len := Name_Len + 1;
 601             Name_Buffer (Name_Len) := Child (P);
 602             P := P + 1;
 603          end loop;
 604
 605          return Name_Find;
 606       end;
 607    end New_Child;
 608
 609    --------------
 610    -- Uname_Ge --
 611    --------------
 612
 613    function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
 614    begin
 615       return Left = Right or else Uname_Gt (Left, Right);
 616    end Uname_Ge;
 617
 618    --------------
 619    -- Uname_Gt --
 620    --------------
 621
 622    function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
 623    begin
 624       return Left /= Right and then not Uname_Lt (Left, Right);
 625    end Uname_Gt;
 626
 627    --------------
 628    -- Uname_Le --
 629    --------------
 630
 631    function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
 632    begin
 633       return Left = Right or else Uname_Lt (Left, Right);
 634    end Uname_Le;
 635
 636    --------------
 637    -- Uname_Lt --
 638    --------------
 639
 640    function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
 641       Left_Name    : String (1 .. Hostparm.Max_Name_Length);
 642       Left_Length  : Natural;
 643       Right_Name   : String renames Name_Buffer;
 644       Right_Length : Natural renames Name_Len;
 645       J            : Natural;
 646
 647    begin
 648       pragma Warnings (Off, Right_Length);
 649       --  Suppress warnings on Right_Length, used in pragma Assert
 650
 651       if Left = Right then
 652          return False;
 653       end if;
 654
 655       Get_Name_String (Left);
 656       Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
 657       Left_Length := Name_Len;
 658       Get_Name_String (Right);
 659       J := 1;
 660
 661       loop
 662          exit when Left_Name (J) = '%';
 663
 664          if Right_Name (J) = '%' then
 665             return False; -- left name is longer
 666          end if;
 667
 668          pragma Assert (J <= Left_Length and then J <= Right_Length);
 669
 670          if Left_Name (J) /= Right_Name (J) then
 671             return Left_Name (J) < Right_Name (J); -- parent names different
 672          end if;
 673
 674          J := J + 1;
 675       end loop;
 676
 677       --  Come here pointing to % in left name
 678
 679       if Right_Name (J) /= '%' then
 680          return True; -- right name is longer
 681       end if;
 682
 683       --  Here the parent names are the same and specs sort low. If neither is
 684       --  a spec, then we are comparing the same name and we want a result of
 685       --  False in any case.
 686
 687       return Left_Name (J + 1) = 's';
 688    end Uname_Lt;
 689
 690    ---------------------
 691    -- Write_Unit_Name --
 692    ---------------------
 693
 694    procedure Write_Unit_Name (N : Unit_Name_Type) is
 695       Buf : Bounded_String;
 696    begin
 697       Get_Unit_Name_String (Buf, N);
 698       Write_Str (Buf.Chars (1 .. Buf.Length));
 699    end Write_Unit_Name;
 700
 701    -------------------------------
 702    -- Write_Unit_Name_For_Debug --
 703    -------------------------------
 704
 705    procedure Write_Unit_Name_For_Debug (N : Unit_Name_Type) is
 706    begin
 707       if Is_Valid_Name (N) then
 708          Write_Unit_Name (N);
 709       else
 710          Write_Name_For_Debug (N);
 711       end if;
 712    end Write_Unit_Name_For_Debug;
 713
 714 end Uname;