gcc/ada/s-vmexta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --           S Y S T E M . V M S _ E X C E P T I O N _ T A B L E            --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1997-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 --  This is an Alpha/VMS package.
  35
  36 with GNAT.HTable;
  37 pragma Elaborate_All (GNAT.HTable);
  38
  39 package body System.VMS_Exception_Table is
  40
  41    use System.Standard_Library;
  42
  43    type HTable_Headers is range 1 .. 37;
  44
  45    type Exception_Code_Data;
  46    type Exception_Code_Data_Ptr is access all Exception_Code_Data;
  47
  48    --  The following record maps an imported VMS condition to an
  49    --  Ada exception.
  50
  51    type Exception_Code_Data is record
  52       Code       : Natural;
  53       Except     : Exception_Data_Ptr;
  54       HTable_Ptr : Exception_Code_Data_Ptr;
  55    end record;
  56
  57    procedure Set_HT_Link
  58      (T    : Exception_Code_Data_Ptr;
  59       Next : Exception_Code_Data_Ptr);
  60
  61    function Get_HT_Link (T : Exception_Code_Data_Ptr)
  62      return Exception_Code_Data_Ptr;
  63
  64    function Hash (F : Natural) return HTable_Headers;
  65    function Get_Key (T : Exception_Code_Data_Ptr) return Natural;
  66
  67    package Exception_Code_HTable is new GNAT.HTable.Static_HTable (
  68      Header_Num => HTable_Headers,
  69      Element    => Exception_Code_Data,
  70      Elmt_Ptr   => Exception_Code_Data_Ptr,
  71      Null_Ptr   => null,
  72      Set_Next   => Set_HT_Link,
  73      Next       => Get_HT_Link,
  74      Key        => Natural,
  75      Get_Key    => Get_Key,
  76      Hash       => Hash,
  77      Equal      => "=");
  78
  79    ---------------------
  80    -- Coded_Exception --
  81    ---------------------
  82
  83    function Coded_Exception (X : Natural) return Exception_Data_Ptr is
  84       Res : Exception_Code_Data_Ptr;
  85
  86    begin
  87       Res := Exception_Code_HTable.Get (X);
  88
  89       if Res /= null  then
  90          return Res.Except;
  91       else
  92          return null;
  93       end if;
  94
  95    end Coded_Exception;
  96
  97    -----------------
  98    -- Get_HT_Link --
  99    -----------------
 100
 101    function  Get_HT_Link (T : Exception_Code_Data_Ptr)
 102      return Exception_Code_Data_Ptr is
 103    begin
 104       return T.HTable_Ptr;
 105    end Get_HT_Link;
 106
 107    -------------
 108    -- Get_Key --
 109    -------------
 110
 111    function Get_Key (T : Exception_Code_Data_Ptr) return Natural is
 112    begin
 113       return T.Code;
 114    end Get_Key;
 115
 116    ----------
 117    -- Hash --
 118    ----------
 119
 120    function Hash (F : Natural) return HTable_Headers is
 121    begin
 122       return HTable_Headers
 123         (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1);
 124    end Hash;
 125
 126    ----------------------------
 127    -- Register_VMS_Exception --
 128    ----------------------------
 129
 130    procedure Register_VMS_Exception (Code : Integer) is
 131       --  Mask off lower 3 bits which are the severity
 132
 133       Excode : Integer := (Code / 8) * 8;
 134    begin
 135
 136       --  This allocates an empty exception that gets filled in by
 137       --  __gnat_error_handler when the exception is raised. Allocating
 138       --  it here prevents having to allocate it each time the exception
 139       --  is raised.
 140
 141       if Exception_Code_HTable.Get (Excode) = null then
 142          Exception_Code_HTable.Set
 143            (new Exception_Code_Data'
 144              (Excode,
 145               new Exception_Data'(False, 'V', 0, null, null, 0),
 146               null));
 147       end if;
 148    end Register_VMS_Exception;
 149
 150    -----------------
 151    -- Set_HT_Link --
 152    -----------------
 153
 154    procedure Set_HT_Link
 155      (T    : Exception_Code_Data_Ptr;
 156       Next : Exception_Code_Data_Ptr)
 157    is
 158    begin
 159       T.HTable_Ptr := Next;
 160    end Set_HT_Link;
 161
 162 end System.VMS_Exception_Table;