Commit | Line | Data |
---|---|---|
840ae05d | 1 | /* Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. |
0f2d19dd JB |
2 | * |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
0f2d19dd | 41 | \f |
d68fee48 JB |
42 | /* Headers. */ |
43 | ||
0f2d19dd JB |
44 | #include <stdio.h> |
45 | #include "_scm.h" | |
20e6290e JB |
46 | #include "genio.h" |
47 | #include "chars.h" | |
0f2d19dd | 48 | |
20e6290e JB |
49 | #include "fports.h" |
50 | #include "strports.h" | |
51 | #include "vports.h" | |
547e65b5 | 52 | #include "keywords.h" |
20e6290e JB |
53 | |
54 | #include "ports.h" | |
0f2d19dd JB |
55 | |
56 | #ifdef HAVE_MALLOC_H | |
95b88819 | 57 | #include <malloc.h> |
0f2d19dd JB |
58 | #endif |
59 | ||
60 | #ifdef HAVE_UNISTD_H | |
61 | #include <unistd.h> | |
62 | #endif | |
63 | ||
95b88819 GH |
64 | #ifdef HAVE_SYS_IOCTL_H |
65 | #include <sys/ioctl.h> | |
66 | #endif | |
d68fee48 | 67 | |
0f2d19dd | 68 | \f |
d68fee48 | 69 | /* The port kind table --- a dynamically resized array of port types. */ |
0f2d19dd JB |
70 | |
71 | ||
72 | /* scm_ptobs scm_numptob | |
73 | * implement a dynamicly resized array of ptob records. | |
74 | * Indexes into this table are used when generating type | |
75 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
76 | */ | |
77 | scm_ptobfuns *scm_ptobs; | |
a1c95c45 | 78 | int scm_numptob; |
0f2d19dd | 79 | |
ee149d03 | 80 | /* GC marker for a port with stream of SCM type. */ |
0f2d19dd JB |
81 | SCM |
82 | scm_markstream (ptr) | |
83 | SCM ptr; | |
0f2d19dd JB |
84 | { |
85 | int openp; | |
0f2d19dd | 86 | openp = SCM_CAR (ptr) & SCM_OPN; |
0f2d19dd JB |
87 | if (openp) |
88 | return SCM_STREAM (ptr); | |
89 | else | |
90 | return SCM_BOOL_F; | |
91 | } | |
92 | ||
93 | ||
0f2d19dd JB |
94 | long |
95 | scm_newptob (ptob) | |
96 | scm_ptobfuns *ptob; | |
0f2d19dd JB |
97 | { |
98 | char *tmp; | |
99 | if (255 <= scm_numptob) | |
100 | goto ptoberr; | |
ee149d03 | 101 | tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)); |
0f2d19dd JB |
102 | if (tmp) |
103 | { | |
104 | scm_ptobs = (scm_ptobfuns *) tmp; | |
105 | scm_ptobs[scm_numptob].mark = ptob->mark; | |
106 | scm_ptobs[scm_numptob].free = ptob->free; | |
107 | scm_ptobs[scm_numptob].print = ptob->print; | |
108 | scm_ptobs[scm_numptob].equalp = ptob->equalp; | |
0f2d19dd | 109 | scm_ptobs[scm_numptob].fflush = ptob->fflush; |
840ae05d | 110 | scm_ptobs[scm_numptob].read_flush = ptob->read_flush; |
0f2d19dd | 111 | scm_ptobs[scm_numptob].fclose = ptob->fclose; |
ee149d03 | 112 | scm_ptobs[scm_numptob].fill_buffer = ptob->fill_buffer; |
840ae05d JB |
113 | scm_ptobs[scm_numptob].seek = ptob->seek; |
114 | scm_ptobs[scm_numptob].ftruncate = ptob->ftruncate; | |
ee149d03 | 115 | scm_ptobs[scm_numptob].input_waiting_p = ptob->input_waiting_p; |
0f2d19dd JB |
116 | scm_numptob++; |
117 | } | |
0f2d19dd JB |
118 | if (!tmp) |
119 | ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); | |
120 | return scm_tc7_port + (scm_numptob - 1) * 256; | |
121 | } | |
122 | ||
123 | \f | |
0f2d19dd | 124 | |
44493941 | 125 | SCM_PROC(s_char_ready_p, "char-ready?", 0, 1, 0, scm_char_ready_p); |
1cc91f1b | 126 | |
0f2d19dd JB |
127 | SCM |
128 | scm_char_ready_p (port) | |
129 | SCM port; | |
0f2d19dd JB |
130 | { |
131 | if (SCM_UNBNDP (port)) | |
132 | port = scm_cur_inp; | |
133 | else | |
d68fee48 JB |
134 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, |
135 | s_char_ready_p); | |
136 | ||
ee149d03 | 137 | if (SCM_CRDYP (port)) |
0f2d19dd | 138 | return SCM_BOOL_T; |
ee149d03 JB |
139 | else |
140 | { | |
840ae05d | 141 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 JB |
142 | |
143 | if (pt->read_pos < pt->read_end) | |
144 | return SCM_BOOL_T; | |
145 | else | |
146 | { | |
147 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; | |
148 | ||
149 | if (ptob->input_waiting_p) | |
840ae05d | 150 | return (ptob->input_waiting_p (port)) ? SCM_BOOL_T : SCM_BOOL_F; |
ee149d03 JB |
151 | else |
152 | return SCM_BOOL_T; | |
153 | } | |
154 | } | |
0f2d19dd | 155 | } |
0f2d19dd | 156 | |
ee149d03 JB |
157 | /* Clear a port's read buffer, returning the contents. */ |
158 | SCM_PROC (s_drain_input, "drain-input", 1, 0, 0, scm_drain_input); | |
159 | SCM | |
160 | scm_drain_input (SCM port) | |
161 | { | |
840ae05d JB |
162 | SCM result; |
163 | scm_port *pt = SCM_PTAB_ENTRY (port); | |
164 | int p_count; | |
165 | char *dst; | |
166 | char *p_buf; | |
ee149d03 JB |
167 | |
168 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, | |
169 | s_drain_input); | |
840ae05d JB |
170 | |
171 | p_count = (SCM_CRDYP (port)) ? SCM_N_READY_CHARS (port) : 0; | |
172 | result = scm_makstr (p_count + pt->read_end - pt->read_pos, 0); | |
173 | dst = SCM_CHARS (result); | |
174 | p_buf = SCM_PTAB_ENTRY (port)->cp; | |
175 | ||
176 | while (p_count > 0) | |
ee149d03 | 177 | { |
840ae05d JB |
178 | *dst++ = *p_buf--; |
179 | p_count--; | |
ee149d03 | 180 | } |
840ae05d JB |
181 | SCM_CLRDY (port); |
182 | ||
183 | while (pt->read_pos < pt->read_end) | |
184 | { | |
185 | *dst++ = *(pt->read_pos++); | |
186 | } | |
187 | return result; | |
ee149d03 | 188 | } |
0f2d19dd JB |
189 | |
190 | \f | |
d68fee48 | 191 | /* Standard ports --- current input, output, error, and more(!). */ |
0f2d19dd | 192 | |
0f2d19dd | 193 | SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); |
1cc91f1b | 194 | |
0f2d19dd JB |
195 | SCM |
196 | scm_current_input_port () | |
0f2d19dd JB |
197 | { |
198 | return scm_cur_inp; | |
199 | } | |
200 | ||
201 | SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); | |
1cc91f1b | 202 | |
0f2d19dd JB |
203 | SCM |
204 | scm_current_output_port () | |
0f2d19dd JB |
205 | { |
206 | return scm_cur_outp; | |
207 | } | |
208 | ||
209 | SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); | |
1cc91f1b | 210 | |
0f2d19dd JB |
211 | SCM |
212 | scm_current_error_port () | |
0f2d19dd JB |
213 | { |
214 | return scm_cur_errp; | |
215 | } | |
216 | ||
31614d8e MD |
217 | SCM_PROC(s_current_load_port, "current-load-port", 0, 0, 0, scm_current_load_port); |
218 | ||
219 | SCM | |
220 | scm_current_load_port () | |
221 | { | |
222 | return scm_cur_loadp; | |
223 | } | |
224 | ||
0f2d19dd | 225 | SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); |
1cc91f1b | 226 | |
0f2d19dd JB |
227 | SCM |
228 | scm_set_current_input_port (port) | |
229 | SCM port; | |
0f2d19dd JB |
230 | { |
231 | SCM oinp = scm_cur_inp; | |
232 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); | |
233 | scm_cur_inp = port; | |
234 | return oinp; | |
235 | } | |
236 | ||
237 | ||
238 | SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); | |
1cc91f1b | 239 | |
0f2d19dd JB |
240 | SCM |
241 | scm_set_current_output_port (port) | |
242 | SCM port; | |
0f2d19dd JB |
243 | { |
244 | SCM ooutp = scm_cur_outp; | |
78446828 | 245 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
246 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); |
247 | scm_cur_outp = port; | |
248 | return ooutp; | |
249 | } | |
250 | ||
251 | ||
252 | SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); | |
1cc91f1b | 253 | |
0f2d19dd JB |
254 | SCM |
255 | scm_set_current_error_port (port) | |
256 | SCM port; | |
0f2d19dd JB |
257 | { |
258 | SCM oerrp = scm_cur_errp; | |
78446828 | 259 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
260 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); |
261 | scm_cur_errp = port; | |
262 | return oerrp; | |
263 | } | |
264 | ||
265 | \f | |
840ae05d | 266 | /* The port table --- an array of pointers to ports. */ |
0f2d19dd | 267 | |
840ae05d | 268 | scm_port **scm_port_table; |
0f2d19dd JB |
269 | |
270 | int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ | |
271 | int scm_port_table_room = 20; /* Size of the array. */ | |
272 | ||
ee149d03 | 273 | /* Add a port to the table. */ |
1cc91f1b | 274 | |
840ae05d | 275 | scm_port * |
0f2d19dd JB |
276 | scm_add_to_port_table (port) |
277 | SCM port; | |
0f2d19dd | 278 | { |
840ae05d JB |
279 | scm_port *entry; |
280 | ||
0f2d19dd JB |
281 | if (scm_port_table_size == scm_port_table_room) |
282 | { | |
ee149d03 | 283 | void *newt = realloc ((char *) scm_port_table, |
840ae05d | 284 | (scm_sizet) (sizeof (scm_port *) |
ee149d03 JB |
285 | * scm_port_table_room * 2)); |
286 | if (newt == NULL) | |
840ae05d JB |
287 | scm_memory_error ("scm_add_to_port_table"); |
288 | scm_port_table = (scm_port **) newt; | |
0f2d19dd JB |
289 | scm_port_table_room *= 2; |
290 | } | |
840ae05d JB |
291 | entry = (scm_port *) malloc (sizeof (scm_port)); |
292 | if (entry == NULL) | |
293 | scm_memory_error ("scm_add_to_port_table"); | |
294 | ||
295 | entry->port = port; | |
296 | entry->entry = scm_port_table_size; | |
297 | entry->revealed = 0; | |
298 | entry->stream = 0; | |
299 | entry->file_name = SCM_BOOL_F; | |
300 | entry->line_number = 0; | |
301 | entry->column_number = 0; | |
302 | entry->cp | |
303 | = entry->cbuf; | |
304 | entry->cbufend | |
305 | = &entry->cbuf[SCM_INITIAL_CBUF_SIZE]; | |
306 | entry->rw_active = 0; | |
307 | ||
308 | scm_port_table[scm_port_table_size] = entry; | |
309 | scm_port_table_size++; | |
310 | ||
311 | return entry; | |
0f2d19dd JB |
312 | } |
313 | ||
ee149d03 | 314 | /* Remove a port from the table. */ |
1cc91f1b | 315 | |
0f2d19dd JB |
316 | void |
317 | scm_remove_from_port_table (port) | |
318 | SCM port; | |
0f2d19dd | 319 | { |
840ae05d | 320 | scm_port *p = SCM_PTAB_ENTRY (port); |
ee1e7e13 MD |
321 | int i = p->entry; |
322 | /* Error if not found: too violent? May occur in GC. */ | |
323 | if (i >= scm_port_table_size) | |
324 | scm_wta (port, "Port not in table", "scm_remove_from_port_table"); | |
840ae05d | 325 | free (p); |
ee1e7e13 MD |
326 | /* Since we have just freed slot i we can shrink the table by moving |
327 | the last entry to that slot... */ | |
328 | if (i < scm_port_table_size - 1) | |
0f2d19dd | 329 | { |
ee1e7e13 MD |
330 | scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; |
331 | scm_port_table[i]->entry = i; | |
0f2d19dd | 332 | } |
0f2d19dd JB |
333 | SCM_SETPTAB_ENTRY (port, 0); |
334 | scm_port_table_size--; | |
335 | } | |
336 | ||
ee1e7e13 MD |
337 | void |
338 | scm_grow_port_cbuf (port, requested) | |
339 | SCM port; | |
340 | size_t requested; | |
341 | { | |
840ae05d | 342 | scm_port *p = SCM_PTAB_ENTRY (port); |
ee1e7e13 MD |
343 | int size = p->cbufend - p->cbuf; |
344 | int new_size = size * 3 / 2; | |
345 | if (new_size < requested) | |
346 | new_size = requested; | |
347 | p = realloc (p, sizeof (*p) - SCM_INITIAL_CBUF_SIZE + new_size); | |
348 | scm_port_table[p->entry] = p; | |
349 | SCM_SETPTAB_ENTRY (port, p); | |
350 | } | |
351 | ||
fea6b4ea | 352 | #ifdef GUILE_DEBUG |
0f2d19dd JB |
353 | /* Undocumented functions for debugging. */ |
354 | /* Return the number of ports in the table. */ | |
1cc91f1b | 355 | |
1146b6cd | 356 | SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size); |
0f2d19dd JB |
357 | SCM |
358 | scm_pt_size () | |
0f2d19dd JB |
359 | { |
360 | return SCM_MAKINUM (scm_port_table_size); | |
361 | } | |
362 | ||
363 | /* Return the ith member of the port table. */ | |
1146b6cd | 364 | SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member); |
0f2d19dd JB |
365 | SCM |
366 | scm_pt_member (member) | |
367 | SCM member; | |
0f2d19dd JB |
368 | { |
369 | int i; | |
370 | SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); | |
371 | i = SCM_INUM (member); | |
372 | if (i < 0 || i >= scm_port_table_size) | |
373 | return SCM_BOOL_F; | |
374 | else | |
375 | return scm_port_table[i]->port; | |
376 | } | |
377 | #endif | |
378 | ||
379 | ||
d68fee48 JB |
380 | \f |
381 | /* Revealed counts --- an oddity inherited from SCSH. */ | |
382 | ||
8b13c6b3 GH |
383 | /* Find a port in the table and return its revealed count. |
384 | Also used by the garbage collector. | |
0f2d19dd | 385 | */ |
1cc91f1b | 386 | |
0f2d19dd JB |
387 | int |
388 | scm_revealed_count (port) | |
389 | SCM port; | |
0f2d19dd JB |
390 | { |
391 | return SCM_REVEALED(port); | |
392 | } | |
393 | ||
394 | ||
395 | ||
396 | /* Return the revealed count for a port. */ | |
397 | ||
398 | SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); | |
1cc91f1b | 399 | |
0f2d19dd JB |
400 | SCM |
401 | scm_port_revealed (port) | |
402 | SCM port; | |
0f2d19dd | 403 | { |
78446828 | 404 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd | 405 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); |
8b13c6b3 | 406 | return SCM_MAKINUM (scm_revealed_count (port)); |
0f2d19dd JB |
407 | } |
408 | ||
409 | /* Set the revealed count for a port. */ | |
410 | SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); | |
1cc91f1b | 411 | |
0f2d19dd JB |
412 | SCM |
413 | scm_set_port_revealed_x (port, rcount) | |
414 | SCM port; | |
415 | SCM rcount; | |
0f2d19dd | 416 | { |
78446828 | 417 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
418 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); |
419 | SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); | |
0f2d19dd | 420 | SCM_REVEALED (port) = SCM_INUM (rcount); |
8b13c6b3 | 421 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
422 | } |
423 | ||
d68fee48 JB |
424 | |
425 | \f | |
426 | /* Retrieving a port's mode. */ | |
427 | ||
eadd48de GH |
428 | /* Return the flags that characterize a port based on the mode |
429 | * string used to open a file for that port. | |
430 | * | |
431 | * See PORT FLAGS in scm.h | |
432 | */ | |
433 | ||
434 | long | |
435 | scm_mode_bits (modes) | |
436 | char *modes; | |
437 | { | |
438 | return (SCM_OPN | |
439 | | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) | |
440 | | ( strchr (modes, 'w') | |
441 | || strchr (modes, 'a') | |
442 | || strchr (modes, '+') ? SCM_WRTNG : 0) | |
ee149d03 JB |
443 | | (strchr (modes, '0') ? SCM_BUF0 : 0) |
444 | | (strchr (modes, 'l') ? SCM_BUFLINE : 0)); | |
eadd48de GH |
445 | } |
446 | ||
447 | ||
448 | /* Return the mode flags from an open port. | |
449 | * Some modes such as "append" are only used when opening | |
450 | * a file and are not returned here. */ | |
451 | ||
452 | SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); | |
453 | ||
454 | SCM | |
455 | scm_port_mode (port) | |
456 | SCM port; | |
457 | { | |
458 | char modes[3]; | |
459 | modes[0] = '\0'; | |
78446828 MV |
460 | |
461 | port = SCM_COERCE_OUTPORT (port); | |
eadd48de GH |
462 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); |
463 | if (SCM_CAR (port) & SCM_RDNG) { | |
464 | if (SCM_CAR (port) & SCM_WRTNG) | |
465 | strcpy (modes, "r+"); | |
466 | else | |
467 | strcpy (modes, "r"); | |
468 | } | |
469 | else if (SCM_CAR (port) & SCM_WRTNG) | |
470 | strcpy (modes, "w"); | |
471 | if (SCM_CAR (port) & SCM_BUF0) | |
472 | strcat (modes, "0"); | |
473 | return scm_makfromstr (modes, strlen (modes), 0); | |
474 | } | |
475 | ||
476 | ||
d68fee48 JB |
477 | \f |
478 | /* Closing ports. */ | |
479 | ||
0f2d19dd JB |
480 | /* scm_close_port |
481 | * Call the close operation on a port object. | |
eadd48de | 482 | * see also scm_close. |
0f2d19dd JB |
483 | */ |
484 | SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); | |
1cc91f1b | 485 | |
0f2d19dd JB |
486 | SCM |
487 | scm_close_port (port) | |
488 | SCM port; | |
0f2d19dd JB |
489 | { |
490 | scm_sizet i; | |
eadd48de GH |
491 | int rv; |
492 | ||
78446828 MV |
493 | port = SCM_COERCE_OUTPORT (port); |
494 | ||
341eaef0 | 495 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, |
3c1750f3 | 496 | s_close_port); |
0f2d19dd | 497 | if (SCM_CLOSEDP (port)) |
eadd48de | 498 | return SCM_BOOL_F; |
0f2d19dd | 499 | i = SCM_PTOBNUM (port); |
0f2d19dd | 500 | if (scm_ptobs[i].fclose) |
ee149d03 | 501 | rv = (scm_ptobs[i].fclose) (port); |
eadd48de GH |
502 | else |
503 | rv = 0; | |
0f2d19dd | 504 | scm_remove_from_port_table (port); |
898a256f | 505 | SCM_SETAND_CAR (port, ~SCM_OPN); |
eadd48de | 506 | return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; |
0f2d19dd JB |
507 | } |
508 | ||
509 | SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); | |
1cc91f1b | 510 | |
0f2d19dd JB |
511 | SCM |
512 | scm_close_all_ports_except (ports) | |
513 | SCM ports; | |
0f2d19dd JB |
514 | { |
515 | int i = 0; | |
516 | SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); | |
0f2d19dd JB |
517 | while (i < scm_port_table_size) |
518 | { | |
519 | SCM thisport = scm_port_table[i]->port; | |
520 | int found = 0; | |
521 | SCM ports_ptr = ports; | |
522 | ||
523 | while (SCM_NNULLP (ports_ptr)) | |
524 | { | |
78446828 | 525 | SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr)); |
0f2d19dd JB |
526 | if (i == 0) |
527 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); | |
528 | if (port == thisport) | |
529 | found = 1; | |
530 | ports_ptr = SCM_CDR (ports_ptr); | |
531 | } | |
532 | if (found) | |
533 | i++; | |
534 | else | |
535 | /* i is not to be incremented here. */ | |
536 | scm_close_port (thisport); | |
537 | } | |
0f2d19dd JB |
538 | return SCM_UNSPECIFIED; |
539 | } | |
540 | ||
d68fee48 JB |
541 | |
542 | \f | |
543 | /* Utter miscellany. Gosh, we should clean this up some time. */ | |
544 | ||
0f2d19dd | 545 | SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); |
1cc91f1b | 546 | |
0f2d19dd JB |
547 | SCM |
548 | scm_input_port_p (x) | |
549 | SCM x; | |
0f2d19dd JB |
550 | { |
551 | if (SCM_IMP (x)) | |
552 | return SCM_BOOL_F; | |
553 | return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
554 | } | |
555 | ||
556 | SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); | |
1cc91f1b | 557 | |
0f2d19dd JB |
558 | SCM |
559 | scm_output_port_p (x) | |
560 | SCM x; | |
0f2d19dd JB |
561 | { |
562 | if (SCM_IMP (x)) | |
563 | return SCM_BOOL_F; | |
564 | return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
565 | } | |
566 | ||
567 | ||
568 | SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); | |
1cc91f1b | 569 | |
0f2d19dd JB |
570 | SCM |
571 | scm_eof_object_p (x) | |
572 | SCM x; | |
0f2d19dd | 573 | { |
0c32d76c | 574 | return SCM_EOF_OBJECT_P (x) ? SCM_BOOL_T : SCM_BOOL_F; |
0f2d19dd JB |
575 | } |
576 | ||
577 | SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); | |
1cc91f1b | 578 | |
0f2d19dd JB |
579 | SCM |
580 | scm_force_output (port) | |
581 | SCM port; | |
0f2d19dd JB |
582 | { |
583 | if (SCM_UNBNDP (port)) | |
3e877d15 | 584 | port = scm_cur_outp; |
0f2d19dd | 585 | else |
78446828 MV |
586 | { |
587 | port = SCM_COERCE_OUTPORT (port); | |
3e877d15 JB |
588 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, |
589 | s_force_output); | |
78446828 | 590 | } |
ee149d03 JB |
591 | scm_fflush (port); |
592 | return SCM_UNSPECIFIED; | |
0f2d19dd JB |
593 | } |
594 | ||
9c29ac66 | 595 | SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports); |
89ea5b7c GH |
596 | SCM |
597 | scm_flush_all_ports (void) | |
598 | { | |
599 | int i; | |
600 | ||
601 | for (i = 0; i < scm_port_table_size; i++) | |
602 | { | |
ee149d03 JB |
603 | if (SCM_OPOUTPORTP (scm_port_table[i]->port)) |
604 | scm_fflush (scm_port_table[i]->port); | |
89ea5b7c GH |
605 | } |
606 | return SCM_UNSPECIFIED; | |
607 | } | |
0f2d19dd JB |
608 | |
609 | SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); | |
1cc91f1b | 610 | |
0f2d19dd JB |
611 | SCM |
612 | scm_read_char (port) | |
613 | SCM port; | |
0f2d19dd JB |
614 | { |
615 | int c; | |
616 | if (SCM_UNBNDP (port)) | |
334341aa | 617 | port = scm_cur_inp; |
0f2d19dd JB |
618 | else |
619 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); | |
b7f3516f | 620 | c = scm_getc (port); |
0f2d19dd JB |
621 | if (EOF == c) |
622 | return SCM_EOF_VAL; | |
623 | return SCM_MAKICHR (c); | |
624 | } | |
625 | ||
ee149d03 JB |
626 | int |
627 | scm_getc (port) | |
0f2d19dd | 628 | SCM port; |
0f2d19dd JB |
629 | { |
630 | int c; | |
840ae05d JB |
631 | scm_port *pt = SCM_PTAB_ENTRY (port); |
632 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; | |
ee149d03 | 633 | |
840ae05d JB |
634 | if (pt->rw_active == SCM_PORT_WRITE) |
635 | { | |
636 | ptob->fflush (port); | |
637 | } | |
ee149d03 JB |
638 | if (SCM_CRDYP (port)) |
639 | { | |
640 | c = SCM_CGETUN (port); | |
641 | SCM_TRY_CLRDY (port); /* Clear ungetted char */ | |
642 | } | |
0f2d19dd | 643 | else |
ee149d03 | 644 | { |
ee149d03 JB |
645 | if (pt->read_pos < pt->read_end) |
646 | { | |
647 | c = *(pt->read_pos++); | |
648 | } | |
649 | else | |
650 | { | |
840ae05d | 651 | c = ptob->fill_buffer (port); |
ee149d03 JB |
652 | } |
653 | } | |
654 | ||
840ae05d JB |
655 | if (pt->rw_random) |
656 | pt->rw_active = SCM_PORT_READ; | |
657 | ||
ee149d03 JB |
658 | if (c == '\n') |
659 | { | |
660 | SCM_INCLINE (port); | |
661 | } | |
662 | else if (c == '\t') | |
663 | { | |
664 | SCM_TABCOL (port); | |
665 | } | |
666 | else | |
667 | { | |
668 | SCM_INCCOL (port); | |
669 | } | |
670 | ||
671 | return c; | |
0f2d19dd JB |
672 | } |
673 | ||
ee149d03 JB |
674 | void |
675 | scm_putc (c, port) | |
676 | int c; | |
677 | SCM port; | |
678 | { | |
840ae05d | 679 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 JB |
680 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
681 | ||
840ae05d JB |
682 | if (pt->rw_active == SCM_PORT_READ) |
683 | ptob->read_flush (port); | |
ee149d03 | 684 | *(pt->write_pos++) = (char) c; |
840ae05d JB |
685 | if (pt->write_pos == pt->write_end) |
686 | ptob->fflush (port); | |
687 | ||
688 | if (pt->rw_random) | |
689 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 690 | } |
3cb988bd | 691 | |
ee149d03 JB |
692 | void |
693 | scm_puts (s, port) | |
694 | char *s; | |
3cb988bd TP |
695 | SCM port; |
696 | { | |
840ae05d | 697 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 | 698 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
3cb988bd | 699 | |
840ae05d JB |
700 | if (pt->rw_active == SCM_PORT_READ) |
701 | ptob->read_flush (port); | |
ee149d03 JB |
702 | while (*s != 0) |
703 | { | |
704 | *pt->write_pos++ = *s++; | |
705 | if (pt->write_pos == pt->write_end) | |
840ae05d | 706 | ptob->fflush (port); |
ee149d03 | 707 | } |
ee149d03 JB |
708 | /* If the port is line-buffered, flush it. */ |
709 | if ((SCM_CAR (port) & SCM_BUFLINE) | |
710 | && memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf)) | |
840ae05d JB |
711 | ptob->fflush (port); |
712 | ||
713 | if (pt->rw_random) | |
714 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 715 | } |
3cb988bd | 716 | |
ee149d03 JB |
717 | void |
718 | scm_lfwrite (ptr, size, port) | |
719 | char *ptr; | |
720 | scm_sizet size; | |
721 | SCM port; | |
722 | { | |
840ae05d | 723 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 | 724 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
3e2043c4 | 725 | |
840ae05d JB |
726 | if (pt->rw_active == SCM_PORT_READ) |
727 | ptob->read_flush (port); | |
ee149d03 | 728 | while (size > 0) |
3e2043c4 | 729 | { |
ee149d03 JB |
730 | int space = pt->write_end - pt->write_pos; |
731 | int write_len = (size > space) ? space : size; | |
732 | ||
733 | strncpy (pt->write_pos, ptr, write_len); | |
734 | pt->write_pos += write_len; | |
735 | size -= write_len; | |
736 | ptr += write_len; | |
737 | if (write_len == space) | |
840ae05d | 738 | ptob->fflush (port); |
3e2043c4 | 739 | } |
ee149d03 JB |
740 | /* If the port is line-buffered, flush it. */ |
741 | if ((SCM_CAR (port) & SCM_BUFLINE) | |
742 | && memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf)) | |
743 | (ptob->fflush) (port); | |
840ae05d JB |
744 | |
745 | if (pt->rw_random) | |
746 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 747 | } |
3cb988bd | 748 | |
3cb988bd | 749 | |
ee149d03 JB |
750 | void |
751 | scm_fflush (port) | |
752 | SCM port; | |
753 | { | |
754 | scm_sizet i = SCM_PTOBNUM (port); | |
755 | (scm_ptobs[i].fflush) (port); | |
756 | } | |
757 | ||
758 | \f | |
759 | ||
760 | ||
761 | void | |
762 | scm_ungetc (c, port) | |
763 | int c; | |
764 | SCM port; | |
765 | { | |
840ae05d JB |
766 | scm_port *pt = SCM_PTAB_ENTRY (port); |
767 | ||
ee149d03 JB |
768 | SCM_CUNGET (c, port); |
769 | ||
840ae05d JB |
770 | if (pt->rw_random) |
771 | pt->rw_active = SCM_PORT_READ; | |
772 | ||
ee149d03 JB |
773 | if (c == '\n') |
774 | { | |
775 | /* What should col be in this case? | |
776 | * We'll leave it at -1. | |
777 | */ | |
778 | SCM_LINUM (port) -= 1; | |
779 | } | |
780 | else | |
781 | SCM_COL(port) -= 1; | |
782 | } | |
783 | ||
784 | ||
785 | void | |
786 | scm_ungets (s, n, port) | |
787 | char *s; | |
788 | int n; | |
789 | SCM port; | |
790 | { | |
791 | /* This is simple minded and inefficient, but unreading strings is | |
792 | * probably not a common operation, and remember that line and | |
793 | * column numbers have to be handled... | |
794 | * | |
795 | * Please feel free to write an optimized version! | |
796 | */ | |
797 | while (n--) | |
798 | scm_ungetc (s[n], port); | |
799 | } | |
800 | ||
801 | ||
802 | SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); | |
803 | ||
804 | SCM | |
805 | scm_peek_char (port) | |
806 | SCM port; | |
807 | { | |
808 | int c; | |
809 | if (SCM_UNBNDP (port)) | |
810 | port = scm_cur_inp; | |
811 | else | |
812 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); | |
813 | c = scm_getc (port); | |
814 | if (EOF == c) | |
815 | return SCM_EOF_VAL; | |
816 | scm_ungetc (c, port); | |
817 | return SCM_MAKICHR (c); | |
3cb988bd TP |
818 | } |
819 | ||
0f2d19dd | 820 | SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); |
1cc91f1b | 821 | |
0f2d19dd JB |
822 | SCM |
823 | scm_unread_char (cobj, port) | |
824 | SCM cobj; | |
825 | SCM port; | |
0f2d19dd JB |
826 | { |
827 | int c; | |
828 | ||
829 | SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); | |
830 | ||
831 | if (SCM_UNBNDP (port)) | |
832 | port = scm_cur_inp; | |
833 | else | |
834 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); | |
835 | ||
836 | ||
837 | c = SCM_ICHR (cobj); | |
838 | ||
b7f3516f | 839 | scm_ungetc (c, port); |
0f2d19dd JB |
840 | return cobj; |
841 | } | |
842 | ||
ee1e7e13 MD |
843 | SCM_PROC (s_unread_string, "unread-string", 2, 0, 0, scm_unread_string); |
844 | ||
845 | SCM | |
846 | scm_unread_string (str, port) | |
847 | SCM str; | |
848 | SCM port; | |
849 | { | |
d1c90db5 | 850 | SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), |
ee1e7e13 MD |
851 | str, SCM_ARG1, s_unread_string); |
852 | ||
853 | if (SCM_UNBNDP (port)) | |
854 | port = scm_cur_inp; | |
855 | else | |
856 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), | |
857 | port, SCM_ARG2, s_unread_string); | |
858 | ||
d1c90db5 | 859 | scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port); |
ee1e7e13 MD |
860 | |
861 | return str; | |
862 | } | |
863 | ||
840ae05d JB |
864 | SCM_PROC (s_lseek, "lseek", 3, 0, 0, scm_lseek); |
865 | SCM | |
866 | scm_lseek (SCM object, SCM offset, SCM whence) | |
867 | { | |
868 | off_t off; | |
869 | off_t rv; | |
870 | int how; | |
871 | ||
872 | object = SCM_COERCE_OUTPORT (object); | |
873 | ||
874 | off = scm_num2long (offset, (char *)SCM_ARG2, s_lseek); | |
875 | SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_lseek); | |
876 | how = SCM_INUM (whence); | |
877 | if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) | |
878 | scm_out_of_range (s_lseek, whence); | |
879 | if (SCM_NIMP (object) && SCM_OPPORTP (object)) | |
880 | { | |
881 | scm_port *pt = SCM_PTAB_ENTRY (object); | |
882 | scm_ptobfuns *ptob = scm_ptobs + SCM_PTOBNUM (object); | |
883 | ||
884 | if (!ptob->seek) | |
885 | scm_misc_error (s_lseek, "port is not seekable", | |
886 | scm_cons (object, SCM_EOL)); | |
887 | else | |
888 | { | |
889 | if (pt->rw_active == SCM_PORT_READ) | |
890 | ptob->read_flush (object); | |
891 | else if (pt->rw_active == SCM_PORT_WRITE) | |
892 | ptob->fflush (object); | |
893 | ||
894 | rv = ptob->seek (object, off, how); | |
840ae05d JB |
895 | } |
896 | } | |
897 | else /* file descriptor?. */ | |
898 | { | |
899 | SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_lseek); | |
900 | rv = lseek (SCM_INUM (object), off, how); | |
901 | if (rv == -1) | |
902 | scm_syserror (s_lseek); | |
903 | } | |
904 | return scm_long2num (rv); | |
905 | } | |
906 | ||
907 | SCM_PROC (s_ftruncate, "ftruncate", 1, 1, 0, scm_ftruncate); | |
908 | ||
909 | SCM | |
910 | scm_ftruncate (SCM port, SCM length) | |
911 | { | |
912 | scm_port *pt; | |
913 | scm_ptobfuns *ptob; | |
914 | ||
915 | port = SCM_COERCE_OUTPORT (port); | |
916 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, | |
917 | s_ftruncate); | |
918 | pt = SCM_PTAB_ENTRY (port); | |
919 | ptob = scm_ptobs + SCM_PTOBNUM (port); | |
920 | if (!ptob->ftruncate) | |
921 | scm_misc_error (s_ftruncate, "port is not truncatable", | |
922 | scm_cons (port, SCM_EOL)); | |
923 | if (SCM_UNBNDP (length)) | |
924 | { | |
925 | length = scm_lseek (port, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); | |
926 | } | |
927 | if (pt->rw_active == SCM_PORT_READ) | |
928 | ptob->read_flush (port); | |
929 | else if (pt->rw_active == SCM_PORT_WRITE) | |
930 | ptob->fflush (port); | |
931 | ||
932 | ptob->ftruncate (port, scm_num2long (length, (char *)SCM_ARG2, s_ftruncate)); | |
933 | return SCM_UNSPECIFIED; | |
934 | } | |
935 | ||
360fc44c | 936 | SCM_PROC (s_port_line, "port-line", 1, 0, 0, scm_port_line); |
1cc91f1b | 937 | |
0f2d19dd | 938 | SCM |
d14af9f2 | 939 | scm_port_line (port) |
0f2d19dd | 940 | SCM port; |
0f2d19dd | 941 | { |
78446828 | 942 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
943 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
944 | port, | |
945 | SCM_ARG1, | |
946 | s_port_line); | |
947 | return SCM_MAKINUM (SCM_LINUM (port)); | |
0f2d19dd JB |
948 | } |
949 | ||
360fc44c | 950 | SCM_PROC (s_set_port_line_x, "set-port-line!", 2, 0, 0, scm_set_port_line_x); |
d043d8c2 MD |
951 | |
952 | SCM | |
953 | scm_set_port_line_x (port, line) | |
954 | SCM port; | |
955 | SCM line; | |
956 | { | |
360fc44c MD |
957 | port = SCM_COERCE_OUTPORT (port); |
958 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
959 | port, | |
960 | SCM_ARG1, | |
961 | s_set_port_line_x); | |
962 | SCM_ASSERT (SCM_INUMP (line), line, SCM_ARG2, s_set_port_line_x); | |
d043d8c2 MD |
963 | return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); |
964 | } | |
965 | ||
360fc44c | 966 | SCM_PROC (s_port_column, "port-column", 1, 0, 0, scm_port_column); |
1cc91f1b | 967 | |
0f2d19dd | 968 | SCM |
d14af9f2 | 969 | scm_port_column (port) |
0f2d19dd | 970 | SCM port; |
0f2d19dd | 971 | { |
78446828 | 972 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
973 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
974 | port, | |
975 | SCM_ARG1, | |
976 | s_port_column); | |
977 | return SCM_MAKINUM (SCM_COL (port)); | |
0f2d19dd JB |
978 | } |
979 | ||
360fc44c | 980 | SCM_PROC (s_set_port_column_x, "set-port-column!", 2, 0, 0, scm_set_port_column_x); |
d043d8c2 MD |
981 | |
982 | SCM | |
983 | scm_set_port_column_x (port, column) | |
984 | SCM port; | |
985 | SCM column; | |
986 | { | |
360fc44c MD |
987 | port = SCM_COERCE_OUTPORT (port); |
988 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
989 | port, | |
990 | SCM_ARG1, | |
991 | s_set_port_column_x); | |
992 | SCM_ASSERT (SCM_INUMP (column), column, SCM_ARG2, s_set_port_column_x); | |
d043d8c2 MD |
993 | return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); |
994 | } | |
995 | ||
360fc44c | 996 | SCM_PROC (s_port_filename, "port-filename", 1, 0, 0, scm_port_filename); |
1cc91f1b | 997 | |
0f2d19dd | 998 | SCM |
d14af9f2 | 999 | scm_port_filename (port) |
0f2d19dd | 1000 | SCM port; |
0f2d19dd | 1001 | { |
78446828 | 1002 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1003 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1004 | port, | |
1005 | SCM_ARG1, | |
1006 | s_port_filename); | |
1007 | return SCM_PTAB_ENTRY (port)->file_name; | |
0f2d19dd JB |
1008 | } |
1009 | ||
360fc44c | 1010 | SCM_PROC (s_set_port_filename_x, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x); |
1cc91f1b | 1011 | |
d14af9f2 MD |
1012 | SCM |
1013 | scm_set_port_filename_x (port, filename) | |
1014 | SCM port; | |
1015 | SCM filename; | |
d14af9f2 | 1016 | { |
360fc44c MD |
1017 | port = SCM_COERCE_OUTPORT (port); |
1018 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1019 | port, | |
1020 | SCM_ARG1, | |
1021 | s_set_port_filename_x); | |
1022 | /* We allow the user to set the filename to whatever he likes. */ | |
d14af9f2 MD |
1023 | return SCM_PTAB_ENTRY (port)->file_name = filename; |
1024 | } | |
1025 | ||
0f2d19dd JB |
1026 | #ifndef ttyname |
1027 | extern char * ttyname(); | |
1028 | #endif | |
1029 | ||
1cc91f1b | 1030 | |
0f2d19dd JB |
1031 | void |
1032 | scm_prinport (exp, port, type) | |
1033 | SCM exp; | |
1034 | SCM port; | |
1035 | char *type; | |
0f2d19dd | 1036 | { |
b7f3516f | 1037 | scm_puts ("#<", port); |
0f2d19dd | 1038 | if (SCM_CLOSEDP (exp)) |
b7f3516f | 1039 | scm_puts ("closed: ", port); |
0f2d19dd JB |
1040 | else |
1041 | { | |
1042 | if (SCM_RDNG & SCM_CAR (exp)) | |
b7f3516f | 1043 | scm_puts ("input: ", port); |
0f2d19dd | 1044 | if (SCM_WRTNG & SCM_CAR (exp)) |
b7f3516f | 1045 | scm_puts ("output: ", port); |
0f2d19dd | 1046 | } |
b7f3516f TT |
1047 | scm_puts (type, port); |
1048 | scm_putc (' ', port); | |
0f2d19dd | 1049 | if (SCM_OPFPORTP (exp)) |
ee149d03 JB |
1050 | { |
1051 | int fdes = (SCM_FSTREAM (exp))->fdes; | |
1052 | ||
1053 | if (isatty (fdes)) | |
1054 | scm_puts (ttyname (fdes), port); | |
1055 | else | |
1056 | scm_intprint (fdes, 10, port); | |
1057 | } | |
0f2d19dd | 1058 | else |
ee149d03 JB |
1059 | { |
1060 | scm_intprint (SCM_CDR (exp), 16, port); | |
1061 | } | |
b7f3516f | 1062 | scm_putc ('>', port); |
0f2d19dd JB |
1063 | } |
1064 | ||
1cc91f1b | 1065 | |
0f2d19dd JB |
1066 | void |
1067 | scm_ports_prehistory () | |
0f2d19dd JB |
1068 | { |
1069 | scm_numptob = 0; | |
1070 | scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); | |
1071 | ||
1072 | /* WARNING: These scm_newptob calls must be done in this order. | |
1073 | * They must agree with the port declarations in tags.h. | |
1074 | */ | |
1075 | /* scm_tc16_fport = */ scm_newptob (&scm_fptob); | |
ee149d03 | 1076 | /* scm_tc16_pipe was here */ scm_newptob (&scm_fptob); /* dummy. */ |
0f2d19dd JB |
1077 | /* scm_tc16_strport = */ scm_newptob (&scm_stptob); |
1078 | /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); | |
1079 | } | |
0f2d19dd JB |
1080 | |
1081 | \f | |
ee149d03 | 1082 | |
d68fee48 | 1083 | /* Void ports. */ |
0f2d19dd JB |
1084 | |
1085 | int scm_tc16_void_port = 0; | |
1086 | ||
1087 | static int | |
38cb0e9c | 1088 | print_void_port (SCM exp, SCM port, scm_print_state *pstate) |
0f2d19dd JB |
1089 | { |
1090 | scm_prinport (exp, port, "void"); | |
1091 | return 1; | |
1092 | } | |
1093 | ||
ee149d03 | 1094 | static void |
0f88a8f3 | 1095 | flush_void_port (SCM port) |
0f2d19dd | 1096 | { |
3cb988bd | 1097 | } |
1cc91f1b | 1098 | |
0f2d19dd | 1099 | static int |
0f88a8f3 | 1100 | close_void_port (SCM port) |
0f2d19dd JB |
1101 | { |
1102 | return 0; /* this is ignored by scm_close_port. */ | |
1103 | } | |
1104 | ||
1105 | ||
1cc91f1b | 1106 | |
0f2d19dd | 1107 | static int |
38cb0e9c | 1108 | noop0 (SCM stream) |
0f2d19dd JB |
1109 | { |
1110 | return 0; | |
1111 | } | |
1112 | ||
1113 | ||
0f88a8f3 | 1114 | static struct scm_ptobfuns void_port_ptob = |
0f2d19dd | 1115 | { |
dc53f026 | 1116 | 0, |
0f2d19dd JB |
1117 | noop0, |
1118 | print_void_port, | |
1119 | 0, /* equal? */ | |
0f2d19dd | 1120 | flush_void_port, |
840ae05d | 1121 | flush_void_port, |
0f2d19dd | 1122 | close_void_port, |
ee149d03 JB |
1123 | 0, |
1124 | 0, | |
1125 | 0, | |
840ae05d | 1126 | 0, |
0f2d19dd JB |
1127 | }; |
1128 | ||
0f2d19dd JB |
1129 | SCM |
1130 | scm_void_port (mode_str) | |
1131 | char * mode_str; | |
0f2d19dd JB |
1132 | { |
1133 | int mode_bits; | |
1134 | SCM answer; | |
840ae05d | 1135 | scm_port * pt; |
0f2d19dd JB |
1136 | |
1137 | SCM_NEWCELL (answer); | |
1138 | SCM_DEFER_INTS; | |
1139 | mode_bits = scm_mode_bits (mode_str); | |
1140 | pt = scm_add_to_port_table (answer); | |
0f2d19dd | 1141 | SCM_SETPTAB_ENTRY (answer, pt); |
ee149d03 JB |
1142 | SCM_SETSTREAM (answer, 0); |
1143 | SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); | |
0f2d19dd JB |
1144 | SCM_ALLOW_INTS; |
1145 | return answer; | |
1146 | } | |
1147 | ||
1148 | ||
1149 | SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); | |
1cc91f1b | 1150 | |
0f2d19dd JB |
1151 | SCM |
1152 | scm_sys_make_void_port (mode) | |
1153 | SCM mode; | |
0f2d19dd | 1154 | { |
89958ad0 | 1155 | SCM_ASSERT (SCM_NIMP (mode) && SCM_ROSTRINGP (mode), mode, |
0f2d19dd JB |
1156 | SCM_ARG1, s_sys_make_void_port); |
1157 | ||
89958ad0 | 1158 | SCM_COERCE_SUBSTR (mode); |
0f2d19dd JB |
1159 | return scm_void_port (SCM_ROCHARS (mode)); |
1160 | } | |
1161 | ||
0f2d19dd | 1162 | \f |
89545eba | 1163 | /* Initialization. */ |
1cc91f1b | 1164 | |
0f2d19dd JB |
1165 | void |
1166 | scm_init_ports () | |
0f2d19dd | 1167 | { |
840ae05d JB |
1168 | /* lseek() symbols. */ |
1169 | scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); | |
1170 | scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); | |
1171 | scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); | |
1172 | ||
0f2d19dd JB |
1173 | scm_tc16_void_port = scm_newptob (&void_port_ptob); |
1174 | #include "ports.x" | |
1175 | } |