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-2009, 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 3, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is an Alpha/VMS package 33 34with System.HTable; 35pragma Elaborate_All (System.HTable); 36 37package body System.VMS_Exception_Table is 38 39 use type SSL.Exception_Code; 40 41 type HTable_Headers is range 1 .. 37; 42 43 type Exception_Code_Data; 44 type Exception_Code_Data_Ptr is access all Exception_Code_Data; 45 46 -- The following record maps an imported VMS condition to an 47 -- Ada exception. 48 49 type Exception_Code_Data is record 50 Code : SSL.Exception_Code; 51 Except : SSL.Exception_Data_Ptr; 52 HTable_Ptr : Exception_Code_Data_Ptr; 53 end record; 54 55 procedure Set_HT_Link 56 (T : Exception_Code_Data_Ptr; 57 Next : Exception_Code_Data_Ptr); 58 59 function Get_HT_Link (T : Exception_Code_Data_Ptr) 60 return Exception_Code_Data_Ptr; 61 62 function Hash (F : SSL.Exception_Code) return HTable_Headers; 63 function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code; 64 65 package Exception_Code_HTable is new System.HTable.Static_HTable ( 66 Header_Num => HTable_Headers, 67 Element => Exception_Code_Data, 68 Elmt_Ptr => Exception_Code_Data_Ptr, 69 Null_Ptr => null, 70 Set_Next => Set_HT_Link, 71 Next => Get_HT_Link, 72 Key => SSL.Exception_Code, 73 Get_Key => Get_Key, 74 Hash => Hash, 75 Equal => "="); 76 77 ------------------ 78 -- Base_Code_In -- 79 ------------------ 80 81 function Base_Code_In 82 (Code : SSL.Exception_Code) return SSL.Exception_Code 83 is 84 begin 85 return Code and not 2#0111#; 86 end Base_Code_In; 87 88 --------------------- 89 -- Coded_Exception -- 90 --------------------- 91 92 function Coded_Exception 93 (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr 94 is 95 Res : Exception_Code_Data_Ptr; 96 97 begin 98 Res := Exception_Code_HTable.Get (X); 99 100 if Res /= null then 101 return Res.Except; 102 else 103 return null; 104 end if; 105 106 end Coded_Exception; 107 108 ----------------- 109 -- Get_HT_Link -- 110 ----------------- 111 112 function Get_HT_Link 113 (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr 114 is 115 begin 116 return T.HTable_Ptr; 117 end Get_HT_Link; 118 119 ------------- 120 -- Get_Key -- 121 ------------- 122 123 function Get_Key (T : Exception_Code_Data_Ptr) 124 return SSL.Exception_Code 125 is 126 begin 127 return T.Code; 128 end Get_Key; 129 130 ---------- 131 -- Hash -- 132 ---------- 133 134 function Hash 135 (F : SSL.Exception_Code) return HTable_Headers 136 is 137 Headers_Magnitude : constant SSL.Exception_Code := 138 SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); 139 140 begin 141 return HTable_Headers (F mod Headers_Magnitude + 1); 142 end Hash; 143 144 ---------------------------- 145 -- Register_VMS_Exception -- 146 ---------------------------- 147 148 procedure Register_VMS_Exception 149 (Code : SSL.Exception_Code; 150 E : SSL.Exception_Data_Ptr) 151 is 152 -- We bind the exception data with the base code found in the 153 -- input value, that is with the severity bits masked off. 154 155 Excode : constant SSL.Exception_Code := Base_Code_In (Code); 156 157 begin 158 -- The exception data registered here is mostly filled prior to this 159 -- call and by __gnat_error_handler when the exception is raised. We 160 -- still need to fill a couple of components for exceptions that will 161 -- be used as propagation filters (exception data pointer registered 162 -- as choices in the unwind tables): in some import/export cases, the 163 -- exception pointers for the choice and the propagated occurrence may 164 -- indeed be different for a single import code, and the personality 165 -- routine attempts to match the import codes in this case. 166 167 E.Lang := 'V'; 168 E.Import_Code := Excode; 169 170 if Exception_Code_HTable.Get (Excode) = null then 171 Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null)); 172 end if; 173 end Register_VMS_Exception; 174 175 ----------------- 176 -- Set_HT_Link -- 177 ----------------- 178 179 procedure Set_HT_Link 180 (T : Exception_Code_Data_Ptr; 181 Next : Exception_Code_Data_Ptr) 182 is 183 begin 184 T.HTable_Ptr := Next; 185 end Set_HT_Link; 186 187end System.VMS_Exception_Table; 188