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