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-2014, 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.Soft_Links; use System.Soft_Links; 35 36package body System.Exception_Table is 37 38 use System.Standard_Library; 39 40 type Hash_Val is mod 2 ** 8; 41 subtype Hash_Idx is Hash_Val range 1 .. 37; 42 43 HTable : array (Hash_Idx) of aliased Exception_Data_Ptr; 44 -- Actual hash table containing all registered exceptions 45 -- 46 -- The table is very small and the hash function weak, as looking up 47 -- registered exceptions is rare and minimizing space and time overhead 48 -- of registration is more important. In addition, it is expected that the 49 -- exceptions that need to be looked up are registered dynamically, and 50 -- therefore will be at the begin of the hash chains. 51 -- 52 -- The table differs from System.HTable.Static_HTable in that the final 53 -- element of each chain is not marked by null, but by a pointer to self. 54 -- This way it is possible to defend against the same entry being inserted 55 -- twice, without having to do a lookup which is relatively expensive for 56 -- programs with large number 57 -- 58 -- All non-local subprograms use the global Task_Lock to protect against 59 -- concurrent use of the exception table. This is needed as local 60 -- exceptions may be declared concurrently with those declared at the 61 -- library level. 62 63 -- Local Subprograms 64 65 generic 66 with procedure Process (T : Exception_Data_Ptr; More : out Boolean); 67 procedure Iterate; 68 -- Iterate over all 69 70 function Lookup (Name : String) return Exception_Data_Ptr; 71 -- Find and return the Exception_Data of the exception with the given Name 72 -- (which must be in all uppercase), or null if none was registered. 73 74 procedure Register (Item : Exception_Data_Ptr); 75 -- Register an exception with the given Exception_Data in the table. 76 77 function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean; 78 -- Return True iff Item.Full_Name and Name are equal. Both names are 79 -- assumed to be in all uppercase and end with ASCII.NUL. 80 81 function Hash (S : String) return Hash_Idx; 82 -- Return the index in the hash table for S, which is assumed to be all 83 -- uppercase and end with ASCII.NUL. 84 85 -------------- 86 -- Has_Name -- 87 -------------- 88 89 function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean 90 is 91 S : constant Big_String_Ptr := To_Ptr (Item.Full_Name); 92 J : Integer := S'First; 93 94 begin 95 for K in Name'Range loop 96 97 -- Note that as both items are terminated with ASCII.NUL, the 98 -- comparison below must fail for strings of different lengths. 99 100 if S (J) /= Name (K) then 101 return False; 102 end if; 103 104 J := J + 1; 105 end loop; 106 107 return True; 108 end Has_Name; 109 110 ------------ 111 -- Lookup -- 112 ------------ 113 114 function Lookup (Name : String) return Exception_Data_Ptr is 115 Prev : Exception_Data_Ptr; 116 Curr : Exception_Data_Ptr; 117 118 begin 119 Curr := HTable (Hash (Name)); 120 Prev := null; 121 while Curr /= Prev loop 122 if Has_Name (Curr, Name) then 123 return Curr; 124 end if; 125 126 Prev := Curr; 127 Curr := Curr.HTable_Ptr; 128 end loop; 129 130 return null; 131 end Lookup; 132 133 ---------- 134 -- Hash -- 135 ---------- 136 137 function Hash (S : String) return Hash_Idx is 138 Hash : Hash_Val := 0; 139 140 begin 141 for J in S'Range loop 142 exit when S (J) = ASCII.NUL; 143 Hash := Hash xor Character'Pos (S (J)); 144 end loop; 145 146 return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1); 147 end Hash; 148 149 ------------- 150 -- Iterate -- 151 ------------- 152 153 procedure Iterate is 154 More : Boolean; 155 Prev, Curr : Exception_Data_Ptr; 156 157 begin 158 Outer : for Idx in HTable'Range loop 159 Prev := null; 160 Curr := HTable (Idx); 161 162 while Curr /= Prev loop 163 Process (Curr, More); 164 165 exit Outer when not More; 166 167 Prev := Curr; 168 Curr := Curr.HTable_Ptr; 169 end loop; 170 end loop Outer; 171 end Iterate; 172 173 -------------- 174 -- Register -- 175 -------------- 176 177 procedure Register (Item : Exception_Data_Ptr) is 178 begin 179 if Item.HTable_Ptr = null then 180 Prepend_To_Chain : declare 181 Chain : Exception_Data_Ptr 182 renames HTable (Hash (To_Ptr (Item.Full_Name).all)); 183 184 begin 185 if Chain = null then 186 Item.HTable_Ptr := Item; 187 else 188 Item.HTable_Ptr := Chain; 189 end if; 190 191 Chain := Item; 192 end Prepend_To_Chain; 193 end if; 194 end Register; 195 196 ------------------------------- 197 -- Get_Registered_Exceptions -- 198 ------------------------------- 199 200 procedure Get_Registered_Exceptions 201 (List : out Exception_Data_Array; 202 Last : out Integer) 203 is 204 procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean); 205 -- Add Item to List (List'First .. Last) by first incrementing Last 206 -- and storing Item in List (Last). Last should be in List'First - 1 207 -- and List'Last. 208 209 procedure Get_All is new Iterate (Get_One); 210 -- Store all registered exceptions in List, updating Last 211 212 ------------- 213 -- Get_One -- 214 ------------- 215 216 procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is 217 begin 218 if Last < List'Last then 219 Last := Last + 1; 220 List (Last) := Item; 221 More := True; 222 223 else 224 More := False; 225 end if; 226 end Get_One; 227 228 begin 229 -- In this routine the invariant is that List (List'First .. Last) 230 -- contains the registered exceptions retrieved so far. 231 232 Last := List'First - 1; 233 234 Lock_Task.all; 235 Get_All; 236 Unlock_Task.all; 237 end Get_Registered_Exceptions; 238 239 ------------------------ 240 -- Internal_Exception -- 241 ------------------------ 242 243 function Internal_Exception 244 (X : String; 245 Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr 246 is 247 -- If X was not yet registered and Create_if_Not_Exist is True, 248 -- dynamically allocate and register a new exception. 249 250 type String_Ptr is access all String; 251 252 Dyn_Copy : String_Ptr; 253 Copy : aliased String (X'First .. X'Last + 1); 254 Result : Exception_Data_Ptr; 255 256 begin 257 Lock_Task.all; 258 259 Copy (X'Range) := X; 260 Copy (Copy'Last) := ASCII.NUL; 261 Result := Lookup (Copy); 262 263 -- If unknown exception, create it on the heap. This is a legitimate 264 -- situation in the distributed case when an exception is defined 265 -- only in a partition 266 267 if Result = null and then Create_If_Not_Exist then 268 Dyn_Copy := new String'(Copy); 269 270 Result := 271 new Exception_Data' 272 (Not_Handled_By_Others => False, 273 Lang => 'A', 274 Name_Length => Copy'Length, 275 Full_Name => Dyn_Copy.all'Address, 276 HTable_Ptr => null, 277 Foreign_Data => Null_Address, 278 Raise_Hook => null); 279 280 Register (Result); 281 end if; 282 283 Unlock_Task.all; 284 285 return Result; 286 end Internal_Exception; 287 288 ------------------------ 289 -- Register_Exception -- 290 ------------------------ 291 292 procedure Register_Exception (X : Exception_Data_Ptr) is 293 begin 294 Lock_Task.all; 295 Register (X); 296 Unlock_Task.all; 297 end Register_Exception; 298 299 --------------------------------- 300 -- Registered_Exceptions_Count -- 301 --------------------------------- 302 303 function Registered_Exceptions_Count return Natural is 304 Count : Natural := 0; 305 306 procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean); 307 -- Update Count for given Item 308 309 procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is 310 pragma Unreferenced (Item); 311 begin 312 Count := Count + 1; 313 More := Count < Natural'Last; 314 end Count_Item; 315 316 procedure Count_All is new Iterate (Count_Item); 317 318 begin 319 Lock_Task.all; 320 Count_All; 321 Unlock_Task.all; 322 323 return Count; 324 end Registered_Exceptions_Count; 325 326begin 327 -- Register the standard exceptions at elaboration time 328 329 -- We don't need to use the locking version here as the elaboration 330 -- will not be concurrent and no tasks can call any subprograms of this 331 -- unit before it has been elaborated. 332 333 Register (Abort_Signal_Def'Access); 334 Register (Tasking_Error_Def'Access); 335 Register (Storage_Error_Def'Access); 336 Register (Program_Error_Def'Access); 337 Register (Numeric_Error_Def'Access); 338 Register (Constraint_Error_Def'Access); 339end System.Exception_Table; 340