1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F N A M E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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. -- 17-- -- 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. -- 21-- -- 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/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Alloc; 33with Table; 34with Types; use Types; 35 36package body Fname is 37 38 ----------------------------- 39 -- Dummy Table Definitions -- 40 ----------------------------- 41 42 -- The following table was used in old versions of the compiler. We retain 43 -- the declarations here for compatibility with old tree files. The new 44 -- version of the compiler does not use this table, and will write out a 45 -- dummy empty table for Tree_Write. 46 47 type SFN_Entry is record 48 U : Unit_Name_Type; 49 F : File_Name_Type; 50 end record; 51 52 package SFN_Table is new Table.Table ( 53 Table_Component_Type => SFN_Entry, 54 Table_Index_Type => Int, 55 Table_Low_Bound => 0, 56 Table_Initial => Alloc.SFN_Table_Initial, 57 Table_Increment => Alloc.SFN_Table_Increment, 58 Table_Name => "Fname_Dummy_Table"); 59 60 function Has_Internal_Extension (Fname : String) return Boolean; 61 pragma Inline (Has_Internal_Extension); 62 -- True if the extension is appropriate for an internal/predefined unit. 63 -- That means ".ads" or ".adb" for source files, and ".ali" for ALI files. 64 65 function Has_Prefix (X, Prefix : String) return Boolean; 66 pragma Inline (Has_Prefix); 67 -- True if Prefix is at the beginning of X. For example, 68 -- Has_Prefix ("a-filename.ads", Prefix => "a-") is True. 69 70 ---------------------------- 71 -- Has_Internal_Extension -- 72 ---------------------------- 73 74 function Has_Internal_Extension (Fname : String) return Boolean is 75 begin 76 if Fname'Length >= 4 then 77 declare 78 S : String renames Fname (Fname'Last - 3 .. Fname'Last); 79 begin 80 return S = ".ads" or else S = ".adb" or else S = ".ali"; 81 end; 82 end if; 83 return False; 84 end Has_Internal_Extension; 85 86 ---------------- 87 -- Has_Prefix -- 88 ---------------- 89 90 function Has_Prefix (X, Prefix : String) return Boolean is 91 begin 92 if X'Length >= Prefix'Length then 93 declare 94 S : String renames X (X'First .. X'First + Prefix'Length - 1); 95 begin 96 return S = Prefix; 97 end; 98 end if; 99 return False; 100 end Has_Prefix; 101 102 ----------------------- 103 -- Is_GNAT_File_Name -- 104 ----------------------- 105 106 function Is_GNAT_File_Name (Fname : String) return Boolean is 107 begin 108 -- Check for internal extensions before checking prefixes, so we don't 109 -- think (e.g.) "gnat.adc" is internal. 110 111 if not Has_Internal_Extension (Fname) then 112 return False; 113 end if; 114 115 -- Definitely internal if prefix is g- 116 117 if Has_Prefix (Fname, "g-") then 118 return True; 119 end if; 120 121 -- See the note in Is_Predefined_File_Name for the rationale 122 123 return Fname'Length = 8 and then Has_Prefix (Fname, "gnat"); 124 end Is_GNAT_File_Name; 125 126 function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is 127 Result : constant Boolean := 128 Is_GNAT_File_Name (Get_Name_String (Fname)); 129 begin 130 return Result; 131 end Is_GNAT_File_Name; 132 133 --------------------------- 134 -- Is_Internal_File_Name -- 135 --------------------------- 136 137 function Is_Internal_File_Name 138 (Fname : String; 139 Renamings_Included : Boolean := True) return Boolean 140 is 141 begin 142 if Is_Predefined_File_Name (Fname, Renamings_Included) then 143 return True; 144 end if; 145 146 return Is_GNAT_File_Name (Fname); 147 end Is_Internal_File_Name; 148 149 function Is_Internal_File_Name 150 (Fname : File_Name_Type; 151 Renamings_Included : Boolean := True) return Boolean 152 is 153 Result : constant Boolean := 154 Is_Internal_File_Name 155 (Get_Name_String (Fname), Renamings_Included); 156 begin 157 return Result; 158 end Is_Internal_File_Name; 159 160 ----------------------------- 161 -- Is_Predefined_File_Name -- 162 ----------------------------- 163 164 function Is_Predefined_File_Name 165 (Fname : String; 166 Renamings_Included : Boolean := True) return Boolean 167 is 168 begin 169 -- Definitely false if longer than 12 characters (8.3) 170 -- except for the Interfaces packages 171 172 if Fname'Length > 12 173 and then Fname (Fname'First .. Fname'First + 1) /= "i-" 174 then 175 return False; 176 end if; 177 178 if not Has_Internal_Extension (Fname) then 179 return False; 180 end if; 181 182 -- Definitely predefined if prefix is a- i- or s- 183 184 if Fname'Length >= 2 then 185 declare 186 S : String renames Fname (Fname'First .. Fname'First + 1); 187 begin 188 if S = "a-" or else S = "i-" or else S = "s-" then 189 return True; 190 end if; 191 end; 192 end if; 193 194 -- We include the "." in the prefixes below, so we don't match (e.g.) 195 -- adamant.ads. So the first line matches "ada.ads", "ada.adb", and 196 -- "ada.ali". But that's not necessary if they have 8 characters. 197 198 if Has_Prefix (Fname, "ada.") -- Ada 199 or else Has_Prefix (Fname, "interfac") -- Interfaces 200 or else Has_Prefix (Fname, "system.a") -- System 201 then 202 return True; 203 end if; 204 205 -- If instructed and the name has 8+ characters, check for renamings 206 207 if Renamings_Included 208 and then Is_Predefined_Renaming_File_Name (Fname) 209 then 210 return True; 211 end if; 212 213 return False; 214 end Is_Predefined_File_Name; 215 216 function Is_Predefined_File_Name 217 (Fname : File_Name_Type; 218 Renamings_Included : Boolean := True) return Boolean 219 is 220 Result : constant Boolean := 221 Is_Predefined_File_Name 222 (Get_Name_String (Fname), Renamings_Included); 223 begin 224 return Result; 225 end Is_Predefined_File_Name; 226 227 -------------------------------------- 228 -- Is_Predefined_Renaming_File_Name -- 229 -------------------------------------- 230 231 function Is_Predefined_Renaming_File_Name 232 (Fname : String) return Boolean 233 is 234 subtype Str8 is String (1 .. 8); 235 236 Renaming_Names : constant array (1 .. 8) of Str8 := 237 ("calendar", -- Calendar 238 "machcode", -- Machine_Code 239 "unchconv", -- Unchecked_Conversion 240 "unchdeal", -- Unchecked_Deallocation 241 "directio", -- Direct_IO 242 "ioexcept", -- IO_Exceptions 243 "sequenio", -- Sequential_IO 244 "text_io."); -- Text_IO 245 begin 246 -- Definitely false if longer than 12 characters (8.3) 247 248 if Fname'Length in 8 .. 12 then 249 declare 250 S : String renames Fname (Fname'First .. Fname'First + 7); 251 begin 252 for J in Renaming_Names'Range loop 253 if S = Renaming_Names (J) then 254 return True; 255 end if; 256 end loop; 257 end; 258 end if; 259 260 return False; 261 end Is_Predefined_Renaming_File_Name; 262 263 function Is_Predefined_Renaming_File_Name 264 (Fname : File_Name_Type) return Boolean is 265 Result : constant Boolean := 266 Is_Predefined_Renaming_File_Name (Get_Name_String (Fname)); 267 begin 268 return Result; 269 end Is_Predefined_Renaming_File_Name; 270 271 --------------- 272 -- Tree_Read -- 273 --------------- 274 275 procedure Tree_Read is 276 begin 277 SFN_Table.Tree_Read; 278 end Tree_Read; 279 280 ---------------- 281 -- Tree_Write -- 282 ---------------- 283 284 procedure Tree_Write is 285 begin 286 SFN_Table.Tree_Write; 287 end Tree_Write; 288 289end Fname; 290