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