1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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
;