File : fname.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- F N A M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, 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 -- --
19 -- --
20 -- --
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
32 with Alloc;
33 with Table;
34 with Types; use Types;
35
36 package 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 predefined if prefix is a- i- or s- followed by letter
138
139 if Name_Len >= 3
140 and then Name_Buffer (2) = '-'
141 and then (Name_Buffer (1) = 'a'
142 or else
143 Name_Buffer (1) = 'i'
144 or else
145 Name_Buffer (1) = 's')
146 and then (Name_Buffer (3) in 'a' .. 'z'
147 or else
148 Name_Buffer (3) in 'A' .. 'Z')
149 then
150 return True;
151
152 -- Definitely false if longer than 12 characters (8.3)
153
154 elsif Name_Len > 8 then
155 return False;
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
196 end Fname;