1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . E X C E P T I O N _ T A B L E --
9 -- Copyright (C) 1996-2023, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with System
.Soft_Links
; use System
.Soft_Links
;
34 package body System
.Exception_Table
is
36 use System
.Standard_Library
;
38 type Hash_Val
is mod 2 ** 8;
39 subtype Hash_Idx
is Hash_Val
range 1 .. 37;
41 HTable
: array (Hash_Idx
) of aliased Exception_Data_Ptr
;
42 -- Actual hash table containing all registered exceptions
44 -- The table is very small and the hash function weak, as looking up
45 -- registered exceptions is rare and minimizing space and time overhead
46 -- of registration is more important. In addition, it is expected that the
47 -- exceptions that need to be looked up are registered dynamically, and
48 -- therefore will be at the begin of the hash chains.
50 -- The table differs from System.HTable.Static_HTable in that the final
51 -- element of each chain is not marked by null, but by a pointer to self.
52 -- This way it is possible to defend against the same entry being inserted
53 -- twice, without having to do a lookup which is relatively expensive for
54 -- programs with large number
56 -- All non-local subprograms use the global Task_Lock to protect against
57 -- concurrent use of the exception table. This is needed as local
58 -- exceptions may be declared concurrently with those declared at the
64 with procedure Process
(T
: Exception_Data_Ptr
; More
: out Boolean);
68 function Lookup
(Name
: String) return Exception_Data_Ptr
;
69 -- Find and return the Exception_Data of the exception with the given Name
70 -- (which must be in all uppercase), or null if none was registered.
72 procedure Register
(Item
: Exception_Data_Ptr
);
73 -- Register an exception with the given Exception_Data in the table.
75 function Has_Name
(Item
: Exception_Data_Ptr
; Name
: String) return Boolean;
76 -- Return True iff Item.Full_Name and Name are equal. Both names are
77 -- assumed to be in all uppercase and end with ASCII.NUL.
79 function Hash
(S
: String) return Hash_Idx
;
80 -- Return the index in the hash table for S, which is assumed to be all
81 -- uppercase and end with ASCII.NUL.
87 function Has_Name
(Item
: Exception_Data_Ptr
; Name
: String) return Boolean
89 S
: constant Big_String_Ptr
:= To_Ptr
(Item
.Full_Name
);
90 J
: Integer := S
'First;
93 for K
in Name
'Range loop
95 -- Note that as both items are terminated with ASCII.NUL, the
96 -- comparison below must fail for strings of different lengths.
98 if S
(J
) /= Name
(K
) then
112 function Lookup
(Name
: String) return Exception_Data_Ptr
is
113 Prev
: Exception_Data_Ptr
;
114 Curr
: Exception_Data_Ptr
;
117 Curr
:= HTable
(Hash
(Name
));
119 while Curr
/= Prev
loop
120 if Has_Name
(Curr
, Name
) then
125 Curr
:= Curr
.HTable_Ptr
;
135 function Hash
(S
: String) return Hash_Idx
is
136 Hash
: Hash_Val
:= 0;
139 for J
in S
'Range loop
140 exit when S
(J
) = ASCII
.NUL
;
141 Hash
:= Hash
xor Character'Pos (S
(J
));
144 return Hash_Idx
'First + Hash
mod (Hash_Idx
'Last - Hash_Idx
'First + 1);
153 Prev
, Curr
: Exception_Data_Ptr
;
156 Outer
: for Idx
in HTable
'Range loop
158 Curr
:= HTable
(Idx
);
160 while Curr
/= Prev
loop
161 Process
(Curr
, More
);
163 exit Outer
when not More
;
166 Curr
:= Curr
.HTable_Ptr
;
175 procedure Register
(Item
: Exception_Data_Ptr
) is
177 if Item
.HTable_Ptr
= null then
178 Prepend_To_Chain
: declare
179 Chain
: Exception_Data_Ptr
180 renames HTable
(Hash
(To_Ptr
(Item
.Full_Name
).all));
184 Item
.HTable_Ptr
:= Item
;
186 Item
.HTable_Ptr
:= Chain
;
190 end Prepend_To_Chain
;
194 -------------------------------
195 -- Get_Registered_Exceptions --
196 -------------------------------
198 procedure Get_Registered_Exceptions
199 (List
: out Exception_Data_Array
;
202 procedure Get_One
(Item
: Exception_Data_Ptr
; More
: out Boolean);
203 -- Add Item to List (List'First .. Last) by first incrementing Last
204 -- and storing Item in List (Last). Last should be in List'First - 1
207 procedure Get_All
is new Iterate
(Get_One
);
208 -- Store all registered exceptions in List, updating Last
214 procedure Get_One
(Item
: Exception_Data_Ptr
; More
: out Boolean) is
216 if Last
< List
'Last then
227 -- In this routine the invariant is that List (List'First .. Last)
228 -- contains the registered exceptions retrieved so far.
230 Last
:= List
'First - 1;
235 end Get_Registered_Exceptions
;
237 ------------------------
238 -- Internal_Exception --
239 ------------------------
241 function Internal_Exception
243 Create_If_Not_Exist
: Boolean := True) return Exception_Data_Ptr
245 -- If X was not yet registered and Create_if_Not_Exist is True,
246 -- dynamically allocate and register a new exception.
248 type String_Ptr
is access all String;
250 Dyn_Copy
: String_Ptr
;
251 Copy
: aliased String (X
'First .. X
'Last + 1);
252 Result
: Exception_Data_Ptr
;
258 Copy
(Copy
'Last) := ASCII
.NUL
;
259 Result
:= Lookup
(Copy
);
261 -- If unknown exception, create it on the heap. This is a legitimate
262 -- situation in the distributed case when an exception is defined
263 -- only in a partition
265 if Result
= null and then Create_If_Not_Exist
then
266 Dyn_Copy
:= new String'(Copy);
270 (Not_Handled_By_Others
=> False,
272 Name_Length
=> Copy
'Length,
273 Full_Name
=> Dyn_Copy
.all'Address,
275 Foreign_Data
=> Null_Address
,
284 end Internal_Exception
;
286 ------------------------
287 -- Register_Exception --
288 ------------------------
290 procedure Register_Exception
(X
: Exception_Data_Ptr
) is
295 end Register_Exception
;
297 ---------------------------------
298 -- Registered_Exceptions_Count --
299 ---------------------------------
301 function Registered_Exceptions_Count
return Natural is
302 Count
: Natural := 0;
304 procedure Count_Item
(Item
: Exception_Data_Ptr
; More
: out Boolean);
305 -- Update Count for given Item
307 procedure Count_Item
(Item
: Exception_Data_Ptr
; More
: out Boolean) is
308 pragma Unreferenced
(Item
);
311 More
:= Count
< Natural'Last;
314 procedure Count_All
is new Iterate
(Count_Item
);
322 end Registered_Exceptions_Count
;
325 -- Register the standard exceptions at elaboration time
327 -- We don't need to use the locking version here as the elaboration
328 -- will not be concurrent and no tasks can call any subprograms of this
329 -- unit before it has been elaborated.
331 Register
(Abort_Signal_Def
'Access);
332 Register
(Tasking_Error_Def
'Access);
333 Register
(Storage_Error_Def
'Access);
334 Register
(Program_Error_Def
'Access);
335 Register
(Numeric_Error_Def
'Access);
336 Register
(Constraint_Error_Def
'Access);
337 end System
.Exception_Table
;