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 -------------------------