git://gcc.gnu.org / gcc.git / blame
| Commit | Line | Data |
|---|---|---|
| cacbc350 RK |
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 | -- -- | |
| cacbc350 RK |
9 | -- Copyright (C) 1996-2001 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 2, 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. See the GNU General Public License -- | |
| 17 | -- for more details. You should have received a copy of the GNU General -- | |
| 18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
| 19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
| 20 | -- MA 02111-1307, USA. -- | |
| 21 | -- -- | |
| 22 | -- As a special exception, if other files instantiate generics from this -- | |
| 23 | -- unit, or you link this unit with other files to produce an executable, -- | |
| 24 | -- this unit does not by itself cause the resulting executable to be -- | |
| 25 | -- covered by the GNU General Public License. This exception does not -- | |
| 26 | -- however invalidate any other reasons why the executable file might be -- | |
| 27 | -- covered by the GNU Public License. -- | |
| 28 | -- -- | |
| 29 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
| 71ff80dc | 30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| cacbc350 RK |
31 | -- -- |
| 32 | ------------------------------------------------------------------------------ | |
| 33 | ||
| 34 | with GNAT.HTable; | |
| 35 | ||
| 36 | package body System.Exception_Table is | |
| 37 | ||
| 38 | use System.Standard_Library; | |
| 39 | ||
| 40 | type HTable_Headers is range 1 .. 37; | |
| 41 | ||
| 42 | procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr); | |
| 43 | function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr; | |
| 44 | ||
| 45 | function Hash (F : Big_String_Ptr) return HTable_Headers; | |
| 46 | function Equal (A, B : Big_String_Ptr) return Boolean; | |
| 47 | function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr; | |
| 48 | ||
| 49 | package Exception_HTable is new GNAT.HTable.Static_HTable ( | |
| 50 | Header_Num => HTable_Headers, | |
| 51 | Element => Exception_Data, | |
| 52 | Elmt_Ptr => Exception_Data_Ptr, | |
| 53 | Null_Ptr => null, | |
| 54 | Set_Next => Set_HT_Link, | |
| 55 | Next => Get_HT_Link, | |
| 56 | Key => Big_String_Ptr, | |
| 57 | Get_Key => Get_Key, | |
| 58 | Hash => Hash, | |
| 59 | Equal => Equal); | |
| 60 | ||
| 61 | ----------- | |
| 62 | -- Equal -- | |
| 63 | ----------- | |
| 64 | ||
| 65 | function Equal (A, B : Big_String_Ptr) return Boolean is | |
| 66 | J : Integer := 1; | |
| 67 | ||
| 68 | begin | |
| 69 | loop | |
| 70 | if A (J) /= B (J) then | |
| 71 | return False; | |
| 72 | ||
| 73 | elsif A (J) = ASCII.NUL then | |
| 74 | return True; | |
| 75 | ||
| 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 Big_String_Ptr is | |
| 96 | begin | |
| 97 | return T.Full_Name; | |
| 98 | end Get_Key; | |
| 99 | ||
| 100 | ---------- | |
| 101 | -- Hash -- | |
| 102 | ---------- | |
| 103 | ||
| 104 | function Hash (F : Big_String_Ptr) return HTable_Headers is | |
| 105 | type S is mod 2**8; | |
| 106 | ||
| 107 | Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1); | |
| 108 | Tmp : S := 0; | |
| 109 | J : Positive; | |
| 110 | ||
| 111 | begin | |
| 112 | J := 1; | |
| 113 | loop | |
| 114 | if F (J) = ASCII.NUL then | |
| 115 | return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size); | |
| 116 | else | |
| 117 | Tmp := Tmp xor S (Character'Pos (F (J))); | |
| 118 | end if; | |
| 119 | J := J + 1; | |
| 120 | end loop; | |
| 121 | end Hash; | |
| 122 | ||
| 123 | ------------------------ | |
| 124 | -- Internal_Exception -- | |
| 125 | ------------------------ | |
| 126 | ||
| 127 | type String_Ptr is access all String; | |
| 128 | ||
| 129 | function Internal_Exception (X : String) return Exception_Data_Ptr is | |
| 130 | Copy : aliased String (X'First .. X'Last + 1); | |
| 131 | Res : Exception_Data_Ptr; | |
| 132 | Dyn_Copy : String_Ptr; | |
| 133 | ||
| 134 | begin | |
| 135 | Copy (X'Range) := X; | |
| 136 | Copy (Copy'Last) := ASCII.NUL; | |
| 137 | Res := Exception_HTable.Get (To_Ptr (Copy'Address)); | |
| 138 | ||
| 139 | -- If unknown exception, create it on the heap. This is a legitimate | |
| 140 | -- situation in the distributed case when an exception is defined only | |
| 141 | -- in a partition | |
| 142 | ||
| 143 | if Res = null then | |
| 144 | Dyn_Copy := new String'(Copy); | |
| 145 | ||
| 146 | Res := | |
| 147 | new Exception_Data' | |
| 148 | (Not_Handled_By_Others => False, | |
| 149 | Lang => 'A', | |
| 150 | Name_Length => Copy'Length, | |
| 151 | Full_Name => To_Ptr (Dyn_Copy.all'Address), | |
| 152 | HTable_Ptr => null, | |
| 153 | Import_Code => 0); | |
| 154 | ||
| 155 | Register_Exception (Res); | |
| 156 | end if; | |
| 157 | ||
| 158 | return Res; | |
| 159 | end Internal_Exception; | |
| 160 | ||
| 161 | ------------------------ | |
| 162 | -- Register_Exception -- | |
| 163 | ------------------------ | |
| 164 | ||
| 165 | procedure Register_Exception (X : Exception_Data_Ptr) is | |
| 166 | begin | |
| 167 | Exception_HTable.Set (X); | |
| 168 | end Register_Exception; | |
| 169 | ||
| 170 | ----------------- | |
| 171 | -- Set_HT_Link -- | |
| 172 | ----------------- | |
| 173 | ||
| 174 | procedure Set_HT_Link | |
| 175 | (T : Exception_Data_Ptr; | |
| 176 | Next : Exception_Data_Ptr) | |
| 177 | is | |
| 178 | begin | |
| 179 | T.HTable_Ptr := Next; | |
| 180 | end Set_HT_Link; | |
| 181 | ||
| 182 | begin | |
| 183 | Register_Exception (Abort_Signal_Def'Access); | |
| 184 | Register_Exception (Tasking_Error_Def'Access); | |
| 185 | Register_Exception (Storage_Error_Def'Access); | |
| 186 | Register_Exception (Program_Error_Def'Access); | |
| 187 | Register_Exception (Numeric_Error_Def'Access); | |
| 188 | Register_Exception (Constraint_Error_Def'Access); | |
| 189 | ||
| 190 | end System.Exception_Table; |