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 --                                                                          --
  10 --          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with GNAT.HTable;
  36
  37 package 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 : Big_String_Ptr) return HTable_Headers;
  47    function Equal (A, B : Big_String_Ptr) return Boolean;
  48    function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr;
  49
  50    package Exception_HTable is new GNAT.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        => Big_String_Ptr,
  58      Get_Key    => Get_Key,
  59      Hash       => Hash,
  60      Equal      => Equal);
  61
  62    -----------
  63    -- Equal --
  64    -----------
  65
  66    function Equal (A, B : Big_String_Ptr) return Boolean is
  67       J    : Integer := 1;
  68
  69    begin
  70       loop
  71          if A (J) /= B (J) then
  72             return False;
  73
  74          elsif A (J) = ASCII.NUL then
  75             return True;
  76
  77          else
  78             J := J + 1;
  79          end if;
  80       end loop;
  81    end Equal;
  82
  83    -----------------
  84    -- Get_HT_Link --
  85    -----------------
  86
  87    function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
  88    begin
  89       return T.HTable_Ptr;
  90    end Get_HT_Link;
  91
  92    -------------
  93    -- Get_Key --
  94    -------------
  95
  96    function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr is
  97    begin
  98       return T.Full_Name;
  99    end Get_Key;
 100
 101    ----------
 102    -- Hash --
 103    ----------
 104
 105    function Hash (F : Big_String_Ptr) return HTable_Headers is
 106       type S is mod 2**8;
 107
 108       Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
 109       Tmp  : S := 0;
 110       J    : Positive;
 111
 112    begin
 113       J := 1;
 114       loop
 115          if F (J) = ASCII.NUL then
 116             return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
 117          else
 118             Tmp := Tmp xor S (Character'Pos (F (J)));
 119          end if;
 120          J := J + 1;
 121       end loop;
 122    end Hash;
 123
 124    ------------------------
 125    -- Internal_Exception --
 126    ------------------------
 127
 128    type String_Ptr is access all String;
 129
 130    function Internal_Exception (X : String) return Exception_Data_Ptr is
 131       Copy     : aliased String (X'First .. X'Last + 1);
 132       Res      : Exception_Data_Ptr;
 133       Dyn_Copy : String_Ptr;
 134
 135    begin
 136       Copy (X'Range) := X;
 137       Copy (Copy'Last) := ASCII.NUL;
 138       Res := Exception_HTable.Get (To_Ptr (Copy'Address));
 139
 140       --  If unknown exception, create it on the heap. This is a legitimate
 141       --  situation in the distributed case when an exception is defined only
 142       --  in a partition
 143
 144       if Res = null  then
 145          Dyn_Copy := new String'(Copy);
 146
 147          Res :=
 148            new Exception_Data'
 149              (Not_Handled_By_Others => False,
 150               Lang                  => 'A',
 151               Name_Length           => Copy'Length,
 152               Full_Name             => To_Ptr (Dyn_Copy.all'Address),
 153               HTable_Ptr            => null,
 154               Import_Code           => 0);
 155
 156          Register_Exception (Res);
 157       end if;
 158
 159       return Res;
 160    end Internal_Exception;
 161
 162    ------------------------
 163    -- Register_Exception --
 164    ------------------------
 165
 166    procedure Register_Exception (X : Exception_Data_Ptr) is
 167    begin
 168       Exception_HTable.Set (X);
 169    end Register_Exception;
 170
 171    -----------------
 172    -- Set_HT_Link --
 173    -----------------
 174
 175    procedure Set_HT_Link
 176      (T    : Exception_Data_Ptr;
 177       Next : Exception_Data_Ptr)
 178    is
 179    begin
 180       T.HTable_Ptr := Next;
 181    end Set_HT_Link;
 182
 183 begin
 184    Register_Exception (Abort_Signal_Def'Access);
 185    Register_Exception (Tasking_Error_Def'Access);
 186    Register_Exception (Storage_Error_Def'Access);
 187    Register_Exception (Program_Error_Def'Access);
 188    Register_Exception (Numeric_Error_Def'Access);
 189    Register_Exception (Constraint_Error_Def'Access);
 190
 191 end System.Exception_Table;