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