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-2013, 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); 36with System.Storage_Elements; use System.Storage_Elements; 37 38package body System.VMS_Exception_Table is 39 40 type HTable_Headers is range 1 .. 37; 41 42 type Exception_Code_Data; 43 type Exception_Code_Data_Ptr is access all Exception_Code_Data; 44 45 -- The following record maps an imported VMS condition to an 46 -- Ada exception. 47 48 type Exception_Code_Data is record 49 Code : Exception_Code; 50 Except : SSL.Exception_Data_Ptr; 51 HTable_Ptr : Exception_Code_Data_Ptr; 52 end record; 53 54 procedure Set_HT_Link 55 (T : Exception_Code_Data_Ptr; 56 Next : Exception_Code_Data_Ptr); 57 58 function Get_HT_Link (T : Exception_Code_Data_Ptr) 59 return Exception_Code_Data_Ptr; 60 61 function Hash (F : Exception_Code) return HTable_Headers; 62 function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code; 63 64 package Exception_Code_HTable is new System.HTable.Static_HTable ( 65 Header_Num => HTable_Headers, 66 Element => Exception_Code_Data, 67 Elmt_Ptr => Exception_Code_Data_Ptr, 68 Null_Ptr => null, 69 Set_Next => Set_HT_Link, 70 Next => Get_HT_Link, 71 Key => Exception_Code, 72 Get_Key => Get_Key, 73 Hash => Hash, 74 Equal => "="); 75 76 ------------------ 77 -- Base_Code_In -- 78 ------------------ 79 80 function Base_Code_In 81 (Code : Exception_Code) return Exception_Code 82 is 83 begin 84 return To_Address (To_Integer (Code) and not 2#0111#); 85 end Base_Code_In; 86 87 --------------------- 88 -- Coded_Exception -- 89 --------------------- 90 91 function Coded_Exception 92 (X : Exception_Code) return SSL.Exception_Data_Ptr 93 is 94 Res : Exception_Code_Data_Ptr; 95 96 begin 97 Res := Exception_Code_HTable.Get (X); 98 99 if Res /= null then 100 return Res.Except; 101 else 102 return null; 103 end if; 104 105 end Coded_Exception; 106 107 ----------------- 108 -- Get_HT_Link -- 109 ----------------- 110 111 function Get_HT_Link 112 (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr 113 is 114 begin 115 return T.HTable_Ptr; 116 end Get_HT_Link; 117 118 ------------- 119 -- Get_Key -- 120 ------------- 121 122 function Get_Key (T : Exception_Code_Data_Ptr) 123 return Exception_Code 124 is 125 begin 126 return T.Code; 127 end Get_Key; 128 129 ---------- 130 -- Hash -- 131 ---------- 132 133 function Hash 134 (F : Exception_Code) return HTable_Headers 135 is 136 Headers_Magnitude : constant Exception_Code := 137 Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); 138 139 begin 140 return HTable_Headers 141 (To_Address ((To_Integer (F) mod To_Integer (Headers_Magnitude)) + 1)); 142 end Hash; 143 144 ---------------------------- 145 -- Register_VMS_Exception -- 146 ---------------------------- 147 148 procedure Register_VMS_Exception 149 (Code : 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 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.Foreign_Data := 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