1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
10 -- Copyright (C) 2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- This is an AlphaVMS package that provides the interface between
36 -- GNAT, DECLib IO packages and the DECLib Bliss library.
38 pragma Extend_System (Aux_DEC);
40 with System; use System;
41 with System.Task_Primitives; use System.Task_Primitives;
42 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
43 with IO_Exceptions; use IO_Exceptions;
44 with Aux_IO_Exceptions; use Aux_IO_Exceptions;
46 package body DEC.IO is
48 type File_Type is record
49 FCB : Integer := 0; -- Temporary
53 for File_Type'Size use 64;
54 for File_Type'Alignment use 8;
56 for File_Type use record
57 FCB at 0 range 0 .. 31;
58 SEQ at 4 range 0 .. 31;
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
65 function GNAT_Name_64 (File : File_Type) return String;
66 pragma Export_Function (GNAT_Name_64, "GNAT$NAME_64");
69 function GNAT_Form_64 (File : File_Type) return String;
70 pragma Export_Function (GNAT_Form_64, "GNAT$FORM_64");
74 pragma Interface (C, Init_IO);
75 pragma Import_Procedure (Init_IO, "GNAT$$INIT_IO");
82 package body IO_Locking is
88 function Create_Mutex return Access_Mutex is
89 M : constant Access_Mutex := new RTS_Lock;
92 Initialize_Lock (M, Global_Task_Level);
100 procedure Acquire (M : Access_Mutex) is
109 procedure Release (M : Access_Mutex) is
120 function GNAT_Name_64 (File : File_Type) return String is
121 subtype Buffer_Subtype is String (1 .. 8192);
123 Buffer : Buffer_Subtype;
124 Length : System.Integer_32;
127 (File : System.Address;
128 MaxLen : System.Integer_32;
129 Buffer : out Buffer_Subtype;
130 Length : out System.Integer_32);
131 pragma Interface (C, Get_Name);
132 pragma Import_Procedure
133 (Get_Name, "GNAT$FILE_NAME",
134 Mechanism => (Value, Value, Reference, Reference));
137 Get_Name (File'Address, Buffer'Length, Buffer, Length);
138 return Buffer (1 .. Integer (Length));
145 function GNAT_Form_64 (File : File_Type) return String is
146 subtype Buffer_Subtype is String (1 .. 8192);
148 Buffer : Buffer_Subtype;
149 Length : System.Integer_32;
152 (File : System.Address;
153 MaxLen : System.Integer_32;
154 Buffer : out Buffer_Subtype;
155 Length : out System.Integer_32);
156 pragma Interface (C, Get_Form);
157 pragma Import_Procedure
158 (Get_Form, "GNAT$FILE_FORM",
159 Mechanism => (Value, Value, Reference, Reference));
162 Get_Form (File'Address, Buffer'Length, Buffer, Length);
163 return Buffer (1 .. Integer (Length));
166 ------------------------
167 -- Raise_IO_Exception --
168 ------------------------
170 procedure Raise_IO_Exception (EN : Exception_Number) is
173 when GNAT_EN_LOCK_ERROR => raise LOCK_ERROR;
174 when GNAT_EN_EXISTENCE_ERROR => raise EXISTENCE_ERROR;
175 when GNAT_EN_KEY_ERROR => raise KEY_ERROR;
176 when GNAT_EN_KEYSIZERR => raise PROGRAM_ERROR; -- KEYSIZERR;
177 when GNAT_EN_STAOVF => raise STORAGE_ERROR; -- STAOVF;
178 when GNAT_EN_CONSTRAINT_ERRO => raise CONSTRAINT_ERROR;
179 when GNAT_EN_IOSYSFAILED => raise DEVICE_ERROR; -- IOSYSFAILED;
180 when GNAT_EN_LAYOUT_ERROR => raise LAYOUT_ERROR;
181 when GNAT_EN_STORAGE_ERROR => raise STORAGE_ERROR;
182 when GNAT_EN_DATA_ERROR => raise DATA_ERROR;
183 when GNAT_EN_DEVICE_ERROR => raise DEVICE_ERROR;
184 when GNAT_EN_END_ERROR => raise END_ERROR;
185 when GNAT_EN_MODE_ERROR => raise MODE_ERROR;
186 when GNAT_EN_NAME_ERROR => raise NAME_ERROR;
187 when GNAT_EN_STATUS_ERROR => raise STATUS_ERROR;
188 when GNAT_EN_NOT_OPEN => raise USE_ERROR; -- NOT_OPEN;
189 when GNAT_EN_ALREADY_OPEN => raise USE_ERROR; -- ALREADY_OPEN;
190 when GNAT_EN_USE_ERROR => raise USE_ERROR;
191 when GNAT_EN_UNSUPPORTED => raise USE_ERROR; -- UNSUPPORTED;
192 when GNAT_EN_FAC_MODE_MISMAT => raise USE_ERROR; -- FAC_MODE_MISMAT;
193 when GNAT_EN_ORG_MISMATCH => raise USE_ERROR; -- ORG_MISMATCH;
194 when GNAT_EN_RFM_MISMATCH => raise USE_ERROR; -- RFM_MISMATCH;
195 when GNAT_EN_RAT_MISMATCH => raise USE_ERROR; -- RAT_MISMATCH;
196 when GNAT_EN_MRS_MISMATCH => raise USE_ERROR; -- MRS_MISMATCH;
197 when GNAT_EN_MRN_MISMATCH => raise USE_ERROR; -- MRN_MISMATCH;
198 when GNAT_EN_KEY_MISMATCH => raise USE_ERROR; -- KEY_MISMATCH;
199 when GNAT_EN_MAXLINEXC => raise CONSTRAINT_ERROR; -- MAXLINEXC;
200 when GNAT_EN_LINEXCMRS => raise CONSTRAINT_ERROR; -- LINEXCMRS;
202 end Raise_IO_Exception;
204 -------------------------
205 -- Package Elaboration --
206 -------------------------