File : s-exctab.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . E X C E P T I O N _ T A B L E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-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 -- --
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 pragma Compiler_Unit_Warning;
33
34 with System.Soft_Links; use System.Soft_Links;
35
36 package body System.Exception_Table is
37
38 use System.Standard_Library;
39
40 type Hash_Val is mod 2 ** 8;
41 subtype Hash_Idx is Hash_Val range 1 .. 37;
42
43 HTable : array (Hash_Idx) of aliased Exception_Data_Ptr;
44 -- Actual hash table containing all registered exceptions
45 --
46 -- The table is very small and the hash function weak, as looking up
47 -- registered exceptions is rare and minimizing space and time overhead
48 -- of registration is more important. In addition, it is expected that the
49 -- exceptions that need to be looked up are registered dynamically, and
50 -- therefore will be at the begin of the hash chains.
51 --
52 -- The table differs from System.HTable.Static_HTable in that the final
53 -- element of each chain is not marked by null, but by a pointer to self.
54 -- This way it is possible to defend against the same entry being inserted
55 -- twice, without having to do a lookup which is relatively expensive for
56 -- programs with large number
57 --
58 -- All non-local subprograms use the global Task_Lock to protect against
59 -- concurrent use of the exception table. This is needed as local
60 -- exceptions may be declared concurrently with those declared at the
61 -- library level.
62
63 -- Local Subprograms
64
65 generic
66 with procedure Process (T : Exception_Data_Ptr; More : out Boolean);
67 procedure Iterate;
68 -- Iterate over all
69
70 function Lookup (Name : String) return Exception_Data_Ptr;
71 -- Find and return the Exception_Data of the exception with the given Name
72 -- (which must be in all uppercase), or null if none was registered.
73
74 procedure Register (Item : Exception_Data_Ptr);
75 -- Register an exception with the given Exception_Data in the table.
76
77 function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean;
78 -- Return True iff Item.Full_Name and Name are equal. Both names are
79 -- assumed to be in all uppercase and end with ASCII.NUL.
80
81 function Hash (S : String) return Hash_Idx;
82 -- Return the index in the hash table for S, which is assumed to be all
83 -- uppercase and end with ASCII.NUL.
84
85 --------------
86 -- Has_Name --
87 --------------
88
89 function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean
90 is
91 S : constant Big_String_Ptr := To_Ptr (Item.Full_Name);
92 J : Integer := S'First;
93
94 begin
95 for K in Name'Range loop
96
97 -- Note that as both items are terminated with ASCII.NUL, the
98 -- comparison below must fail for strings of different lengths.
99
100 if S (J) /= Name (K) then
101 return False;
102 end if;
103
104 J := J + 1;
105 end loop;
106
107 return True;
108 end Has_Name;
109
110 ------------
111 -- Lookup --
112 ------------
113
114 function Lookup (Name : String) return Exception_Data_Ptr is
115 Prev : Exception_Data_Ptr;
116 Curr : Exception_Data_Ptr;
117
118 begin
119 Curr := HTable (Hash (Name));
120 Prev := null;
121 while Curr /= Prev loop
122 if Has_Name (Curr, Name) then
123 return Curr;
124 end if;
125
126 Prev := Curr;
127 Curr := Curr.HTable_Ptr;
128 end loop;
129
130 return null;
131 end Lookup;
132
133 ----------
134 -- Hash --
135 ----------
136
137 function Hash (S : String) return Hash_Idx is
138 Hash : Hash_Val := 0;
139
140 begin
141 for J in S'Range loop
142 exit when S (J) = ASCII.NUL;
143 Hash := Hash xor Character'Pos (S (J));
144 end loop;
145
146 return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1);
147 end Hash;
148
149 -------------
150 -- Iterate --
151 -------------
152
153 procedure Iterate is
154 More : Boolean;
155 Prev, Curr : Exception_Data_Ptr;
156
157 begin
158 Outer : for Idx in HTable'Range loop
159 Prev := null;
160 Curr := HTable (Idx);
161
162 while Curr /= Prev loop
163 Process (Curr, More);
164
165 exit Outer when not More;
166
167 Prev := Curr;
168 Curr := Curr.HTable_Ptr;
169 end loop;
170 end loop Outer;
171 end Iterate;
172
173 --------------
174 -- Register --
175 --------------
176
177 procedure Register (Item : Exception_Data_Ptr) is
178 begin
179 if Item.HTable_Ptr = null then
180 Prepend_To_Chain : declare
181 Chain : Exception_Data_Ptr
182 renames HTable (Hash (To_Ptr (Item.Full_Name).all));
183
184 begin
185 if Chain = null then
186 Item.HTable_Ptr := Item;
187 else
188 Item.HTable_Ptr := Chain;
189 end if;
190
191 Chain := Item;
192 end Prepend_To_Chain;
193 end if;
194 end Register;
195
196 -------------------------------
197 -- Get_Registered_Exceptions --
198 -------------------------------
199
200 procedure Get_Registered_Exceptions
201 (List : out Exception_Data_Array;
202 Last : out Integer)
203 is
204 procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean);
205 -- Add Item to List (List'First .. Last) by first incrementing Last
206 -- and storing Item in List (Last). Last should be in List'First - 1
207 -- and List'Last.
208
209 procedure Get_All is new Iterate (Get_One);
210 -- Store all registered exceptions in List, updating Last
211
212 -------------
213 -- Get_One --
214 -------------
215
216 procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is
217 begin
218 if Last < List'Last then
219 Last := Last + 1;
220 List (Last) := Item;
221 More := True;
222
223 else
224 More := False;
225 end if;
226 end Get_One;
227
228 begin
229 -- In this routine the invariant is that List (List'First .. Last)
230 -- contains the registered exceptions retrieved so far.
231
232 Last := List'First - 1;
233
234 Lock_Task.all;
235 Get_All;
236 Unlock_Task.all;
237 end Get_Registered_Exceptions;
238
239 ------------------------
240 -- Internal_Exception --
241 ------------------------
242
243 function Internal_Exception
244 (X : String;
245 Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
246 is
247 -- If X was not yet registered and Create_if_Not_Exist is True,
248 -- dynamically allocate and register a new exception.
249
250 type String_Ptr is access all String;
251
252 Dyn_Copy : String_Ptr;
253 Copy : aliased String (X'First .. X'Last + 1);
254 Result : Exception_Data_Ptr;
255
256 begin
257 Lock_Task.all;
258
259 Copy (X'Range) := X;
260 Copy (Copy'Last) := ASCII.NUL;
261 Result := Lookup (Copy);
262
263 -- If unknown exception, create it on the heap. This is a legitimate
264 -- situation in the distributed case when an exception is defined
265 -- only in a partition
266
267 if Result = null and then Create_If_Not_Exist then
268 Dyn_Copy := new String'(Copy);
269
270 Result :=
271 new Exception_Data'
272 (Not_Handled_By_Others => False,
273 Lang => 'A',
274 Name_Length => Copy'Length,
275 Full_Name => Dyn_Copy.all'Address,
276 HTable_Ptr => null,
277 Foreign_Data => Null_Address,
278 Raise_Hook => null);
279
280 Register (Result);
281 end if;
282
283 Unlock_Task.all;
284
285 return Result;
286 end Internal_Exception;
287
288 ------------------------
289 -- Register_Exception --
290 ------------------------
291
292 procedure Register_Exception (X : Exception_Data_Ptr) is
293 begin
294 Lock_Task.all;
295 Register (X);
296 Unlock_Task.all;
297 end Register_Exception;
298
299 ---------------------------------
300 -- Registered_Exceptions_Count --
301 ---------------------------------
302
303 function Registered_Exceptions_Count return Natural is
304 Count : Natural := 0;
305
306 procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean);
307 -- Update Count for given Item
308
309 procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is
310 pragma Unreferenced (Item);
311 begin
312 Count := Count + 1;
313 More := Count < Natural'Last;
314 end Count_Item;
315
316 procedure Count_All is new Iterate (Count_Item);
317
318 begin
319 Lock_Task.all;
320 Count_All;
321 Unlock_Task.all;
322
323 return Count;
324 end Registered_Exceptions_Count;
325
326 begin
327 -- Register the standard exceptions at elaboration time
328
329 -- We don't need to use the locking version here as the elaboration
330 -- will not be concurrent and no tasks can call any subprograms of this
331 -- unit before it has been elaborated.
332
333 Register (Abort_Signal_Def'Access);
334 Register (Tasking_Error_Def'Access);
335 Register (Storage_Error_Def'Access);
336 Register (Program_Error_Def'Access);
337 Register (Numeric_Error_Def'Access);
338 Register (Constraint_Error_Def'Access);
339 end System.Exception_Table;