1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F N A M E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2014, 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 --------------------------- 61 -- Is_Internal_File_Name -- 62 --------------------------- 63 64 function Is_Internal_File_Name 65 (Fname : File_Name_Type; 66 Renamings_Included : Boolean := True) return Boolean 67 is 68 begin 69 if Is_Predefined_File_Name (Fname, Renamings_Included) then 70 return True; 71 72 -- Once Is_Predefined_File_Name has been called and returns False, 73 -- Name_Buffer contains Fname and Name_Len is set to 8. 74 75 elsif Name_Buffer (1 .. 2) = "g-" 76 or else Name_Buffer (1 .. 8) = "gnat " 77 then 78 return True; 79 80 else 81 return False; 82 end if; 83 end Is_Internal_File_Name; 84 85 ----------------------------- 86 -- Is_Predefined_File_Name -- 87 ----------------------------- 88 89 -- This should really be a test of unit name, given the possibility of 90 -- pragma Source_File_Name setting arbitrary file names for any files??? 91 92 -- Once Is_Predefined_File_Name has been called and returns False, 93 -- Name_Buffer contains Fname and Name_Len is set to 8. This is used 94 -- only by Is_Internal_File_Name, and is not part of the official 95 -- external interface of this function. 96 97 function Is_Predefined_File_Name 98 (Fname : File_Name_Type; 99 Renamings_Included : Boolean := True) return Boolean 100 is 101 begin 102 Get_Name_String (Fname); 103 return Is_Predefined_File_Name (Renamings_Included); 104 end Is_Predefined_File_Name; 105 106 function Is_Predefined_File_Name 107 (Renamings_Included : Boolean := True) return Boolean 108 is 109 subtype Str8 is String (1 .. 8); 110 111 Predef_Names : constant array (1 .. 11) of Str8 := 112 ("ada ", -- Ada 113 "interfac", -- Interfaces 114 "system ", -- System 115 116 -- Remaining entries are only considered if Renamings_Included true 117 118 "calendar", -- Calendar 119 "machcode", -- Machine_Code 120 "unchconv", -- Unchecked_Conversion 121 "unchdeal", -- Unchecked_Deallocation 122 "directio", -- Direct_IO 123 "ioexcept", -- IO_Exceptions 124 "sequenio", -- Sequential_IO 125 "text_io "); -- Text_IO 126 127 Num_Entries : constant Natural := 128 3 + 8 * Boolean'Pos (Renamings_Included); 129 130 begin 131 -- Remove extension (if present) 132 133 if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then 134 Name_Len := Name_Len - 4; 135 end if; 136 137 -- Definitely false if longer than 12 characters (8.3) 138 139 if Name_Len > 8 then 140 return False; 141 142 -- Definitely predefined if prefix is a- i- or s- followed by letter 143 144 elsif Name_Len >= 3 145 and then Name_Buffer (2) = '-' 146 and then (Name_Buffer (1) = 'a' 147 or else 148 Name_Buffer (1) = 'i' 149 or else 150 Name_Buffer (1) = 's') 151 and then (Name_Buffer (3) in 'a' .. 'z' 152 or else 153 Name_Buffer (3) in 'A' .. 'Z') 154 then 155 return True; 156 end if; 157 158 -- Otherwise check against special list, first padding to 8 characters 159 160 while Name_Len < 8 loop 161 Name_Len := Name_Len + 1; 162 Name_Buffer (Name_Len) := ' '; 163 end loop; 164 165 for J in 1 .. Num_Entries loop 166 if Name_Buffer (1 .. 8) = Predef_Names (J) then 167 return True; 168 end if; 169 end loop; 170 171 -- Note: when we return False here, the Name_Buffer contains the 172 -- padded file name. This is not defined for clients of the package, 173 -- but is used by Is_Internal_File_Name. 174 175 return False; 176 end Is_Predefined_File_Name; 177 178 --------------- 179 -- Tree_Read -- 180 --------------- 181 182 procedure Tree_Read is 183 begin 184 SFN_Table.Tree_Read; 185 end Tree_Read; 186 187 ---------------- 188 -- Tree_Write -- 189 ---------------- 190 191 procedure Tree_Write is 192 begin 193 SFN_Table.Tree_Write; 194 end Tree_Write; 195 196end Fname; 197