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