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