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