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