1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F N A M E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2009, 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 Hostparm; use Hostparm; 34with Table; 35with Types; use Types; 36 37package body Fname is 38 39 ----------------------------- 40 -- Dummy Table Definitions -- 41 ----------------------------- 42 43 -- The following table was used in old versions of the compiler. We retain 44 -- the declarations here for compatibility with old tree files. The new 45 -- version of the compiler does not use this table, and will write out a 46 -- dummy empty table for Tree_Write. 47 48 type SFN_Entry is record 49 U : Unit_Name_Type; 50 F : File_Name_Type; 51 end record; 52 53 package SFN_Table is new Table.Table ( 54 Table_Component_Type => SFN_Entry, 55 Table_Index_Type => Int, 56 Table_Low_Bound => 0, 57 Table_Initial => Alloc.SFN_Table_Initial, 58 Table_Increment => Alloc.SFN_Table_Increment, 59 Table_Name => "Fname_Dummy_Table"); 60 61 --------------------------- 62 -- Is_Internal_File_Name -- 63 --------------------------- 64 65 function Is_Internal_File_Name 66 (Fname : File_Name_Type; 67 Renamings_Included : Boolean := True) return Boolean 68 is 69 begin 70 if Is_Predefined_File_Name (Fname, Renamings_Included) then 71 return True; 72 73 -- Once Is_Predefined_File_Name has been called and returns False, 74 -- Name_Buffer contains Fname and Name_Len is set to 8. 75 76 elsif Name_Buffer (1 .. 2) = "g-" 77 or else Name_Buffer (1 .. 8) = "gnat " 78 then 79 return True; 80 81 elsif OpenVMS 82 and then 83 (Name_Buffer (1 .. 4) = "dec-" 84 or else Name_Buffer (1 .. 8) = "dec ") 85 then 86 return True; 87 88 else 89 return False; 90 end if; 91 end Is_Internal_File_Name; 92 93 ----------------------------- 94 -- Is_Predefined_File_Name -- 95 ----------------------------- 96 97 -- This should really be a test of unit name, given the possibility of 98 -- pragma Source_File_Name setting arbitrary file names for any files??? 99 100 -- Once Is_Predefined_File_Name has been called and returns False, 101 -- Name_Buffer contains Fname and Name_Len is set to 8. This is used 102 -- only by Is_Internal_File_Name, and is not part of the official 103 -- external interface of this function. 104 105 function Is_Predefined_File_Name 106 (Fname : File_Name_Type; 107 Renamings_Included : Boolean := True) return Boolean 108 is 109 begin 110 Get_Name_String (Fname); 111 return Is_Predefined_File_Name (Renamings_Included); 112 end Is_Predefined_File_Name; 113 114 function Is_Predefined_File_Name 115 (Renamings_Included : Boolean := True) return Boolean 116 is 117 subtype Str8 is String (1 .. 8); 118 119 Predef_Names : constant array (1 .. 11) of Str8 := 120 ("ada ", -- Ada 121 "interfac", -- Interfaces 122 "system ", -- System 123 124 -- Remaining entries are only considered if Renamings_Included true 125 126 "calendar", -- Calendar 127 "machcode", -- Machine_Code 128 "unchconv", -- Unchecked_Conversion 129 "unchdeal", -- Unchecked_Deallocation 130 "directio", -- Direct_IO 131 "ioexcept", -- IO_Exceptions 132 "sequenio", -- Sequential_IO 133 "text_io "); -- Text_IO 134 135 Num_Entries : constant Natural := 136 3 + 8 * Boolean'Pos (Renamings_Included); 137 138 begin 139 -- Remove extension (if present) 140 141 if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then 142 Name_Len := Name_Len - 4; 143 end if; 144 145 -- Definitely false if longer than 12 characters (8.3) 146 147 if Name_Len > 8 then 148 return False; 149 150 -- Definitely predefined if prefix is a- i- or s- followed by letter 151 152 elsif Name_Len >= 3 153 and then Name_Buffer (2) = '-' 154 and then (Name_Buffer (1) = 'a' 155 or else 156 Name_Buffer (1) = 'i' 157 or else 158 Name_Buffer (1) = 's') 159 and then (Name_Buffer (3) in 'a' .. 'z' 160 or else 161 Name_Buffer (3) in 'A' .. 'Z') 162 then 163 return True; 164 end if; 165 166 -- Otherwise check against special list, first padding to 8 characters 167 168 while Name_Len < 8 loop 169 Name_Len := Name_Len + 1; 170 Name_Buffer (Name_Len) := ' '; 171 end loop; 172 173 for J in 1 .. Num_Entries loop 174 if Name_Buffer (1 .. 8) = Predef_Names (J) then 175 return True; 176 end if; 177 end loop; 178 179 -- Note: when we return False here, the Name_Buffer contains the 180 -- padded file name. This is not defined for clients of the package, 181 -- but is used by Is_Internal_File_Name. 182 183 return False; 184 end Is_Predefined_File_Name; 185 186 --------------- 187 -- Tree_Read -- 188 --------------- 189 190 procedure Tree_Read is 191 begin 192 SFN_Table.Tree_Read; 193 end Tree_Read; 194 195 ---------------- 196 -- Tree_Write -- 197 ---------------- 198 199 procedure Tree_Write is 200 begin 201 SFN_Table.Tree_Write; 202 end Tree_Write; 203 204end Fname; 205