1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F M A P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2012, 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 26with Opt; use Opt; 27with Osint; use Osint; 28with Output; use Output; 29with Table; 30with Types; use Types; 31 32pragma Warnings (Off); 33-- This package is used also by gnatcoll 34with System.OS_Lib; use System.OS_Lib; 35pragma Warnings (On); 36 37with Unchecked_Conversion; 38 39with GNAT.HTable; 40 41package 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 bufferize 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 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 535end Fmap; 536