gcc/ada/s-exctab.adb

   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-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 pragma Warnings (Off);
  35 pragma Compiler_Unit;
  36 pragma Warnings (On);
  37
  38 with System.HTable;
  39 with System.Soft_Links;   use System.Soft_Links;
  40
  41 package body System.Exception_Table is
  42
  43    use System.Standard_Library;
  44
  45    type HTable_Headers is range 1 .. 37;
  46
  47    procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
  48    function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
  49
  50    function Hash (F : System.Address) return HTable_Headers;
  51    function Equal (A, B : System.Address) return Boolean;
  52    function Get_Key (T : Exception_Data_Ptr) return System.Address;
  53
  54    package Exception_HTable is new System.HTable.Static_HTable (
  55      Header_Num => HTable_Headers,
  56      Element    => Exception_Data,
  57      Elmt_Ptr   => Exception_Data_Ptr,
  58      Null_Ptr   => null,
  59      Set_Next   => Set_HT_Link,
  60      Next       => Get_HT_Link,
  61      Key        => System.Address,
  62      Get_Key    => Get_Key,
  63      Hash       => Hash,
  64      Equal      => Equal);
  65
  66    -----------
  67    -- Equal --
  68    -----------
  69
  70    function Equal (A, B : System.Address) return Boolean is
  71       S1 : constant Big_String_Ptr := To_Ptr (A);
  72       S2 : constant Big_String_Ptr := To_Ptr (B);
  73       J : Integer := 1;
  74
  75    begin
  76       loop
  77          if S1 (J) /= S2 (J) then
  78             return False;
  79
  80          elsif S1 (J) = ASCII.NUL then
  81             return True;
  82
  83          else
  84             J := J + 1;
  85          end if;
  86       end loop;
  87    end Equal;
  88
  89    -----------------
  90    -- Get_HT_Link --
  91    -----------------
  92
  93    function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
  94    begin
  95       return T.HTable_Ptr;
  96    end Get_HT_Link;
  97
  98    -------------
  99    -- Get_Key --
 100    -------------
 101
 102    function Get_Key (T : Exception_Data_Ptr) return System.Address is
 103    begin
 104       return T.Full_Name;
 105    end Get_Key;
 106
 107    -------------------------------
 108    -- Get_Registered_Exceptions --
 109    -------------------------------
 110
 111    procedure Get_Registered_Exceptions
 112      (List : out Exception_Data_Array;
 113       Last : out Integer)
 114    is
 115       Data : Exception_Data_Ptr := Exception_HTable.Get_First;
 116
 117    begin
 118       Lock_Task.all;
 119       Last := List'First - 1;
 120
 121       while Last < List'Last and then Data /= null loop
 122          Last := Last + 1;
 123          List (Last) := Data;
 124          Data := Exception_HTable.Get_Next;
 125       end loop;
 126
 127       Unlock_Task.all;
 128    end Get_Registered_Exceptions;
 129
 130    ----------
 131    -- Hash --
 132    ----------
 133
 134    function Hash (F : System.Address) return HTable_Headers is
 135       type S is mod 2**8;
 136
 137       Str  : constant Big_String_Ptr := To_Ptr (F);
 138       Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
 139       Tmp  : S := 0;
 140       J    : Positive;
 141
 142    begin
 143       J := 1;
 144       loop
 145          if Str (J) = ASCII.NUL then
 146             return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
 147          else
 148             Tmp := Tmp xor S (Character'Pos (Str (J)));
 149          end if;
 150          J := J + 1;
 151       end loop;
 152    end Hash;
 153
 154    ------------------------
 155    -- Internal_Exception --
 156    ------------------------
 157
 158    function Internal_Exception
 159      (X                   : String;
 160       Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
 161    is
 162       type String_Ptr is access all String;
 163
 164       Copy     : aliased String (X'First .. X'Last + 1);
 165       Res      : Exception_Data_Ptr;
 166       Dyn_Copy : String_Ptr;
 167
 168    begin
 169       Copy (X'Range) := X;
 170       Copy (Copy'Last) := ASCII.NUL;
 171       Res := Exception_HTable.Get (Copy'Address);
 172
 173       --  If unknown exception, create it on the heap. This is a legitimate
 174       --  situation in the distributed case when an exception is defined only
 175       --  in a partition
 176
 177       if Res = null and then Create_If_Not_Exist then
 178          Dyn_Copy := new String'(Copy);
 179
 180          Res :=
 181            new Exception_Data'
 182              (Not_Handled_By_Others => False,
 183               Lang                  => 'A',
 184               Name_Length           => Copy'Length,
 185               Full_Name             => Dyn_Copy.all'Address,
 186               HTable_Ptr            => null,
 187               Import_Code           => 0,
 188               Raise_Hook            => null);
 189
 190          Register_Exception (Res);
 191       end if;
 192
 193       return Res;
 194    end Internal_Exception;
 195
 196    ------------------------
 197    -- Register_Exception --
 198    ------------------------
 199
 200    procedure Register_Exception (X : Exception_Data_Ptr) is
 201    begin
 202       Exception_HTable.Set (X);
 203    end Register_Exception;
 204
 205    ---------------------------------
 206    -- Registered_Exceptions_Count --
 207    ---------------------------------
 208
 209    function Registered_Exceptions_Count return Natural is
 210       Count : Natural := 0;
 211       Data  : Exception_Data_Ptr := Exception_HTable.Get_First;
 212
 213    begin
 214       --  We need to lock the runtime in the meantime, to avoid concurrent
 215       --  access since we have only one iterator.
 216
 217       Lock_Task.all;
 218
 219       while Data /= null loop
 220          Count := Count + 1;
 221          Data := Exception_HTable.Get_Next;
 222       end loop;
 223
 224       Unlock_Task.all;
 225       return Count;
 226    end Registered_Exceptions_Count;
 227
 228    -----------------
 229    -- Set_HT_Link --
 230    -----------------
 231
 232    procedure Set_HT_Link
 233      (T    : Exception_Data_Ptr;
 234       Next : Exception_Data_Ptr)
 235    is
 236    begin
 237       T.HTable_Ptr := Next;
 238    end Set_HT_Link;
 239
 240 --  Register the standard exceptions at elaboration time
 241
 242 begin
 243    Register_Exception (Abort_Signal_Def'Access);
 244    Register_Exception (Tasking_Error_Def'Access);
 245    Register_Exception (Storage_Error_Def'Access);
 246    Register_Exception (Program_Error_Def'Access);
 247    Register_Exception (Numeric_Error_Def'Access);
 248    Register_Exception (Constraint_Error_Def'Access);
 249
 250 end System.Exception_Table;