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 --                            $Revision: 1.6 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Alloc;
  30 with Debug;    use Debug;
  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    begin
 141       --  Null or error name means that some previous error occured
 142       --  This is an unrecoverable error, so signal it.
 143
 144       if Uname <= Error_Name then
 145          raise Unrecoverable_Error;
 146       end if;
 147
 148       N := SFN_HTable.Get (Uname);
 149
 150       if N /= No_Entry then
 151          return SFN_Table.Table (N).F;
 152       end if;
 153
 154       --  Here for the case where the name was not found in the table
 155
 156       Get_Decoded_Name_String (Uname);
 157
 158       --  A special fudge, normally we don't have operator symbols present,
 159       --  since it is always an error to do so. However, if we do, at this
 160       --  stage it has a leading double quote.
 161
 162       --  What we do in this case is to go back to the undecoded name, which
 163       --  is of the form, for example:
 164
 165       --    Oand%s
 166
 167       --  and build a file name that looks like:
 168
 169       --    _and_.ads
 170
 171       --  which is bit peculiar, but we keep it that way. This means that
 172       --  we avoid bombs due to writing a bad file name, and w get expected
 173       --  error processing downstream, e.g. a compilation following gnatchop.
 174
 175       if Name_Buffer (1) = '"' then
 176          Get_Name_String (Uname);
 177          Name_Len := Name_Len + 1;
 178          Name_Buffer (Name_Len)     := Name_Buffer (Name_Len - 1);
 179          Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
 180          Name_Buffer (Name_Len - 2) := '_';
 181          Name_Buffer (1)            := '_';
 182       end if;
 183
 184       --  Deal with spec or body suffix
 185
 186       Unit_Char := Name_Buffer (Name_Len);
 187       pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
 188       pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
 189       Name_Len := Name_Len - 2;
 190
 191       if Subunit then
 192          Unit_Char := 'u';
 193       end if;
 194
 195       --  Now we need to find the proper translation of the name
 196
 197       declare
 198          Uname : constant String (1 .. Name_Len) :=
 199                    Name_Buffer (1 .. Name_Len);
 200
 201          Pent : Nat;
 202          Plen : Natural;
 203          Fnam : File_Name_Type := No_File;
 204          J    : Natural;
 205          Dot  : String_Ptr;
 206          Dotl : Natural;
 207
 208          function C (N : Natural) return Character;
 209          --  Return N'th character of pattern
 210
 211          function C (N : Natural) return Character is
 212          begin
 213             return SFN_Patterns.Table (Pent).Pat (N);
 214          end C;
 215
 216       --  Start of search through pattern table
 217
 218       begin
 219          --  Search pattern table to find a matching entry. In the general
 220          --  case we do two complete searches. The first time through we
 221          --  stop only if a matching file is found, the second time through
 222          --  we accept the first match regardless. Note that there will
 223          --  always be a match the second time around, because of the
 224          --  default entries at the end of the table.
 225
 226          for No_File_Check in False .. True loop
 227             Unit_Char_Search := Unit_Char;
 228
 229          <<Repeat_Search>>
 230          --  The search is repeated with Unit_Char_Search set to b, if an
 231          --  initial search for the subunit case fails to find any match.
 232
 233             Pent := SFN_Patterns.First;
 234             while Pent <= SFN_Patterns.Last loop
 235                if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
 236                   Name_Len := 0;
 237
 238                   --  Found a match, execute the pattern
 239
 240                   Name_Len := Uname'Length;
 241                   Name_Buffer (1 .. Name_Len) := Uname;
 242                   Set_Casing (SFN_Patterns.Table (Pent).Cas);
 243
 244                   --  If dot translation required do it
 245
 246                   Dot  := SFN_Patterns.Table (Pent).Dot;
 247                   Dotl := Dot.all'Length;
 248
 249                   if Dot.all /= "." then
 250                      J := 1;
 251
 252                      while J <= Name_Len loop
 253                         if Name_Buffer (J) = '.' then
 254
 255                            if Dotl = 1 then
 256                               Name_Buffer (J) := Dot (Dot'First);
 257
 258                            else
 259                               Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
 260                                 Name_Buffer (J + 1 .. Name_Len);
 261                               Name_Buffer (J .. J + Dotl - 1) := Dot.all;
 262                               Name_Len := Name_Len + Dotl - 1;
 263                            end if;
 264
 265                            J := J + Dotl;
 266
 267                         --  Skip past wide char sequences to avoid messing
 268                         --  with dot characters that are part of a sequence.
 269
 270                         elsif Name_Buffer (J) = ASCII.ESC
 271                           or else (Upper_Half_Encoding
 272                                     and then
 273                                       Name_Buffer (J) in Upper_Half_Character)
 274                         then
 275                            Skip_Wide (Name_Buffer, J);
 276                         else
 277                            J := J + 1;
 278                         end if;
 279                      end loop;
 280                   end if;
 281
 282                   --  Here move result to right if preinsertion before *
 283
 284                   Plen := SFN_Patterns.Table (Pent).Pat'Length;
 285                   for K in 1 .. Plen loop
 286                      if C (K) = '*' then
 287                         if K /= 1 then
 288                            Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
 289                              Name_Buffer (1 .. Name_Len);
 290
 291                            for L in 1 .. K - 1 loop
 292                               Name_Buffer (L) := C (L);
 293                            end loop;
 294
 295                            Name_Len := Name_Len + K - 1;
 296                         end if;
 297
 298                         for L in K + 1 .. Plen loop
 299                            Name_Len := Name_Len + 1;
 300                            Name_Buffer (Name_Len) := C (L);
 301                         end loop;
 302
 303                         exit;
 304                      end if;
 305                   end loop;
 306
 307                   --  Execute possible crunch on constructed name. The krunch
 308                   --  operation excludes any extension that may be present.
 309
 310                   J := Name_Len;
 311                   while J > 1 loop
 312                      exit when Name_Buffer (J) = '.';
 313                      J := J - 1;
 314                   end loop;
 315
 316                   --  Case of extension present
 317
 318                   if J > 1 then
 319                      declare
 320                         Ext : constant String := Name_Buffer (J .. Name_Len);
 321
 322                      begin
 323                         --  Remove extension
 324
 325                         Name_Len := J - 1;
 326
 327                         --  Krunch what's left
 328
 329                         Krunch
 330                           (Name_Buffer,
 331                            Name_Len,
 332                            Integer (Maximum_File_Name_Length),
 333                            Debug_Flag_4);
 334
 335                         --  Replace extension
 336
 337                         Name_Buffer
 338                           (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
 339                         Name_Len := Name_Len + Ext'Length;
 340                      end;
 341
 342                   --  Case of no extension present, straight krunch on
 343                   --  the entire file name.
 344
 345                   else
 346                      Krunch
 347                        (Name_Buffer,
 348                         Name_Len,
 349                         Integer (Maximum_File_Name_Length),
 350                         Debug_Flag_4);
 351                   end if;
 352
 353                   Fnam := File_Name_Type (Name_Find);
 354
 355                   --  If we are in the first search of the table, then
 356                   --  we check if the file is present, and only accept
 357                   --  the entry if it is indeed present. For the second
 358                   --  search, we accept the entry without this check.
 359
 360                   --  If we only have two entries in the table, then there
 361                   --  is no point in seeing if the file exists, since we
 362                   --  will end up accepting it anyway on the second search,
 363                   --  so just quit and accept it now to save time.
 364
 365                   if No_File_Check or else SFN_Patterns.Last = 2 then
 366                      return Fnam;
 367
 368                   --  Check if file exists and if so, return the entry
 369
 370                   elsif Find_File (Fnam, Source) /= No_File then
 371                      return Fnam;
 372
 373                   --  This entry does not match after all, because this is
 374                   --  the first search loop, and the file does not exist.
 375
 376                   else
 377                      Fnam := No_File;
 378                   end if;
 379                end if;
 380
 381                Pent := Pent + 1;
 382             end loop;
 383
 384             --  If search failed, and was for a subunit, repeat the search
 385             --  with Unit_Char_Search reset to 'b', since in the normal case
 386             --  we simply treat subunits as bodies.
 387
 388             if Fnam = No_File and then Unit_Char_Search = 'u' then
 389                Unit_Char_Search := 'b';
 390                goto Repeat_Search;
 391             end if;
 392
 393             --  Repeat entire search in No_File_Check mode if necessary
 394
 395          end loop;
 396
 397          --  Something is wrong if search fails completely, since the
 398          --  default entries should catch all possibilities at this stage.
 399
 400          raise Program_Error;
 401       end;
 402    end Get_File_Name;
 403
 404    ----------------
 405    -- Initialize --
 406    ----------------
 407
 408    procedure Initialize is
 409    begin
 410       SFN_Table.Init;
 411       SFN_Patterns.Init;
 412
 413       --  Add default entries to SFN_Patterns.Table to represent the
 414       --  standard default GNAT rules for file name translation.
 415
 416       SFN_Patterns.Append (New_Val =>
 417         (Pat => new String'("*.ads"),
 418          Typ => 's',
 419          Dot => new String'("-"),
 420          Cas => All_Lower_Case));
 421
 422       SFN_Patterns.Append (New_Val =>
 423         (Pat => new String'("*.adb"),
 424          Typ => 'b',
 425          Dot => new String'("-"),
 426          Cas => All_Lower_Case));
 427    end Initialize;
 428
 429    ----------
 430    -- Lock --
 431    ----------
 432
 433    procedure Lock is
 434    begin
 435       SFN_Table.Locked := True;
 436       SFN_Table.Release;
 437    end Lock;
 438
 439    -------------------
 440    -- Set_File_Name --
 441    -------------------
 442
 443    procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is
 444    begin
 445       SFN_Table.Increment_Last;
 446       SFN_Table.Table (SFN_Table.Last) := (U, F);
 447       SFN_HTable.Set (U, SFN_Table.Last);
 448    end Set_File_Name;
 449
 450    ---------------------------
 451    -- Set_File_Name_Pattern --
 452    ---------------------------
 453
 454    procedure Set_File_Name_Pattern
 455      (Pat : String_Ptr;
 456       Typ : Character;
 457       Dot : String_Ptr;
 458       Cas : Casing_Type)
 459    is
 460       L : constant Nat := SFN_Patterns.Last;
 461    begin
 462       SFN_Patterns.Increment_Last;
 463
 464       --  Move up the last two entries (the default ones) and then
 465       --  put the new entry into the table just before them (we
 466       --  always have the default entries be the last ones).
 467
 468       SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
 469       SFN_Patterns.Table (L)     := SFN_Patterns.Table (L - 1);
 470       SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
 471    end Set_File_Name_Pattern;
 472
 473    --------------
 474    -- SFN_Hash --
 475    --------------
 476
 477    function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
 478    begin
 479       return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
 480    end SFN_Hash;
 481
 482 begin
 483
 484    --  We call the initialization routine from the package body, so that
 485    --  Fname.Init only needs to be called explicitly to reinitialize.
 486
 487    Fname.UF.Initialize;
 488 end Fname.UF;