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-2003, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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       -- Get_Line --
 205       --------------
 206
 207       procedure Get_Line is
 208          use ASCII;
 209
 210       begin
 211          First := Last + 1;
 212
 213          --  If not at the end of file, skip the end of line
 214
 215          while First < SP'Last
 216            and then (SP (First) = CR
 217                      or else SP (First) = LF
 218                      or else SP (First) = EOF)
 219          loop
 220             First := First + 1;
 221          end loop;
 222
 223          --  If not at the end of file, find the end of this new line
 224
 225          if First < SP'Last and then SP (First) /= EOF then
 226             Last := First;
 227
 228             while Last < SP'Last
 229               and then SP (Last + 1) /= CR
 230               and then SP (Last + 1) /= LF
 231               and then SP (Last + 1) /= EOF
 232             loop
 233                Last := Last + 1;
 234             end loop;
 235
 236          end if;
 237       end Get_Line;
 238
 239       ---------------
 240       -- Find_Name --
 241       ---------------
 242
 243       function Find_Name return Name_Id is
 244       begin
 245          if Name_Buffer (1 .. Name_Len) = "/" then
 246             return Error_Name;
 247
 248          else
 249             return Name_Find;
 250          end if;
 251       end Find_Name;
 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 formated");
 296                Empty_Tables;
 297                return;
 298             end if;
 299
 300
 301             Name_Len := Last - First + 1;
 302             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 303             Uname := Find_Name;
 304
 305             --  Get the file name
 306
 307             Get_Line;
 308
 309             --  If end of line has been reached, file is truncated
 310
 311             if First > Last then
 312                Report_Truncated;
 313                Empty_Tables;
 314                return;
 315             end if;
 316
 317             Name_Len := Last - First + 1;
 318             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 319             Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 320             Fname := Find_Name;
 321
 322             --  Get the path name
 323
 324             Get_Line;
 325
 326             --  If end of line has been reached, file is truncated
 327
 328             if First > Last then
 329                Report_Truncated;
 330                Empty_Tables;
 331                return;
 332             end if;
 333
 334             Name_Len := Last - First + 1;
 335             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 336             Pname := Find_Name;
 337
 338             --  Check for duplicate entries
 339
 340             if Unit_Hash_Table.Get (Uname) /= No_Entry then
 341                Write_Str ("warning: duplicate entry """);
 342                Write_Str (Get_Name_String (Uname));
 343                Write_Str (""" in mapping file """);
 344                Write_Str (File_Name);
 345                Write_Line ("""");
 346                The_Mapping := File_Mapping.Table (Unit_Hash_Table.Get (Uname));
 347                Write_Line (Get_Name_String (The_Mapping.Uname));
 348                Write_Line (Get_Name_String (The_Mapping.Fname));
 349                Empty_Tables;
 350                return;
 351             end if;
 352
 353             if File_Hash_Table.Get (Fname) /= No_Entry then
 354                Write_Str ("warning: duplicate entry """);
 355                Write_Str (Get_Name_String (Fname));
 356                Write_Str (""" in mapping file """);
 357                Write_Str (File_Name);
 358                Write_Line ("""");
 359                The_Mapping := Path_Mapping.Table (File_Hash_Table.Get (Fname));
 360                Write_Line (Get_Name_String (The_Mapping.Uname));
 361                Write_Line (Get_Name_String (The_Mapping.Fname));
 362                Empty_Tables;
 363                return;
 364             end if;
 365
 366             --  Add the mappings for this unit name
 367
 368             Add_To_File_Map (Uname, Fname, Pname);
 369          end loop;
 370       end if;
 371
 372       --  Record the length of the two mapping tables
 373
 374       Last_In_Table := File_Mapping.Last;
 375
 376    end Initialize;
 377
 378    ----------------------
 379    -- Mapped_File_Name --
 380    ----------------------
 381
 382    function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
 383       The_Index : constant Int := Unit_Hash_Table.Get (Unit);
 384
 385    begin
 386       if The_Index = No_Entry then
 387          return No_File;
 388       else
 389          return File_Mapping.Table (The_Index).Fname;
 390       end if;
 391    end Mapped_File_Name;
 392
 393    ----------------------
 394    -- Mapped_Path_Name --
 395    ----------------------
 396
 397    function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
 398       Index : Int := No_Entry;
 399
 400    begin
 401       if Forbidden_Names.Get (File) then
 402          return Error_Name;
 403       end if;
 404
 405       Index := File_Hash_Table.Get (File);
 406
 407       if Index = No_Entry then
 408          return No_File;
 409       else
 410          return Path_Mapping.Table (Index).Fname;
 411       end if;
 412    end Mapped_Path_Name;
 413
 414    --------------------------------
 415    -- Remove_Forbidden_File_Name --
 416    --------------------------------
 417
 418    procedure Remove_Forbidden_File_Name (Name : Name_Id) is
 419    begin
 420       Forbidden_Names.Set (Name, False);
 421    end Remove_Forbidden_File_Name;
 422
 423    ------------------
 424    -- Reset_Tables --
 425    ------------------
 426
 427    procedure Reset_Tables is
 428    begin
 429       File_Mapping.Init;
 430       Path_Mapping.Init;
 431       Unit_Hash_Table.Reset;
 432       File_Hash_Table.Reset;
 433       Forbidden_Names.Reset;
 434       Last_In_Table := 0;
 435    end Reset_Tables;
 436
 437    -------------------------
 438    -- Update_Mapping_File --
 439    -------------------------
 440
 441    procedure Update_Mapping_File (File_Name : String) is
 442       File    : File_Descriptor;
 443       N_Bytes : Integer;
 444
 445       Status : Boolean;
 446       --  For the call to Close
 447
 448       procedure Put_Line (Name : Name_Id);
 449       --  Put Name as a line in the Mapping File
 450
 451       --------------
 452       -- Put_Line --
 453       --------------
 454
 455       procedure Put_Line (Name : Name_Id) is
 456       begin
 457          Get_Name_String (Name);
 458
 459          --  If the Buffer is full, write it to the file
 460
 461          if Buffer_Last + Name_Len + 1 > Buffer'Last then
 462             N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
 463
 464             if N_Bytes < Buffer_Last then
 465                Fail ("disk full");
 466             end if;
 467
 468             Buffer_Last := 0;
 469          end if;
 470
 471          --  Add the line to the Buffer
 472
 473          Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) :=
 474            Name_Buffer (1 .. Name_Len);
 475          Buffer_Last := Buffer_Last + Name_Len + 1;
 476          Buffer (Buffer_Last) := ASCII.LF;
 477       end Put_Line;
 478
 479    --  Start of Update_Mapping_File
 480
 481    begin
 482
 483       --  Only Update if there are new entries in the mappings
 484
 485       if Last_In_Table < File_Mapping.Last then
 486
 487          --  If the tables have been emptied, recreate the file.
 488          --  Otherwise, append to it.
 489
 490          if Last_In_Table = 0 then
 491             declare
 492                Discard : Boolean;
 493
 494             begin
 495                Delete_File (File_Name, Discard);
 496             end;
 497
 498             File := Create_File (File_Name, Binary);
 499
 500          else
 501             File := Open_Read_Write (Name => File_Name, Fmode => Binary);
 502          end if;
 503
 504          if File /= Invalid_FD then
 505             if Last_In_Table > 0 then
 506                Lseek (File, 0, Seek_End);
 507             end if;
 508
 509             for Unit in Last_In_Table + 1 .. File_Mapping.Last loop
 510                Put_Line (File_Mapping.Table (Unit).Uname);
 511                Put_Line (File_Mapping.Table (Unit).Fname);
 512                Put_Line (Path_Mapping.Table (Unit).Fname);
 513             end loop;
 514
 515             --  Before closing the file, write the buffer to the file.
 516             --  It is guaranteed that the Buffer is not empty, because
 517             --  Put_Line has been called at least 3 times, and after
 518             --  a call to Put_Line, the Buffer is not empty.
 519
 520             N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
 521
 522             if N_Bytes < Buffer_Last then
 523                Fail ("disk full");
 524             end if;
 525
 526             Close (File, Status);
 527
 528             if not Status then
 529                Fail ("disk full");
 530             end if;
 531
 532          elsif not Quiet_Output then
 533             Write_Str ("warning: could not open mapping file """);
 534             Write_Str (File_Name);
 535             Write_Line (""" for update");
 536          end if;
 537
 538       end if;
 539    end Update_Mapping_File;
 540
 541 end Fmap;