1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Primitives to perform I/O to and from files. */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "osio.h"
32
33 #ifndef CLOSE_CHANNEL_HOOK
34 #define CLOSE_CHANNEL_HOOK(channel)
35 #endif
36
37 Tchannel
arg_to_channel(SCHEME_OBJECT argument,int arg_number)38 arg_to_channel (SCHEME_OBJECT argument, int arg_number)
39 {
40 unsigned long channel = (arg_ulong_integer (arg_number));
41 if (! (channel < OS_channel_table_size))
42 error_wrong_type_arg (arg_number);
43 return (channel);
44 }
45
46 Tchannel
arg_channel(int arg_number)47 arg_channel (int arg_number)
48 {
49 Tchannel channel = (arg_to_channel ((ARG_REF (arg_number)), arg_number));
50 if (!OS_channel_open_p (channel))
51 error_bad_range_arg (arg_number);
52 return (channel);
53 }
54
55 DEFINE_PRIMITIVE ("CHANNEL-CLOSE", Prim_channel_close, 1, 1,
56 "Close file CHANNEL-NUMBER.")
57 {
58 PRIMITIVE_HEADER (1);
59 {
60 Tchannel channel = (arg_to_channel ((ARG_REF (1)), 1));
61 if (OS_channel_open_p (channel))
62 {
63 CLOSE_CHANNEL_HOOK (channel);
64 OS_channel_close (channel);
65 }
66 }
67 PRIMITIVE_RETURN (UNSPECIFIC);
68 }
69
70 DEFINE_PRIMITIVE ("CHANNEL-SYNCHRONIZE", Prim_channel_synchronize, 1, 1,
71 "(CHANNEL)\n\
72 Synchronize CHANNEL with any permanent storage associated with it,\n\
73 forcing any buffered data to be written permanently.")
74 {
75 PRIMITIVE_HEADER (1);
76 OS_channel_synchronize (arg_channel (1));
77 PRIMITIVE_RETURN (UNSPECIFIC);
78 }
79
80 DEFINE_PRIMITIVE ("CHANNEL-TABLE", Prim_channel_table, 0, 0,
81 "Return a vector of all channels in the channel table.")
82 {
83 PRIMITIVE_HEADER (0);
84 {
85 Tchannel channel;
86 for (channel = 0; (channel < OS_channel_table_size); channel += 1)
87 if (OS_channel_open_p (channel))
88 obstack_grow ((&scratch_obstack), (&channel), (sizeof (Tchannel)));
89 }
90 {
91 unsigned int n_channels =
92 ((obstack_object_size ((&scratch_obstack))) / (sizeof (Tchannel)));
93 if (n_channels == 0)
94 PRIMITIVE_RETURN (SHARP_F);
95 {
96 Tchannel * channels = (obstack_finish (&scratch_obstack));
97 Tchannel * scan_channels = channels;
98 SCHEME_OBJECT vector =
99 (allocate_marked_vector (TC_VECTOR, n_channels, 1));
100 SCHEME_OBJECT * scan_vector = (VECTOR_LOC (vector, 0));
101 SCHEME_OBJECT * end_vector = (scan_vector + n_channels);
102 while (scan_vector < end_vector)
103 (*scan_vector++) = (long_to_integer (*scan_channels++));
104 obstack_free ((&scratch_obstack), channels);
105 PRIMITIVE_RETURN (vector);
106 }
107 }
108 }
109
110 DEFINE_PRIMITIVE ("CHANNEL-TYPE", Prim_channel_type, 1, 1,
111 "Return (as a nonnegative integer) the type of CHANNEL.")
112 {
113 PRIMITIVE_HEADER (1);
114 PRIMITIVE_RETURN
115 (long_to_integer ((long) (OS_channel_type (arg_channel (1)))));
116 }
117
118 /* Must match definition of `enum channel_type' in "osio.h". */
119 static const char * channel_type_names [] =
120 {
121 "unknown",
122 "file",
123 "unix-pipe",
124 "unix-fifo",
125 "terminal",
126 "unix-pty-master",
127 "unix-stream-socket",
128 "tcp-stream-socket",
129 "tcp-server-socket",
130 "directory",
131 "unix-character-device",
132 "unix-block-device",
133 "os/2-console",
134 "os/2-unnamed-pipe",
135 "os/2-named-pipe",
136 "win32-anonymous-pipe",
137 "win32-named-pipe"
138 };
139
140 DEFINE_PRIMITIVE ("CHANNEL-TYPE-NAME", Prim_channel_type_name, 1, 1,
141 "Return (as a string) the type of CHANNEL.")
142 {
143 enum channel_type type;
144 unsigned int index;
145 PRIMITIVE_HEADER (1);
146 type = (OS_channel_type (arg_channel (1)));
147 if (type == channel_type_unknown)
148 PRIMITIVE_RETURN (SHARP_F);
149 index = ((unsigned int) type);
150 if (index >= ((sizeof (channel_type_names)) / (sizeof (char *))))
151 PRIMITIVE_RETURN (SHARP_F);
152 PRIMITIVE_RETURN (char_pointer_to_string (channel_type_names [index]));
153 }
154
155 DEFINE_PRIMITIVE ("CHANNEL-READ", Prim_channel_read, 4, 4,
156 "Read characters from CHANNEL, storing them in STRING.\n\
157 Third and fourth args START and END specify the substring to use.\n\
158 Attempt to fill that substring unless end-of-file is reached.\n\
159 Return the number of characters actually read from CHANNEL.")
160 {
161 PRIMITIVE_HEADER (4);
162 {
163 unsigned long length;
164 unsigned char * buffer = (arg_extended_string (2, (&length)));
165 unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
166 unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
167 long nread =
168 (OS_channel_read ((arg_channel (1)),
169 (buffer + start),
170 (end - start)));
171 PRIMITIVE_RETURN ((nread < 0) ? SHARP_F : (long_to_integer (nread)));
172 }
173 }
174
175 DEFINE_PRIMITIVE ("CHANNEL-WRITE", Prim_channel_write, 4, 4,
176 "Write characters to CHANNEL, reading them from STRING.\n\
177 Third and fourth args START and END specify the substring to use.")
178 {
179 PRIMITIVE_HEADER (4);
180 {
181 unsigned long length;
182 const unsigned char * buffer = (arg_extended_string (2, (&length)));
183 unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
184 unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
185 long nwritten =
186 (OS_channel_write ((arg_channel (1)),
187 (buffer + start),
188 (end - start)));
189 PRIMITIVE_RETURN ((nwritten < 0) ? SHARP_F : (long_to_integer (nwritten)));
190 }
191 }
192
193 DEFINE_PRIMITIVE ("CHANNEL-BLOCKING?", Prim_channel_blocking_p, 1, 1,
194 "Return #F iff CHANNEL is in non-blocking mode.\n\
195 Otherwise, CHANNEL is in blocking mode.\n\
196 If CHANNEL can be put in non-blocking mode, #T is returned.\n\
197 If it cannot, 0 is returned.")
198 {
199 PRIMITIVE_HEADER (1);
200 {
201 int result = (OS_channel_nonblocking_p (arg_channel (1)));
202 PRIMITIVE_RETURN
203 ((result < 0)
204 ? (LONG_TO_UNSIGNED_FIXNUM (0))
205 : (BOOLEAN_TO_OBJECT (result == 0)));
206 }
207 }
208
209 DEFINE_PRIMITIVE ("CHANNEL-NONBLOCKING", Prim_channel_nonblocking, 1, 1,
210 "Put CHANNEL in non-blocking mode.")
211 {
212 PRIMITIVE_HEADER (1);
213 OS_channel_nonblocking (arg_channel (1));
214 PRIMITIVE_RETURN (UNSPECIFIC);
215 }
216
217 DEFINE_PRIMITIVE ("CHANNEL-BLOCKING", Prim_channel_blocking, 1, 1,
218 "Put CHANNEL in blocking mode.")
219 {
220 PRIMITIVE_HEADER (1);
221 OS_channel_blocking (arg_channel (1));
222 PRIMITIVE_RETURN (UNSPECIFIC);
223 }
224
225 DEFINE_PRIMITIVE ("MAKE-PIPE", Prim_make_pipe, 0, 0,
226 "Return a cons of two channels, the reader and writer of a pipe.")
227 {
228 PRIMITIVE_HEADER (0);
229 {
230 SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
231 Tchannel reader;
232 Tchannel writer;
233 OS_make_pipe ((&reader), (&writer));
234 SET_PAIR_CAR (result, (long_to_integer (reader)));
235 SET_PAIR_CDR (result, (long_to_integer (writer)));
236 PRIMITIVE_RETURN (result);
237 }
238 }
239
240 DEFINE_PRIMITIVE ("NEW-MAKE-PIPE", Prim_new_make_pipe, 2, 2,
241 "Store the reader and writer of a new pipe in the cdrs of weak pairs.")
242 {
243 PRIMITIVE_HEADER (2);
244 CHECK_ARG (1, WEAK_PAIR_P);
245 CHECK_ARG (2, WEAK_PAIR_P);
246 {
247 Tchannel reader;
248 Tchannel writer;
249 OS_make_pipe ((&reader), (&writer));
250 SET_PAIR_CDR ((ARG_REF (1)), (long_to_integer (reader)));
251 SET_PAIR_CDR ((ARG_REF (2)), (long_to_integer (writer)));
252 PRIMITIVE_RETURN (UNSPECIFIC);
253 }
254 }
255
256 /* Select registry */
257
258 static select_registry_t
arg_select_registry(int arg_number)259 arg_select_registry (int arg_number)
260 {
261 return ((select_registry_t) (arg_ulong_integer (arg_number)));
262 }
263
264 static unsigned int
arg_sr_mode(int arg_number)265 arg_sr_mode (int arg_number)
266 {
267 unsigned long n = (arg_ulong_integer (arg_number));
268 if (! ((n >= 1) && (n <= 3)))
269 error_bad_range_arg (arg_number);
270 return (n);
271 }
272
273 DEFINE_PRIMITIVE ("HAVE-SELECT?", Prim_have_select_p, 0, 0, 0)
274 {
275 PRIMITIVE_HEADER (0);
276 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_have_select_p));
277 }
278
279 DEFINE_PRIMITIVE ("ALLOCATE-SELECT-REGISTRY", Prim_alloc_selreg, 0, 0, 0)
280 {
281 PRIMITIVE_HEADER (0);
282 PRIMITIVE_RETURN
283 (ulong_to_integer
284 ((unsigned long) (OS_allocate_select_registry ())));
285 }
286
287 DEFINE_PRIMITIVE ("DEALLOCATE-SELECT-REGISTRY", Prim_dealloc_selreg, 1, 1, 0)
288 {
289 PRIMITIVE_HEADER (1);
290 OS_deallocate_select_registry (arg_select_registry (1));
291 PRIMITIVE_RETURN (UNSPECIFIC);
292 }
293
294 DEFINE_PRIMITIVE ("ADD-TO-SELECT-REGISTRY", Prim_add_to_selreg, 3, 3, 0)
295 {
296 PRIMITIVE_HEADER (3);
297 OS_add_to_select_registry ((arg_select_registry (1)),
298 (arg_nonnegative_integer (2)),
299 (arg_sr_mode (3)));
300 PRIMITIVE_RETURN (UNSPECIFIC);
301 }
302
303 DEFINE_PRIMITIVE ("REMOVE-FROM-SELECT-REGISTRY", Prim_rem_from_selreg, 3, 3, 0)
304 {
305 PRIMITIVE_HEADER (3);
306 OS_remove_from_select_registry ((arg_select_registry (1)),
307 (arg_nonnegative_integer (2)),
308 (arg_sr_mode (3)));
309 PRIMITIVE_RETURN (UNSPECIFIC);
310 }
311
312 DEFINE_PRIMITIVE ("SELECT-REGISTRY-LENGTH", Prim_selreg_length, 1, 1, 0)
313 {
314 PRIMITIVE_HEADER (1);
315 PRIMITIVE_RETURN
316 (ulong_to_integer (OS_select_registry_length (arg_select_registry (1))));
317 }
318
319 DEFINE_PRIMITIVE ("TEST-SELECT-REGISTRY", Prim_test_selreg, 4, 4, 0)
320 {
321 PRIMITIVE_HEADER (4);
322 {
323 select_registry_t r = (arg_select_registry (1));
324 unsigned int rl = (OS_select_registry_length (r));
325 int blockp = (BOOLEAN_ARG (2));
326 SCHEME_OBJECT vfd = (VECTOR_ARG (3));
327 SCHEME_OBJECT vmode = (VECTOR_ARG (4));
328 int result;
329
330 if ((VECTOR_LENGTH (vfd)) < rl)
331 error_bad_range_arg (3);
332 if ((VECTOR_LENGTH (vmode)) < rl)
333 error_bad_range_arg (4);
334 result = ((rl == 0)
335 ? (blockp ? (OS_pause ()) : SELECT_INTERRUPT)
336 : (OS_test_select_registry (r, blockp)));
337 if (result > 0)
338 {
339 unsigned int i = 0;
340 unsigned int iv = 0;
341 while (i < rl)
342 {
343 int fd;
344 unsigned int mode;
345
346 OS_select_registry_result (r, i, (&fd), (&mode));
347 if (mode > 0)
348 {
349 VECTOR_SET (vfd, iv, (long_to_integer (fd)));
350 VECTOR_SET (vmode, iv, (ulong_to_integer (mode)));
351 iv += 1;
352 }
353 i += 1;
354 }
355 }
356 PRIMITIVE_RETURN (long_to_integer (result));
357 }
358 }
359
360 DEFINE_PRIMITIVE ("TEST-SELECT-DESCRIPTOR", Prim_test_sel_desc, 3, 3, 0)
361 {
362 PRIMITIVE_HEADER (3);
363 PRIMITIVE_RETURN
364 (long_to_integer
365 (OS_test_select_descriptor ((arg_nonnegative_integer (1)),
366 (BOOLEAN_ARG (2)),
367 (arg_sr_mode (3)))));
368 }
369