File: dbf\unsigned_io.adb
1 --::::::::::
2 --unsignio.adb
3 --::::::::::
4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
5 -- Moscow, Russia,
6 -- Voice: 7 (095) 398-23-38
7 -- e-mail: edv@edv.msk.ru
8 -- This is free software; you can freely redistribute it and/or
9 -- modify it without any restrictions. Please report any errors.
10 -- All corrections will be made as soon as possible.
11 with direct_io;
12 with unchecked_deallocation, unchecked_conversion;
13 package body unsigned_io is
14
15 package bio is new direct_io(byte);
16
17 type file_object is
18 record
19 f : bio.file_type;
20 end record;
21
22 bio_mode : constant array(file_mode) of bio.file_mode :=
23 (in_file => bio.in_file,
24 inout_file => bio.inout_file,
25 out_file => bio.out_file);
26
27 bin_mode : constant array(bio.file_mode) of file_mode :=
28 (bio.in_file => in_file,
29 bio.inout_file => inout_file,
30 bio.out_file => out_file);
31
32 procedure destroy (file : in out file_type) is
33 procedure free is new unchecked_deallocation(file_object, file_type);
34 begin
35 free (file);
36 file := null;
37 end;
38
39 procedure create(file : in out file_type;
40 mode : in file_mode := inout_file;
41 name : in string := "";
42 form : in string := "") is
43 begin
44 file := new file_object;
45 bio.create(file.f, bio_mode(mode), name, form);
46 exception
47 when constraint_error => destroy (file);
48 raise status_error;
49 when others => destroy (file);
50 raise;
51 end create;
52
53 procedure open(file : in out file_type;
54 mode : in file_mode;
55 name : in string;
56 form : in string := "") is
57 begin
58 file := new file_object;
59 bio.open(file.f, bio_mode(mode), name, form);
60 exception
61 when constraint_error => destroy (file);
62 raise status_error;
63 when others => destroy (file);
64 raise;
65 end open;
66
67 procedure close(file : in out file_type) is
68 begin
69 bio.close(file.f);
70 destroy (file);
71 exception
72 when constraint_error =>
73 raise status_error;
74 when others =>
75 raise;
76 end close;
77
78 procedure delete(file : in out file_type) is
79 begin
80 bio.delete(file.f);
81 destroy (file);
82 exception
83 when constraint_error =>
84 raise status_error;
85 when others =>
86 raise;
87 end delete;
88
89 procedure reset(file : in out file_type;
90 mode : in file_mode) is
91 begin
92 bio.reset(file.f, bio_mode(mode));
93 exception
94 when constraint_error =>
95 raise status_error;
96 when others =>
97 raise;
98 end reset;
99
100 procedure reset(file : in out file_type) is
101 begin
102 bio.reset(file.f);
103 exception
104 when constraint_error =>
105 raise status_error;
106 when others =>
107 raise;
108 end reset;
109
110 function mode(file : in file_type) return file_mode is
111 begin
112 return bin_mode(bio.mode(file.f));
113 exception
114 when constraint_error =>
115 raise status_error;
116 when others =>
117 raise;
118 end mode;
119
120 function name(file : in file_type) return string is
121 begin
122 return bio.name(file.f);
123 exception
124 when constraint_error =>
125 raise status_error;
126 when others =>
127 raise;
128 end name;
129
130 function form(file : in file_type) return string is
131 begin
132 return bio.form(file.f);
133 exception
134 when constraint_error =>
135 raise status_error;
136 when others =>
137 raise;
138 end form;
139
140 function is_open(file : in file_type) return boolean is
141 begin
142 if file = null then
143 return false;
144 end if;
145 return bio.is_open(file.f);
146 exception
147 when others =>
148 raise;
149 end is_open;
150
151 procedure read(file : in file_type;
152 item : out byte) is
153 begin
154 bio.read(file.f, item);
155 exception
156 when constraint_error =>
157 raise status_error;
158 when others =>
159 raise;
160 end read;
161
162 procedure read(file : in file_type;
163 item : out byte;
164 from : in positive_count) is
165 begin
166 bio.read(file.f, item, bio.count(from));
167 exception
168 when constraint_error =>
169 raise status_error;
170 when others =>
171 raise;
172 end read;
173
174 procedure read(file : in file_type;
175 item : out byte_string) is
176 begin
177 for n in item'range loop
178 bio.read(file.f, item(n));
179 end loop;
180 exception
181 when constraint_error =>
182 raise status_error;
183 when others =>
184 raise;
185 end read;
186
187 procedure read(file : in file_type;
188 item : out byte_string;
189 from : in positive_count) is
190 begin
191 set_index(file, from);
192 read(file, item);
193 exception
194 when constraint_error =>
195 raise status_error;
196 when others =>
197 raise;
198 end read;
199
200 procedure write(file : in file_type;
201 item : in byte) is
202 begin
203 bio.write(file.f, item);
204 exception
205 when constraint_error =>
206 raise status_error;
207 when others =>
208 raise;
209 end write;
210
211 procedure write(file : in file_type;
212 item : in byte;
213 to : in positive_count) is
214 begin
215 bio.write(file.f, item, bio.count(to));
216 exception
217 when constraint_error =>
218 raise status_error;
219 when others =>
220 raise;
221 end write;
222
223 procedure write(file : in file_type;
224 item : in byte_string) is
225 begin
226 for n in item'range loop
227 bio.write(file.f, item(n));
228 end loop;
229 exception
230 when constraint_error =>
231 raise status_error;
232 when others =>
233 raise;
234 end write;
235
236 procedure write(file : in file_type;
237 item : in byte_string;
238 to : in positive_count) is
239 begin
240 set_index(file, to);
241 write(file, item);
242 exception
243 when constraint_error =>
244 raise status_error;
245 when others =>
246 raise;
247 end write;
248
249 procedure set_index(file : in file_type;
250 to : in positive_count) is
251 begin
252 bio.set_index(file.f, bio.count(to));
253 exception
254 when constraint_error =>
255 raise status_error;
256 when others =>
257 raise;
258 end set_index;
259
260 function index(file : in file_type) return positive_count is
261 begin
262 return count(bio.index(file.f));
263 exception
264 when constraint_error =>
265 raise status_error;
266 when others =>
267 raise;
268 end index;
269
270 function size(file : in file_type) return count is
271 begin
272 return count(bio.size(file.f));
273 exception
274 when constraint_error =>
275 raise status_error;
276 when others =>
277 raise;
278 end size;
279
280 function end_of_file(file : in file_type) return boolean is
281 begin
282 return bio.end_of_file(file.f);
283 exception
284 when constraint_error =>
285 raise status_error;
286 when others =>
287 raise;
288 end end_of_file;
289
290 procedure write_bytes (file: in out file_type;
291 data: in data_type) is
292
293 subtype byte_array is byte_string (1..data_type'size/byte'size);
294 function convert is new unchecked_conversion (data_type, byte_array);
295 buf: byte_array := convert (data);
296 begin
297 write (file, buf);
298 end;
299
300 procedure read_bytes (file: in out file_type;
301 data: out data_type) is
302
303 subtype byte_array is byte_string (1..data_type'size/byte'size);
304 function convert is new unchecked_conversion (byte_array, data_type);
305 buf: byte_array;
306 begin
307 read (file, buf);
308 data := convert (buf);
309 end;
310
311 end unsigned_io;
312