summaryrefslogtreecommitdiff
path: root/gcc/ada/fname-uf.adb
blob: 8f4e66f8566a5790dda7f51c9d67c56d7d00afae (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             F N A M E . U F                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Alloc;
with Debug;    use Debug;
with Fmap;     use Fmap;
with Krunch;
with Opt;      use Opt;
with Osint;    use Osint;
with Table;
with Targparm; use Targparm;
with Uname;    use Uname;
with Widechar; use Widechar;

with GNAT.HTable;

package body Fname.UF is

   --------------------------------------------------------
   -- Declarations for Handling Source_File_Name pragmas --
   --------------------------------------------------------

   type SFN_Entry is record
      U     : Unit_Name_Type; -- Unit name
      F     : File_Name_Type; -- Spec/Body file name
      Index : Nat;            -- Index from SFN pragma (0 if none)
   end record;
   --  Record single Unit_Name type call to Set_File_Name

   package SFN_Table is new Table.Table (
     Table_Component_Type => SFN_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 0,
     Table_Initial        => Alloc.SFN_Table_Initial,
     Table_Increment      => Alloc.SFN_Table_Increment,
     Table_Name           => "SFN_Table");
   --  Table recording all Unit_Name calls to Set_File_Name

   type SFN_Header_Num is range 0 .. 100;

   function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
   --  Compute hash index for use by Simple_HTable

   No_Entry : constant Int := -1;
   --  Signals no entry in following table

   package SFN_HTable is new GNAT.HTable.Simple_HTable (
     Header_Num => SFN_Header_Num,
     Element    => Int,
     No_Element => No_Entry,
     Key        => Unit_Name_Type,
     Hash       => SFN_Hash,
     Equal      => "=");
   --  Hash table allowing rapid access to SFN_Table, the element value
   --  is an index into this table.

   type SFN_Pattern_Entry is record
      Pat : String_Ptr;   -- File name pattern (with asterisk in it)
      Typ : Character;    -- 'S'/'B'/'U' for spec/body/subunit
      Dot : String_Ptr;   -- Dot_Separator string
      Cas : Casing_Type;  -- Upper/Lower/Mixed
   end record;
   --  Records single call to Set_File_Name_Patterm

   package SFN_Patterns is new Table.Table (
     Table_Component_Type => SFN_Pattern_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 1,
     Table_Initial        => 10,
     Table_Increment      => 100,
     Table_Name           => "SFN_Patterns");
   --  Table recording all calls to Set_File_Name_Pattern. Note that the
   --  first two entries are set to represent the standard GNAT rules
   --  for file naming.

   -----------------------
   -- File_Name_Of_Body --
   -----------------------

   function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
   begin
      Get_Name_String (Name);
      Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
      Name_Len := Name_Len + 2;
      return Get_File_Name (Name_Enter, Subunit => False);
   end File_Name_Of_Body;

   -----------------------
   -- File_Name_Of_Spec --
   -----------------------

   function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
   begin
      Get_Name_String (Name);
      Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
      Name_Len := Name_Len + 2;
      return Get_File_Name (Name_Enter, Subunit => False);
   end File_Name_Of_Spec;

   ----------------------------
   -- Get_Expected_Unit_Type --
   ----------------------------

   function Get_Expected_Unit_Type
     (Fname : File_Name_Type) return Expected_Unit_Type
   is
   begin
      --  In syntax checking only mode or in multiple unit per file mode,
      --  there can be more than one unit in a file, so the file name is
      --  not a useful guide to the nature of the unit.

      if Operating_Mode = Check_Syntax
        or else Multiple_Unit_Index /= 0
      then
         return Unknown;
      end if;

      --  Search the file mapping table, if we find an entry for this
      --  file we know whether it is a spec or a body.

      for J in SFN_Table.First .. SFN_Table.Last loop
         if Fname = SFN_Table.Table (J).F then
            if Is_Body_Name (SFN_Table.Table (J).U) then
               return Expect_Body;
            else
               return Expect_Spec;
            end if;
         end if;
      end loop;

      --  If no entry in file naming table, assume .ads/.adb for spec/body
      --  and return unknown if we have neither of these two cases.

      Get_Name_String (Fname);

      if Name_Len > 4 then
         if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
            return Expect_Spec;
         elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
            return Expect_Body;
         end if;
      end if;

      return Unknown;
   end Get_Expected_Unit_Type;

   -------------------
   -- Get_File_Name --
   -------------------

   function Get_File_Name
     (Uname    : Unit_Name_Type;
      Subunit  : Boolean;
      May_Fail : Boolean := False) return File_Name_Type
   is
      Unit_Char : Character;
      --  Set to 's' or 'b' for spec or body or to 'u' for a subunit

      Unit_Char_Search : Character;
      --  Same as Unit_Char, except that in the case of 'u' for a subunit,
      --  we set Unit_Char_Search to 'b' if we do not find a subunit match.

      N : Int;

      Pname : File_Name_Type := No_File;
      Fname : File_Name_Type := No_File;
      --  Path name and File name for mapping

   begin
      --  Null or error name means that some previous error occurred
      --  This is an unrecoverable error, so signal it.

      if Uname in Error_Unit_Name_Or_No_Unit_Name then
         raise Unrecoverable_Error;
      end if;

      --  Look in the map from unit names to file names

      Fname := Mapped_File_Name (Uname);

      --  If the unit name is already mapped, return the corresponding
      --  file name from the map.

      if Fname /= No_File then
         return Fname;
      end if;

      --  If there is a specific SFN pragma, return the corresponding file name

      N := SFN_HTable.Get (Uname);

      if N /= No_Entry then
         return SFN_Table.Table (N).F;
      end if;

      --  Here for the case where the name was not found in the table

      Get_Decoded_Name_String (Uname);

      --  A special fudge, normally we don't have operator symbols present,
      --  since it is always an error to do so. However, if we do, at this
      --  stage it has a leading double quote.

      --  What we do in this case is to go back to the undecoded name, which
      --  is of the form, for example:

      --    Oand%s

      --  and build a file name that looks like:

      --    _and_.ads

      --  which is bit peculiar, but we keep it that way. This means that
      --  we avoid bombs due to writing a bad file name, and w get expected
      --  error processing downstream, e.g. a compilation following gnatchop.

      if Name_Buffer (1) = '"' then
         Get_Name_String (Uname);
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len)     := Name_Buffer (Name_Len - 1);
         Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
         Name_Buffer (Name_Len - 2) := '_';
         Name_Buffer (1)            := '_';
      end if;

      --  Deal with spec or body suffix

      Unit_Char := Name_Buffer (Name_Len);
      pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
      pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
      Name_Len := Name_Len - 2;

      if Subunit then
         Unit_Char := 'u';
      end if;

      --  Now we need to find the proper translation of the name

      declare
         Uname : constant String (1 .. Name_Len) :=
                   Name_Buffer (1 .. Name_Len);

         Pent : Nat;
         Plen : Natural;
         Fnam : File_Name_Type := No_File;
         J    : Natural;
         Dot  : String_Ptr;
         Dotl : Natural;

         Is_Predef : Boolean;
         --  Set True for predefined file

         function C (N : Natural) return Character;
         --  Return N'th character of pattern

         function C (N : Natural) return Character is
         begin
            return SFN_Patterns.Table (Pent).Pat (N);
         end C;

      --  Start of search through pattern table

      begin
         --  Search pattern table to find a matching entry. In the general
         --  case we do two complete searches. The first time through we
         --  stop only if a matching file is found, the second time through
         --  we accept the first match regardless. Note that there will
         --  always be a match the second time around, because of the
         --  default entries at the end of the table.

         for No_File_Check in False .. True loop
            Unit_Char_Search := Unit_Char;

         <<Repeat_Search>>
         --  The search is repeated with Unit_Char_Search set to b, if an
         --  initial search for the subunit case fails to find any match.

            Pent := SFN_Patterns.First;
            while Pent <= SFN_Patterns.Last loop
               if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
                  Name_Len := 0;

                  --  Determine if we have a predefined file name

                  Name_Len := Uname'Length;
                  Name_Buffer (1 .. Name_Len) := Uname;
                  Is_Predef :=
                    Is_Predefined_File_Name (Renamings_Included => True);

                  --  Found a match, execute the pattern

                  Name_Len := Uname'Length;
                  Name_Buffer (1 .. Name_Len) := Uname;

                  --  Apply casing, except that we do not do this for the case
                  --  of a predefined library file. For the latter, we always
                  --  use the all lower case name, regardless of the setting.

                  if not Is_Predef then
                     Set_Casing (SFN_Patterns.Table (Pent).Cas);
                  end if;

                  --  If dot translation required do it

                  Dot  := SFN_Patterns.Table (Pent).Dot;
                  Dotl := Dot.all'Length;

                  if Dot.all /= "." then
                     J := 1;

                     while J <= Name_Len loop
                        if Name_Buffer (J) = '.' then

                           if Dotl = 1 then
                              Name_Buffer (J) := Dot (Dot'First);

                           else
                              Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
                                Name_Buffer (J + 1 .. Name_Len);
                              Name_Buffer (J .. J + Dotl - 1) := Dot.all;
                              Name_Len := Name_Len + Dotl - 1;
                           end if;

                           J := J + Dotl;

                        --  Skip past wide char sequences to avoid messing
                        --  with dot characters that are part of a sequence.

                        elsif Name_Buffer (J) = ASCII.ESC
                          or else (Upper_Half_Encoding
                                    and then
                                      Name_Buffer (J) in Upper_Half_Character)
                        then
                           Skip_Wide (Name_Buffer, J);
                        else
                           J := J + 1;
                        end if;
                     end loop;
                  end if;

                  --  Here move result to right if preinsertion before *

                  Plen := SFN_Patterns.Table (Pent).Pat'Length;
                  for K in 1 .. Plen loop
                     if C (K) = '*' then
                        if K /= 1 then
                           Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
                             Name_Buffer (1 .. Name_Len);

                           for L in 1 .. K - 1 loop
                              Name_Buffer (L) := C (L);
                           end loop;

                           Name_Len := Name_Len + K - 1;
                        end if;

                        for L in K + 1 .. Plen loop
                           Name_Len := Name_Len + 1;
                           Name_Buffer (Name_Len) := C (L);
                        end loop;

                        exit;
                     end if;
                  end loop;

                  --  Execute possible crunch on constructed name. The krunch
                  --  operation excludes any extension that may be present.

                  J := Name_Len;
                  while J > 1 loop
                     exit when Name_Buffer (J) = '.';
                     J := J - 1;
                  end loop;

                  --  Case of extension present

                  if J > 1 then
                     declare
                        Ext : constant String := Name_Buffer (J .. Name_Len);

                     begin
                        --  Remove extension

                        Name_Len := J - 1;

                        --  Krunch what's left

                        Krunch
                          (Name_Buffer,
                           Name_Len,
                           Integer (Maximum_File_Name_Length),
                           Debug_Flag_4,
                           OpenVMS_On_Target);

                        --  Replace extension

                        Name_Buffer
                          (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
                        Name_Len := Name_Len + Ext'Length;
                     end;

                  --  Case of no extension present, straight krunch on
                  --  the entire file name.

                  else
                     Krunch
                       (Name_Buffer,
                        Name_Len,
                        Integer (Maximum_File_Name_Length),
                        Debug_Flag_4);
                  end if;

                  Fnam := Name_Find;

                  --  If we are in the second search of the table, we accept
                  --  the file name without checking, because we know that
                  --  the file does not exist, except when May_Fail is True,
                  --  in which case we return No_File.

                  if No_File_Check then
                     if May_Fail then
                        return No_File;
                     else
                        return Fnam;
                     end if;

                  --  Otherwise we check if the file exists

                  else
                     Pname := Find_File (Fnam, Source);

                     --  If it does exist, we add it to the mappings and
                     --  return the file name.

                     if Pname /= No_File then

                        --  Add to mapping, so that we don't do another
                        --  path search in Find_File for this file name
                        --  and, if we use a mapping file, we are ready
                        --  to update it at the end of this compilation
                        --  for the benefit of other compilation processes.

                        Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
                        return Fnam;

                     --  If there are only two entries, they are those of
                     --  the default GNAT naming scheme. The file does
                     --  not exist, but there is no point doing the
                     --  second search, because we will end up with the
                     --  same file name. Just return the file name.

                     elsif SFN_Patterns.Last = 2 then
                        return Fnam;

                     --  The file does not exist, but there may be other
                     --  naming scheme. Keep on searching.

                     else
                        Fnam := No_File;
                     end if;
                  end if;
               end if;

               Pent := Pent + 1;
            end loop;

            --  If search failed, and was for a subunit, repeat the search
            --  with Unit_Char_Search reset to 'b', since in the normal case
            --  we simply treat subunits as bodies.

            if Fnam = No_File and then Unit_Char_Search = 'u' then
               Unit_Char_Search := 'b';
               goto Repeat_Search;
            end if;

            --  Repeat entire search in No_File_Check mode if necessary

         end loop;

         --  Something is wrong if search fails completely, since the
         --  default entries should catch all possibilities at this stage.

         raise Program_Error;
      end;
   end Get_File_Name;

   --------------------
   -- Get_Unit_Index --
   --------------------

   function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
      N : constant Int := SFN_HTable.Get (Uname);
   begin
      if N /= No_Entry then
         return SFN_Table.Table (N).Index;
      else
         return 0;
      end if;
   end Get_Unit_Index;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      SFN_Table.Init;
      SFN_Patterns.Init;

      --  Add default entries to SFN_Patterns.Table to represent the
      --  standard default GNAT rules for file name translation.

      SFN_Patterns.Append (New_Val =>
        (Pat => new String'("*.ads"),
         Typ => 's',
         Dot => new String'("-"),
         Cas => All_Lower_Case));

      SFN_Patterns.Append (New_Val =>
        (Pat => new String'("*.adb"),
         Typ => 'b',
         Dot => new String'("-"),
         Cas => All_Lower_Case));
   end Initialize;

   ----------
   -- Lock --
   ----------

   procedure Lock is
   begin
      SFN_Table.Locked := True;
      SFN_Table.Release;
   end Lock;

   -------------------
   -- Set_File_Name --
   -------------------

   procedure Set_File_Name
     (U     : Unit_Name_Type;
      F     : File_Name_Type;
      Index : Nat)
   is
   begin
      SFN_Table.Increment_Last;
      SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
      SFN_HTable.Set (U, SFN_Table.Last);
   end Set_File_Name;

   ---------------------------
   -- Set_File_Name_Pattern --
   ---------------------------

   procedure Set_File_Name_Pattern
     (Pat : String_Ptr;
      Typ : Character;
      Dot : String_Ptr;
      Cas : Casing_Type)
   is
      L : constant Nat := SFN_Patterns.Last;

   begin
      SFN_Patterns.Increment_Last;

      --  Move up the last two entries (the default ones) and then
      --  put the new entry into the table just before them (we
      --  always have the default entries be the last ones).

      SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
      SFN_Patterns.Table (L)     := SFN_Patterns.Table (L - 1);
      SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
   end Set_File_Name_Pattern;

   --------------
   -- SFN_Hash --
   --------------

   function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
   begin
      return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
   end SFN_Hash;

begin

   --  We call the initialization routine from the package body, so that
   --  Fname.Init only needs to be called explicitly to reinitialize.

   Fname.UF.Initialize;
end Fname.UF;