Commit | Line | Data |
---|---|---|
7dc6e754 | 1 | /* Copyright (C) 1995,1996,1997,1998 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 | 49 | #include "markers.h" |
5d09ff4e | 50 | #include "filesys.h" |
20e6290e JB |
51 | #include "fports.h" |
52 | #include "strports.h" | |
53 | #include "vports.h" | |
89ea5b7c | 54 | #include "kw.h" |
20e6290e JB |
55 | |
56 | #include "ports.h" | |
0f2d19dd JB |
57 | |
58 | #ifdef HAVE_MALLOC_H | |
95b88819 | 59 | #include <malloc.h> |
0f2d19dd JB |
60 | #endif |
61 | ||
62 | #ifdef HAVE_UNISTD_H | |
63 | #include <unistd.h> | |
64 | #endif | |
65 | ||
95b88819 GH |
66 | #ifdef HAVE_SYS_IOCTL_H |
67 | #include <sys/ioctl.h> | |
68 | #endif | |
d68fee48 | 69 | |
0f2d19dd | 70 | \f |
d68fee48 | 71 | /* The port kind table --- a dynamically resized array of port types. */ |
0f2d19dd JB |
72 | |
73 | ||
74 | /* scm_ptobs scm_numptob | |
75 | * implement a dynamicly resized array of ptob records. | |
76 | * Indexes into this table are used when generating type | |
77 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
78 | */ | |
79 | scm_ptobfuns *scm_ptobs; | |
a1c95c45 | 80 | int scm_numptob; |
0f2d19dd | 81 | |
1cc91f1b | 82 | |
0f2d19dd JB |
83 | SCM |
84 | scm_markstream (ptr) | |
85 | SCM ptr; | |
0f2d19dd JB |
86 | { |
87 | int openp; | |
0f2d19dd | 88 | openp = SCM_CAR (ptr) & SCM_OPN; |
0f2d19dd JB |
89 | if (openp) |
90 | return SCM_STREAM (ptr); | |
91 | else | |
92 | return SCM_BOOL_F; | |
93 | } | |
94 | ||
95 | ||
1cc91f1b | 96 | |
0f2d19dd JB |
97 | long |
98 | scm_newptob (ptob) | |
99 | scm_ptobfuns *ptob; | |
0f2d19dd JB |
100 | { |
101 | char *tmp; | |
102 | if (255 <= scm_numptob) | |
103 | goto ptoberr; | |
104 | SCM_DEFER_INTS; | |
105 | SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns))); | |
106 | if (tmp) | |
107 | { | |
108 | scm_ptobs = (scm_ptobfuns *) tmp; | |
109 | scm_ptobs[scm_numptob].mark = ptob->mark; | |
110 | scm_ptobs[scm_numptob].free = ptob->free; | |
111 | scm_ptobs[scm_numptob].print = ptob->print; | |
112 | scm_ptobs[scm_numptob].equalp = ptob->equalp; | |
113 | scm_ptobs[scm_numptob].fputc = ptob->fputc; | |
114 | scm_ptobs[scm_numptob].fputs = ptob->fputs; | |
115 | scm_ptobs[scm_numptob].fwrite = ptob->fwrite; | |
116 | scm_ptobs[scm_numptob].fflush = ptob->fflush; | |
117 | scm_ptobs[scm_numptob].fgetc = ptob->fgetc; | |
3cb988bd | 118 | scm_ptobs[scm_numptob].fgets = ptob->fgets; |
0f2d19dd JB |
119 | scm_ptobs[scm_numptob].fclose = ptob->fclose; |
120 | scm_numptob++; | |
121 | } | |
122 | SCM_ALLOW_INTS; | |
123 | if (!tmp) | |
124 | ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); | |
125 | return scm_tc7_port + (scm_numptob - 1) * 256; | |
126 | } | |
127 | ||
128 | \f | |
0f2d19dd | 129 | |
44493941 | 130 | SCM_PROC(s_char_ready_p, "char-ready?", 0, 1, 0, scm_char_ready_p); |
1cc91f1b | 131 | |
0f2d19dd JB |
132 | SCM |
133 | scm_char_ready_p (port) | |
134 | SCM port; | |
0f2d19dd JB |
135 | { |
136 | if (SCM_UNBNDP (port)) | |
137 | port = scm_cur_inp; | |
138 | else | |
d68fee48 JB |
139 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, |
140 | s_char_ready_p); | |
141 | ||
0f2d19dd JB |
142 | if (SCM_CRDYP (port) || !SCM_FPORTP (port)) |
143 | return SCM_BOOL_T; | |
5d09ff4e MD |
144 | return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p) |
145 | ? SCM_BOOL_T | |
146 | : SCM_BOOL_F); | |
0f2d19dd | 147 | } |
0f2d19dd JB |
148 | |
149 | ||
150 | \f | |
d68fee48 | 151 | /* Standard ports --- current input, output, error, and more(!). */ |
0f2d19dd | 152 | |
0f2d19dd | 153 | SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); |
1cc91f1b | 154 | |
0f2d19dd JB |
155 | SCM |
156 | scm_current_input_port () | |
0f2d19dd JB |
157 | { |
158 | return scm_cur_inp; | |
159 | } | |
160 | ||
161 | SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); | |
1cc91f1b | 162 | |
0f2d19dd JB |
163 | SCM |
164 | scm_current_output_port () | |
0f2d19dd JB |
165 | { |
166 | return scm_cur_outp; | |
167 | } | |
168 | ||
169 | SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); | |
1cc91f1b | 170 | |
0f2d19dd JB |
171 | SCM |
172 | scm_current_error_port () | |
0f2d19dd JB |
173 | { |
174 | return scm_cur_errp; | |
175 | } | |
176 | ||
31614d8e MD |
177 | SCM_PROC(s_current_load_port, "current-load-port", 0, 0, 0, scm_current_load_port); |
178 | ||
179 | SCM | |
180 | scm_current_load_port () | |
181 | { | |
182 | return scm_cur_loadp; | |
183 | } | |
184 | ||
0f2d19dd | 185 | SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); |
1cc91f1b | 186 | |
0f2d19dd JB |
187 | SCM |
188 | scm_set_current_input_port (port) | |
189 | SCM port; | |
0f2d19dd JB |
190 | { |
191 | SCM oinp = scm_cur_inp; | |
192 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); | |
193 | scm_cur_inp = port; | |
194 | return oinp; | |
195 | } | |
196 | ||
197 | ||
198 | SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); | |
1cc91f1b | 199 | |
0f2d19dd JB |
200 | SCM |
201 | scm_set_current_output_port (port) | |
202 | SCM port; | |
0f2d19dd JB |
203 | { |
204 | SCM ooutp = scm_cur_outp; | |
78446828 | 205 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
206 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); |
207 | scm_cur_outp = port; | |
208 | return ooutp; | |
209 | } | |
210 | ||
211 | ||
212 | SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); | |
1cc91f1b | 213 | |
0f2d19dd JB |
214 | SCM |
215 | scm_set_current_error_port (port) | |
216 | SCM port; | |
0f2d19dd JB |
217 | { |
218 | SCM oerrp = scm_cur_errp; | |
78446828 | 219 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
220 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); |
221 | scm_cur_errp = port; | |
222 | return oerrp; | |
223 | } | |
224 | ||
225 | \f | |
d68fee48 | 226 | /* The port table --- a table of all the open ports. */ |
0f2d19dd JB |
227 | |
228 | /* Array of open ports, required for reliable MOVE->FDES etc. */ | |
229 | struct scm_port_table **scm_port_table; | |
230 | ||
231 | int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ | |
232 | int scm_port_table_room = 20; /* Size of the array. */ | |
233 | ||
234 | /* Add a port to the table. Call with SCM_DEFER_INTS active. */ | |
1cc91f1b | 235 | |
0f2d19dd JB |
236 | struct scm_port_table * |
237 | scm_add_to_port_table (port) | |
238 | SCM port; | |
0f2d19dd JB |
239 | { |
240 | if (scm_port_table_size == scm_port_table_room) | |
241 | { | |
242 | scm_port_table = ((struct scm_port_table **) | |
243 | realloc ((char *) scm_port_table, | |
67fe060e GH |
244 | (scm_sizet) (sizeof (struct scm_port_table *) |
245 | * scm_port_table_room * 2))); | |
0f2d19dd JB |
246 | /* !!! error checking */ |
247 | scm_port_table_room *= 2; | |
248 | } | |
249 | scm_port_table[scm_port_table_size] = ((struct scm_port_table *) | |
250 | scm_must_malloc (sizeof (struct scm_port_table), | |
251 | "system port table")); | |
252 | scm_port_table[scm_port_table_size]->port = port; | |
ee1e7e13 | 253 | scm_port_table[scm_port_table_size]->entry = scm_port_table_size; |
0f2d19dd JB |
254 | scm_port_table[scm_port_table_size]->revealed = 0; |
255 | scm_port_table[scm_port_table_size]->stream = 0; | |
ebf7394e | 256 | scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F; |
d0defdf3 | 257 | scm_port_table[scm_port_table_size]->line_number = 0; |
0f2d19dd | 258 | scm_port_table[scm_port_table_size]->column_number = 0; |
ee1e7e13 MD |
259 | scm_port_table[scm_port_table_size]->cp |
260 | = scm_port_table[scm_port_table_size]->cbuf; | |
261 | scm_port_table[scm_port_table_size]->cbufend | |
262 | = &scm_port_table[scm_port_table_size]->cbuf[SCM_INITIAL_CBUF_SIZE]; | |
0f2d19dd JB |
263 | return scm_port_table[scm_port_table_size++]; |
264 | } | |
265 | ||
266 | /* Remove a port from the table. Call with SCM_DEFER_INTS active. */ | |
1cc91f1b | 267 | |
0f2d19dd JB |
268 | void |
269 | scm_remove_from_port_table (port) | |
270 | SCM port; | |
0f2d19dd | 271 | { |
ee1e7e13 MD |
272 | struct scm_port_table *p = SCM_PTAB_ENTRY (port); |
273 | int i = p->entry; | |
274 | /* Error if not found: too violent? May occur in GC. */ | |
275 | if (i >= scm_port_table_size) | |
276 | scm_wta (port, "Port not in table", "scm_remove_from_port_table"); | |
277 | scm_mallocated -= (sizeof (*p) | |
278 | + (p->cbufend - p->cbuf) | |
279 | - SCM_INITIAL_CBUF_SIZE); | |
280 | scm_must_free ((char *)p); | |
281 | /* Since we have just freed slot i we can shrink the table by moving | |
282 | the last entry to that slot... */ | |
283 | if (i < scm_port_table_size - 1) | |
0f2d19dd | 284 | { |
ee1e7e13 MD |
285 | scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; |
286 | scm_port_table[i]->entry = i; | |
0f2d19dd | 287 | } |
0f2d19dd JB |
288 | SCM_SETPTAB_ENTRY (port, 0); |
289 | scm_port_table_size--; | |
290 | } | |
291 | ||
ee1e7e13 MD |
292 | void |
293 | scm_grow_port_cbuf (port, requested) | |
294 | SCM port; | |
295 | size_t requested; | |
296 | { | |
297 | struct scm_port_table *p = SCM_PTAB_ENTRY (port); | |
298 | int size = p->cbufend - p->cbuf; | |
299 | int new_size = size * 3 / 2; | |
300 | if (new_size < requested) | |
301 | new_size = requested; | |
302 | p = realloc (p, sizeof (*p) - SCM_INITIAL_CBUF_SIZE + new_size); | |
303 | scm_port_table[p->entry] = p; | |
304 | SCM_SETPTAB_ENTRY (port, p); | |
305 | } | |
306 | ||
fea6b4ea | 307 | #ifdef GUILE_DEBUG |
0f2d19dd JB |
308 | /* Undocumented functions for debugging. */ |
309 | /* Return the number of ports in the table. */ | |
1cc91f1b | 310 | |
1146b6cd | 311 | SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size); |
0f2d19dd JB |
312 | SCM |
313 | scm_pt_size () | |
0f2d19dd JB |
314 | { |
315 | return SCM_MAKINUM (scm_port_table_size); | |
316 | } | |
317 | ||
318 | /* Return the ith member of the port table. */ | |
1146b6cd | 319 | SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member); |
0f2d19dd JB |
320 | SCM |
321 | scm_pt_member (member) | |
322 | SCM member; | |
0f2d19dd JB |
323 | { |
324 | int i; | |
325 | SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); | |
326 | i = SCM_INUM (member); | |
327 | if (i < 0 || i >= scm_port_table_size) | |
328 | return SCM_BOOL_F; | |
329 | else | |
330 | return scm_port_table[i]->port; | |
331 | } | |
332 | #endif | |
333 | ||
334 | ||
d68fee48 JB |
335 | \f |
336 | /* Revealed counts --- an oddity inherited from SCSH. */ | |
337 | ||
8b13c6b3 GH |
338 | /* Find a port in the table and return its revealed count. |
339 | Also used by the garbage collector. | |
0f2d19dd | 340 | */ |
1cc91f1b | 341 | |
0f2d19dd JB |
342 | int |
343 | scm_revealed_count (port) | |
344 | SCM port; | |
0f2d19dd JB |
345 | { |
346 | return SCM_REVEALED(port); | |
347 | } | |
348 | ||
349 | ||
350 | ||
351 | /* Return the revealed count for a port. */ | |
352 | ||
353 | SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); | |
1cc91f1b | 354 | |
0f2d19dd JB |
355 | SCM |
356 | scm_port_revealed (port) | |
357 | SCM port; | |
0f2d19dd | 358 | { |
78446828 | 359 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd | 360 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); |
8b13c6b3 | 361 | return SCM_MAKINUM (scm_revealed_count (port)); |
0f2d19dd JB |
362 | } |
363 | ||
364 | /* Set the revealed count for a port. */ | |
365 | SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); | |
1cc91f1b | 366 | |
0f2d19dd JB |
367 | SCM |
368 | scm_set_port_revealed_x (port, rcount) | |
369 | SCM port; | |
370 | SCM rcount; | |
0f2d19dd | 371 | { |
78446828 | 372 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
373 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); |
374 | SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); | |
375 | SCM_DEFER_INTS; | |
376 | SCM_REVEALED (port) = SCM_INUM (rcount); | |
377 | SCM_ALLOW_INTS; | |
8b13c6b3 | 378 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
379 | } |
380 | ||
d68fee48 JB |
381 | |
382 | \f | |
383 | /* Retrieving a port's mode. */ | |
384 | ||
eadd48de GH |
385 | /* Return the flags that characterize a port based on the mode |
386 | * string used to open a file for that port. | |
387 | * | |
388 | * See PORT FLAGS in scm.h | |
389 | */ | |
390 | ||
391 | long | |
392 | scm_mode_bits (modes) | |
393 | char *modes; | |
394 | { | |
395 | return (SCM_OPN | |
396 | | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) | |
397 | | ( strchr (modes, 'w') | |
398 | || strchr (modes, 'a') | |
399 | || strchr (modes, '+') ? SCM_WRTNG : 0) | |
400 | | (strchr (modes, '0') ? SCM_BUF0 : 0)); | |
401 | } | |
402 | ||
403 | ||
404 | /* Return the mode flags from an open port. | |
405 | * Some modes such as "append" are only used when opening | |
406 | * a file and are not returned here. */ | |
407 | ||
408 | SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); | |
409 | ||
410 | SCM | |
411 | scm_port_mode (port) | |
412 | SCM port; | |
413 | { | |
414 | char modes[3]; | |
415 | modes[0] = '\0'; | |
78446828 MV |
416 | |
417 | port = SCM_COERCE_OUTPORT (port); | |
eadd48de GH |
418 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); |
419 | if (SCM_CAR (port) & SCM_RDNG) { | |
420 | if (SCM_CAR (port) & SCM_WRTNG) | |
421 | strcpy (modes, "r+"); | |
422 | else | |
423 | strcpy (modes, "r"); | |
424 | } | |
425 | else if (SCM_CAR (port) & SCM_WRTNG) | |
426 | strcpy (modes, "w"); | |
427 | if (SCM_CAR (port) & SCM_BUF0) | |
428 | strcat (modes, "0"); | |
429 | return scm_makfromstr (modes, strlen (modes), 0); | |
430 | } | |
431 | ||
432 | ||
d68fee48 JB |
433 | \f |
434 | /* Closing ports. */ | |
435 | ||
0f2d19dd JB |
436 | /* scm_close_port |
437 | * Call the close operation on a port object. | |
eadd48de | 438 | * see also scm_close. |
0f2d19dd JB |
439 | */ |
440 | SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); | |
1cc91f1b | 441 | |
0f2d19dd JB |
442 | SCM |
443 | scm_close_port (port) | |
444 | SCM port; | |
0f2d19dd JB |
445 | { |
446 | scm_sizet i; | |
eadd48de GH |
447 | int rv; |
448 | ||
78446828 MV |
449 | port = SCM_COERCE_OUTPORT (port); |
450 | ||
341eaef0 | 451 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, |
3c1750f3 | 452 | s_close_port); |
0f2d19dd | 453 | if (SCM_CLOSEDP (port)) |
eadd48de | 454 | return SCM_BOOL_F; |
0f2d19dd JB |
455 | i = SCM_PTOBNUM (port); |
456 | SCM_DEFER_INTS; | |
457 | if (scm_ptobs[i].fclose) | |
eadd48de | 458 | { |
0f88a8f3 | 459 | SCM_SYSCALL (rv = (scm_ptobs[i].fclose) (port)); |
eadd48de GH |
460 | /* ports with a closed file descriptor can be reclosed without error. */ |
461 | if (rv < 0 && errno != EBADF) | |
462 | scm_syserror (s_close_port); | |
463 | } | |
464 | else | |
465 | rv = 0; | |
0f2d19dd | 466 | scm_remove_from_port_table (port); |
898a256f | 467 | SCM_SETAND_CAR (port, ~SCM_OPN); |
0f2d19dd | 468 | SCM_ALLOW_INTS; |
eadd48de | 469 | return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; |
0f2d19dd JB |
470 | } |
471 | ||
472 | SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); | |
1cc91f1b | 473 | |
0f2d19dd JB |
474 | SCM |
475 | scm_close_all_ports_except (ports) | |
476 | SCM ports; | |
0f2d19dd JB |
477 | { |
478 | int i = 0; | |
479 | SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); | |
480 | SCM_DEFER_INTS; | |
481 | while (i < scm_port_table_size) | |
482 | { | |
483 | SCM thisport = scm_port_table[i]->port; | |
484 | int found = 0; | |
485 | SCM ports_ptr = ports; | |
486 | ||
487 | while (SCM_NNULLP (ports_ptr)) | |
488 | { | |
78446828 | 489 | SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr)); |
0f2d19dd JB |
490 | if (i == 0) |
491 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); | |
492 | if (port == thisport) | |
493 | found = 1; | |
494 | ports_ptr = SCM_CDR (ports_ptr); | |
495 | } | |
496 | if (found) | |
497 | i++; | |
498 | else | |
499 | /* i is not to be incremented here. */ | |
500 | scm_close_port (thisport); | |
501 | } | |
502 | SCM_ALLOW_INTS; | |
503 | return SCM_UNSPECIFIED; | |
504 | } | |
505 | ||
d68fee48 JB |
506 | |
507 | \f | |
508 | /* Utter miscellany. Gosh, we should clean this up some time. */ | |
509 | ||
0f2d19dd | 510 | SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); |
1cc91f1b | 511 | |
0f2d19dd JB |
512 | SCM |
513 | scm_input_port_p (x) | |
514 | SCM x; | |
0f2d19dd JB |
515 | { |
516 | if (SCM_IMP (x)) | |
517 | return SCM_BOOL_F; | |
518 | return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
519 | } | |
520 | ||
521 | SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); | |
1cc91f1b | 522 | |
0f2d19dd JB |
523 | SCM |
524 | scm_output_port_p (x) | |
525 | SCM x; | |
0f2d19dd JB |
526 | { |
527 | if (SCM_IMP (x)) | |
528 | return SCM_BOOL_F; | |
529 | return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
530 | } | |
531 | ||
532 | ||
533 | SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); | |
1cc91f1b | 534 | |
0f2d19dd JB |
535 | SCM |
536 | scm_eof_object_p (x) | |
537 | SCM x; | |
0f2d19dd | 538 | { |
0c32d76c | 539 | return SCM_EOF_OBJECT_P (x) ? SCM_BOOL_T : SCM_BOOL_F; |
0f2d19dd JB |
540 | } |
541 | ||
542 | SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); | |
1cc91f1b | 543 | |
0f2d19dd JB |
544 | SCM |
545 | scm_force_output (port) | |
546 | SCM port; | |
0f2d19dd JB |
547 | { |
548 | if (SCM_UNBNDP (port)) | |
3e877d15 | 549 | port = scm_cur_outp; |
0f2d19dd | 550 | else |
78446828 MV |
551 | { |
552 | port = SCM_COERCE_OUTPORT (port); | |
3e877d15 JB |
553 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, |
554 | s_force_output); | |
78446828 | 555 | } |
0f2d19dd JB |
556 | { |
557 | scm_sizet i = SCM_PTOBNUM (port); | |
0f88a8f3 | 558 | SCM_SYSCALL ((scm_ptobs[i].fflush) (port)); |
0f2d19dd JB |
559 | return SCM_UNSPECIFIED; |
560 | } | |
561 | } | |
562 | ||
9c29ac66 | 563 | SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports); |
89ea5b7c GH |
564 | SCM |
565 | scm_flush_all_ports (void) | |
566 | { | |
567 | int i; | |
568 | ||
569 | for (i = 0; i < scm_port_table_size; i++) | |
570 | { | |
571 | SCM port = scm_port_table[i]->port; | |
572 | if (SCM_OPOUTPORTP (port)) | |
573 | { | |
574 | scm_sizet ptob = SCM_PTOBNUM (port); | |
0f88a8f3 | 575 | (scm_ptobs[ptob].fflush) (port); |
89ea5b7c GH |
576 | } |
577 | } | |
578 | return SCM_UNSPECIFIED; | |
579 | } | |
0f2d19dd JB |
580 | |
581 | SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); | |
1cc91f1b | 582 | |
0f2d19dd JB |
583 | SCM |
584 | scm_read_char (port) | |
585 | SCM port; | |
0f2d19dd JB |
586 | { |
587 | int c; | |
588 | if (SCM_UNBNDP (port)) | |
334341aa | 589 | port = scm_cur_inp; |
0f2d19dd JB |
590 | else |
591 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); | |
b7f3516f | 592 | c = scm_getc (port); |
0f2d19dd JB |
593 | if (EOF == c) |
594 | return SCM_EOF_VAL; | |
595 | return SCM_MAKICHR (c); | |
596 | } | |
597 | ||
598 | ||
599 | SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); | |
1cc91f1b | 600 | |
0f2d19dd JB |
601 | SCM |
602 | scm_peek_char (port) | |
603 | SCM port; | |
0f2d19dd JB |
604 | { |
605 | int c; | |
606 | if (SCM_UNBNDP (port)) | |
607 | port = scm_cur_inp; | |
608 | else | |
609 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); | |
b7f3516f | 610 | c = scm_getc (port); |
0f2d19dd JB |
611 | if (EOF == c) |
612 | return SCM_EOF_VAL; | |
b7f3516f | 613 | scm_ungetc (c, port); |
0f2d19dd JB |
614 | return SCM_MAKICHR (c); |
615 | } | |
616 | ||
3cb988bd TP |
617 | /* |
618 | * A generic fgets method. We supply this method so that ports which | |
619 | * can't use fgets(3) (like string ports or soft ports) can still use | |
620 | * line-based i/o. The generic method calls the port's own fgetc method | |
621 | * for input. It should be possible to write a more efficient | |
622 | * method for any given port representation -- this is supplied just | |
623 | * to ensure that you don't have to. | |
624 | */ | |
625 | ||
848f2a01 | 626 | char * scm_generic_fgets SCM_P ((SCM port, int *len)); |
3cb988bd TP |
627 | |
628 | char * | |
848f2a01 | 629 | scm_generic_fgets (port, len) |
3cb988bd | 630 | SCM port; |
848f2a01 | 631 | int *len; |
3cb988bd | 632 | { |
3cb988bd TP |
633 | scm_sizet p = SCM_PTOBNUM (port); |
634 | ||
848f2a01 | 635 | char *buf; |
3cb988bd TP |
636 | int limit = 80; /* current size of buffer */ |
637 | int c; | |
638 | ||
848f2a01 | 639 | /* FIXME: It would be nice to be able to check for EOF before anything. */ |
3cb988bd | 640 | |
848f2a01 | 641 | *len = 0; |
3e2043c4 TP |
642 | buf = (char *) malloc (limit * sizeof(char)); |
643 | ||
644 | /* If a char has been pushed onto the port with scm_ungetc, | |
645 | read that first. */ | |
ee1e7e13 | 646 | while (SCM_CRDYP (port)) |
3e2043c4 | 647 | { |
848f2a01 | 648 | buf[*len] = SCM_CGETUN (port); |
ee1e7e13 MD |
649 | SCM_TRY_CLRDY (port); |
650 | if (buf[(*len)++] == '\n' || *len == limit - 1) | |
3e2043c4 | 651 | { |
848f2a01 | 652 | buf[*len] = '\0'; |
3e2043c4 TP |
653 | return buf; |
654 | } | |
655 | } | |
3cb988bd TP |
656 | |
657 | while (1) { | |
848f2a01 | 658 | if (*len >= limit-1) |
3cb988bd | 659 | { |
3e2043c4 | 660 | buf = (char *) realloc (buf, sizeof(char) * limit * 2); |
3cb988bd TP |
661 | limit *= 2; |
662 | } | |
663 | ||
0f88a8f3 | 664 | c = (scm_ptobs[p].fgetc) (port); |
3cb988bd | 665 | if (c != EOF) |
848f2a01 | 666 | buf[(*len)++] = c; |
3cb988bd TP |
667 | |
668 | if (c == EOF || c == '\n') | |
669 | { | |
848f2a01 | 670 | if (*len) |
3cb988bd | 671 | { |
848f2a01 | 672 | buf[*len] = '\0'; |
3cb988bd TP |
673 | return buf; |
674 | } | |
3e2043c4 | 675 | free (buf); |
3cb988bd TP |
676 | return NULL; |
677 | } | |
678 | } | |
679 | } | |
680 | ||
0f2d19dd | 681 | SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); |
1cc91f1b | 682 | |
0f2d19dd JB |
683 | SCM |
684 | scm_unread_char (cobj, port) | |
685 | SCM cobj; | |
686 | SCM port; | |
0f2d19dd JB |
687 | { |
688 | int c; | |
689 | ||
690 | SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); | |
691 | ||
692 | if (SCM_UNBNDP (port)) | |
693 | port = scm_cur_inp; | |
694 | else | |
695 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); | |
696 | ||
697 | ||
698 | c = SCM_ICHR (cobj); | |
699 | ||
b7f3516f | 700 | scm_ungetc (c, port); |
0f2d19dd JB |
701 | return cobj; |
702 | } | |
703 | ||
ee1e7e13 MD |
704 | SCM_PROC (s_unread_string, "unread-string", 2, 0, 0, scm_unread_string); |
705 | ||
706 | SCM | |
707 | scm_unread_string (str, port) | |
708 | SCM str; | |
709 | SCM port; | |
710 | { | |
d1c90db5 | 711 | SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), |
ee1e7e13 MD |
712 | str, SCM_ARG1, s_unread_string); |
713 | ||
714 | if (SCM_UNBNDP (port)) | |
715 | port = scm_cur_inp; | |
716 | else | |
717 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), | |
718 | port, SCM_ARG2, s_unread_string); | |
719 | ||
d1c90db5 | 720 | scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port); |
ee1e7e13 MD |
721 | |
722 | return str; | |
723 | } | |
724 | ||
360fc44c | 725 | SCM_PROC (s_port_line, "port-line", 1, 0, 0, scm_port_line); |
1cc91f1b | 726 | |
0f2d19dd | 727 | SCM |
d14af9f2 | 728 | scm_port_line (port) |
0f2d19dd | 729 | SCM port; |
0f2d19dd | 730 | { |
78446828 | 731 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
732 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
733 | port, | |
734 | SCM_ARG1, | |
735 | s_port_line); | |
736 | return SCM_MAKINUM (SCM_LINUM (port)); | |
0f2d19dd JB |
737 | } |
738 | ||
360fc44c | 739 | SCM_PROC (s_set_port_line_x, "set-port-line!", 2, 0, 0, scm_set_port_line_x); |
d043d8c2 MD |
740 | |
741 | SCM | |
742 | scm_set_port_line_x (port, line) | |
743 | SCM port; | |
744 | SCM line; | |
745 | { | |
360fc44c MD |
746 | port = SCM_COERCE_OUTPORT (port); |
747 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
748 | port, | |
749 | SCM_ARG1, | |
750 | s_set_port_line_x); | |
751 | SCM_ASSERT (SCM_INUMP (line), line, SCM_ARG2, s_set_port_line_x); | |
d043d8c2 MD |
752 | return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); |
753 | } | |
754 | ||
360fc44c | 755 | SCM_PROC (s_port_column, "port-column", 1, 0, 0, scm_port_column); |
1cc91f1b | 756 | |
0f2d19dd | 757 | SCM |
d14af9f2 | 758 | scm_port_column (port) |
0f2d19dd | 759 | SCM port; |
0f2d19dd | 760 | { |
78446828 | 761 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
762 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
763 | port, | |
764 | SCM_ARG1, | |
765 | s_port_column); | |
766 | return SCM_MAKINUM (SCM_COL (port)); | |
0f2d19dd JB |
767 | } |
768 | ||
360fc44c | 769 | SCM_PROC (s_set_port_column_x, "set-port-column!", 2, 0, 0, scm_set_port_column_x); |
d043d8c2 MD |
770 | |
771 | SCM | |
772 | scm_set_port_column_x (port, column) | |
773 | SCM port; | |
774 | SCM column; | |
775 | { | |
360fc44c MD |
776 | port = SCM_COERCE_OUTPORT (port); |
777 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
778 | port, | |
779 | SCM_ARG1, | |
780 | s_set_port_column_x); | |
781 | SCM_ASSERT (SCM_INUMP (column), column, SCM_ARG2, s_set_port_column_x); | |
d043d8c2 MD |
782 | return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); |
783 | } | |
784 | ||
360fc44c | 785 | SCM_PROC (s_port_filename, "port-filename", 1, 0, 0, scm_port_filename); |
1cc91f1b | 786 | |
0f2d19dd | 787 | SCM |
d14af9f2 | 788 | scm_port_filename (port) |
0f2d19dd | 789 | SCM port; |
0f2d19dd | 790 | { |
78446828 | 791 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
792 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
793 | port, | |
794 | SCM_ARG1, | |
795 | s_port_filename); | |
796 | return SCM_PTAB_ENTRY (port)->file_name; | |
0f2d19dd JB |
797 | } |
798 | ||
360fc44c | 799 | SCM_PROC (s_set_port_filename_x, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x); |
1cc91f1b | 800 | |
d14af9f2 MD |
801 | SCM |
802 | scm_set_port_filename_x (port, filename) | |
803 | SCM port; | |
804 | SCM filename; | |
d14af9f2 | 805 | { |
360fc44c MD |
806 | port = SCM_COERCE_OUTPORT (port); |
807 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
808 | port, | |
809 | SCM_ARG1, | |
810 | s_set_port_filename_x); | |
811 | /* We allow the user to set the filename to whatever he likes. */ | |
d14af9f2 MD |
812 | return SCM_PTAB_ENTRY (port)->file_name = filename; |
813 | } | |
814 | ||
0f2d19dd JB |
815 | #ifndef ttyname |
816 | extern char * ttyname(); | |
817 | #endif | |
818 | ||
1cc91f1b | 819 | |
0f2d19dd JB |
820 | void |
821 | scm_prinport (exp, port, type) | |
822 | SCM exp; | |
823 | SCM port; | |
824 | char *type; | |
0f2d19dd | 825 | { |
b7f3516f | 826 | scm_puts ("#<", port); |
0f2d19dd | 827 | if (SCM_CLOSEDP (exp)) |
b7f3516f | 828 | scm_puts ("closed: ", port); |
0f2d19dd JB |
829 | else |
830 | { | |
831 | if (SCM_RDNG & SCM_CAR (exp)) | |
b7f3516f | 832 | scm_puts ("input: ", port); |
0f2d19dd | 833 | if (SCM_WRTNG & SCM_CAR (exp)) |
b7f3516f | 834 | scm_puts ("output: ", port); |
0f2d19dd | 835 | } |
b7f3516f TT |
836 | scm_puts (type, port); |
837 | scm_putc (' ', port); | |
0f2d19dd JB |
838 | #ifndef MSDOS |
839 | #ifndef __EMX__ | |
840 | #ifndef _DCC | |
841 | #ifndef AMIGA | |
842 | #ifndef THINK_C | |
843 | if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) | |
b7f3516f | 844 | scm_puts (ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); |
0f2d19dd JB |
845 | else |
846 | #endif | |
847 | #endif | |
848 | #endif | |
849 | #endif | |
850 | #endif | |
851 | if (SCM_OPFPORTP (exp)) | |
852 | scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); | |
853 | else | |
854 | scm_intprint (SCM_CDR (exp), 16, port); | |
b7f3516f | 855 | scm_putc ('>', port); |
0f2d19dd JB |
856 | } |
857 | ||
1cc91f1b | 858 | |
0f2d19dd JB |
859 | void |
860 | scm_ports_prehistory () | |
0f2d19dd JB |
861 | { |
862 | scm_numptob = 0; | |
863 | scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); | |
864 | ||
865 | /* WARNING: These scm_newptob calls must be done in this order. | |
866 | * They must agree with the port declarations in tags.h. | |
867 | */ | |
868 | /* scm_tc16_fport = */ scm_newptob (&scm_fptob); | |
869 | /* scm_tc16_pipe = */ scm_newptob (&scm_pipob); | |
870 | /* scm_tc16_strport = */ scm_newptob (&scm_stptob); | |
871 | /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); | |
872 | } | |
0f2d19dd JB |
873 | |
874 | \f | |
d68fee48 | 875 | /* Void ports. */ |
0f2d19dd JB |
876 | |
877 | int scm_tc16_void_port = 0; | |
878 | ||
879 | static int | |
38cb0e9c | 880 | print_void_port (SCM exp, SCM port, scm_print_state *pstate) |
0f2d19dd JB |
881 | { |
882 | scm_prinport (exp, port, "void"); | |
883 | return 1; | |
884 | } | |
885 | ||
886 | static int | |
0f88a8f3 | 887 | putc_void_port (int c, SCM port) |
0f2d19dd JB |
888 | { |
889 | return 0; /* vestigial return value */ | |
890 | } | |
891 | ||
892 | static int | |
0f88a8f3 | 893 | puts_void_port (char *s, SCM port) |
0f2d19dd JB |
894 | { |
895 | return 0; /* vestigial return value */ | |
896 | } | |
897 | ||
898 | static scm_sizet | |
0f88a8f3 | 899 | write_void_port (char *ptr, scm_sizet size, scm_sizet nitems, SCM port) |
0f2d19dd JB |
900 | { |
901 | int len; | |
902 | len = size * nitems; | |
903 | return len; | |
904 | } | |
905 | ||
1cc91f1b | 906 | |
0f2d19dd | 907 | static int |
0f88a8f3 | 908 | flush_void_port (SCM port) |
0f2d19dd JB |
909 | { |
910 | return 0; | |
911 | } | |
912 | ||
1cc91f1b | 913 | |
0f2d19dd | 914 | static int |
0f88a8f3 | 915 | getc_void_port (SCM port) |
0f2d19dd JB |
916 | { |
917 | return EOF; | |
918 | } | |
919 | ||
3cb988bd | 920 | static char * |
0f88a8f3 | 921 | fgets_void_port (SCM port, int *len) |
3cb988bd TP |
922 | { |
923 | return NULL; | |
924 | } | |
1cc91f1b | 925 | |
0f2d19dd | 926 | static int |
0f88a8f3 | 927 | close_void_port (SCM port) |
0f2d19dd JB |
928 | { |
929 | return 0; /* this is ignored by scm_close_port. */ | |
930 | } | |
931 | ||
932 | ||
1cc91f1b | 933 | |
0f2d19dd | 934 | static int |
38cb0e9c | 935 | noop0 (SCM stream) |
0f2d19dd JB |
936 | { |
937 | return 0; | |
938 | } | |
939 | ||
940 | ||
0f88a8f3 | 941 | static struct scm_ptobfuns void_port_ptob = |
0f2d19dd | 942 | { |
dc53f026 | 943 | 0, |
0f2d19dd JB |
944 | noop0, |
945 | print_void_port, | |
946 | 0, /* equal? */ | |
947 | putc_void_port, | |
948 | puts_void_port, | |
949 | write_void_port, | |
950 | flush_void_port, | |
951 | getc_void_port, | |
3cb988bd | 952 | fgets_void_port, |
0f2d19dd JB |
953 | close_void_port, |
954 | }; | |
955 | ||
0f2d19dd JB |
956 | SCM |
957 | scm_void_port (mode_str) | |
958 | char * mode_str; | |
0f2d19dd JB |
959 | { |
960 | int mode_bits; | |
961 | SCM answer; | |
962 | struct scm_port_table * pt; | |
963 | ||
964 | SCM_NEWCELL (answer); | |
965 | SCM_DEFER_INTS; | |
966 | mode_bits = scm_mode_bits (mode_str); | |
967 | pt = scm_add_to_port_table (answer); | |
898a256f | 968 | SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); |
0f2d19dd JB |
969 | SCM_SETPTAB_ENTRY (answer, pt); |
970 | SCM_SETSTREAM (answer, SCM_BOOL_F); | |
971 | SCM_ALLOW_INTS; | |
972 | return answer; | |
973 | } | |
974 | ||
975 | ||
976 | SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); | |
1cc91f1b | 977 | |
0f2d19dd JB |
978 | SCM |
979 | scm_sys_make_void_port (mode) | |
980 | SCM mode; | |
0f2d19dd | 981 | { |
89958ad0 | 982 | SCM_ASSERT (SCM_NIMP (mode) && SCM_ROSTRINGP (mode), mode, |
0f2d19dd JB |
983 | SCM_ARG1, s_sys_make_void_port); |
984 | ||
89958ad0 | 985 | SCM_COERCE_SUBSTR (mode); |
0f2d19dd JB |
986 | return scm_void_port (SCM_ROCHARS (mode)); |
987 | } | |
988 | ||
989 | ||
990 | ||
991 | \f | |
89545eba | 992 | /* Initialization. */ |
1cc91f1b | 993 | |
0f2d19dd JB |
994 | void |
995 | scm_init_ports () | |
0f2d19dd JB |
996 | { |
997 | scm_tc16_void_port = scm_newptob (&void_port_ptob); | |
998 | #include "ports.x" | |
999 | } | |
1000 |