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-2009, 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-- 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.               --
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
32pragma Compiler_Unit;
33
34with System.HTable;
35with System.Soft_Links;   use System.Soft_Links;
36
37package body System.Exception_Table is
38
39   use System.Standard_Library;
40
41   type HTable_Headers is range 1 .. 37;
42
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;
45
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;
49
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,
54     Null_Ptr   => null,
55     Set_Next   => Set_HT_Link,
56     Next       => Get_HT_Link,
57     Key        => System.Address,
58     Get_Key    => Get_Key,
59     Hash       => Hash,
60     Equal      => Equal);
61
62   -----------
63   -- Equal --
64   -----------
65
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);
69      J : Integer := 1;
70
71   begin
72      loop
73         if S1 (J) /= S2 (J) then
74            return False;
75
76         elsif S1 (J) = ASCII.NUL then
77            return True;
78
79         else
80            J := J + 1;
81         end if;
82      end loop;
83   end Equal;
84
85   -----------------
86   -- Get_HT_Link --
87   -----------------
88
89   function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
90   begin
91      return T.HTable_Ptr;
92   end Get_HT_Link;
93
94   -------------
95   -- Get_Key --
96   -------------
97
98   function Get_Key (T : Exception_Data_Ptr) return System.Address is
99   begin
100      return T.Full_Name;
101   end Get_Key;
102
103   -------------------------------
104   -- Get_Registered_Exceptions --
105   -------------------------------
106
107   procedure Get_Registered_Exceptions
108     (List : out Exception_Data_Array;
109      Last : out Integer)
110   is
111      Data : Exception_Data_Ptr := Exception_HTable.Get_First;
112
113   begin
114      Lock_Task.all;
115      Last := List'First - 1;
116
117      while Last < List'Last and then Data /= null loop
118         Last := Last + 1;
119         List (Last) := Data;
120         Data := Exception_HTable.Get_Next;
121      end loop;
122
123      Unlock_Task.all;
124   end Get_Registered_Exceptions;
125
126   ----------
127   -- Hash --
128   ----------
129
130   function Hash (F : System.Address) return HTable_Headers is
131      type S is mod 2**8;
132
133      Str  : constant Big_String_Ptr := To_Ptr (F);
134      Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
135      Tmp  : S := 0;
136      J    : Positive;
137
138   begin
139      J := 1;
140      loop
141         if Str (J) = ASCII.NUL then
142            return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
143         else
144            Tmp := Tmp xor S (Character'Pos (Str (J)));
145         end if;
146         J := J + 1;
147      end loop;
148   end Hash;
149
150   ------------------------
151   -- Internal_Exception --
152   ------------------------
153
154   function Internal_Exception
155     (X                   : String;
156      Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
157   is
158      type String_Ptr is access all String;
159
160      Copy     : aliased String (X'First .. X'Last + 1);
161      Res      : Exception_Data_Ptr;
162      Dyn_Copy : String_Ptr;
163
164   begin
165      Copy (X'Range) := X;
166      Copy (Copy'Last) := ASCII.NUL;
167      Res := Exception_HTable.Get (Copy'Address);
168
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
171      --  in a partition
172
173      if Res = null and then Create_If_Not_Exist then
174         Dyn_Copy := new String'(Copy);
175
176         Res :=
177           new Exception_Data'
178             (Not_Handled_By_Others => False,
179              Lang                  => 'A',
180              Name_Length           => Copy'Length,
181              Full_Name             => Dyn_Copy.all'Address,
182              HTable_Ptr            => null,
183              Import_Code           => 0,
184              Raise_Hook            => null);
185
186         Register_Exception (Res);
187      end if;
188
189      return Res;
190   end Internal_Exception;
191
192   ------------------------
193   -- Register_Exception --
194   ------------------------
195
196   procedure Register_Exception (X : Exception_Data_Ptr) is
197   begin
198      Exception_HTable.Set (X);
199   end Register_Exception;
200
201   ---------------------------------
202   -- Registered_Exceptions_Count --
203   ---------------------------------
204
205   function Registered_Exceptions_Count return Natural is
206      Count : Natural := 0;
207      Data  : Exception_Data_Ptr := Exception_HTable.Get_First;
208
209   begin
210      --  We need to lock the runtime in the meantime, to avoid concurrent
211      --  access since we have only one iterator.
212
213      Lock_Task.all;
214
215      while Data /= null loop
216         Count := Count + 1;
217         Data := Exception_HTable.Get_Next;
218      end loop;
219
220      Unlock_Task.all;
221      return Count;
222   end Registered_Exceptions_Count;
223
224   -----------------
225   -- Set_HT_Link --
226   -----------------
227
228   procedure Set_HT_Link
229     (T    : Exception_Data_Ptr;
230      Next : Exception_Data_Ptr)
231   is
232   begin
233      T.HTable_Ptr := Next;
234   end Set_HT_Link;
235
236--  Register the standard exceptions at elaboration time
237
238begin
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);
245
246end System.Exception_Table;
247