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-2007, 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    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    function Hash (F : File_Name_Type) return Header_Num;
  95    --  Function used to compute hash of file name
  96
  97    package File_Hash_Table is new GNAT.HTable.Simple_HTable (
  98      Header_Num => Header_Num,
  99      Element    => Int,
 100      No_Element => No_Entry,
 101      Key        => File_Name_Type,
 102      Hash       => Hash,
 103      Equal      => "=");
 104    --  Hash table to map file names to path names. Used in conjunction with
 105    --  table Path_Mapping above.
 106
 107    Last_In_Table : Int := 0;
 108
 109    package Forbidden_Names is new GNAT.HTable.Simple_HTable (
 110      Header_Num => Header_Num,
 111      Element    => Boolean,
 112      No_Element => False,
 113      Key        => File_Name_Type,
 114      Hash       => Hash,
 115      Equal      => "=");
 116
 117    -----------------------------
 118    -- Add_Forbidden_File_Name --
 119    -----------------------------
 120
 121    procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
 122    begin
 123       Forbidden_Names.Set (Name, True);
 124    end Add_Forbidden_File_Name;
 125
 126    ---------------------
 127    -- Add_To_File_Map --
 128    ---------------------
 129
 130    procedure Add_To_File_Map
 131      (Unit_Name : Unit_Name_Type;
 132       File_Name : File_Name_Type;
 133       Path_Name : File_Name_Type)
 134    is
 135       Unit_Entry : constant Int := Unit_Hash_Table.Get (Unit_Name);
 136       File_Entry : constant Int := File_Hash_Table.Get (File_Name);
 137    begin
 138       if Unit_Entry = No_Entry or else
 139         File_Mapping.Table (Unit_Entry).Fname /= File_Name
 140       then
 141          File_Mapping.Increment_Last;
 142          Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
 143          File_Mapping.Table (File_Mapping.Last) :=
 144            (Uname => Unit_Name, Fname => File_Name);
 145       end if;
 146
 147       if File_Entry = No_Entry or else
 148         Path_Mapping.Table (File_Entry).Fname /= Path_Name
 149       then
 150          Path_Mapping.Increment_Last;
 151          File_Hash_Table.Set (File_Name, Path_Mapping.Last);
 152          Path_Mapping.Table (Path_Mapping.Last) :=
 153            (Uname => Unit_Name, Fname => Path_Name);
 154       end if;
 155    end Add_To_File_Map;
 156
 157    ----------
 158    -- Hash --
 159    ----------
 160
 161    function Hash (F : File_Name_Type) return Header_Num is
 162    begin
 163       return Header_Num (Int (F) rem Header_Num'Range_Length);
 164    end Hash;
 165
 166    function Hash (F : Unit_Name_Type) return Header_Num is
 167    begin
 168       return Header_Num (Int (F) rem Header_Num'Range_Length);
 169    end Hash;
 170
 171    ----------------
 172    -- Initialize --
 173    ----------------
 174
 175    procedure Initialize (File_Name : String) is
 176       Src : Source_Buffer_Ptr;
 177       Hi  : Source_Ptr;
 178       BS  : Big_String_Ptr;
 179       SP  : String_Ptr;
 180
 181       First : Positive := 1;
 182       Last  : Natural  := 0;
 183
 184       Uname : Unit_Name_Type;
 185       Fname : File_Name_Type;
 186       Pname : File_Name_Type;
 187
 188       procedure Empty_Tables;
 189       --  Remove all entries in case of incorrect mapping file
 190
 191       function Find_File_Name return File_Name_Type;
 192       --  Return Error_File_Name for "/", otherwise call Name_Find
 193       --  What is this about, explanation required ???
 194
 195       function Find_Unit_Name return Unit_Name_Type;
 196       --  Return Error_Unit_Name for "/", otherwise call Name_Find
 197       --  Even more mysterious??? function appeared when Find_Name was split
 198       --  for the two types, but this routine is definitely called!
 199
 200       procedure Get_Line;
 201       --  Get a line from the mapping file
 202
 203       procedure Report_Truncated;
 204       --  Report a warning when the mapping file is truncated
 205       --  (number of lines is not a multiple of 3).
 206
 207       ------------------
 208       -- Empty_Tables --
 209       ------------------
 210
 211       procedure Empty_Tables is
 212       begin
 213          Unit_Hash_Table.Reset;
 214          File_Hash_Table.Reset;
 215          Path_Mapping.Set_Last (0);
 216          File_Mapping.Set_Last (0);
 217          Last_In_Table := 0;
 218       end Empty_Tables;
 219
 220       --------------------
 221       -- Find_File_Name --
 222       --------------------
 223
 224       --  Why is only / illegal, why not \ on windows ???
 225
 226       function Find_File_Name return File_Name_Type is
 227       begin
 228          if Name_Buffer (1 .. Name_Len) = "/" then
 229             return Error_File_Name;
 230          else
 231             return Name_Find;
 232          end if;
 233       end Find_File_Name;
 234
 235       --------------------
 236       -- Find_Unit_Name --
 237       --------------------
 238
 239       function Find_Unit_Name return Unit_Name_Type is
 240       begin
 241          return Unit_Name_Type (Find_File_Name);
 242          --  very odd ???
 243       end Find_Unit_Name;
 244
 245       --------------
 246       -- Get_Line --
 247       --------------
 248
 249       procedure Get_Line is
 250          use ASCII;
 251
 252       begin
 253          First := Last + 1;
 254
 255          --  If not at the end of file, skip the end of line
 256
 257          while First < SP'Last
 258            and then (SP (First) = CR
 259                       or else SP (First) = LF
 260                       or else SP (First) = EOF)
 261          loop
 262             First := First + 1;
 263          end loop;
 264
 265          --  If not at the end of file, find the end of this new line
 266
 267          if First < SP'Last and then SP (First) /= EOF then
 268             Last := First;
 269
 270             while Last < SP'Last
 271               and then SP (Last + 1) /= CR
 272               and then SP (Last + 1) /= LF
 273               and then SP (Last + 1) /= EOF
 274             loop
 275                Last := Last + 1;
 276             end loop;
 277
 278          end if;
 279       end Get_Line;
 280
 281       ----------------------
 282       -- Report_Truncated --
 283       ----------------------
 284
 285       procedure Report_Truncated is
 286       begin
 287          Write_Str ("warning: mapping file """);
 288          Write_Str (File_Name);
 289          Write_Line (""" is truncated");
 290       end Report_Truncated;
 291
 292    --  Start of processing for Initialize
 293
 294    begin
 295       Empty_Tables;
 296       Name_Len := File_Name'Length;
 297       Name_Buffer (1 .. Name_Len) := File_Name;
 298       Read_Source_File (Name_Enter, 0, Hi, Src, Config);
 299
 300       if Src = null then
 301          Write_Str ("warning: could not read mapping file """);
 302          Write_Str (File_Name);
 303          Write_Line ("""");
 304
 305       else
 306          BS := To_Big_String_Ptr (Src);
 307          SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
 308
 309          loop
 310             --  Get the unit name
 311
 312             Get_Line;
 313
 314             --  Exit if end of file has been reached
 315
 316             exit when First > Last;
 317
 318             if (Last < First + 2) or else (SP (Last - 1) /= '%')
 319               or else (SP (Last) /= 's' and then SP (Last) /= 'b')
 320             then
 321                Write_Str ("warning: mapping file """);
 322                Write_Str (File_Name);
 323                Write_Line (""" is incorrectly formatted");
 324                Empty_Tables;
 325                return;
 326             end if;
 327
 328             Name_Len := Last - First + 1;
 329             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 330             Uname := Find_Unit_Name;
 331
 332             --  Get the file name
 333
 334             Get_Line;
 335
 336             --  If end of line has been reached, file is truncated
 337
 338             if First > Last then
 339                Report_Truncated;
 340                Empty_Tables;
 341                return;
 342             end if;
 343
 344             Name_Len := Last - First + 1;
 345             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 346             Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 347             Fname := Find_File_Name;
 348
 349             --  Get the path name
 350
 351             Get_Line;
 352
 353             --  If end of line has been reached, file is truncated
 354
 355             if First > Last then
 356                Report_Truncated;
 357                Empty_Tables;
 358                return;
 359             end if;
 360
 361             Name_Len := Last - First + 1;
 362             Name_Buffer (1 .. Name_Len) := SP (First .. Last);
 363             Pname := Find_File_Name;
 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    end Initialize;
 375
 376    ----------------------
 377    -- Mapped_File_Name --
 378    ----------------------
 379
 380    function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
 381       The_Index : constant Int := Unit_Hash_Table.Get (Unit);
 382
 383    begin
 384       if The_Index = No_Entry then
 385          return No_File;
 386       else
 387          return File_Mapping.Table (The_Index).Fname;
 388       end if;
 389    end Mapped_File_Name;
 390
 391    ----------------------
 392    -- Mapped_Path_Name --
 393    ----------------------
 394
 395    function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
 396       Index : Int := No_Entry;
 397
 398    begin
 399       if Forbidden_Names.Get (File) then
 400          return Error_File_Name;
 401       end if;
 402
 403       Index := File_Hash_Table.Get (File);
 404
 405       if Index = No_Entry then
 406          return No_File;
 407       else
 408          return Path_Mapping.Table (Index).Fname;
 409       end if;
 410    end Mapped_Path_Name;
 411
 412    --------------------------------
 413    -- Remove_Forbidden_File_Name --
 414    --------------------------------
 415
 416    procedure Remove_Forbidden_File_Name (Name : File_Name_Type) is
 417    begin
 418       Forbidden_Names.Set (Name, False);
 419    end Remove_Forbidden_File_Name;
 420
 421    ------------------
 422    -- Reset_Tables --
 423    ------------------
 424
 425    procedure Reset_Tables is
 426    begin
 427       File_Mapping.Init;
 428       Path_Mapping.Init;
 429       Unit_Hash_Table.Reset;
 430       File_Hash_Table.Reset;
 431       Forbidden_Names.Reset;
 432       Last_In_Table := 0;
 433    end Reset_Tables;
 434
 435    -------------------------
 436    -- Update_Mapping_File --
 437    -------------------------
 438
 439    procedure Update_Mapping_File (File_Name : String) is
 440       File    : File_Descriptor;
 441       N_Bytes : Integer;
 442
 443       File_Entry : Int;
 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                pragma Warnings (Off, Discard);
 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 (Name_Id (File_Mapping.Table (Unit).Uname));
 511                Put_Line (Name_Id (File_Mapping.Table (Unit).Fname));
 512                File_Entry :=
 513                  File_Hash_Table.Get (File_Mapping.Table (Unit).Fname);
 514                Put_Line (Name_Id (Path_Mapping.Table (File_Entry).Fname));
 515             end loop;
 516
 517             --  Before closing the file, write the buffer to the file. It is
 518             --  guaranteed that the Buffer is not empty, because Put_Line has
 519             --  been called at least 3 times, and after a call to Put_Line, the
 520             --  Buffer is not empty.
 521
 522             N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
 523
 524             if N_Bytes < Buffer_Last then
 525                Fail ("disk full");
 526             end if;
 527
 528             Close (File, Status);
 529
 530             if not Status then
 531                Fail ("disk full");
 532             end if;
 533
 534          elsif not Quiet_Output then
 535             Write_Str ("warning: could not open mapping file """);
 536             Write_Str (File_Name);
 537             Write_Line (""" for update");
 538          end if;
 539
 540       end if;
 541    end Update_Mapping_File;
 542
 543 end Fmap;