1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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. 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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.
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.
38 ----------------------------
39 -- Has_Internal_Extension --
40 ----------------------------
42 function Has_Internal_Extension (Fname : String) return Boolean is
44 if Fname'Length >= 4 then
46 S : String renames Fname (Fname'Last - 3 .. Fname'Last);
48 return S = ".ads" or else S = ".adb" or else S = ".ali";
52 end Has_Internal_Extension;
58 function Has_Prefix (X, Prefix : String) return Boolean is
60 if X'Length >= Prefix'Length then
62 S : String renames X (X'First .. X'First + Prefix'Length - 1);
70 -----------------------
71 -- Is_GNAT_File_Name --
72 -----------------------
74 function Is_GNAT_File_Name (Fname : String) return Boolean is
76 -- Check for internal extensions before checking prefixes, so we don't
77 -- think (e.g.) "gnat.adc" is internal.
79 if not Has_Internal_Extension (Fname) then
83 -- Definitely internal if prefix is g-
85 if Has_Prefix (Fname, "g-") then
89 -- See the note in Is_Predefined_File_Name for the rationale
91 return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
92 end Is_GNAT_File_Name;
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));
99 end Is_GNAT_File_Name;
101 ---------------------------
102 -- Is_Internal_File_Name --
103 ---------------------------
105 function Is_Internal_File_Name
107 Renamings_Included : Boolean := True) return Boolean
110 if Is_Predefined_File_Name (Fname, Renamings_Included) then
114 return Is_GNAT_File_Name (Fname);
115 end Is_Internal_File_Name;
117 function Is_Internal_File_Name
118 (Fname : File_Name_Type;
119 Renamings_Included : Boolean := True) return Boolean
121 Result : constant Boolean :=
122 Is_Internal_File_Name
123 (Get_Name_String (Fname), Renamings_Included);
126 end Is_Internal_File_Name;
128 -----------------------------
129 -- Is_Predefined_File_Name --
130 -----------------------------
132 function Is_Predefined_File_Name
134 Renamings_Included : Boolean := True) return Boolean
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.
142 and then Fname (Fname'First .. Fname'First + 1) /= "i-"
143 and then Fname (Fname'First .. Fname'First + 1) /= "s-"
148 if not Has_Internal_Extension (Fname) then
152 -- Definitely predefined if prefix is a- i- or s-
154 if Fname'Length >= 2 then
156 S : String renames Fname (Fname'First .. Fname'First + 1);
158 if S = "a-" or else S = "i-" or else S = "s-" then
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.
168 if Has_Prefix (Fname, "ada.") -- Ada
169 or else Has_Prefix (Fname, "interfac") -- Interfaces
170 or else Has_Prefix (Fname, "system.a") -- System
175 -- If instructed and the name has 8+ characters, check for renamings
177 if Renamings_Included
178 and then Is_Predefined_Renaming_File_Name (Fname)
184 end Is_Predefined_File_Name;
186 function Is_Predefined_File_Name
187 (Fname : File_Name_Type;
188 Renamings_Included : Boolean := True) return Boolean
190 Result : constant Boolean :=
191 Is_Predefined_File_Name
192 (Get_Name_String (Fname), Renamings_Included);
195 end Is_Predefined_File_Name;
197 --------------------------------------
198 -- Is_Predefined_Renaming_File_Name --
199 --------------------------------------
201 function Is_Predefined_Renaming_File_Name
202 (Fname : String) return Boolean
204 subtype Str8 is String (1 .. 8);
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
216 -- Definitely false if longer than 12 characters (8.3)
218 if Fname'Length in 8 .. 12 then
220 S : String renames Fname (Fname'First .. Fname'First + 7);
222 for J in Renaming_Names'Range loop
223 if S = Renaming_Names (J) then
231 end Is_Predefined_Renaming_File_Name;
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));
239 end Is_Predefined_Renaming_File_Name;