1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                F N A M E                                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2020, 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
26package body Fname is
27
28   function Has_Internal_Extension (Fname : String) return Boolean;
29   pragma Inline (Has_Internal_Extension);
30   --  True if the extension is appropriate for an internal/predefined unit.
31   --  That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
32
33   function Has_Prefix (X, Prefix : String) return Boolean;
34   pragma Inline (Has_Prefix);
35   --  True if Prefix is at the beginning of X. For example,
36   --  Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
37
38   ----------------------------
39   -- Has_Internal_Extension --
40   ----------------------------
41
42   function Has_Internal_Extension (Fname : String) return Boolean is
43   begin
44      if Fname'Length >= 4 then
45         declare
46            S : String renames Fname (Fname'Last - 3 .. Fname'Last);
47         begin
48            return S = ".ads" or else S = ".adb" or else S = ".ali";
49         end;
50      end if;
51      return False;
52   end Has_Internal_Extension;
53
54   ----------------
55   -- Has_Prefix --
56   ----------------
57
58   function Has_Prefix (X, Prefix : String) return Boolean is
59   begin
60      if X'Length >= Prefix'Length then
61         declare
62            S : String renames X (X'First .. X'First + Prefix'Length - 1);
63         begin
64            return S = Prefix;
65         end;
66      end if;
67      return False;
68   end Has_Prefix;
69
70   -----------------------
71   -- Is_GNAT_File_Name --
72   -----------------------
73
74   function Is_GNAT_File_Name (Fname : String) return Boolean is
75   begin
76      --  Check for internal extensions before checking prefixes, so we don't
77      --  think (e.g.) "gnat.adc" is internal.
78
79      if not Has_Internal_Extension (Fname) then
80         return False;
81      end if;
82
83      --  Definitely internal if prefix is g-
84
85      if Has_Prefix (Fname, "g-") then
86         return True;
87      end if;
88
89      --  See the note in Is_Predefined_File_Name for the rationale
90
91      return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
92   end Is_GNAT_File_Name;
93
94   function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
95      Result : constant Boolean :=
96                 Is_GNAT_File_Name (Get_Name_String (Fname));
97   begin
98      return Result;
99   end Is_GNAT_File_Name;
100
101   ---------------------------
102   -- Is_Internal_File_Name --
103   ---------------------------
104
105   function Is_Internal_File_Name
106     (Fname              : String;
107      Renamings_Included : Boolean := True) return Boolean
108   is
109   begin
110      if Is_Predefined_File_Name (Fname, Renamings_Included) then
111         return True;
112      end if;
113
114      return Is_GNAT_File_Name (Fname);
115   end Is_Internal_File_Name;
116
117   function Is_Internal_File_Name
118     (Fname              : File_Name_Type;
119      Renamings_Included : Boolean := True) return Boolean
120   is
121      Result : constant Boolean :=
122                 Is_Internal_File_Name
123                   (Get_Name_String (Fname), Renamings_Included);
124   begin
125      return Result;
126   end Is_Internal_File_Name;
127
128   -----------------------------
129   -- Is_Predefined_File_Name --
130   -----------------------------
131
132   function Is_Predefined_File_Name
133     (Fname              : String;
134      Renamings_Included : Boolean := True) return Boolean
135   is
136   begin
137      --  Definitely false if longer than 12 characters (8.3), except for the
138      --  Interfaces packages and also the implementation units of the 128-bit
139      --  types under System.
140
141      if Fname'Length > 12
142        and then Fname (Fname'First .. Fname'First + 1) /= "i-"
143        and then Fname (Fname'First .. Fname'First + 1) /= "s-"
144      then
145         return False;
146      end if;
147
148      if not Has_Internal_Extension (Fname) then
149         return False;
150      end if;
151
152      --  Definitely predefined if prefix is a- i- or s-
153
154      if Fname'Length >= 2 then
155         declare
156            S : String renames Fname (Fname'First .. Fname'First + 1);
157         begin
158            if S = "a-" or else S = "i-" or else S = "s-" then
159               return True;
160            end if;
161         end;
162      end if;
163
164      --  We include the "." in the prefixes below, so we don't match (e.g.)
165      --  adamant.ads. So the first line matches "ada.ads", "ada.adb", and
166      --  "ada.ali". But that's not necessary if they have 8 characters.
167
168      if Has_Prefix (Fname, "ada.")             --  Ada
169        or else Has_Prefix (Fname, "interfac")  --  Interfaces
170        or else Has_Prefix (Fname, "system.a")  --  System
171      then
172         return True;
173      end if;
174
175      --  If instructed and the name has 8+ characters, check for renamings
176
177      if Renamings_Included
178        and then Is_Predefined_Renaming_File_Name (Fname)
179      then
180         return True;
181      end if;
182
183      return False;
184   end Is_Predefined_File_Name;
185
186   function Is_Predefined_File_Name
187     (Fname              : File_Name_Type;
188      Renamings_Included : Boolean := True) return Boolean
189   is
190      Result : constant Boolean :=
191                 Is_Predefined_File_Name
192                   (Get_Name_String (Fname), Renamings_Included);
193   begin
194      return Result;
195   end Is_Predefined_File_Name;
196
197   --------------------------------------
198   -- Is_Predefined_Renaming_File_Name --
199   --------------------------------------
200
201   function Is_Predefined_Renaming_File_Name
202     (Fname : String) return Boolean
203   is
204      subtype Str8 is String (1 .. 8);
205
206      Renaming_Names : constant array (1 .. 8) of Str8 :=
207        ("calendar",   --  Calendar
208         "machcode",   --  Machine_Code
209         "unchconv",   --  Unchecked_Conversion
210         "unchdeal",   --  Unchecked_Deallocation
211         "directio",   --  Direct_IO
212         "ioexcept",   --  IO_Exceptions
213         "sequenio",   --  Sequential_IO
214         "text_io.");  --  Text_IO
215   begin
216      --  Definitely false if longer than 12 characters (8.3)
217
218      if Fname'Length in 8 .. 12 then
219         declare
220            S : String renames Fname (Fname'First .. Fname'First + 7);
221         begin
222            for J in Renaming_Names'Range loop
223               if S = Renaming_Names (J) then
224                  return True;
225               end if;
226            end loop;
227         end;
228      end if;
229
230      return False;
231   end Is_Predefined_Renaming_File_Name;
232
233   function Is_Predefined_Renaming_File_Name
234     (Fname : File_Name_Type) return Boolean is
235      Result : constant Boolean :=
236                 Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
237   begin
238      return Result;
239   end Is_Predefined_Renaming_File_Name;
240
241end Fname;
242