1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                F N A M E                                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with Alloc;
33with Table;
34with Types; use Types;
35
36package body Fname is
37
38   -----------------------------
39   -- Dummy Table Definitions --
40   -----------------------------
41
42   --  The following table was used in old versions of the compiler. We retain
43   --  the declarations here for compatibility with old tree files. The new
44   --  version of the compiler does not use this table, and will write out a
45   --  dummy empty table for Tree_Write.
46
47   type SFN_Entry is record
48      U : Unit_Name_Type;
49      F : File_Name_Type;
50   end record;
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           => "Fname_Dummy_Table");
59
60   function Has_Internal_Extension (Fname : String) return Boolean;
61   pragma Inline (Has_Internal_Extension);
62   --  True if the extension is appropriate for an internal/predefined unit.
63   --  That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
64
65   function Has_Prefix (X, Prefix : String) return Boolean;
66   pragma Inline (Has_Prefix);
67   --  True if Prefix is at the beginning of X. For example,
68   --  Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
69
70   ----------------------------
71   -- Has_Internal_Extension --
72   ----------------------------
73
74   function Has_Internal_Extension (Fname : String) return Boolean is
75   begin
76      if Fname'Length >= 4 then
77         declare
78            S : String renames Fname (Fname'Last - 3 .. Fname'Last);
79         begin
80            return S = ".ads" or else S = ".adb" or else S = ".ali";
81         end;
82      end if;
83      return False;
84   end Has_Internal_Extension;
85
86   ----------------
87   -- Has_Prefix --
88   ----------------
89
90   function Has_Prefix (X, Prefix : String) return Boolean is
91   begin
92      if X'Length >= Prefix'Length then
93         declare
94            S : String renames X (X'First .. X'First + Prefix'Length - 1);
95         begin
96            return S = Prefix;
97         end;
98      end if;
99      return False;
100   end Has_Prefix;
101
102   -----------------------
103   -- Is_GNAT_File_Name --
104   -----------------------
105
106   function Is_GNAT_File_Name (Fname : String) return Boolean is
107   begin
108      --  Check for internal extensions before checking prefixes, so we don't
109      --  think (e.g.) "gnat.adc" is internal.
110
111      if not Has_Internal_Extension (Fname) then
112         return False;
113      end if;
114
115      --  Definitely internal if prefix is g-
116
117      if Has_Prefix (Fname, "g-") then
118         return True;
119      end if;
120
121      --  See the note in Is_Predefined_File_Name for the rationale
122
123      return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
124   end Is_GNAT_File_Name;
125
126   function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
127      Result : constant Boolean :=
128                 Is_GNAT_File_Name (Get_Name_String (Fname));
129   begin
130      return Result;
131   end Is_GNAT_File_Name;
132
133   ---------------------------
134   -- Is_Internal_File_Name --
135   ---------------------------
136
137   function Is_Internal_File_Name
138     (Fname              : String;
139      Renamings_Included : Boolean := True) return Boolean
140   is
141   begin
142      if Is_Predefined_File_Name (Fname, Renamings_Included) then
143         return True;
144      end if;
145
146      return Is_GNAT_File_Name (Fname);
147   end Is_Internal_File_Name;
148
149   function Is_Internal_File_Name
150     (Fname              : File_Name_Type;
151      Renamings_Included : Boolean := True) return Boolean
152   is
153      Result : constant Boolean :=
154                 Is_Internal_File_Name
155                   (Get_Name_String (Fname), Renamings_Included);
156   begin
157      return Result;
158   end Is_Internal_File_Name;
159
160   -----------------------------
161   -- Is_Predefined_File_Name --
162   -----------------------------
163
164   function Is_Predefined_File_Name
165     (Fname              : String;
166      Renamings_Included : Boolean := True) return Boolean
167   is
168   begin
169      --  Definitely false if longer than 12 characters (8.3)
170      --  except for the Interfaces packages
171
172      if Fname'Length > 12
173        and then Fname (Fname'First .. Fname'First + 1) /= "i-"
174      then
175         return False;
176      end if;
177
178      if not Has_Internal_Extension (Fname) then
179         return False;
180      end if;
181
182      --  Definitely predefined if prefix is a- i- or s-
183
184      if Fname'Length >= 2 then
185         declare
186            S : String renames Fname (Fname'First .. Fname'First + 1);
187         begin
188            if S = "a-" or else S = "i-" or else S = "s-" then
189               return True;
190            end if;
191         end;
192      end if;
193
194      --  We include the "." in the prefixes below, so we don't match (e.g.)
195      --  adamant.ads. So the first line matches "ada.ads", "ada.adb", and
196      --  "ada.ali". But that's not necessary if they have 8 characters.
197
198      if Has_Prefix (Fname, "ada.")             --  Ada
199        or else Has_Prefix (Fname, "interfac")  --  Interfaces
200        or else Has_Prefix (Fname, "system.a")  --  System
201      then
202         return True;
203      end if;
204
205      --  If instructed and the name has 8+ characters, check for renamings
206
207      if Renamings_Included
208        and then Is_Predefined_Renaming_File_Name (Fname)
209      then
210         return True;
211      end if;
212
213      return False;
214   end Is_Predefined_File_Name;
215
216   function Is_Predefined_File_Name
217     (Fname              : File_Name_Type;
218      Renamings_Included : Boolean := True) return Boolean
219   is
220      Result : constant Boolean :=
221                 Is_Predefined_File_Name
222                   (Get_Name_String (Fname), Renamings_Included);
223   begin
224      return Result;
225   end Is_Predefined_File_Name;
226
227   --------------------------------------
228   -- Is_Predefined_Renaming_File_Name --
229   --------------------------------------
230
231   function Is_Predefined_Renaming_File_Name
232     (Fname : String) return Boolean
233   is
234      subtype Str8 is String (1 .. 8);
235
236      Renaming_Names : constant array (1 .. 8) of Str8 :=
237        ("calendar",   --  Calendar
238         "machcode",   --  Machine_Code
239         "unchconv",   --  Unchecked_Conversion
240         "unchdeal",   --  Unchecked_Deallocation
241         "directio",   --  Direct_IO
242         "ioexcept",   --  IO_Exceptions
243         "sequenio",   --  Sequential_IO
244         "text_io.");  --  Text_IO
245   begin
246      --  Definitely false if longer than 12 characters (8.3)
247
248      if Fname'Length in 8 .. 12 then
249         declare
250            S : String renames Fname (Fname'First .. Fname'First + 7);
251         begin
252            for J in Renaming_Names'Range loop
253               if S = Renaming_Names (J) then
254                  return True;
255               end if;
256            end loop;
257         end;
258      end if;
259
260      return False;
261   end Is_Predefined_Renaming_File_Name;
262
263   function Is_Predefined_Renaming_File_Name
264     (Fname : File_Name_Type) return Boolean is
265      Result : constant Boolean :=
266                 Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
267   begin
268      return Result;
269   end Is_Predefined_Renaming_File_Name;
270
271   ---------------
272   -- Tree_Read --
273   ---------------
274
275   procedure Tree_Read is
276   begin
277      SFN_Table.Tree_Read;
278   end Tree_Read;
279
280   ----------------
281   -- Tree_Write --
282   ----------------
283
284   procedure Tree_Write is
285   begin
286      SFN_Table.Tree_Write;
287   end Tree_Write;
288
289end Fname;
290