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