1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Osint; use Osint;
29 with Output; use Output;
31 with Types; use Types;
33 with System.OS_Lib; use System.OS_Lib;
35 with Unchecked_Conversion;
41 subtype Big_String is String (Positive);
42 type Big_String_Ptr is access all Big_String;
44 function To_Big_String_Ptr is new Unchecked_Conversion
45 (Source_Buffer_Ptr, Big_String_Ptr);
47 Max_Buffer : constant := 1_500;
48 Buffer : String (1 .. Max_Buffer);
49 -- Used to bufferize output when writing to a new mapping file
51 Buffer_Last : Natural := 0;
52 -- Index of last valid character in Buffer
54 type Mapping is record
55 Uname : Unit_Name_Type;
56 Fname : File_Name_Type;
59 package File_Mapping is new Table.Table (
60 Table_Component_Type => Mapping,
61 Table_Index_Type => Int,
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
68 package Path_Mapping is new Table.Table (
69 Table_Component_Type => Mapping,
70 Table_Index_Type => Int,
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
77 type Header_Num is range 0 .. 1_000;
79 function Hash (F : Unit_Name_Type) return Header_Num;
80 -- Function used to compute hash of unit name
82 No_Entry : constant Int := -1;
83 -- Signals no entry in following table
85 package Unit_Hash_Table is new GNAT.HTable.Simple_HTable (
86 Header_Num => Header_Num,
88 No_Element => No_Entry,
89 Key => Unit_Name_Type,
92 -- Hash table to map unit names to file names. Used in conjunction with
93 -- table File_Mapping above.
95 function Hash (F : File_Name_Type) return Header_Num;
96 -- Function used to compute hash of file name
98 package File_Hash_Table is new GNAT.HTable.Simple_HTable (
99 Header_Num => Header_Num,
101 No_Element => No_Entry,
102 Key => File_Name_Type,
105 -- Hash table to map file names to path names. Used in conjunction with
106 -- table Path_Mapping above.
108 Last_In_Table : Int := 0;
110 package Forbidden_Names is new GNAT.HTable.Simple_HTable (
111 Header_Num => Header_Num,
114 Key => File_Name_Type,
118 -----------------------------
119 -- Add_Forbidden_File_Name --
120 -----------------------------
122 procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
124 Forbidden_Names.Set (Name, True);
125 end Add_Forbidden_File_Name;
127 ---------------------
128 -- Add_To_File_Map --
129 ---------------------
131 procedure Add_To_File_Map
132 (Unit_Name : Unit_Name_Type;
133 File_Name : File_Name_Type;
134 Path_Name : File_Name_Type)
137 File_Mapping.Increment_Last;
138 Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
139 File_Mapping.Table (File_Mapping.Last) :=
140 (Uname => Unit_Name, Fname => File_Name);
141 Path_Mapping.Increment_Last;
142 File_Hash_Table.Set (File_Name, Path_Mapping.Last);
143 Path_Mapping.Table (Path_Mapping.Last) :=
144 (Uname => Unit_Name, Fname => Path_Name);
151 function Hash (F : File_Name_Type) return Header_Num is
153 return Header_Num (Int (F) rem Header_Num'Range_Length);
156 function Hash (F : Unit_Name_Type) return Header_Num is
158 return Header_Num (Int (F) rem Header_Num'Range_Length);
165 procedure Initialize (File_Name : String) is
166 Src : Source_Buffer_Ptr;
171 First : Positive := 1;
174 Uname : Unit_Name_Type;
175 Fname : File_Name_Type;
176 Pname : File_Name_Type;
178 procedure Empty_Tables;
179 -- Remove all entries in case of incorrect mapping file
181 function Find_File_Name return File_Name_Type;
182 -- Return Error_File_Name for "/", otherwise call Name_Find
183 -- What is this about, explanation required ???
185 function Find_Unit_Name return Unit_Name_Type;
186 -- Return Error_Unit_Name for "/", otherwise call Name_Find
187 -- Even more mysterious??? function appeared when Find_Name was split
188 -- for the two types, but this routine is definitely called!
191 -- Get a line from the mapping file
193 procedure Report_Truncated;
194 -- Report a warning when the mapping file is truncated
195 -- (number of lines is not a multiple of 3).
201 procedure Empty_Tables is
203 Unit_Hash_Table.Reset;
204 File_Hash_Table.Reset;
205 Path_Mapping.Set_Last (0);
206 File_Mapping.Set_Last (0);
214 -- Why is only / illegal, why not \ on windows ???
216 function Find_File_Name return File_Name_Type is
218 if Name_Buffer (1 .. Name_Len) = "/" then
219 return Error_File_Name;
229 function Find_Unit_Name return Unit_Name_Type is
231 return Unit_Name_Type (Find_File_Name);
239 procedure Get_Line is
245 -- If not at the end of file, skip the end of line
247 while First < SP'Last
248 and then (SP (First) = CR
249 or else SP (First) = LF
250 or else SP (First) = EOF)
255 -- If not at the end of file, find the end of this new line
257 if First < SP'Last and then SP (First) /= EOF then
261 and then SP (Last + 1) /= CR
262 and then SP (Last + 1) /= LF
263 and then SP (Last + 1) /= EOF
271 ----------------------
272 -- Report_Truncated --
273 ----------------------
275 procedure Report_Truncated is
277 Write_Str ("warning: mapping file """);
278 Write_Str (File_Name);
279 Write_Line (""" is truncated");
280 end Report_Truncated;
282 -- Start of processing for Initialize
286 Name_Len := File_Name'Length;
287 Name_Buffer (1 .. Name_Len) := File_Name;
288 Read_Source_File (Name_Enter, 0, Hi, Src, Config);
291 Write_Str ("warning: could not read mapping file """);
292 Write_Str (File_Name);
296 BS := To_Big_String_Ptr (Src);
297 SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
304 -- Exit if end of file has been reached
306 exit when First > Last;
308 if (Last < First + 2) or else (SP (Last - 1) /= '%')
309 or else (SP (Last) /= 's' and then SP (Last) /= 'b')
311 Write_Str ("warning: mapping file """);
312 Write_Str (File_Name);
313 Write_Line (""" is incorrectly formatted");
318 Name_Len := Last - First + 1;
319 Name_Buffer (1 .. Name_Len) := SP (First .. Last);
320 Uname := Find_Unit_Name;
326 -- If end of line has been reached, file is truncated
334 Name_Len := Last - First + 1;
335 Name_Buffer (1 .. Name_Len) := SP (First .. Last);
336 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
337 Fname := Find_File_Name;
343 -- If end of line has been reached, file is truncated
351 Name_Len := Last - First + 1;
352 Name_Buffer (1 .. Name_Len) := SP (First .. Last);
353 Pname := Find_File_Name;
355 -- Check for duplicate entries
357 if Unit_Hash_Table.Get (Uname) /= No_Entry then
362 if File_Hash_Table.Get (Fname) /= No_Entry then
367 -- Add the mappings for this unit name
369 Add_To_File_Map (Uname, Fname, Pname);
373 -- Record the length of the two mapping tables
375 Last_In_Table := File_Mapping.Last;
378 ----------------------
379 -- Mapped_File_Name --
380 ----------------------
382 function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
383 The_Index : constant Int := Unit_Hash_Table.Get (Unit);
386 if The_Index = No_Entry then
389 return File_Mapping.Table (The_Index).Fname;
391 end Mapped_File_Name;
393 ----------------------
394 -- Mapped_Path_Name --
395 ----------------------
397 function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
398 Index : Int := No_Entry;
401 if Forbidden_Names.Get (File) then
402 return Error_File_Name;
405 Index := File_Hash_Table.Get (File);
407 if Index = No_Entry then
410 return Path_Mapping.Table (Index).Fname;
412 end Mapped_Path_Name;
414 --------------------------------
415 -- Remove_Forbidden_File_Name --
416 --------------------------------
418 procedure Remove_Forbidden_File_Name (Name : File_Name_Type) is
420 Forbidden_Names.Set (Name, False);
421 end Remove_Forbidden_File_Name;
427 procedure Reset_Tables is
431 Unit_Hash_Table.Reset;
432 File_Hash_Table.Reset;
433 Forbidden_Names.Reset;
437 -------------------------
438 -- Update_Mapping_File --
439 -------------------------
441 procedure Update_Mapping_File (File_Name : String) is
442 File : File_Descriptor;
446 -- For the call to Close
448 procedure Put_Line (Name : Name_Id);
449 -- Put Name as a line in the Mapping File
455 procedure Put_Line (Name : Name_Id) is
457 Get_Name_String (Name);
459 -- If the Buffer is full, write it to the file
461 if Buffer_Last + Name_Len + 1 > Buffer'Last then
462 N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
464 if N_Bytes < Buffer_Last then
471 -- Add the line to the Buffer
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;
479 -- Start of Update_Mapping_File
483 -- Only Update if there are new entries in the mappings
485 if Last_In_Table < File_Mapping.Last then
487 -- If the tables have been emptied, recreate the file.
488 -- Otherwise, append to it.
490 if Last_In_Table = 0 then
495 Delete_File (File_Name, Discard);
498 File := Create_File (File_Name, Binary);
501 File := Open_Read_Write (Name => File_Name, Fmode => Binary);
504 if File /= Invalid_FD then
505 if Last_In_Table > 0 then
506 Lseek (File, 0, Seek_End);
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 Put_Line (Name_Id (Path_Mapping.Table (Unit).Fname));
515 -- Before closing the file, write the buffer to the file.
516 -- It is guaranteed that the Buffer is not empty, because
517 -- Put_Line has been called at least 3 times, and after
518 -- a call to Put_Line, the Buffer is not empty.
520 N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
522 if N_Bytes < Buffer_Last then
526 Close (File, Status);
532 elsif not Quiet_Output then
533 Write_Str ("warning: could not open mapping file """);
534 Write_Str (File_Name);
535 Write_Line (""" for update");
539 end Update_Mapping_File;