------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--           S Y S T E M . V M S _ E X C E P T I O N _ T A B L E            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1997-2004, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is an Alpha/VMS package.

with System.HTable;
pragma Elaborate_All (System.HTable);

package body System.VMS_Exception_Table is

   use type SSL.Exception_Code;

   type HTable_Headers is range 1 .. 37;

   type Exception_Code_Data;
   type Exception_Code_Data_Ptr is access all Exception_Code_Data;

   --  The following record maps an imported VMS condition to an
   --  Ada exception.

   type Exception_Code_Data is record
      Code       : SSL.Exception_Code;
      Except     : SSL.Exception_Data_Ptr;
      HTable_Ptr : Exception_Code_Data_Ptr;
   end record;

   procedure Set_HT_Link
     (T    : Exception_Code_Data_Ptr;
      Next : Exception_Code_Data_Ptr);

   function Get_HT_Link (T : Exception_Code_Data_Ptr)
     return Exception_Code_Data_Ptr;

   function Hash (F : SSL.Exception_Code) return HTable_Headers;
   function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code;

   package Exception_Code_HTable is new System.HTable.Static_HTable (
     Header_Num => HTable_Headers,
     Element    => Exception_Code_Data,
     Elmt_Ptr   => Exception_Code_Data_Ptr,
     Null_Ptr   => null,
     Set_Next   => Set_HT_Link,
     Next       => Get_HT_Link,
     Key        => SSL.Exception_Code,
     Get_Key    => Get_Key,
     Hash       => Hash,
     Equal      => "=");

   ------------------
   -- Base_Code_In --
   ------------------

   function Base_Code_In
     (Code : SSL.Exception_Code) return SSL.Exception_Code
   is
   begin
      return Code and not 2#0111#;
   end Base_Code_In;

   ---------------------
   -- Coded_Exception --
   ---------------------

   function Coded_Exception
     (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr
   is
      Res : Exception_Code_Data_Ptr;

   begin
      Res := Exception_Code_HTable.Get (X);

      if Res /= null  then
         return Res.Except;
      else
         return null;
      end if;

   end Coded_Exception;

   -----------------
   -- Get_HT_Link --
   -----------------

   function Get_HT_Link
     (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr
   is
   begin
      return T.HTable_Ptr;
   end Get_HT_Link;

   -------------
   -- Get_Key --
   -------------

   function Get_Key (T : Exception_Code_Data_Ptr)
     return SSL.Exception_Code
   is
   begin
      return T.Code;
   end Get_Key;

   ----------
   -- Hash --
   ----------

   function Hash
     (F : SSL.Exception_Code) return HTable_Headers
   is
      Headers_Magnitude : constant SSL.Exception_Code :=
        SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);

   begin
      return HTable_Headers (F mod Headers_Magnitude + 1);
   end Hash;

   ----------------------------
   -- Register_VMS_Exception --
   ----------------------------

   procedure Register_VMS_Exception
     (Code : SSL.Exception_Code;
      E    : SSL.Exception_Data_Ptr)
   is
      --  We bind the exception data with the base code found in the
      --  input value, that is with the severity bits masked off.

      Excode : constant SSL.Exception_Code := Base_Code_In (Code);

   begin
      --  The exception data registered here is mostly filled prior to this
      --  call and by __gnat_error_handler when the exception is raised. We
      --  still need to fill a couple of components for exceptions that will
      --  be used as propagation filters (exception data pointer registered
      --  as choices in the unwind tables): in some import/export cases, the
      --  exception pointers for the choice and the propagated occurrence may
      --  indeed be different for a single import code, and the personality
      --  routine attempts to match the import codes in this case.

      E.Lang := 'V';
      E.Import_Code := Excode;

      if Exception_Code_HTable.Get (Excode) = null then
         Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null));
      end if;
   end Register_VMS_Exception;

   -----------------
   -- Set_HT_Link --
   -----------------

   procedure Set_HT_Link
     (T    : Exception_Code_Data_Ptr;
      Next : Exception_Code_Data_Ptr)
   is
   begin
      T.HTable_Ptr := Next;
   end Set_HT_Link;

end System.VMS_Exception_Table;