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