1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This is an AlphaVMS package that provides the interface between
35 -- GNAT, DECLib IO packages and the DECLib Bliss library.
37 pragma Extend_System
(Aux_DEC
);
39 with System
; use System
;
40 with System
.Task_Primitives
; use System
.Task_Primitives
;
41 with System
.Task_Primitives
.Operations
; use System
.Task_Primitives
.Operations
;
42 with IO_Exceptions
; use IO_Exceptions
;
43 with Aux_IO_Exceptions
; use Aux_IO_Exceptions
;
45 package body DEC
.IO
is
47 type File_Type
is record
48 FCB
: Integer := 0; -- Temporary
52 for File_Type
'Size use 64;
53 for File_Type
'Alignment use 8;
55 for File_Type
use record
56 FCB
at 0 range 0 .. 31;
57 SEQ
at 4 range 0 .. 31;
60 -----------------------
61 -- Local Subprograms --
62 -----------------------
64 function GNAT_Name_64
(File
: File_Type
) return String;
65 pragma Export_Function
(GNAT_Name_64
, "GNAT$NAME_64");
68 function GNAT_Form_64
(File
: File_Type
) return String;
69 pragma Export_Function
(GNAT_Form_64
, "GNAT$FORM_64");
73 pragma Interface
(C
, Init_IO
);
74 pragma Import_Procedure
(Init_IO
, "GNAT$$INIT_IO");
81 package body IO_Locking
is
87 function Create_Mutex
return Access_Mutex
is
88 M
: constant Access_Mutex
:= new RTS_Lock
;
91 Initialize_Lock
(M
, Global_Task_Level
);
99 procedure Acquire
(M
: Access_Mutex
) is
108 procedure Release
(M
: Access_Mutex
) is
119 function GNAT_Name_64
(File
: File_Type
) return String is
120 subtype Buffer_Subtype
is String (1 .. 8192);
122 Buffer
: Buffer_Subtype
;
123 Length
: System
.Integer_32
;
126 (File
: System
.Address
;
127 MaxLen
: System
.Integer_32
;
128 Buffer
: out Buffer_Subtype
;
129 Length
: out System
.Integer_32
);
130 pragma Interface
(C
, Get_Name
);
131 pragma Import_Procedure
132 (Get_Name
, "GNAT$FILE_NAME",
133 Mechanism
=> (Value
, Value
, Reference
, Reference
));
136 Get_Name
(File
'Address, Buffer
'Length, Buffer
, Length
);
137 return Buffer
(1 .. Integer (Length
));
144 function GNAT_Form_64
(File
: File_Type
) return String is
145 subtype Buffer_Subtype
is String (1 .. 8192);
147 Buffer
: Buffer_Subtype
;
148 Length
: System
.Integer_32
;
151 (File
: System
.Address
;
152 MaxLen
: System
.Integer_32
;
153 Buffer
: out Buffer_Subtype
;
154 Length
: out System
.Integer_32
);
155 pragma Interface
(C
, Get_Form
);
156 pragma Import_Procedure
157 (Get_Form
, "GNAT$FILE_FORM",
158 Mechanism
=> (Value
, Value
, Reference
, Reference
));
161 Get_Form
(File
'Address, Buffer
'Length, Buffer
, Length
);
162 return Buffer
(1 .. Integer (Length
));
165 ------------------------
166 -- Raise_IO_Exception --
167 ------------------------
169 procedure Raise_IO_Exception
(EN
: Exception_Number
) is
172 when GNAT_EN_LOCK_ERROR
=> raise LOCK_ERROR
;
173 when GNAT_EN_EXISTENCE_ERROR
=> raise EXISTENCE_ERROR
;
174 when GNAT_EN_KEY_ERROR
=> raise KEY_ERROR
;
175 when GNAT_EN_KEYSIZERR
=> raise PROGRAM_ERROR
; -- KEYSIZERR;
176 when GNAT_EN_STAOVF
=> raise STORAGE_ERROR
; -- STAOVF;
177 when GNAT_EN_CONSTRAINT_ERRO
=> raise CONSTRAINT_ERROR
;
178 when GNAT_EN_IOSYSFAILED
=> raise DEVICE_ERROR
; -- IOSYSFAILED;
179 when GNAT_EN_LAYOUT_ERROR
=> raise LAYOUT_ERROR
;
180 when GNAT_EN_STORAGE_ERROR
=> raise STORAGE_ERROR
;
181 when GNAT_EN_DATA_ERROR
=> raise DATA_ERROR
;
182 when GNAT_EN_DEVICE_ERROR
=> raise DEVICE_ERROR
;
183 when GNAT_EN_END_ERROR
=> raise END_ERROR
;
184 when GNAT_EN_MODE_ERROR
=> raise MODE_ERROR
;
185 when GNAT_EN_NAME_ERROR
=> raise NAME_ERROR
;
186 when GNAT_EN_STATUS_ERROR
=> raise STATUS_ERROR
;
187 when GNAT_EN_NOT_OPEN
=> raise USE_ERROR
; -- NOT_OPEN;
188 when GNAT_EN_ALREADY_OPEN
=> raise USE_ERROR
; -- ALREADY_OPEN;
189 when GNAT_EN_USE_ERROR
=> raise USE_ERROR
;
190 when GNAT_EN_UNSUPPORTED
=> raise USE_ERROR
; -- UNSUPPORTED;
191 when GNAT_EN_FAC_MODE_MISMAT
=> raise USE_ERROR
; -- FAC_MODE_MISMAT;
192 when GNAT_EN_ORG_MISMATCH
=> raise USE_ERROR
; -- ORG_MISMATCH;
193 when GNAT_EN_RFM_MISMATCH
=> raise USE_ERROR
; -- RFM_MISMATCH;
194 when GNAT_EN_RAT_MISMATCH
=> raise USE_ERROR
; -- RAT_MISMATCH;
195 when GNAT_EN_MRS_MISMATCH
=> raise USE_ERROR
; -- MRS_MISMATCH;
196 when GNAT_EN_MRN_MISMATCH
=> raise USE_ERROR
; -- MRN_MISMATCH;
197 when GNAT_EN_KEY_MISMATCH
=> raise USE_ERROR
; -- KEY_MISMATCH;
198 when GNAT_EN_MAXLINEXC
=> raise CONSTRAINT_ERROR
; -- MAXLINEXC;
199 when GNAT_EN_LINEXCMRS
=> raise CONSTRAINT_ERROR
; -- LINEXCMRS;
201 end Raise_IO_Exception
;
203 -------------------------
204 -- Package Elaboration --
205 -------------------------