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-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. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  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;