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-2009, 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 ------------------------------------------------------------------------------
35 with System.Soft_Links; use System.Soft_Links;
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 : System.Address) return HTable_Headers;
47 function Equal (A, B : System.Address) return Boolean;
48 function Get_Key (T : Exception_Data_Ptr) return System.Address;
50 package Exception_HTable is new System.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 => System.Address,
66 function Equal (A, B : System.Address) return Boolean is
67 S1 : constant Big_String_Ptr := To_Ptr (A);
68 S2 : constant Big_String_Ptr := To_Ptr (B);
73 if S1 (J) /= S2 (J) then
76 elsif S1 (J) = ASCII.NUL then
89 function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
98 function Get_Key (T : Exception_Data_Ptr) return System.Address is
103 -------------------------------
104 -- Get_Registered_Exceptions --
105 -------------------------------
107 procedure Get_Registered_Exceptions
108 (List : out Exception_Data_Array;
111 Data : Exception_Data_Ptr := Exception_HTable.Get_First;
115 Last := List'First - 1;
117 while Last < List'Last and then Data /= null loop
120 Data := Exception_HTable.Get_Next;
124 end Get_Registered_Exceptions;
130 function Hash (F : System.Address) return HTable_Headers is
133 Str : constant Big_String_Ptr := To_Ptr (F);
134 Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
141 if Str (J) = ASCII.NUL then
142 return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
144 Tmp := Tmp xor S (Character'Pos (Str (J)));
150 ------------------------
151 -- Internal_Exception --
152 ------------------------
154 function Internal_Exception
156 Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
158 type String_Ptr is access all String;
160 Copy : aliased String (X'First .. X'Last + 1);
161 Res : Exception_Data_Ptr;
162 Dyn_Copy : String_Ptr;
166 Copy (Copy'Last) := ASCII.NUL;
167 Res := Exception_HTable.Get (Copy'Address);
169 -- If unknown exception, create it on the heap. This is a legitimate
170 -- situation in the distributed case when an exception is defined only
173 if Res = null and then Create_If_Not_Exist then
174 Dyn_Copy := new String'(Copy);
178 (Not_Handled_By_Others => False,
180 Name_Length => Copy'Length,
181 Full_Name => Dyn_Copy.all'Address,
186 Register_Exception (Res);
190 end Internal_Exception;
192 ------------------------
193 -- Register_Exception --
194 ------------------------
196 procedure Register_Exception (X : Exception_Data_Ptr) is
198 Exception_HTable.Set (X);
199 end Register_Exception;
201 ---------------------------------
202 -- Registered_Exceptions_Count --
203 ---------------------------------
205 function Registered_Exceptions_Count return Natural is
206 Count : Natural := 0;
207 Data : Exception_Data_Ptr := Exception_HTable.Get_First;
210 -- We need to lock the runtime in the meantime, to avoid concurrent
211 -- access since we have only one iterator.
215 while Data /= null loop
217 Data := Exception_HTable.Get_Next;
222 end Registered_Exceptions_Count;
228 procedure Set_HT_Link
229 (T : Exception_Data_Ptr;
230 Next : Exception_Data_Ptr)
233 T.HTable_Ptr := Next;
236 -- Register the standard exceptions at elaboration time
239 Register_Exception (Abort_Signal_Def'Access);
240 Register_Exception (Tasking_Error_Def'Access);
241 Register_Exception (Storage_Error_Def'Access);
242 Register_Exception (Program_Error_Def'Access);
243 Register_Exception (Numeric_Error_Def'Access);
244 Register_Exception (Constraint_Error_Def'Access);
246 end System.Exception_Table;