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 --
10 -- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
37 package body System
.Exception_Table
is
39 use System
.Standard_Library
;
41 type HTable_Headers
is range 1 .. 37;
43 procedure Set_HT_Link
(T
: Exception_Data_Ptr
; Next
: Exception_Data_Ptr
);
44 function Get_HT_Link
(T
: Exception_Data_Ptr
) return Exception_Data_Ptr
;
46 function Hash
(F
: Big_String_Ptr
) return HTable_Headers
;
47 function Equal
(A
, B
: Big_String_Ptr
) return Boolean;
48 function Get_Key
(T
: Exception_Data_Ptr
) return Big_String_Ptr
;
50 package Exception_HTable
is new GNAT
.HTable
.Static_HTable
(
51 Header_Num
=> HTable_Headers
,
52 Element
=> Exception_Data
,
53 Elmt_Ptr
=> Exception_Data_Ptr
,
55 Set_Next
=> Set_HT_Link
,
57 Key
=> Big_String_Ptr
,
66 function Equal
(A
, B
: Big_String_Ptr
) return Boolean is
71 if A
(J
) /= B
(J
) then
74 elsif A
(J
) = ASCII
.NUL
then
87 function Get_HT_Link
(T
: Exception_Data_Ptr
) return Exception_Data_Ptr
is
96 function Get_Key
(T
: Exception_Data_Ptr
) return Big_String_Ptr
is
105 function Hash
(F
: Big_String_Ptr
) return HTable_Headers
is
108 Size
: constant S
:= S
(HTable_Headers
'Last - HTable_Headers
'First + 1);
115 if F
(J
) = ASCII
.NUL
then
116 return HTable_Headers
'First + HTable_Headers
'Base (Tmp
mod Size
);
118 Tmp
:= Tmp
xor S
(Character'Pos (F
(J
)));
124 ------------------------
125 -- Internal_Exception --
126 ------------------------
128 type String_Ptr
is access all String;
130 function Internal_Exception
(X
: String) return Exception_Data_Ptr
is
131 Copy
: aliased String (X
'First .. X
'Last + 1);
132 Res
: Exception_Data_Ptr
;
133 Dyn_Copy
: String_Ptr
;
137 Copy
(Copy
'Last) := ASCII
.NUL
;
138 Res
:= Exception_HTable
.Get
(To_Ptr
(Copy
'Address));
140 -- If unknown exception, create it on the heap. This is a legitimate
141 -- situation in the distributed case when an exception is defined only
145 Dyn_Copy
:= new String'(Copy);
149 (Not_Handled_By_Others
=> False,
151 Name_Length
=> Copy
'Length,
152 Full_Name
=> To_Ptr
(Dyn_Copy
.all'Address),
156 Register_Exception
(Res
);
160 end Internal_Exception
;
162 ------------------------
163 -- Register_Exception --
164 ------------------------
166 procedure Register_Exception
(X
: Exception_Data_Ptr
) is
168 Exception_HTable
.Set
(X
);
169 end Register_Exception
;
175 procedure Set_HT_Link
176 (T
: Exception_Data_Ptr
;
177 Next
: Exception_Data_Ptr
)
180 T
.HTable_Ptr
:= Next
;
184 Register_Exception
(Abort_Signal_Def
'Access);
185 Register_Exception
(Tasking_Error_Def
'Access);
186 Register_Exception
(Storage_Error_Def
'Access);
187 Register_Exception
(Program_Error_Def
'Access);
188 Register_Exception
(Numeric_Error_Def
'Access);
189 Register_Exception
(Constraint_Error_Def
'Access);
191 end System
.Exception_Table
;