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