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