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-2001, 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
(GNAT
.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 GNAT
.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 -- Mask off lower 3 bits which are the severity
133 Excode
: Integer := (Code
/ 8) * 8;
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
141 if Exception_Code_HTable
.Get
(Excode
) = null then
142 Exception_Code_HTable
.Set
143 (new Exception_Code_Data
'
145 new Exception_Data'(False, 'V', 0, null, null, 0),
148 end Register_VMS_Exception
;
154 procedure Set_HT_Link
155 (T
: Exception_Code_Data_Ptr
;
156 Next
: Exception_Code_Data_Ptr
)
159 T
.HTable_Ptr
:= Next
;
162 end System
.VMS_Exception_Table
;