1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
34 function Has_Internal_Extension (Fname : String) return Boolean;
35 pragma Inline (Has_Internal_Extension);
36 -- True if the extension is appropriate for an internal/predefined unit.
37 -- That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
39 function Has_Prefix (X, Prefix : String) return Boolean;
40 pragma Inline (Has_Prefix);
41 -- True if Prefix is at the beginning of X. For example,
42 -- Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
44 ----------------------------
45 -- Has_Internal_Extension --
46 ----------------------------
48 function Has_Internal_Extension (Fname : String) return Boolean is
50 if Fname'Length >= 4 then
52 S : String renames Fname (Fname'Last - 3 .. Fname'Last);
54 return S = ".ads" or else S = ".adb" or else S = ".ali";
58 end Has_Internal_Extension;
64 function Has_Prefix (X, Prefix : String) return Boolean is
66 if X'Length >= Prefix'Length then
68 S : String renames X (X'First .. X'First + Prefix'Length - 1);
76 -----------------------
77 -- Is_GNAT_File_Name --
78 -----------------------
80 function Is_GNAT_File_Name (Fname : String) return Boolean is
82 -- Check for internal extensions before checking prefixes, so we don't
83 -- think (e.g.) "gnat.adc" is internal.
85 if not Has_Internal_Extension (Fname) then
89 -- Definitely internal if prefix is g-
91 if Has_Prefix (Fname, "g-") then
95 -- See the note in Is_Predefined_File_Name for the rationale
97 return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
98 end Is_GNAT_File_Name;
100 function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
101 Result : constant Boolean :=
102 Is_GNAT_File_Name (Get_Name_String (Fname));
105 end Is_GNAT_File_Name;
107 ---------------------------
108 -- Is_Internal_File_Name --
109 ---------------------------
111 function Is_Internal_File_Name
113 Renamings_Included : Boolean := True) return Boolean
116 if Is_Predefined_File_Name (Fname, Renamings_Included) then
120 return Is_GNAT_File_Name (Fname);
121 end Is_Internal_File_Name;
123 function Is_Internal_File_Name
124 (Fname : File_Name_Type;
125 Renamings_Included : Boolean := True) return Boolean
127 Result : constant Boolean :=
128 Is_Internal_File_Name
129 (Get_Name_String (Fname), Renamings_Included);
132 end Is_Internal_File_Name;
134 -----------------------------
135 -- Is_Predefined_File_Name --
136 -----------------------------
138 function Is_Predefined_File_Name
140 Renamings_Included : Boolean := True) return Boolean
143 -- Definitely false if longer than 12 characters (8.3)
144 -- except for the Interfaces packages
147 and then Fname (Fname'First .. Fname'First + 1) /= "i-"
152 if not Has_Internal_Extension (Fname) then
156 -- Definitely predefined if prefix is a- i- or s-
158 if Fname'Length >= 2 then
160 S : String renames Fname (Fname'First .. Fname'First + 1);
162 if S = "a-" or else S = "i-" or else S = "s-" then
168 -- We include the "." in the prefixes below, so we don't match (e.g.)
169 -- adamant.ads. So the first line matches "ada.ads", "ada.adb", and
170 -- "ada.ali". But that's not necessary if they have 8 characters.
172 if Has_Prefix (Fname, "ada.") -- Ada
173 or else Has_Prefix (Fname, "interfac") -- Interfaces
174 or else Has_Prefix (Fname, "system.a") -- System
179 -- If instructed and the name has 8+ characters, check for renamings
181 if Renamings_Included
182 and then Is_Predefined_Renaming_File_Name (Fname)
188 end Is_Predefined_File_Name;
190 function Is_Predefined_File_Name
191 (Fname : File_Name_Type;
192 Renamings_Included : Boolean := True) return Boolean
194 Result : constant Boolean :=
195 Is_Predefined_File_Name
196 (Get_Name_String (Fname), Renamings_Included);
199 end Is_Predefined_File_Name;
201 --------------------------------------
202 -- Is_Predefined_Renaming_File_Name --
203 --------------------------------------
205 function Is_Predefined_Renaming_File_Name
206 (Fname : String) return Boolean
208 subtype Str8 is String (1 .. 8);
210 Renaming_Names : constant array (1 .. 8) of Str8 :=
211 ("calendar", -- Calendar
212 "machcode", -- Machine_Code
213 "unchconv", -- Unchecked_Conversion
214 "unchdeal", -- Unchecked_Deallocation
215 "directio", -- Direct_IO
216 "ioexcept", -- IO_Exceptions
217 "sequenio", -- Sequential_IO
218 "text_io."); -- Text_IO
220 -- Definitely false if longer than 12 characters (8.3)
222 if Fname'Length in 8 .. 12 then
224 S : String renames Fname (Fname'First .. Fname'First + 7);
226 for J in Renaming_Names'Range loop
227 if S = Renaming_Names (J) then
235 end Is_Predefined_Renaming_File_Name;
237 function Is_Predefined_Renaming_File_Name
238 (Fname : File_Name_Type) return Boolean is
239 Result : constant Boolean :=
240 Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
243 end Is_Predefined_Renaming_File_Name;