1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 2001, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
29 with Namet
; use Namet
;
31 with Osint
; use Osint
;
32 with Output
; use Output
;
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 type Mapping
is record
48 Uname
: Unit_Name_Type
;
49 Fname
: File_Name_Type
;
52 package File_Mapping
is new Table
.Table
(
53 Table_Component_Type
=> Mapping
,
54 Table_Index_Type
=> Int
,
56 Table_Initial
=> 1_000
,
57 Table_Increment
=> 1_000
,
58 Table_Name
=> "Fmap.File_Mapping");
59 -- Mapping table to map unit names to file names.
61 package Path_Mapping
is new Table
.Table
(
62 Table_Component_Type
=> Mapping
,
63 Table_Index_Type
=> Int
,
65 Table_Initial
=> 1_000
,
66 Table_Increment
=> 1_000
,
67 Table_Name
=> "Fmap.Path_Mapping");
68 -- Mapping table to map file names to path names
70 type Header_Num
is range 0 .. 1_000
;
72 function Hash
(F
: Unit_Name_Type
) return Header_Num
;
73 -- Function used to compute hash of unit name
75 No_Entry
: constant Int
:= -1;
76 -- Signals no entry in following table
78 package Unit_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
79 Header_Num
=> Header_Num
,
81 No_Element
=> No_Entry
,
82 Key
=> Unit_Name_Type
,
85 -- Hash table to map unit names to file names. Used in conjunction with
86 -- table File_Mapping above.
88 package File_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
89 Header_Num
=> Header_Num
,
91 No_Element
=> No_Entry
,
92 Key
=> File_Name_Type
,
95 -- Hash table to map file names to path names. Used in conjunction with
96 -- table Path_Mapping above.
98 Last_In_Table
: Int
:= 0;
100 ---------------------
101 -- Add_To_File_Map --
102 ---------------------
104 procedure Add_To_File_Map
105 (Unit_Name
: Unit_Name_Type
;
106 File_Name
: File_Name_Type
;
107 Path_Name
: File_Name_Type
)
110 File_Mapping
.Increment_Last
;
111 Unit_Hash_Table
.Set
(Unit_Name
, File_Mapping
.Last
);
112 File_Mapping
.Table
(File_Mapping
.Last
) :=
113 (Uname
=> Unit_Name
, Fname
=> File_Name
);
114 Path_Mapping
.Increment_Last
;
115 File_Hash_Table
.Set
(File_Name
, Path_Mapping
.Last
);
116 Path_Mapping
.Table
(Path_Mapping
.Last
) :=
117 (Uname
=> Unit_Name
, Fname
=> Path_Name
);
124 function Hash
(F
: Unit_Name_Type
) return Header_Num
is
126 return Header_Num
(Int
(F
) rem Header_Num
'Range_Length);
133 procedure Initialize
(File_Name
: String) is
134 Src
: Source_Buffer_Ptr
;
139 First
: Positive := 1;
142 Uname
: Unit_Name_Type
;
146 The_Mapping
: Mapping
;
148 procedure Empty_Tables
;
149 -- Remove all entries in case of incorrect mapping file
152 -- Get a line from the mapping file
154 procedure Report_Truncated
;
155 -- Report a warning when the mapping file is truncated
156 -- (number of lines is not a multiple of 3).
162 procedure Empty_Tables
is
164 Unit_Hash_Table
.Reset
;
165 File_Hash_Table
.Reset
;
166 Path_Mapping
.Set_Last
(0);
167 File_Mapping
.Set_Last
(0);
175 procedure Get_Line
is
181 -- If not at the end of file, skip the end of line
183 while First
< SP
'Last
184 and then (SP
(First
) = CR
185 or else SP
(First
) = LF
186 or else SP
(First
) = EOF
)
191 -- If not at the end of file, find the end of this new line
193 if First
< SP
'Last and then SP
(First
) /= EOF
then
197 and then SP
(Last
+ 1) /= CR
198 and then SP
(Last
+ 1) /= LF
199 and then SP
(Last
+ 1) /= EOF
207 ----------------------
208 -- Report_Truncated --
209 ----------------------
211 procedure Report_Truncated
is
213 if not Quiet_Output
then
214 Write_Str
("warning: mapping file """);
215 Write_Str
(File_Name
);
216 Write_Line
(""" is truncated");
218 end Report_Truncated
;
220 -- Start of procedure Initialize
224 Name_Len
:= File_Name
'Length;
225 Name_Buffer
(1 .. Name_Len
) := File_Name
;
226 Read_Source_File
(Name_Enter
, 0, Hi
, Src
, Config
);
229 if not Quiet_Output
then
230 Write_Str
("warning: could not read mapping file """);
231 Write_Str
(File_Name
);
236 BS
:= To_Big_String_Ptr
(Src
);
237 SP
:= BS
(1 .. Natural (Hi
))'Unrestricted_Access;
244 -- Exit if end of file has been reached
246 exit when First
> Last
;
248 pragma Assert
(Last
>= First
+ 2);
249 pragma Assert
(SP
(Last
- 1) = '%');
250 pragma Assert
(SP
(Last
) = 's' or else SP
(Last
) = 'b');
252 Name_Len
:= Last
- First
+ 1;
253 Name_Buffer
(1 .. Name_Len
) := SP
(First
.. Last
);
260 -- If end of line has been reached, file is truncated
268 Name_Len
:= Last
- First
+ 1;
269 Name_Buffer
(1 .. Name_Len
) := SP
(First
.. Last
);
276 -- If end of line has been reached, file is truncated
284 Name_Len
:= Last
- First
+ 1;
285 Name_Buffer
(1 .. Name_Len
) := SP
(First
.. Last
);
288 -- Check for duplicate entries
290 if Unit_Hash_Table
.Get
(Uname
) /= No_Entry
then
291 if not Quiet_Output
then
292 Write_Str
("warning: duplicate entry """);
293 Write_Str
(Get_Name_String
(Uname
));
294 Write_Str
(""" in mapping file """);
295 Write_Str
(File_Name
);
298 File_Mapping
.Table
(Unit_Hash_Table
.Get
(Uname
));
299 Write_Line
(Get_Name_String
(The_Mapping
.Uname
));
300 Write_Line
(Get_Name_String
(The_Mapping
.Fname
));
307 if File_Hash_Table
.Get
(Fname
) /= No_Entry
then
308 if not Quiet_Output
then
309 Write_Str
("warning: duplicate entry """);
310 Write_Str
(Get_Name_String
(Fname
));
311 Write_Str
(""" in mapping file """);
312 Write_Str
(File_Name
);
315 Path_Mapping
.Table
(File_Hash_Table
.Get
(Fname
));
316 Write_Line
(Get_Name_String
(The_Mapping
.Uname
));
317 Write_Line
(Get_Name_String
(The_Mapping
.Fname
));
324 -- Add the mappings for this unit name
326 Add_To_File_Map
(Uname
, Fname
, Pname
);
330 -- Record the length of the two mapping tables
332 Last_In_Table
:= File_Mapping
.Last
;
336 ----------------------
337 -- Mapped_File_Name --
338 ----------------------
340 function Mapped_File_Name
(Unit
: Unit_Name_Type
) return File_Name_Type
is
341 The_Index
: constant Int
:= Unit_Hash_Table
.Get
(Unit
);
344 if The_Index
= No_Entry
then
347 return File_Mapping
.Table
(The_Index
).Fname
;
349 end Mapped_File_Name
;
351 ----------------------
352 -- Mapped_Path_Name --
353 ----------------------
355 function Mapped_Path_Name
(File
: File_Name_Type
) return File_Name_Type
is
356 Index
: Int
:= No_Entry
;
359 Index
:= File_Hash_Table
.Get
(File
);
361 if Index
= No_Entry
then
364 return Path_Mapping
.Table
(Index
).Fname
;
366 end Mapped_Path_Name
;
368 -------------------------
369 -- Update_Mapping_File --
370 -------------------------
372 procedure Update_Mapping_File
(File_Name
: String) is
373 File
: File_Descriptor
;
375 procedure Put_Line
(Name
: Name_Id
);
376 -- Put Name as a line in the Mapping File
382 procedure Put_Line
(Name
: Name_Id
) is
385 Get_Name_String
(Name
);
386 Name_Len
:= Name_Len
+ 1;
387 Name_Buffer
(Name_Len
) := ASCII
.LF
;
388 N_Bytes
:= Write
(File
, Name_Buffer
(1)'Address, Name_Len
);
390 if N_Bytes
< Name_Len
then
396 -- Start of Update_Mapping_File
400 -- Only Update if there are new entries in the mappings
402 if Last_In_Table
< File_Mapping
.Last
then
404 -- If the tables have been emptied, recreate the file.
405 -- Otherwise, append to it.
407 if Last_In_Table
= 0 then
412 Delete_File
(File_Name
, Discard
);
415 File
:= Create_File
(File_Name
, Binary
);
418 File
:= Open_Read_Write
(Name
=> File_Name
, Fmode
=> Binary
);
421 if File
/= Invalid_FD
then
422 if Last_In_Table
> 0 then
423 Lseek
(File
, 0, Seek_End
);
426 for Unit
in Last_In_Table
+ 1 .. File_Mapping
.Last
loop
427 Put_Line
(File_Mapping
.Table
(Unit
).Uname
);
428 Put_Line
(File_Mapping
.Table
(Unit
).Fname
);
429 Put_Line
(Path_Mapping
.Table
(Unit
).Fname
);
434 elsif not Quiet_Output
then
435 Write_Str
("warning: could not open mapping file """);
436 Write_Str
(File_Name
);
437 Write_Line
(""" for update");
441 end Update_Mapping_File
;