[thirdparty/gcc.git] / gcc / ada / s-vmexta.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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-2002, 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,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, 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 System.Standard_Library;

   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       : Natural;
      Except     : 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 : Natural) return HTable_Headers;
   function Get_Key (T : Exception_Code_Data_Ptr) return Natural;

   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        => Natural,
     Get_Key    => Get_Key,
     Hash       => Hash,
     Equal      => "=");

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

   function Coded_Exception (X : Natural) return 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 Natural is
   begin
      return T.Code;
   end Get_Key;

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

   function Hash (F : Natural) return HTable_Headers is
   begin
      return HTable_Headers
        (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1);
   end Hash;

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

   procedure Register_VMS_Exception (Code : Integer) is
      Excode : constant Integer := (Code / 8) * 8;
      --  Mask off lower 3 bits which are the severity

   begin
      --  This allocates an empty exception that gets filled in by
      --  __gnat_error_handler when the exception is raised. Allocating
      --  it here prevents having to allocate it each time the exception
      --  is raised.

      if Exception_Code_HTable.Get (Excode) = null then
         Exception_Code_HTable.Set
           (new Exception_Code_Data'
             (Excode,
              new Exception_Data'
               (Not_Handled_By_Others => False,
                Lang                  => 'V',
                Name_Length           => 0,
                Full_Name             => null,
                HTable_Ptr            => null,
                Import_Code           => 0,
                Raise_Hook            => null),
              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;
Commit	Line	Data
cacbc350 RK	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	-- --
fbf5a39b	9	-- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
cacbc350 RK	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. --
71ff80dc	30	-- Extensive contributions were provided by Ada Core Technologies Inc. --
cacbc350 RK	31	-- --
	32	------------------------------------------------------------------------------
	33
	34	-- This is an Alpha/VMS package.
	35
fbf5a39b AC	36	with System.HTable;
fbf5a39b AC	37	pragma Elaborate_All (System.HTable);
cacbc350 RK	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
fbf5a39b	67	package Exception_Code_HTable is new System.HTable.Static_HTable (
cacbc350 RK	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
fbf5a39b	131	Excode : constant Integer := (Code / 8) * 8;
cacbc350 RK	132	-- Mask off lower 3 bits which are the severity
cacbc350 RK	133
cacbc350	134	begin
cacbc350 RK	135	-- This allocates an empty exception that gets filled in by
	136	-- __gnat_error_handler when the exception is raised. Allocating
	137	-- it here prevents having to allocate it each time the exception
	138	-- is raised.
	139
	140	if Exception_Code_HTable.Get (Excode) = null then
	141	Exception_Code_HTable.Set
	142	(new Exception_Code_Data'
	143	(Excode,
fbf5a39b AC	144	new Exception_Data'
	145	(Not_Handled_By_Others => False,
	146	Lang => 'V',
	147	Name_Length => 0,
	148	Full_Name => null,
	149	HTable_Ptr => null,
	150	Import_Code => 0,
	151	Raise_Hook => null),
cacbc350 RK	152	null));
	153	end if;
	154	end Register_VMS_Exception;
	155
	156	-----------------
	157	-- Set_HT_Link --
	158	-----------------
	159
	160	procedure Set_HT_Link
	161	(T : Exception_Code_Data_Ptr;
	162	Next : Exception_Code_Data_Ptr)
	163	is
	164	begin
	165	T.HTable_Ptr := Next;
	166	end Set_HT_Link;
	167
	168	end System.VMS_Exception_Table;