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-2013, 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_Warning;
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   begin
71      loop
72         if S1 (J) /= S2 (J) then
73            return False;
74         elsif S1 (J) = ASCII.NUL then
75            return True;
76         else
77            J := J + 1;
78         end if;
79      end loop;
80   end Equal;
81
82   -----------------
83   -- Get_HT_Link --
84   -----------------
85
86   function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
87   begin
88      return T.HTable_Ptr;
89   end Get_HT_Link;
90
91   -------------
92   -- Get_Key --
93   -------------
94
95   function Get_Key (T : Exception_Data_Ptr) return System.Address is
96   begin
97      return T.Full_Name;
98   end Get_Key;
99
100   -------------------------------
101   -- Get_Registered_Exceptions --
102   -------------------------------
103
104   procedure Get_Registered_Exceptions
105     (List : out Exception_Data_Array;
106      Last : out Integer)
107   is
108      Data : Exception_Data_Ptr := Exception_HTable.Get_First;
109
110   begin
111      Lock_Task.all;
112      Last := List'First - 1;
113
114      while Last < List'Last and then Data /= null loop
115         Last := Last + 1;
116         List (Last) := Data;
117         Data := Exception_HTable.Get_Next;
118      end loop;
119
120      Unlock_Task.all;
121   end Get_Registered_Exceptions;
122
123   ----------
124   -- Hash --
125   ----------
126
127   function Hash (F : System.Address) return HTable_Headers is
128      type S is mod 2**8;
129
130      Str  : constant Big_String_Ptr := To_Ptr (F);
131      Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
132      Tmp  : S := 0;
133      J    : Positive;
134
135   begin
136      J := 1;
137      loop
138         if Str (J) = ASCII.NUL then
139            return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
140         else
141            Tmp := Tmp xor S (Character'Pos (Str (J)));
142         end if;
143         J := J + 1;
144      end loop;
145   end Hash;
146
147   ------------------------
148   -- Internal_Exception --
149   ------------------------
150
151   function Internal_Exception
152     (X                   : String;
153      Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
154   is
155      type String_Ptr is access all String;
156
157      Copy     : aliased String (X'First .. X'Last + 1);
158      Res      : Exception_Data_Ptr;
159      Dyn_Copy : String_Ptr;
160
161   begin
162      Copy (X'Range) := X;
163      Copy (Copy'Last) := ASCII.NUL;
164      Res := Exception_HTable.Get (Copy'Address);
165
166      --  If unknown exception, create it on the heap. This is a legitimate
167      --  situation in the distributed case when an exception is defined only
168      --  in a partition
169
170      if Res = null and then Create_If_Not_Exist then
171         Dyn_Copy := new String'(Copy);
172
173         Res :=
174           new Exception_Data'
175             (Not_Handled_By_Others => False,
176              Lang                  => 'A',
177              Name_Length           => Copy'Length,
178              Full_Name             => Dyn_Copy.all'Address,
179              HTable_Ptr            => null,
180              Foreign_Data          => Null_Address,
181              Raise_Hook            => null);
182
183         Register_Exception (Res);
184      end if;
185
186      return Res;
187   end Internal_Exception;
188
189   ------------------------
190   -- Register_Exception --
191   ------------------------
192
193   procedure Register_Exception (X : Exception_Data_Ptr) is
194   begin
195      Exception_HTable.Set (X);
196   end Register_Exception;
197
198   ---------------------------------
199   -- Registered_Exceptions_Count --
200   ---------------------------------
201
202   function Registered_Exceptions_Count return Natural is
203      Count : Natural := 0;
204      Data  : Exception_Data_Ptr := Exception_HTable.Get_First;
205
206   begin
207      --  We need to lock the runtime in the meantime, to avoid concurrent
208      --  access since we have only one iterator.
209
210      Lock_Task.all;
211
212      while Data /= null loop
213         Count := Count + 1;
214         Data := Exception_HTable.Get_Next;
215      end loop;
216
217      Unlock_Task.all;
218      return Count;
219   end Registered_Exceptions_Count;
220
221   -----------------
222   -- Set_HT_Link --
223   -----------------
224
225   procedure Set_HT_Link
226     (T    : Exception_Data_Ptr;
227      Next : Exception_Data_Ptr)
228   is
229   begin
230      T.HTable_Ptr := Next;
231   end Set_HT_Link;
232
233--  Register the standard exceptions at elaboration time
234
235begin
236   Register_Exception (Abort_Signal_Def'Access);
237   Register_Exception (Tasking_Error_Def'Access);
238   Register_Exception (Storage_Error_Def'Access);
239   Register_Exception (Program_Error_Def'Access);
240   Register_Exception (Numeric_Error_Def'Access);
241   Register_Exception (Constraint_Error_Def'Access);
242
243end System.Exception_Table;
244