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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [fname-uf.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 N A M E . U F                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, 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 Alloc;
27
with Debug;    use Debug;
28
with Fmap;     use Fmap;
29
with Krunch;
30
with Opt;      use Opt;
31
with Osint;    use Osint;
32
with Table;
33
with Targparm; use Targparm;
34
with Uname;    use Uname;
35
with Widechar; use Widechar;
36
 
37
with GNAT.HTable;
38
 
39
package body Fname.UF is
40
 
41
   --------------------------------------------------------
42
   -- Declarations for Handling Source_File_Name pragmas --
43
   --------------------------------------------------------
44
 
45
   type SFN_Entry is record
46
      U     : Unit_Name_Type; -- Unit name
47
      F     : File_Name_Type; -- Spec/Body file name
48
      Index : Nat;            -- Index from SFN pragma (0 if none)
49
   end record;
50
   --  Record single Unit_Name type call to Set_File_Name
51
 
52
   package SFN_Table is new Table.Table (
53
     Table_Component_Type => SFN_Entry,
54
     Table_Index_Type     => Int,
55
     Table_Low_Bound      => 0,
56
     Table_Initial        => Alloc.SFN_Table_Initial,
57
     Table_Increment      => Alloc.SFN_Table_Increment,
58
     Table_Name           => "SFN_Table");
59
   --  Table recording all Unit_Name calls to Set_File_Name
60
 
61
   type SFN_Header_Num is range 0 .. 100;
62
 
63
   function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
64
   --  Compute hash index for use by Simple_HTable
65
 
66
   No_Entry : constant Int := -1;
67
   --  Signals no entry in following table
68
 
69
   package SFN_HTable is new GNAT.HTable.Simple_HTable (
70
     Header_Num => SFN_Header_Num,
71
     Element    => Int,
72
     No_Element => No_Entry,
73
     Key        => Unit_Name_Type,
74
     Hash       => SFN_Hash,
75
     Equal      => "=");
76
   --  Hash table allowing rapid access to SFN_Table, the element value is an
77
   --  index into this table.
78
 
79
   type SFN_Pattern_Entry is record
80
      Pat : String_Ptr;   -- File name pattern (with asterisk in it)
81
      Typ : Character;    -- 'S'/'B'/'U' for spec/body/subunit
82
      Dot : String_Ptr;   -- Dot_Separator string
83
      Cas : Casing_Type;  -- Upper/Lower/Mixed
84
   end record;
85
   --  Records single call to Set_File_Name_Patterm
86
 
87
   package SFN_Patterns is new Table.Table (
88
     Table_Component_Type => SFN_Pattern_Entry,
89
     Table_Index_Type     => Int,
90
     Table_Low_Bound      => 1,
91
     Table_Initial        => 10,
92
     Table_Increment      => 100,
93
     Table_Name           => "SFN_Patterns");
94
   --  Table recording calls to Set_File_Name_Pattern. Note that the first two
95
   --  entries are set to represent the standard GNAT rules for file naming.
96
 
97
   -----------------------
98
   -- File_Name_Of_Body --
99
   -----------------------
100
 
101
   function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
102
   begin
103
      Get_Name_String (Name);
104
      Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
105
      Name_Len := Name_Len + 2;
106
      return Get_File_Name (Name_Enter, Subunit => False);
107
   end File_Name_Of_Body;
108
 
109
   -----------------------
110
   -- File_Name_Of_Spec --
111
   -----------------------
112
 
113
   function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
114
   begin
115
      Get_Name_String (Name);
116
      Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
117
      Name_Len := Name_Len + 2;
118
      return Get_File_Name (Name_Enter, Subunit => False);
119
   end File_Name_Of_Spec;
120
 
121
   ----------------------------
122
   -- Get_Expected_Unit_Type --
123
   ----------------------------
124
 
125
   function Get_Expected_Unit_Type
126
     (Fname : File_Name_Type) return Expected_Unit_Type
127
   is
128
   begin
129
      --  In syntax checking only mode or in multiple unit per file mode, there
130
      --  can be more than one unit in a file, so the file name is not a useful
131
      --  guide to the nature of the unit.
132
 
133
      if Operating_Mode = Check_Syntax
134
        or else Multiple_Unit_Index /= 0
135
      then
136
         return Unknown;
137
      end if;
138
 
139
      --  Search the file mapping table, if we find an entry for this file we
140
      --  know whether it is a spec or a body.
141
 
142
      for J in SFN_Table.First .. SFN_Table.Last loop
143
         if Fname = SFN_Table.Table (J).F then
144
            if Is_Body_Name (SFN_Table.Table (J).U) then
145
               return Expect_Body;
146
            else
147
               return Expect_Spec;
148
            end if;
149
         end if;
150
      end loop;
151
 
152
      --  If no entry in file naming table, assume .ads/.adb for spec/body and
153
      --  return unknown if we have neither of these two cases.
154
 
155
      Get_Name_String (Fname);
156
 
157
      if Name_Len > 4 then
158
         if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
159
            return Expect_Spec;
160
         elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
161
            return Expect_Body;
162
         end if;
163
      end if;
164
 
165
      return Unknown;
166
   end Get_Expected_Unit_Type;
167
 
168
   -------------------
169
   -- Get_File_Name --
170
   -------------------
171
 
172
   function Get_File_Name
173
     (Uname    : Unit_Name_Type;
174
      Subunit  : Boolean;
175
      May_Fail : Boolean := False) return File_Name_Type
176
   is
177
      Unit_Char : Character;
178
      --  Set to 's' or 'b' for spec or body or to 'u' for a subunit
179
 
180
      Unit_Char_Search : Character;
181
      --  Same as Unit_Char, except that in the case of 'u' for a subunit, we
182
      --  set Unit_Char_Search to 'b' if we do not find a subunit match.
183
 
184
      N : Int;
185
 
186
      Pname : File_Name_Type := No_File;
187
      Fname : File_Name_Type := No_File;
188
      --  Path name and File name for mapping
189
 
190
   begin
191
      --  Null or error name means that some previous error occurred. This is
192
      --  an unrecoverable error, so signal it.
193
 
194
      if Uname in Error_Unit_Name_Or_No_Unit_Name then
195
         raise Unrecoverable_Error;
196
      end if;
197
 
198
      --  Look in the map from unit names to file names
199
 
200
      Fname := Mapped_File_Name (Uname);
201
 
202
      --  If the unit name is already mapped, return the corresponding file
203
      --  name from the map.
204
 
205
      if Fname /= No_File then
206
         return Fname;
207
      end if;
208
 
209
      --  If there is a specific SFN pragma, return the corresponding file name
210
 
211
      N := SFN_HTable.Get (Uname);
212
 
213
      if N /= No_Entry then
214
         return SFN_Table.Table (N).F;
215
      end if;
216
 
217
      --  Here for the case where the name was not found in the table
218
 
219
      Get_Decoded_Name_String (Uname);
220
 
221
      --  A special fudge, normally we don't have operator symbols present,
222
      --  since it is always an error to do so. However, if we do, at this
223
      --  stage it has a leading double quote.
224
 
225
      --  What we do in this case is to go back to the undecoded name, which
226
      --  is of the form, for example:
227
 
228
      --    Oand%s
229
 
230
      --  and build a file name that looks like:
231
 
232
      --    _and_.ads
233
 
234
      --  which is bit peculiar, but we keep it that way. This means that we
235
      --  avoid bombs due to writing a bad file name, and w get expected error
236
      --  processing downstream, e.g. a compilation following gnatchop.
237
 
238
      if Name_Buffer (1) = '"' then
239
         Get_Name_String (Uname);
240
         Name_Len := Name_Len + 1;
241
         Name_Buffer (Name_Len)     := Name_Buffer (Name_Len - 1);
242
         Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
243
         Name_Buffer (Name_Len - 2) := '_';
244
         Name_Buffer (1)            := '_';
245
      end if;
246
 
247
      --  Deal with spec or body suffix
248
 
249
      Unit_Char := Name_Buffer (Name_Len);
250
      pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
251
      pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
252
      Name_Len := Name_Len - 2;
253
 
254
      if Subunit then
255
         Unit_Char := 'u';
256
      end if;
257
 
258
      --  Now we need to find the proper translation of the name
259
 
260
      declare
261
         Uname : constant String (1 .. Name_Len) :=
262
                   Name_Buffer (1 .. Name_Len);
263
 
264
         Pent : Nat;
265
         Plen : Natural;
266
         Fnam : File_Name_Type := No_File;
267
         J    : Natural;
268
         Dot  : String_Ptr;
269
         Dotl : Natural;
270
 
271
         Is_Predef : Boolean;
272
         --  Set True for predefined file
273
 
274
         function C (N : Natural) return Character;
275
         --  Return N'th character of pattern
276
 
277
         function C (N : Natural) return Character is
278
         begin
279
            return SFN_Patterns.Table (Pent).Pat (N);
280
         end C;
281
 
282
      --  Start of search through pattern table
283
 
284
      begin
285
         --  Search pattern table to find a matching entry. In the general case
286
         --  we do two complete searches. The first time through we stop only
287
         --  if a matching file is found, the second time through we accept the
288
         --  first match regardless. Note that there will always be a match the
289
         --  second time around, because of the default entries at the end of
290
         --  the table.
291
 
292
         for No_File_Check in False .. True loop
293
            Unit_Char_Search := Unit_Char;
294
 
295
         <<Repeat_Search>>
296
         --  The search is repeated with Unit_Char_Search set to b, if an
297
         --  initial search for the subunit case fails to find any match.
298
 
299
            Pent := SFN_Patterns.First;
300
            while Pent <= SFN_Patterns.Last loop
301
               if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
302
                  Name_Len := 0;
303
 
304
                  --  Determine if we have a predefined file name
305
 
306
                  Name_Len := Uname'Length;
307
                  Name_Buffer (1 .. Name_Len) := Uname;
308
                  Is_Predef :=
309
                    Is_Predefined_File_Name (Renamings_Included => True);
310
 
311
                  --  Found a match, execute the pattern
312
 
313
                  Name_Len := Uname'Length;
314
                  Name_Buffer (1 .. Name_Len) := Uname;
315
 
316
                  --  Apply casing, except that we do not do this for the case
317
                  --  of a predefined library file. For the latter, we always
318
                  --  use the all lower case name, regardless of the setting.
319
 
320
                  if not Is_Predef then
321
                     Set_Casing (SFN_Patterns.Table (Pent).Cas);
322
                  end if;
323
 
324
                  --  If dot translation required do it
325
 
326
                  Dot  := SFN_Patterns.Table (Pent).Dot;
327
                  Dotl := Dot.all'Length;
328
 
329
                  if Dot.all /= "." then
330
                     J := 1;
331
 
332
                     while J <= Name_Len loop
333
                        if Name_Buffer (J) = '.' then
334
 
335
                           if Dotl = 1 then
336
                              Name_Buffer (J) := Dot (Dot'First);
337
 
338
                           else
339
                              Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
340
                                Name_Buffer (J + 1 .. Name_Len);
341
                              Name_Buffer (J .. J + Dotl - 1) := Dot.all;
342
                              Name_Len := Name_Len + Dotl - 1;
343
                           end if;
344
 
345
                           J := J + Dotl;
346
 
347
                        --  Skip past wide char sequences to avoid messing with
348
                        --  dot characters that are part of a sequence.
349
 
350
                        elsif Name_Buffer (J) = ASCII.ESC
351
                          or else (Upper_Half_Encoding
352
                                    and then
353
                                      Name_Buffer (J) in Upper_Half_Character)
354
                        then
355
                           Skip_Wide (Name_Buffer, J);
356
                        else
357
                           J := J + 1;
358
                        end if;
359
                     end loop;
360
                  end if;
361
 
362
                  --  Here move result to right if preinsertion before *
363
 
364
                  Plen := SFN_Patterns.Table (Pent).Pat'Length;
365
                  for K in 1 .. Plen loop
366
                     if C (K) = '*' then
367
                        if K /= 1 then
368
                           Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
369
                             Name_Buffer (1 .. Name_Len);
370
 
371
                           for L in 1 .. K - 1 loop
372
                              Name_Buffer (L) := C (L);
373
                           end loop;
374
 
375
                           Name_Len := Name_Len + K - 1;
376
                        end if;
377
 
378
                        for L in K + 1 .. Plen loop
379
                           Name_Len := Name_Len + 1;
380
                           Name_Buffer (Name_Len) := C (L);
381
                        end loop;
382
 
383
                        exit;
384
                     end if;
385
                  end loop;
386
 
387
                  --  Execute possible crunch on constructed name. The krunch
388
                  --  operation excludes any extension that may be present.
389
 
390
                  J := Name_Len;
391
                  while J > 1 loop
392
                     exit when Name_Buffer (J) = '.';
393
                     J := J - 1;
394
                  end loop;
395
 
396
                  --  Case of extension present
397
 
398
                  if J > 1 then
399
                     declare
400
                        Ext : constant String := Name_Buffer (J .. Name_Len);
401
 
402
                     begin
403
                        --  Remove extension
404
 
405
                        Name_Len := J - 1;
406
 
407
                        --  Krunch what's left
408
 
409
                        Krunch
410
                          (Name_Buffer,
411
                           Name_Len,
412
                           Integer (Maximum_File_Name_Length),
413
                           Debug_Flag_4,
414
                           OpenVMS_On_Target);
415
 
416
                        --  Replace extension
417
 
418
                        Name_Buffer
419
                          (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
420
                        Name_Len := Name_Len + Ext'Length;
421
                     end;
422
 
423
                  --  Case of no extension present, straight krunch on the
424
                  --  entire file name.
425
 
426
                  else
427
                     Krunch
428
                       (Name_Buffer,
429
                        Name_Len,
430
                        Integer (Maximum_File_Name_Length),
431
                        Debug_Flag_4);
432
                  end if;
433
 
434
                  Fnam := Name_Find;
435
 
436
                  --  If we are in the second search of the table, we accept
437
                  --  the file name without checking, because we know that the
438
                  --  file does not exist, except when May_Fail is True, in
439
                  --  which case we return No_File.
440
 
441
                  if No_File_Check then
442
                     if May_Fail then
443
                        return No_File;
444
                     else
445
                        return Fnam;
446
                     end if;
447
 
448
                  --  Otherwise we check if the file exists
449
 
450
                  else
451
                     Pname := Find_File (Fnam, Source);
452
 
453
                     --  If it does exist, we add it to the mappings and return
454
                     --  the file name.
455
 
456
                     if Pname /= No_File then
457
 
458
                        --  Add to mapping, so that we don't do another path
459
                        --  search in Find_File for this file name and, if we
460
                        --  use a mapping file, we are ready to update it at
461
                        --  the end of this compilation for the benefit of
462
                        --  other compilation processes.
463
 
464
                        Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
465
                        return Fnam;
466
 
467
                     --  If there are only two entries, they are those of the
468
                     --  default GNAT naming scheme. The file does not exist,
469
                     --  but there is no point doing the second search, because
470
                     --  we will end up with the same file name. Just return
471
                     --  the file name, or No_File if May_Fail is True.
472
 
473
                     elsif SFN_Patterns.Last = 2 then
474
                        if May_Fail then
475
                           return No_File;
476
                        else
477
                           return Fnam;
478
                        end if;
479
 
480
                     --  The file does not exist, but there may be other naming
481
                     --  scheme. Keep on searching.
482
 
483
                     else
484
                        Fnam := No_File;
485
                     end if;
486
                  end if;
487
               end if;
488
 
489
               Pent := Pent + 1;
490
            end loop;
491
 
492
            --  If search failed, and was for a subunit, repeat the search with
493
            --  Unit_Char_Search reset to 'b', since in the normal case we
494
            --  simply treat subunits as bodies.
495
 
496
            if Fnam = No_File and then Unit_Char_Search = 'u' then
497
               Unit_Char_Search := 'b';
498
               goto Repeat_Search;
499
            end if;
500
 
501
            --  Repeat entire search in No_File_Check mode if necessary
502
 
503
         end loop;
504
 
505
         --  Something is wrong if search fails completely, since the default
506
         --  entries should catch all possibilities at this stage.
507
 
508
         raise Program_Error;
509
      end;
510
   end Get_File_Name;
511
 
512
   --------------------
513
   -- Get_Unit_Index --
514
   --------------------
515
 
516
   function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
517
      N : constant Int := SFN_HTable.Get (Uname);
518
   begin
519
      if N /= No_Entry then
520
         return SFN_Table.Table (N).Index;
521
      else
522
         return 0;
523
      end if;
524
   end Get_Unit_Index;
525
 
526
   ----------------
527
   -- Initialize --
528
   ----------------
529
 
530
   procedure Initialize is
531
   begin
532
      SFN_Table.Init;
533
      SFN_Patterns.Init;
534
 
535
      --  Add default entries to SFN_Patterns.Table to represent the standard
536
      --  default GNAT rules for file name translation.
537
 
538
      SFN_Patterns.Append (New_Val =>
539
        (Pat => new String'("*.ads"),
540
         Typ => 's',
541
         Dot => new String'("-"),
542
         Cas => All_Lower_Case));
543
 
544
      SFN_Patterns.Append (New_Val =>
545
        (Pat => new String'("*.adb"),
546
         Typ => 'b',
547
         Dot => new String'("-"),
548
         Cas => All_Lower_Case));
549
   end Initialize;
550
 
551
   ----------
552
   -- Lock --
553
   ----------
554
 
555
   procedure Lock is
556
   begin
557
      SFN_Table.Locked := True;
558
      SFN_Table.Release;
559
   end Lock;
560
 
561
   -------------------
562
   -- Set_File_Name --
563
   -------------------
564
 
565
   procedure Set_File_Name
566
     (U     : Unit_Name_Type;
567
      F     : File_Name_Type;
568
      Index : Nat)
569
   is
570
   begin
571
      SFN_Table.Increment_Last;
572
      SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
573
      SFN_HTable.Set (U, SFN_Table.Last);
574
   end Set_File_Name;
575
 
576
   ---------------------------
577
   -- Set_File_Name_Pattern --
578
   ---------------------------
579
 
580
   procedure Set_File_Name_Pattern
581
     (Pat : String_Ptr;
582
      Typ : Character;
583
      Dot : String_Ptr;
584
      Cas : Casing_Type)
585
   is
586
      L : constant Nat := SFN_Patterns.Last;
587
 
588
   begin
589
      SFN_Patterns.Increment_Last;
590
 
591
      --  Move up the last two entries (the default ones) and then put the new
592
      --  entry into the table just before them (we always have the default
593
      --  entries be the last ones).
594
 
595
      SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
596
      SFN_Patterns.Table (L)     := SFN_Patterns.Table (L - 1);
597
      SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
598
   end Set_File_Name_Pattern;
599
 
600
   --------------
601
   -- SFN_Hash --
602
   --------------
603
 
604
   function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
605
   begin
606
      return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
607
   end SFN_Hash;
608
 
609
begin
610
 
611
   --  We call the initialization routine from the package body, so that
612
   --  Fname.Init only needs to be called explicitly to reinitialize.
613
 
614
   Fname.UF.Initialize;
615
end Fname.UF;

powered by: WebSVN 2.1.0

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