OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [fmap.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                 F M A P                                  --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2001-2010, 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
pragma Warnings (Off);
33
--  This package is used also by gnatcoll
34
with System.OS_Lib; use System.OS_Lib;
35
pragma Warnings (On);
36
 
37
with Unchecked_Conversion;
38
 
39
with GNAT.HTable;
40
 
41
package 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
 
535
end Fmap;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.