gcc/ada/fname-uf.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             F N A M E . U F                              --
   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 Alloc;
  27 with Debug;    use Debug;
  28 with Fmap;     use Fmap;
  29 with Krunch;
  30 with Opt;      use Opt;
  31 with Osint;    use Osint;
  32 with Table;
  33 with Uname;    use Uname;
  34 with Widechar; use Widechar;
  35
  36 with GNAT.HTable;
  37
  38 package body Fname.UF is
  39
  40    --------------------------------------------------------
  41    -- Declarations for Handling Source_File_Name pragmas --
  42    --------------------------------------------------------
  43
  44    type SFN_Entry is record
  45       U     : Unit_Name_Type; -- Unit name
  46       F     : File_Name_Type; -- Spec/Body file name
  47       Index : Nat;            -- Index from SFN pragma (0 if none)
  48    end record;
  49    --  Record single Unit_Name type call to Set_File_Name
  50
  51    package SFN_Table is new Table.Table (
  52      Table_Component_Type => SFN_Entry,
  53      Table_Index_Type     => Int,
  54      Table_Low_Bound      => 0,
  55      Table_Initial        => Alloc.SFN_Table_Initial,
  56      Table_Increment      => Alloc.SFN_Table_Increment,
  57      Table_Name           => "SFN_Table");
  58    --  Table recording all Unit_Name calls to Set_File_Name
  59
  60    type SFN_Header_Num is range 0 .. 100;
  61
  62    function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
  63    --  Compute hash index for use by Simple_HTable
  64
  65    No_Entry : constant Int := -1;
  66    --  Signals no entry in following table
  67
  68    package SFN_HTable is new GNAT.HTable.Simple_HTable (
  69      Header_Num => SFN_Header_Num,
  70      Element    => Int,
  71      No_Element => No_Entry,
  72      Key        => Unit_Name_Type,
  73      Hash       => SFN_Hash,
  74      Equal      => "=");
  75    --  Hash table allowing rapid access to SFN_Table, the element value is an
  76    --  index into this table.
  77
  78    type SFN_Pattern_Entry is record
  79       Pat : String_Ptr;   -- File name pattern (with asterisk in it)
  80       Typ : Character;    -- 'S'/'B'/'U' for spec/body/subunit
  81       Dot : String_Ptr;   -- Dot_Separator string
  82       Cas : Casing_Type;  -- Upper/Lower/Mixed
  83    end record;
  84    --  Records single call to Set_File_Name_Patterm
  85
  86    package SFN_Patterns is new Table.Table (
  87      Table_Component_Type => SFN_Pattern_Entry,
  88      Table_Index_Type     => Int,
  89      Table_Low_Bound      => 1,
  90      Table_Initial        => 10,
  91      Table_Increment      => 100,
  92      Table_Name           => "SFN_Patterns");
  93    --  Table recording calls to Set_File_Name_Pattern. Note that the first two
  94    --  entries are set to represent the standard GNAT rules for file naming.
  95
  96    procedure Instantiate_SFN_Pattern
  97      (Pattern   : SFN_Pattern_Entry;
  98       Buf       : in out Bounded_String;
  99       Is_Predef : Boolean := False);
 100    --  On entry, Buf must contain a unit name. After returning, Buf contains
 101    --  the file name corresponding to the unit following the naming pattern
 102    --  described by Pattern. Is_Predef must be whether the unit name in Buf
 103    --  is a predefined unit name as defined by Is_Predefined_Unit_Name.
 104
 105    -----------------------
 106    -- File_Name_Of_Body --
 107    -----------------------
 108
 109    function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
 110    begin
 111       Get_Name_String (Name);
 112       Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
 113       Name_Len := Name_Len + 2;
 114       return Get_File_Name (Name_Enter, Subunit => False);
 115    end File_Name_Of_Body;
 116
 117    -----------------------
 118    -- File_Name_Of_Spec --
 119    -----------------------
 120
 121    function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
 122    begin
 123       Get_Name_String (Name);
 124       Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
 125       Name_Len := Name_Len + 2;
 126       return Get_File_Name (Name_Enter, Subunit => False);
 127    end File_Name_Of_Spec;
 128
 129    ----------------------------
 130    -- Get_Expected_Unit_Type --
 131    ----------------------------
 132
 133    function Get_Expected_Unit_Type
 134      (Fname : File_Name_Type) return Expected_Unit_Type
 135    is
 136    begin
 137       --  In syntax checking only mode or in multiple unit per file mode, there
 138       --  can be more than one unit in a file, so the file name is not a useful
 139       --  guide to the nature of the unit.
 140
 141       if Operating_Mode = Check_Syntax
 142         or else Multiple_Unit_Index /= 0
 143       then
 144          return Unknown;
 145       end if;
 146
 147       --  Search the file mapping table, if we find an entry for this file we
 148       --  know whether it is a spec or a body.
 149
 150       for J in SFN_Table.First .. SFN_Table.Last loop
 151          if Fname = SFN_Table.Table (J).F then
 152             if Is_Body_Name (SFN_Table.Table (J).U) then
 153                return Expect_Body;
 154             else
 155                return Expect_Spec;
 156             end if;
 157          end if;
 158       end loop;
 159
 160       --  If no entry in file naming table, assume .ads/.adb for spec/body and
 161       --  return unknown if we have neither of these two cases.
 162
 163       Get_Name_String (Fname);
 164
 165       if Name_Len > 4 then
 166          if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
 167             return Expect_Spec;
 168          elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
 169             return Expect_Body;
 170          end if;
 171       end if;
 172
 173       return Unknown;
 174    end Get_Expected_Unit_Type;
 175
 176    ---------------------------
 177    -- Get_Default_File_Name --
 178    ---------------------------
 179
 180    function Get_Default_File_Name (Uname : Unit_Name_Type) return String is
 181       Buf : Bounded_String;
 182
 183       Pattern : SFN_Pattern_Entry;
 184    begin
 185       Get_Unit_Name_String (Buf, Uname, False);
 186
 187       if Is_Spec_Name (Uname) then
 188          Pattern := SFN_Patterns.Table (1);
 189       else
 190          pragma Assert (Is_Body_Name (Uname));
 191          Pattern := SFN_Patterns.Table (2);
 192       end if;
 193
 194       Instantiate_SFN_Pattern (Pattern, Buf);
 195
 196       return To_String (Buf);
 197    end Get_Default_File_Name;
 198
 199    -------------------
 200    -- Get_File_Name --
 201    -------------------
 202
 203    function Get_File_Name
 204      (Uname    : Unit_Name_Type;
 205       Subunit  : Boolean;
 206       May_Fail : Boolean := False) return File_Name_Type
 207    is
 208       Unit_Char : Character;
 209       --  Set to 's' or 'b' for spec or body or to 'u' for a subunit
 210
 211       Unit_Char_Search : Character;
 212       --  Same as Unit_Char, except that in the case of 'u' for a subunit, we
 213       --  set Unit_Char_Search to 'b' if we do not find a subunit match.
 214
 215       N : Int;
 216
 217       Pname : File_Name_Type := No_File;
 218       Fname : File_Name_Type := No_File;
 219       --  Path name and File name for mapping
 220
 221    begin
 222       --  Null or error name means that some previous error occurred. This is
 223       --  an unrecoverable error, so signal it.
 224
 225       if Uname in Error_Unit_Name_Or_No_Unit_Name then
 226          raise Unrecoverable_Error;
 227       end if;
 228
 229       --  Look in the map from unit names to file names
 230
 231       Fname := Mapped_File_Name (Uname);
 232
 233       --  If the unit name is already mapped, return the corresponding file
 234       --  name from the map.
 235
 236       if Fname /= No_File then
 237          return Fname;
 238       end if;
 239
 240       --  If there is a specific SFN pragma, return the corresponding file name
 241
 242       N := SFN_HTable.Get (Uname);
 243
 244       if N /= No_Entry then
 245          return SFN_Table.Table (N).F;
 246       end if;
 247
 248       --  Here for the case where the name was not found in the table
 249
 250       Get_Decoded_Name_String (Uname);
 251
 252       --  A special fudge, normally we don't have operator symbols present,
 253       --  since it is always an error to do so. However, if we do, at this
 254       --  stage it has a leading double quote.
 255
 256       --  What we do in this case is to go back to the undecoded name, which
 257       --  is of the form, for example:
 258
 259       --    Oand%s
 260
 261       --  and build a file name that looks like:
 262
 263       --    _and_.ads
 264
 265       --  which is bit peculiar, but we keep it that way. This means that we
 266       --  avoid bombs due to writing a bad file name, and we get expected error
 267       --  processing downstream, e.g. a compilation following gnatchop.
 268
 269       if Name_Buffer (1) = '"' then
 270          Get_Name_String (Uname);
 271          Name_Len := Name_Len + 1;
 272          Name_Buffer (Name_Len)     := Name_Buffer (Name_Len - 1);
 273          Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
 274          Name_Buffer (Name_Len - 2) := '_';
 275          Name_Buffer (1)            := '_';
 276       end if;
 277
 278       --  Deal with spec or body suffix
 279
 280       Unit_Char := Name_Buffer (Name_Len);
 281       pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
 282       pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
 283       Name_Len := Name_Len - 2;
 284
 285       if Subunit then
 286          Unit_Char := 'u';
 287       end if;
 288
 289       --  Now we need to find the proper translation of the name
 290
 291       declare
 292          Uname : constant String (1 .. Name_Len) :=
 293                    Name_Buffer (1 .. Name_Len);
 294
 295          Pent : Nat;
 296          Fnam : File_Name_Type := No_File;
 297
 298          Is_Predef : Boolean;
 299          --  Set True for predefined file
 300
 301       --  Start of search through pattern table
 302
 303       begin
 304          --  Search pattern table to find a matching entry. In the general case
 305          --  we do two complete searches. The first time through we stop only
 306          --  if a matching file is found, the second time through we accept the
 307          --  first match regardless. Note that there will always be a match the
 308          --  second time around, because of the default entries at the end of
 309          --  the table.
 310
 311          for No_File_Check in False .. True loop
 312             Unit_Char_Search := Unit_Char;
 313
 314          <<Repeat_Search>>
 315          --  The search is repeated with Unit_Char_Search set to b, if an
 316          --  initial search for the subunit case fails to find any match.
 317
 318             Pent := SFN_Patterns.First;
 319             while Pent <= SFN_Patterns.Last loop
 320                if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
 321                   --  Determine if we have a predefined file name
 322
 323                   Is_Predef :=
 324                     Is_Predefined_Unit_Name
 325                       (Uname, Renamings_Included => True);
 326
 327                   --  Found a match, execute the pattern
 328
 329                   Name_Len := Uname'Length;
 330                   Name_Buffer (1 .. Name_Len) := Uname;
 331
 332                   Instantiate_SFN_Pattern
 333                     (SFN_Patterns.Table (Pent), Global_Name_Buffer, Is_Predef);
 334
 335                   Fnam := Name_Find;
 336
 337                   --  If we are in the second search of the table, we accept
 338                   --  the file name without checking, because we know that the
 339                   --  file does not exist, except when May_Fail is True, in
 340                   --  which case we return No_File.
 341
 342                   if No_File_Check then
 343                      if May_Fail then
 344                         return No_File;
 345                      else
 346                         return Fnam;
 347                      end if;
 348
 349                   --  Otherwise we check if the file exists
 350
 351                   else
 352                      Pname := Find_File (Fnam, Source);
 353
 354                      --  If it does exist, we add it to the mappings and return
 355                      --  the file name.
 356
 357                      if Pname /= No_File then
 358
 359                         --  Add to mapping, so that we don't do another path
 360                         --  search in Find_File for this file name and, if we
 361                         --  use a mapping file, we are ready to update it at
 362                         --  the end of this compilation for the benefit of
 363                         --  other compilation processes.
 364
 365                         Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
 366                         return Fnam;
 367
 368                      --  If there are only two entries, they are those of the
 369                      --  default GNAT naming scheme. The file does not exist,
 370                      --  but there is no point doing the second search, because
 371                      --  we will end up with the same file name. Just return
 372                      --  the file name, or No_File if May_Fail is True.
 373
 374                      elsif SFN_Patterns.Last = 2 then
 375                         if May_Fail then
 376                            return No_File;
 377                         else
 378                            return Fnam;
 379                         end if;
 380
 381                      --  The file does not exist, but there may be other naming
 382                      --  scheme. Keep on searching.
 383
 384                      else
 385                         Fnam := No_File;
 386                      end if;
 387                   end if;
 388                end if;
 389
 390                Pent := Pent + 1;
 391             end loop;
 392
 393             --  If search failed, and was for a subunit, repeat the search with
 394             --  Unit_Char_Search reset to 'b', since in the normal case we
 395             --  simply treat subunits as bodies.
 396
 397             if Fnam = No_File and then Unit_Char_Search = 'u' then
 398                Unit_Char_Search := 'b';
 399                goto Repeat_Search;
 400             end if;
 401
 402             --  Repeat entire search in No_File_Check mode if necessary
 403
 404          end loop;
 405
 406          --  Something is wrong if search fails completely, since the default
 407          --  entries should catch all possibilities at this stage.
 408
 409          raise Program_Error;
 410       end;
 411    end Get_File_Name;
 412
 413    --------------------
 414    -- Get_Unit_Index --
 415    --------------------
 416
 417    function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
 418       N : constant Int := SFN_HTable.Get (Uname);
 419    begin
 420       if N /= No_Entry then
 421          return SFN_Table.Table (N).Index;
 422       else
 423          return 0;
 424       end if;
 425    end Get_Unit_Index;
 426
 427    ----------------
 428    -- Initialize --
 429    ----------------
 430
 431    procedure Initialize is
 432    begin
 433       SFN_Table.Init;
 434       SFN_Patterns.Init;
 435
 436       --  Add default entries to SFN_Patterns.Table to represent the standard
 437       --  default GNAT rules for file name translation.
 438
 439       SFN_Patterns.Append (New_Val =>
 440         (Pat => new String'("*.ads"),
 441          Typ => 's',
 442          Dot => new String'("-"),
 443          Cas => All_Lower_Case));
 444
 445       SFN_Patterns.Append (New_Val =>
 446         (Pat => new String'("*.adb"),
 447          Typ => 'b',
 448          Dot => new String'("-"),
 449          Cas => All_Lower_Case));
 450    end Initialize;
 451
 452    -----------------------------
 453    -- Instantiate_SFN_Pattern --
 454    -----------------------------
 455
 456    procedure Instantiate_SFN_Pattern
 457      (Pattern   : SFN_Pattern_Entry;
 458       Buf       : in out Bounded_String;
 459       Is_Predef : Boolean := False)
 460    is
 461       function C (N : Natural) return Character;
 462       --  Return N'th character of pattern
 463
 464       function C (N : Natural) return Character is
 465       begin
 466          return Pattern.Pat (N);
 467       end C;
 468
 469       Dot : constant String_Ptr := Pattern.Dot;
 470
 471       Dotl : constant Natural := Dot.all'Length;
 472
 473       Plen : constant Natural := Pattern.Pat'Length;
 474
 475       J : Natural;
 476    begin
 477       --  Apply casing, except that we do not do this for the case
 478       --  of a predefined library file. For the latter, we always
 479       --  use the all lower case name, regardless of the setting.
 480
 481       if not Is_Predef then
 482          Set_Casing (Buf, Pattern.Cas);
 483       end if;
 484
 485       --  If dot translation required do it
 486
 487       if Dot.all /= "." then
 488          J := 1;
 489
 490          while J <= Buf.Length loop
 491             if Buf.Chars (J) = '.' then
 492
 493                if Dotl = 1 then
 494                   Buf.Chars (J) := Dot (Dot'First);
 495
 496                else
 497                   Buf.Chars (J + Dotl .. Buf.Length + Dotl - 1) :=
 498                     Buf.Chars (J + 1 .. Buf.Length);
 499                   Buf.Chars (J .. J + Dotl - 1) := Dot.all;
 500                   Buf.Length := Buf.Length + Dotl - 1;
 501                end if;
 502
 503                J := J + Dotl;
 504
 505             --  Skip past wide char sequences to avoid messing with
 506             --  dot characters that are part of a sequence.
 507
 508             elsif Buf.Chars (J) = ASCII.ESC
 509               or else (Upper_Half_Encoding
 510                         and then
 511                           Buf.Chars (J) in Upper_Half_Character)
 512             then
 513                Skip_Wide (Buf.Chars, J);
 514             else
 515                J := J + 1;
 516             end if;
 517          end loop;
 518       end if;
 519
 520       --  Here move result to right if preinsertion before *
 521
 522       for K in 1 .. Plen loop
 523          if C (K) = '*' then
 524             if K /= 1 then
 525                Buf.Chars (1 + K - 1 .. Buf.Length + K - 1) :=
 526                  Buf.Chars (1 .. Buf.Length);
 527
 528                for L in 1 .. K - 1 loop
 529                   Buf.Chars (L) := C (L);
 530                end loop;
 531
 532                Buf.Length := Buf.Length + K - 1;
 533             end if;
 534
 535             for L in K + 1 .. Plen loop
 536                Buf.Length := Buf.Length + 1;
 537                Buf.Chars (Buf.Length) := C (L);
 538             end loop;
 539
 540             exit;
 541          end if;
 542       end loop;
 543
 544       --  Execute possible crunch on constructed name. The krunch
 545       --  operation excludes any extension that may be present.
 546
 547       J := Buf.Length;
 548       while J > 1 loop
 549          exit when Buf.Chars (J) = '.';
 550          J := J - 1;
 551       end loop;
 552
 553       --  Case of extension present
 554
 555       if J > 1 then
 556          declare
 557             Ext : constant String := Buf.Chars (J .. Buf.Length);
 558
 559          begin
 560             --  Remove extension
 561
 562             Buf.Length := J - 1;
 563
 564             --  Krunch what's left
 565
 566             Krunch
 567               (Buf.Chars,
 568                Buf.Length,
 569                Integer (Maximum_File_Name_Length),
 570                Debug_Flag_4);
 571
 572             --  Replace extension
 573
 574             Buf.Chars
 575               (Buf.Length + 1 .. Buf.Length + Ext'Length) := Ext;
 576             Buf.Length := Buf.Length + Ext'Length;
 577          end;
 578
 579       --  Case of no extension present, straight krunch on the
 580       --  entire file name.
 581
 582       else
 583          Krunch
 584            (Buf.Chars,
 585             Buf.Length,
 586             Integer (Maximum_File_Name_Length),
 587             Debug_Flag_4);
 588       end if;
 589    end Instantiate_SFN_Pattern;
 590
 591    ----------
 592    -- Lock --
 593    ----------
 594
 595    procedure Lock is
 596    begin
 597       SFN_Table.Release;
 598       SFN_Table.Locked := True;
 599    end Lock;
 600
 601    -------------------
 602    -- Set_File_Name --
 603    -------------------
 604
 605    procedure Set_File_Name
 606      (U     : Unit_Name_Type;
 607       F     : File_Name_Type;
 608       Index : Nat)
 609    is
 610    begin
 611       SFN_Table.Increment_Last;
 612       SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
 613       SFN_HTable.Set (U, SFN_Table.Last);
 614    end Set_File_Name;
 615
 616    ---------------------------
 617    -- Set_File_Name_Pattern --
 618    ---------------------------
 619
 620    procedure Set_File_Name_Pattern
 621      (Pat : String_Ptr;
 622       Typ : Character;
 623       Dot : String_Ptr;
 624       Cas : Casing_Type)
 625    is
 626       L : constant Nat := SFN_Patterns.Last;
 627
 628    begin
 629       SFN_Patterns.Increment_Last;
 630
 631       --  Move up the last two entries (the default ones) and then put the new
 632       --  entry into the table just before them (we always have the default
 633       --  entries be the last ones).
 634
 635       SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
 636       SFN_Patterns.Table (L)     := SFN_Patterns.Table (L - 1);
 637       SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
 638    end Set_File_Name_Pattern;
 639
 640    --------------
 641    -- SFN_Hash --
 642    --------------
 643
 644    function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
 645    begin
 646       return SFN_Header_Num (Int (F) mod SFN_Header_Num'Range_Length);
 647    end SFN_Hash;
 648
 649 begin
 650
 651    --  We call the initialization routine from the package body, so that
 652    --  Fname.Init only needs to be called explicitly to reinitialize.
 653
 654    Fname.UF.Initialize;
 655 end Fname.UF;