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