1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E --
9 -- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This is an Alpha/VMS package.
37 pragma Elaborate_All (System.HTable);
39 package body System.VMS_Exception_Table is
41 use System.Standard_Library;
43 type HTable_Headers is range 1 .. 37;
45 type Exception_Code_Data;
46 type Exception_Code_Data_Ptr is access all Exception_Code_Data;
48 -- The following record maps an imported VMS condition to an
51 type Exception_Code_Data is record
53 Except : Exception_Data_Ptr;
54 HTable_Ptr : Exception_Code_Data_Ptr;
58 (T : Exception_Code_Data_Ptr;
59 Next : Exception_Code_Data_Ptr);
61 function Get_HT_Link (T : Exception_Code_Data_Ptr)
62 return Exception_Code_Data_Ptr;
64 function Hash (F : Natural) return HTable_Headers;
65 function Get_Key (T : Exception_Code_Data_Ptr) return Natural;
67 package Exception_Code_HTable is new System.HTable.Static_HTable (
68 Header_Num => HTable_Headers,
69 Element => Exception_Code_Data,
70 Elmt_Ptr => Exception_Code_Data_Ptr,
72 Set_Next => Set_HT_Link,
83 function Coded_Exception (X : Natural) return Exception_Data_Ptr is
84 Res : Exception_Code_Data_Ptr;
87 Res := Exception_Code_HTable.Get (X);
101 function Get_HT_Link (T : Exception_Code_Data_Ptr)
102 return Exception_Code_Data_Ptr is
111 function Get_Key (T : Exception_Code_Data_Ptr) return Natural is
120 function Hash (F : Natural) return HTable_Headers is
122 return HTable_Headers
123 (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1);
126 ----------------------------
127 -- Register_VMS_Exception --
128 ----------------------------
130 procedure Register_VMS_Exception (Code : Integer) is
131 Excode : constant Integer := (Code / 8) * 8;
132 -- Mask off lower 3 bits which are the severity
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
140 if Exception_Code_HTable.Get (Excode) = null then
141 Exception_Code_HTable.Set
142 (new Exception_Code_Data'
145 (Not_Handled_By_Others => False,
154 end Register_VMS_Exception;
160 procedure Set_HT_Link
161 (T : Exception_Code_Data_Ptr;
162 Next : Exception_Code_Data_Ptr)
165 T.HTable_Ptr := Next;
168 end System.VMS_Exception_Table;