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