gcc/ada/fmap.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 F M A P                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2001-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 GNAT.OS_Lib; use GNAT.OS_Lib;
  28 with Namet;       use Namet;
  29 with Opt;         use Opt;
  30 with Osint;       use Osint;
  31 with Output;      use Output;
  32 with Table;
  33
  34 with Unchecked_Conversion;
  35
  36 with GNAT.HTable;
  37
  38 package body Fmap is
  39
  40    subtype Big_String is String (Positive);
  41    type Big_String_Ptr is access all Big_String;
  42
  43    function To_Big_String_Ptr is new Unchecked_Conversion
  44      (Source_Buffer_Ptr, Big_String_Ptr);
  45
  46    Max_Buffer : constant := 1_500;
  47    Buffer : String (1 .. Max_Buffer);
  48    --  Used to bufferize output when writing to a new mapping file
  49
  50    Buffer_Last : Natural := 0;
  51    --  Index of last valid character in Buffer
  52
  53    type Mapping is record
  54       Uname : Unit_Name_Type;
  55       Fname : File_Name_Type;
  56    end record;
  57
  58    package File_Mapping is new Table.Table (
  59      Table_Component_Type => Mapping,
  60      Table_Index_Type     => Int,
  61      Table_Low_Bound      => 0,
  62      Table_Initial        => 1_000,
  63      Table_Increment      => 1_000,
  64      Table_Name           => "Fmap.File_Mapping");
  65    --  Mapping table to map unit names to file names
  66
  67    package Path_Mapping is new Table.Table (
  68      Table_Component_Type => Mapping,
  69      Table_Index_Type     => Int,
  70      Table_Low_Bound      => 0,
  71      Table_Initial        => 1_000,
  72      Table_Increment      => 1_000,
  73      Table_Name           => "Fmap.Path_Mapping");
  74    --  Mapping table to map file names to path names
  75
  76    type Header_Num is range 0 .. 1_000;
  77
  78    function Hash (F : Unit_Name_Type) return Header_Num;
  79    --  Function used to compute hash of unit name
  80
  81    No_Entry : constant Int := -1;
  82    --  Signals no entry in following table
  83
  84    package Unit_Hash_Table is new GNAT.HTable.Simple_HTable (
  85      Header_Num => Header_Num,
  86      Element    => Int,
  87      No_Element => No_Entry,
  88      Key        => Unit_Name_Type,
  89      Hash       => Hash,
  90      Equal      => "=");
  91    --  Hash table to map unit names to file names. Used in conjunction with
  92    --  table File_Mapping above.
  93
  94    package File_Hash_Table is new GNAT.HTable.Simple_HTable (
  95      Header_Num => Header_Num,
  96      Element    => Int,
  97      No_Element => No_Entry,
  98      Key        => File_Name_Type,
  99      Hash       => Hash,
 100      Equal      => "=");
 101    --  Hash table to map file names to path names. Used in conjunction with
 102    --  table Path_Mapping above.
 103
 104    Last_In_Table : Int := 0;
 105
 106    package Forbidden_Names is new GNAT.HTable.Simple_HTable (
 107      Header_Num => Header_Num,
 108      Element    => Boolean,
 109      No_Element => False,
 110      Key        => File_Name_Type,
 111      Hash       => Hash,
 112      Equal      => "=");
 113
 114    -----------------------------
 115    -- Add_Forbidden_File_Name --
 116    -----------------------------
 117
 118    procedure Add_Forbidden_File_Name (Name : Name_Id) is
 119    begin
 120       Forbidden_Names.Set (Name, True);
 121    end Add_Forbidden_File_Name;
 122
 123    ---------------------
 124    -- Add_To_File_Map --
 125    ---------------------
 126
 127    procedure Add_To_File_Map
 128      (Unit_Name : Unit_Name_Type;
 129       File_Name : File_Name_Type;
 130       Path_Name : File_Name_Type)
 131    is
 132    begin
 133       File_Mapping.Increment_Last;
 134       Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
 135       File_Mapping.Table (File_Mapping.Last) :=
 136         (Uname => Unit_Name, Fname => File_Name);
 137       Path_Mapping.Increment_Last;
 138       File_Hash_Table.Set (File_Name, Path_Mapping.Last);
 139       Path_Mapping.Table (Path_Mapping.Last) :=
 140         (Uname => Unit_Name, Fname => Path_Name);
 141    end Add_To_File_Map;
 142
 143    ----------
 144    -- Hash --
 145    ----------
 146
 147    function Hash (F : Unit_Name_Type) return Header_Num is
 148    begin
 149       return Header_Num (Int (F) rem Header_Num'Range_Length);
 150    end Hash;
 151
 152    ----------------
 153    -- Initialize --
 154    ----------------
 155
 156    procedure Initialize (File_Name : String) is
 157       Src : Source_Buffer_Ptr;
 158       Hi  : Source_Ptr;
 159       BS  : Big_String_Ptr;
 160       SP  : String_Ptr;
 161
 162       First : Positive := 1;
 163       Last  : Natural  := 0;
 164
 165       Uname : Unit_Name_Type;
 166       Fname : Name_Id;
 167       Pname : Name_Id;
 168
 169       The_Mapping : Mapping;
 170
 171       procedure Empty_Tables (Warning : Boolean := True);
 172       --  Remove all entries in case of incorrect mapping file
 173
 174       function Find_Name return Name_Id;
 175       --  Return Error_Name for "/", otherwise call Name_Find
 176
 177       procedure Get_Line;
 178       --  Get a line from the mapping file
 179
 180       procedure Report_Truncated;
 181       --  Report a warning when the mapping file is truncated
 182       --  (number of lines is not a multiple of 3).
 183
 184       ------------------
 185       -- Empty_Tables --
 186       ------------------
 187
 188       procedure Empty_Tables (Warning : Boolean := True) is
 189       begin
 190          if Warning then
 191             Write_Str ("mapping file """);
 192             Write_Str (File_Name);
 193             Write_Line (""" is not taken into account");
 194          end if;
 195
 196          Unit_Hash_Table.Reset;
 197          File_Hash_Table.Reset;
 198          Path_Mapping.Set_Last (0);
 199          File_Mapping.Set_Last (0);
 200          Last_In_Table := 0;
 201       end Empty_Tables;
 202
 203       ---------------
 204       -- Find_Name --
 205       ---------------
 206
 207       function Find_Name return Name_Id is
 208       begin
 209          if Name_Buffer (1 .. Name_Len) = "/" then
 210             return Error_Name;
 211
 212          else
 213             return Name_Find;
 214          end if;
 215       end Find_Name;
 216
 217       --------------
 218       -- Get_Line --
 219       --------------
 220
 221       procedure Get_Line is
 222          use ASCII;
 223
 224       begin
 225          First := Last + 1;
 226
 227          --  If not at the end of file, skip the end of line
 228
 229          while First < SP'Last
 230            and then (SP (First) = CR
 231                       or else SP (First) = LF
 232                       or else SP (First) = EOF)
 233          loop
 234             First := First + 1;
 235          end loop;
 236
 237          --  If not at the end of file, find the end of this new line
 238
 239          if First < SP'Last and then SP (First) /= EOF then
 240             Last := First;
 241
 242             while Last < SP'Last
 243               and then SP (Last + 1) /= CR
 244               and then SP (Last + 1) /= LF
 245               and then SP (Last + 1) /= EOF
 246             loop
 247                Last := Last + 1;
 248             end loop;
 249
 250          end if;
 251       end Get_Line;
 252
 253       ----------------------
 254       -- Report_Truncated --
 255       ----------------------
 256
 257       procedure Report_Truncated is
 258       begin
 259          Write_Str ("warning: mapping file """);
 260          Write_Str (File_Name);
 261          Write_Line (""" is truncated");
 262       end Report_Truncated;
 263
 264    --  Start of procedure Initialize
 265
 266    begin
 267       Empty_Tables (Warning => False);
 268       Name_Len := File_Name'Length;
 269       Name_Buffer (1 .. Name_Len) := File_Name;
 270       Read_Source_File (Name_Enter, 0, Hi, Src, Config);
 271
 272       if Src = null then
 273          Write_Str ("warning: could not read mapping file """);
 274          Write_Str (File_Name);
 275          Write_Line ("""");
 276
 277       else
 278          BS := To_Big_String_Ptr (Src);
 279          SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
 280
 281          loop
 282             --  Get the unit name
 283
 284             Get_Line;
 285
 286             --  Exit if end of file has been reached
 287
 288             exit when First > Last;
 289
 290             if (Last < First + 2) or else (SP (Last - 1) /= '%')
 291               or else (SP (Last) /= 's' and then SP (Last) /= 'b')
 292             then
 293                Write_Str ("warning: mapping file """);
 294                Write_Str (File_Name);
 295                Write_Line (""" is incorrectly formatted");
 296                Empty_Tables;
 297                return;
 298             end if;
 299
 300             Name_Len := Last - First + 1;
 301             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 302             Uname := Find_Name;
 303
 304             --  Get the file name
 305
 306             Get_Line;
 307
 308             --  If end of line has been reached, file is truncated
 309
 310             if First > Last then
 311                Report_Truncated;
 312                Empty_Tables;
 313                return;
 314             end if;
 315
 316             Name_Len := Last - First + 1;
 317             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 318             Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 319             Fname := Find_Name;
 320
 321             --  Get the path name
 322
 323             Get_Line;
 324
 325             --  If end of line has been reached, file is truncated
 326
 327             if First > Last then
 328                Report_Truncated;
 329                Empty_Tables;
 330                return;
 331             end if;
 332
 333             Name_Len := Last - First + 1;
 334             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 335             Pname := Find_Name;
 336
 337             --  Check for duplicate entries
 338
 339             if Unit_Hash_Table.Get (Uname) /= No_Entry then
 340                Write_Str ("warning: duplicate entry """);
 341                Write_Str (Get_Name_String (Uname));
 342                Write_Str (""" in mapping file """);
 343                Write_Str (File_Name);
 344                Write_Line ("""");
 345                The_Mapping := File_Mapping.Table (Unit_Hash_Table.Get (Uname));
 346                Write_Line (Get_Name_String (The_Mapping.Uname));
 347                Write_Line (Get_Name_String (The_Mapping.Fname));
 348                Empty_Tables;
 349                return;
 350             end if;
 351
 352             if File_Hash_Table.Get (Fname) /= No_Entry then
 353                Write_Str ("warning: duplicate entry """);
 354                Write_Str (Get_Name_String (Fname));
 355                Write_Str (""" in mapping file """);
 356                Write_Str (File_Name);
 357                Write_Line ("""");
 358                The_Mapping := Path_Mapping.Table (File_Hash_Table.Get (Fname));
 359                Write_Line (Get_Name_String (The_Mapping.Uname));
 360                Write_Line (Get_Name_String (The_Mapping.Fname));
 361                Empty_Tables;
 362                return;
 363             end if;
 364
 365             --  Add the mappings for this unit name
 366
 367             Add_To_File_Map (Uname, Fname, Pname);
 368          end loop;
 369       end if;
 370
 371       --  Record the length of the two mapping tables
 372
 373       Last_In_Table := File_Mapping.Last;
 374
 375    end Initialize;
 376
 377    ----------------------
 378    -- Mapped_File_Name --
 379    ----------------------
 380
 381    function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
 382       The_Index : constant Int := Unit_Hash_Table.Get (Unit);
 383
 384    begin
 385       if The_Index = No_Entry then
 386          return No_File;
 387       else
 388          return File_Mapping.Table (The_Index).Fname;
 389       end if;
 390    end Mapped_File_Name;
 391
 392    ----------------------
 393    -- Mapped_Path_Name --
 394    ----------------------
 395
 396    function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
 397       Index : Int := No_Entry;
 398
 399    begin
 400       if Forbidden_Names.Get (File) then
 401          return Error_Name;
 402       end if;
 403
 404       Index := File_Hash_Table.Get (File);
 405
 406       if Index = No_Entry then
 407          return No_File;
 408       else
 409          return Path_Mapping.Table (Index).Fname;
 410       end if;
 411    end Mapped_Path_Name;
 412
 413    --------------------------------
 414    -- Remove_Forbidden_File_Name --
 415    --------------------------------
 416
 417    procedure Remove_Forbidden_File_Name (Name : Name_Id) is
 418    begin
 419       Forbidden_Names.Set (Name, False);
 420    end Remove_Forbidden_File_Name;
 421
 422    ------------------
 423    -- Reset_Tables --
 424    ------------------
 425
 426    procedure Reset_Tables is
 427    begin
 428       File_Mapping.Init;
 429       Path_Mapping.Init;
 430       Unit_Hash_Table.Reset;
 431       File_Hash_Table.Reset;
 432       Forbidden_Names.Reset;
 433       Last_In_Table := 0;
 434    end Reset_Tables;
 435
 436    -------------------------
 437    -- Update_Mapping_File --
 438    -------------------------
 439
 440    procedure Update_Mapping_File (File_Name : String) is
 441       File    : File_Descriptor;
 442       N_Bytes : Integer;
 443
 444       Status : Boolean;
 445       --  For the call to Close
 446
 447       procedure Put_Line (Name : Name_Id);
 448       --  Put Name as a line in the Mapping File
 449
 450       --------------
 451       -- Put_Line --
 452       --------------
 453
 454       procedure Put_Line (Name : Name_Id) is
 455       begin
 456          Get_Name_String (Name);
 457
 458          --  If the Buffer is full, write it to the file
 459
 460          if Buffer_Last + Name_Len + 1 > Buffer'Last then
 461             N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
 462
 463             if N_Bytes < Buffer_Last then
 464                Fail ("disk full");
 465             end if;
 466
 467             Buffer_Last := 0;
 468          end if;
 469
 470          --  Add the line to the Buffer
 471
 472          Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) :=
 473            Name_Buffer (1 .. Name_Len);
 474          Buffer_Last := Buffer_Last + Name_Len + 1;
 475          Buffer (Buffer_Last) := ASCII.LF;
 476       end Put_Line;
 477
 478    --  Start of Update_Mapping_File
 479
 480    begin
 481
 482       --  Only Update if there are new entries in the mappings
 483
 484       if Last_In_Table < File_Mapping.Last then
 485
 486          --  If the tables have been emptied, recreate the file.
 487          --  Otherwise, append to it.
 488
 489          if Last_In_Table = 0 then
 490             declare
 491                Discard : Boolean;
 492
 493             begin
 494                Delete_File (File_Name, Discard);
 495             end;
 496
 497             File := Create_File (File_Name, Binary);
 498
 499          else
 500             File := Open_Read_Write (Name => File_Name, Fmode => Binary);
 501          end if;
 502
 503          if File /= Invalid_FD then
 504             if Last_In_Table > 0 then
 505                Lseek (File, 0, Seek_End);
 506             end if;
 507
 508             for Unit in Last_In_Table + 1 .. File_Mapping.Last loop
 509                Put_Line (File_Mapping.Table (Unit).Uname);
 510                Put_Line (File_Mapping.Table (Unit).Fname);
 511                Put_Line (Path_Mapping.Table (Unit).Fname);
 512             end loop;
 513
 514             --  Before closing the file, write the buffer to the file.
 515             --  It is guaranteed that the Buffer is not empty, because
 516             --  Put_Line has been called at least 3 times, and after
 517             --  a call to Put_Line, the Buffer is not empty.
 518
 519             N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
 520
 521             if N_Bytes < Buffer_Last then
 522                Fail ("disk full");
 523             end if;
 524
 525             Close (File, Status);
 526
 527             if not Status then
 528                Fail ("disk full");
 529             end if;
 530
 531          elsif not Quiet_Output then
 532             Write_Str ("warning: could not open mapping file """);
 533             Write_Str (File_Name);
 534             Write_Line (""" for update");
 535          end if;
 536
 537       end if;
 538    end Update_Mapping_File;
 539
 540 end Fmap;