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