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