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 | 130 | { |
6c951427 GH |
131 | scm_port *pt = SCM_PTAB_ENTRY (port); |
132 | ||
0f2d19dd JB |
133 | if (SCM_UNBNDP (port)) |
134 | port = scm_cur_inp; | |
135 | else | |
d68fee48 JB |
136 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, |
137 | s_char_ready_p); | |
138 | ||
6c951427 GH |
139 | /* if the current read buffer is filled, or the |
140 | last pushed-back char has been read and the saved buffer is | |
141 | filled, result is true. */ | |
142 | if (pt->read_pos < pt->read_end | |
143 | || (pt->read_buf == pt->putback_buf | |
144 | && pt->saved_read_pos < pt->saved_read_end)) | |
0f2d19dd | 145 | return SCM_BOOL_T; |
ee149d03 JB |
146 | else |
147 | { | |
6c951427 | 148 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
ee149d03 | 149 | |
6c951427 GH |
150 | if (ptob->input_waiting_p) |
151 | return (ptob->input_waiting_p (port)) ? SCM_BOOL_T : SCM_BOOL_F; | |
ee149d03 | 152 | else |
6c951427 | 153 | return SCM_BOOL_T; |
ee149d03 | 154 | } |
0f2d19dd | 155 | } |
0f2d19dd | 156 | |
6c951427 | 157 | /* Clear a port's read buffers, returning the contents. */ |
ee149d03 JB |
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); | |
6c951427 | 164 | int count; |
840ae05d | 165 | char *dst; |
ee149d03 JB |
166 | |
167 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, | |
168 | s_drain_input); | |
840ae05d | 169 | |
6c951427 GH |
170 | count = pt->read_end - pt->read_pos; |
171 | if (pt->read_buf == pt->putback_buf) | |
172 | count += pt->saved_read_end - pt->saved_read_pos; | |
840ae05d | 173 | |
6c951427 GH |
174 | result = scm_makstr (count, 0); |
175 | dst = SCM_CHARS (result); | |
840ae05d JB |
176 | |
177 | while (pt->read_pos < pt->read_end) | |
6c951427 GH |
178 | *dst++ = *(pt->read_pos++); |
179 | ||
180 | if (pt->read_buf == pt->putback_buf) | |
840ae05d | 181 | { |
6c951427 GH |
182 | while (pt->saved_read_pos < pt->saved_read_end) |
183 | *dst++ = *(pt->saved_read_pos++); | |
840ae05d | 184 | } |
6c951427 | 185 | |
840ae05d | 186 | return result; |
ee149d03 | 187 | } |
0f2d19dd JB |
188 | |
189 | \f | |
d68fee48 | 190 | /* Standard ports --- current input, output, error, and more(!). */ |
0f2d19dd | 191 | |
0f2d19dd | 192 | SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); |
1cc91f1b | 193 | |
0f2d19dd JB |
194 | SCM |
195 | scm_current_input_port () | |
0f2d19dd JB |
196 | { |
197 | return scm_cur_inp; | |
198 | } | |
199 | ||
200 | SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); | |
1cc91f1b | 201 | |
0f2d19dd JB |
202 | SCM |
203 | scm_current_output_port () | |
0f2d19dd JB |
204 | { |
205 | return scm_cur_outp; | |
206 | } | |
207 | ||
208 | SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); | |
1cc91f1b | 209 | |
0f2d19dd JB |
210 | SCM |
211 | scm_current_error_port () | |
0f2d19dd JB |
212 | { |
213 | return scm_cur_errp; | |
214 | } | |
215 | ||
31614d8e MD |
216 | SCM_PROC(s_current_load_port, "current-load-port", 0, 0, 0, scm_current_load_port); |
217 | ||
218 | SCM | |
219 | scm_current_load_port () | |
220 | { | |
221 | return scm_cur_loadp; | |
222 | } | |
223 | ||
0f2d19dd | 224 | SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); |
1cc91f1b | 225 | |
0f2d19dd JB |
226 | SCM |
227 | scm_set_current_input_port (port) | |
228 | SCM port; | |
0f2d19dd JB |
229 | { |
230 | SCM oinp = scm_cur_inp; | |
231 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); | |
232 | scm_cur_inp = port; | |
233 | return oinp; | |
234 | } | |
235 | ||
236 | ||
237 | SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); | |
1cc91f1b | 238 | |
0f2d19dd JB |
239 | SCM |
240 | scm_set_current_output_port (port) | |
241 | SCM port; | |
0f2d19dd JB |
242 | { |
243 | SCM ooutp = scm_cur_outp; | |
78446828 | 244 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
245 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); |
246 | scm_cur_outp = port; | |
247 | return ooutp; | |
248 | } | |
249 | ||
250 | ||
251 | SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); | |
1cc91f1b | 252 | |
0f2d19dd JB |
253 | SCM |
254 | scm_set_current_error_port (port) | |
255 | SCM port; | |
0f2d19dd JB |
256 | { |
257 | SCM oerrp = scm_cur_errp; | |
78446828 | 258 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
259 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); |
260 | scm_cur_errp = port; | |
261 | return oerrp; | |
262 | } | |
263 | ||
264 | \f | |
840ae05d | 265 | /* The port table --- an array of pointers to ports. */ |
0f2d19dd | 266 | |
840ae05d | 267 | scm_port **scm_port_table; |
0f2d19dd JB |
268 | |
269 | int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ | |
270 | int scm_port_table_room = 20; /* Size of the array. */ | |
271 | ||
ee149d03 | 272 | /* Add a port to the table. */ |
1cc91f1b | 273 | |
840ae05d | 274 | scm_port * |
0f2d19dd JB |
275 | scm_add_to_port_table (port) |
276 | SCM port; | |
0f2d19dd | 277 | { |
840ae05d JB |
278 | scm_port *entry; |
279 | ||
0f2d19dd JB |
280 | if (scm_port_table_size == scm_port_table_room) |
281 | { | |
ee149d03 | 282 | void *newt = realloc ((char *) scm_port_table, |
840ae05d | 283 | (scm_sizet) (sizeof (scm_port *) |
ee149d03 JB |
284 | * scm_port_table_room * 2)); |
285 | if (newt == NULL) | |
840ae05d JB |
286 | scm_memory_error ("scm_add_to_port_table"); |
287 | scm_port_table = (scm_port **) newt; | |
0f2d19dd JB |
288 | scm_port_table_room *= 2; |
289 | } | |
840ae05d JB |
290 | entry = (scm_port *) malloc (sizeof (scm_port)); |
291 | if (entry == NULL) | |
292 | scm_memory_error ("scm_add_to_port_table"); | |
293 | ||
294 | entry->port = port; | |
295 | entry->entry = scm_port_table_size; | |
296 | entry->revealed = 0; | |
297 | entry->stream = 0; | |
298 | entry->file_name = SCM_BOOL_F; | |
299 | entry->line_number = 0; | |
300 | entry->column_number = 0; | |
6c951427 GH |
301 | entry->putback_buf = 0; |
302 | entry->putback_buf_size = 0; | |
840ae05d JB |
303 | entry->rw_active = 0; |
304 | ||
305 | scm_port_table[scm_port_table_size] = entry; | |
306 | scm_port_table_size++; | |
307 | ||
308 | return entry; | |
0f2d19dd JB |
309 | } |
310 | ||
6c951427 | 311 | /* Remove a port from the table and destroy it. */ |
1cc91f1b | 312 | |
0f2d19dd JB |
313 | void |
314 | scm_remove_from_port_table (port) | |
315 | SCM port; | |
0f2d19dd | 316 | { |
840ae05d | 317 | scm_port *p = SCM_PTAB_ENTRY (port); |
ee1e7e13 | 318 | int i = p->entry; |
6c951427 | 319 | |
ee1e7e13 MD |
320 | if (i >= scm_port_table_size) |
321 | scm_wta (port, "Port not in table", "scm_remove_from_port_table"); | |
6c951427 GH |
322 | if (p->putback_buf) |
323 | free (p->putback_buf); | |
840ae05d | 324 | free (p); |
ee1e7e13 MD |
325 | /* Since we have just freed slot i we can shrink the table by moving |
326 | the last entry to that slot... */ | |
327 | if (i < scm_port_table_size - 1) | |
0f2d19dd | 328 | { |
ee1e7e13 MD |
329 | scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; |
330 | scm_port_table[i]->entry = i; | |
0f2d19dd | 331 | } |
0f2d19dd JB |
332 | SCM_SETPTAB_ENTRY (port, 0); |
333 | scm_port_table_size--; | |
334 | } | |
335 | ||
6c951427 | 336 | #if 0 |
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; | |
6c951427 GH |
345 | int count = p->cp - p->cbuf; |
346 | ||
ee1e7e13 MD |
347 | if (new_size < requested) |
348 | new_size = requested; | |
349 | p = realloc (p, sizeof (*p) - SCM_INITIAL_CBUF_SIZE + new_size); | |
6c951427 GH |
350 | p->cp = p->cbuf + count; |
351 | p->bufend = p->cbuf + new_size; | |
ee1e7e13 MD |
352 | scm_port_table[p->entry] = p; |
353 | SCM_SETPTAB_ENTRY (port, p); | |
354 | } | |
6c951427 | 355 | #endif |
ee1e7e13 | 356 | |
fea6b4ea | 357 | #ifdef GUILE_DEBUG |
0f2d19dd JB |
358 | /* Undocumented functions for debugging. */ |
359 | /* Return the number of ports in the table. */ | |
1cc91f1b | 360 | |
1146b6cd | 361 | SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size); |
0f2d19dd JB |
362 | SCM |
363 | scm_pt_size () | |
0f2d19dd JB |
364 | { |
365 | return SCM_MAKINUM (scm_port_table_size); | |
366 | } | |
367 | ||
368 | /* Return the ith member of the port table. */ | |
1146b6cd | 369 | SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member); |
0f2d19dd JB |
370 | SCM |
371 | scm_pt_member (member) | |
372 | SCM member; | |
0f2d19dd JB |
373 | { |
374 | int i; | |
375 | SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); | |
376 | i = SCM_INUM (member); | |
377 | if (i < 0 || i >= scm_port_table_size) | |
378 | return SCM_BOOL_F; | |
379 | else | |
380 | return scm_port_table[i]->port; | |
381 | } | |
382 | #endif | |
383 | ||
384 | ||
d68fee48 JB |
385 | \f |
386 | /* Revealed counts --- an oddity inherited from SCSH. */ | |
387 | ||
8b13c6b3 GH |
388 | /* Find a port in the table and return its revealed count. |
389 | Also used by the garbage collector. | |
0f2d19dd | 390 | */ |
1cc91f1b | 391 | |
0f2d19dd JB |
392 | int |
393 | scm_revealed_count (port) | |
394 | SCM port; | |
0f2d19dd JB |
395 | { |
396 | return SCM_REVEALED(port); | |
397 | } | |
398 | ||
399 | ||
400 | ||
401 | /* Return the revealed count for a port. */ | |
402 | ||
403 | SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); | |
1cc91f1b | 404 | |
0f2d19dd JB |
405 | SCM |
406 | scm_port_revealed (port) | |
407 | SCM port; | |
0f2d19dd | 408 | { |
78446828 | 409 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd | 410 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); |
8b13c6b3 | 411 | return SCM_MAKINUM (scm_revealed_count (port)); |
0f2d19dd JB |
412 | } |
413 | ||
414 | /* Set the revealed count for a port. */ | |
415 | SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); | |
1cc91f1b | 416 | |
0f2d19dd JB |
417 | SCM |
418 | scm_set_port_revealed_x (port, rcount) | |
419 | SCM port; | |
420 | SCM rcount; | |
0f2d19dd | 421 | { |
78446828 | 422 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
423 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); |
424 | SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); | |
0f2d19dd | 425 | SCM_REVEALED (port) = SCM_INUM (rcount); |
8b13c6b3 | 426 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
427 | } |
428 | ||
d68fee48 JB |
429 | |
430 | \f | |
431 | /* Retrieving a port's mode. */ | |
432 | ||
eadd48de GH |
433 | /* Return the flags that characterize a port based on the mode |
434 | * string used to open a file for that port. | |
435 | * | |
436 | * See PORT FLAGS in scm.h | |
437 | */ | |
438 | ||
439 | long | |
440 | scm_mode_bits (modes) | |
441 | char *modes; | |
442 | { | |
443 | return (SCM_OPN | |
444 | | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) | |
445 | | ( strchr (modes, 'w') | |
446 | || strchr (modes, 'a') | |
447 | || strchr (modes, '+') ? SCM_WRTNG : 0) | |
ee149d03 JB |
448 | | (strchr (modes, '0') ? SCM_BUF0 : 0) |
449 | | (strchr (modes, 'l') ? SCM_BUFLINE : 0)); | |
eadd48de GH |
450 | } |
451 | ||
452 | ||
453 | /* Return the mode flags from an open port. | |
454 | * Some modes such as "append" are only used when opening | |
455 | * a file and are not returned here. */ | |
456 | ||
457 | SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); | |
458 | ||
459 | SCM | |
460 | scm_port_mode (port) | |
461 | SCM port; | |
462 | { | |
463 | char modes[3]; | |
464 | modes[0] = '\0'; | |
78446828 MV |
465 | |
466 | port = SCM_COERCE_OUTPORT (port); | |
eadd48de GH |
467 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); |
468 | if (SCM_CAR (port) & SCM_RDNG) { | |
469 | if (SCM_CAR (port) & SCM_WRTNG) | |
470 | strcpy (modes, "r+"); | |
471 | else | |
472 | strcpy (modes, "r"); | |
473 | } | |
474 | else if (SCM_CAR (port) & SCM_WRTNG) | |
475 | strcpy (modes, "w"); | |
476 | if (SCM_CAR (port) & SCM_BUF0) | |
477 | strcat (modes, "0"); | |
478 | return scm_makfromstr (modes, strlen (modes), 0); | |
479 | } | |
480 | ||
481 | ||
d68fee48 JB |
482 | \f |
483 | /* Closing ports. */ | |
484 | ||
0f2d19dd JB |
485 | /* scm_close_port |
486 | * Call the close operation on a port object. | |
eadd48de | 487 | * see also scm_close. |
0f2d19dd JB |
488 | */ |
489 | SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); | |
1cc91f1b | 490 | |
0f2d19dd JB |
491 | SCM |
492 | scm_close_port (port) | |
493 | SCM port; | |
0f2d19dd JB |
494 | { |
495 | scm_sizet i; | |
eadd48de GH |
496 | int rv; |
497 | ||
78446828 MV |
498 | port = SCM_COERCE_OUTPORT (port); |
499 | ||
341eaef0 | 500 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, |
3c1750f3 | 501 | s_close_port); |
0f2d19dd | 502 | if (SCM_CLOSEDP (port)) |
eadd48de | 503 | return SCM_BOOL_F; |
0f2d19dd | 504 | i = SCM_PTOBNUM (port); |
0f2d19dd | 505 | if (scm_ptobs[i].fclose) |
ee149d03 | 506 | rv = (scm_ptobs[i].fclose) (port); |
eadd48de GH |
507 | else |
508 | rv = 0; | |
0f2d19dd | 509 | scm_remove_from_port_table (port); |
898a256f | 510 | SCM_SETAND_CAR (port, ~SCM_OPN); |
eadd48de | 511 | return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; |
0f2d19dd JB |
512 | } |
513 | ||
514 | SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); | |
1cc91f1b | 515 | |
0f2d19dd JB |
516 | SCM |
517 | scm_close_all_ports_except (ports) | |
518 | SCM ports; | |
0f2d19dd JB |
519 | { |
520 | int i = 0; | |
521 | SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); | |
0f2d19dd JB |
522 | while (i < scm_port_table_size) |
523 | { | |
524 | SCM thisport = scm_port_table[i]->port; | |
525 | int found = 0; | |
526 | SCM ports_ptr = ports; | |
527 | ||
528 | while (SCM_NNULLP (ports_ptr)) | |
529 | { | |
78446828 | 530 | SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr)); |
0f2d19dd JB |
531 | if (i == 0) |
532 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); | |
533 | if (port == thisport) | |
534 | found = 1; | |
535 | ports_ptr = SCM_CDR (ports_ptr); | |
536 | } | |
537 | if (found) | |
538 | i++; | |
539 | else | |
540 | /* i is not to be incremented here. */ | |
541 | scm_close_port (thisport); | |
542 | } | |
0f2d19dd JB |
543 | return SCM_UNSPECIFIED; |
544 | } | |
545 | ||
d68fee48 JB |
546 | |
547 | \f | |
548 | /* Utter miscellany. Gosh, we should clean this up some time. */ | |
549 | ||
0f2d19dd | 550 | SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); |
1cc91f1b | 551 | |
0f2d19dd JB |
552 | SCM |
553 | scm_input_port_p (x) | |
554 | SCM x; | |
0f2d19dd JB |
555 | { |
556 | if (SCM_IMP (x)) | |
557 | return SCM_BOOL_F; | |
558 | return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
559 | } | |
560 | ||
561 | SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); | |
1cc91f1b | 562 | |
0f2d19dd JB |
563 | SCM |
564 | scm_output_port_p (x) | |
565 | SCM x; | |
0f2d19dd JB |
566 | { |
567 | if (SCM_IMP (x)) | |
568 | return SCM_BOOL_F; | |
569 | return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
570 | } | |
571 | ||
572 | ||
573 | SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); | |
1cc91f1b | 574 | |
0f2d19dd JB |
575 | SCM |
576 | scm_eof_object_p (x) | |
577 | SCM x; | |
0f2d19dd | 578 | { |
0c32d76c | 579 | return SCM_EOF_OBJECT_P (x) ? SCM_BOOL_T : SCM_BOOL_F; |
0f2d19dd JB |
580 | } |
581 | ||
582 | SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); | |
1cc91f1b | 583 | |
0f2d19dd JB |
584 | SCM |
585 | scm_force_output (port) | |
586 | SCM port; | |
0f2d19dd JB |
587 | { |
588 | if (SCM_UNBNDP (port)) | |
3e877d15 | 589 | port = scm_cur_outp; |
0f2d19dd | 590 | else |
78446828 MV |
591 | { |
592 | port = SCM_COERCE_OUTPORT (port); | |
3e877d15 JB |
593 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, |
594 | s_force_output); | |
78446828 | 595 | } |
ee149d03 JB |
596 | scm_fflush (port); |
597 | return SCM_UNSPECIFIED; | |
0f2d19dd JB |
598 | } |
599 | ||
9c29ac66 | 600 | SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports); |
89ea5b7c GH |
601 | SCM |
602 | scm_flush_all_ports (void) | |
603 | { | |
604 | int i; | |
605 | ||
606 | for (i = 0; i < scm_port_table_size; i++) | |
607 | { | |
ee149d03 JB |
608 | if (SCM_OPOUTPORTP (scm_port_table[i]->port)) |
609 | scm_fflush (scm_port_table[i]->port); | |
89ea5b7c GH |
610 | } |
611 | return SCM_UNSPECIFIED; | |
612 | } | |
0f2d19dd JB |
613 | |
614 | SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); | |
1cc91f1b | 615 | |
0f2d19dd JB |
616 | SCM |
617 | scm_read_char (port) | |
618 | SCM port; | |
0f2d19dd JB |
619 | { |
620 | int c; | |
621 | if (SCM_UNBNDP (port)) | |
334341aa | 622 | port = scm_cur_inp; |
0f2d19dd JB |
623 | else |
624 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); | |
b7f3516f | 625 | c = scm_getc (port); |
0f2d19dd JB |
626 | if (EOF == c) |
627 | return SCM_EOF_VAL; | |
628 | return SCM_MAKICHR (c); | |
629 | } | |
630 | ||
6c951427 | 631 | int |
283a1a0e | 632 | scm_fill_buffer (SCM port) |
6c951427 | 633 | { |
283a1a0e GH |
634 | scm_port *pt = SCM_PTAB_ENTRY (port); |
635 | ||
6c951427 GH |
636 | if (pt->read_buf == pt->putback_buf) |
637 | { | |
638 | /* finished reading put-back chars. */ | |
639 | pt->read_buf = pt->saved_read_buf; | |
640 | pt->read_pos = pt->saved_read_pos; | |
641 | pt->read_end = pt->saved_read_end; | |
642 | pt->read_buf_size = pt->saved_read_buf_size; | |
643 | if (pt->read_pos < pt->read_end) | |
644 | return *(pt->read_pos++); | |
645 | } | |
646 | return scm_ptobs[SCM_PTOBNUM (port)].fill_buffer (port); | |
647 | } | |
648 | ||
ee149d03 JB |
649 | int |
650 | scm_getc (port) | |
0f2d19dd | 651 | SCM port; |
0f2d19dd JB |
652 | { |
653 | int c; | |
840ae05d | 654 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 | 655 | |
840ae05d JB |
656 | if (pt->rw_active == SCM_PORT_WRITE) |
657 | { | |
6c951427 GH |
658 | /* may be marginally faster than calling scm_fflush. */ |
659 | scm_ptobs[SCM_PTOBNUM (port)].fflush (port); | |
840ae05d | 660 | } |
6c951427 GH |
661 | |
662 | if (pt->read_pos < pt->read_end) | |
ee149d03 | 663 | { |
6c951427 | 664 | c = *(pt->read_pos++); |
ee149d03 | 665 | } |
0f2d19dd | 666 | else |
ee149d03 | 667 | { |
283a1a0e | 668 | c = scm_fill_buffer (port); |
ee149d03 JB |
669 | } |
670 | ||
840ae05d JB |
671 | if (pt->rw_random) |
672 | pt->rw_active = SCM_PORT_READ; | |
673 | ||
ee149d03 JB |
674 | if (c == '\n') |
675 | { | |
676 | SCM_INCLINE (port); | |
677 | } | |
678 | else if (c == '\t') | |
679 | { | |
680 | SCM_TABCOL (port); | |
681 | } | |
682 | else | |
683 | { | |
684 | SCM_INCCOL (port); | |
685 | } | |
686 | ||
687 | return c; | |
0f2d19dd JB |
688 | } |
689 | ||
ee149d03 JB |
690 | void |
691 | scm_putc (c, port) | |
692 | int c; | |
693 | SCM port; | |
694 | { | |
840ae05d | 695 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 JB |
696 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
697 | ||
840ae05d | 698 | if (pt->rw_active == SCM_PORT_READ) |
283a1a0e | 699 | scm_read_flush (port); |
6c951427 | 700 | |
ee149d03 | 701 | *(pt->write_pos++) = (char) c; |
6c951427 | 702 | |
840ae05d JB |
703 | if (pt->write_pos == pt->write_end) |
704 | ptob->fflush (port); | |
705 | ||
706 | if (pt->rw_random) | |
707 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 708 | } |
3cb988bd | 709 | |
ee149d03 JB |
710 | void |
711 | scm_puts (s, port) | |
712 | char *s; | |
3cb988bd TP |
713 | SCM port; |
714 | { | |
840ae05d | 715 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 | 716 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
3cb988bd | 717 | |
840ae05d | 718 | if (pt->rw_active == SCM_PORT_READ) |
283a1a0e GH |
719 | scm_read_flush (port); |
720 | ||
ee149d03 JB |
721 | while (*s != 0) |
722 | { | |
723 | *pt->write_pos++ = *s++; | |
724 | if (pt->write_pos == pt->write_end) | |
840ae05d | 725 | ptob->fflush (port); |
ee149d03 | 726 | } |
ee149d03 JB |
727 | /* If the port is line-buffered, flush it. */ |
728 | if ((SCM_CAR (port) & SCM_BUFLINE) | |
729 | && memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf)) | |
840ae05d JB |
730 | ptob->fflush (port); |
731 | ||
732 | if (pt->rw_random) | |
733 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 734 | } |
3cb988bd | 735 | |
ee149d03 JB |
736 | void |
737 | scm_lfwrite (ptr, size, port) | |
738 | char *ptr; | |
739 | scm_sizet size; | |
740 | SCM port; | |
741 | { | |
840ae05d | 742 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 | 743 | scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
3e2043c4 | 744 | |
840ae05d | 745 | if (pt->rw_active == SCM_PORT_READ) |
283a1a0e GH |
746 | scm_read_flush (port); |
747 | ||
ee149d03 | 748 | while (size > 0) |
3e2043c4 | 749 | { |
ee149d03 JB |
750 | int space = pt->write_end - pt->write_pos; |
751 | int write_len = (size > space) ? space : size; | |
752 | ||
753 | strncpy (pt->write_pos, ptr, write_len); | |
754 | pt->write_pos += write_len; | |
755 | size -= write_len; | |
756 | ptr += write_len; | |
757 | if (write_len == space) | |
840ae05d | 758 | ptob->fflush (port); |
3e2043c4 | 759 | } |
ee149d03 JB |
760 | /* If the port is line-buffered, flush it. */ |
761 | if ((SCM_CAR (port) & SCM_BUFLINE) | |
762 | && memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf)) | |
763 | (ptob->fflush) (port); | |
840ae05d JB |
764 | |
765 | if (pt->rw_random) | |
766 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 767 | } |
3cb988bd | 768 | |
3cb988bd | 769 | |
ee149d03 JB |
770 | void |
771 | scm_fflush (port) | |
772 | SCM port; | |
773 | { | |
774 | scm_sizet i = SCM_PTOBNUM (port); | |
775 | (scm_ptobs[i].fflush) (port); | |
776 | } | |
777 | ||
283a1a0e GH |
778 | void |
779 | scm_read_flush (port) | |
780 | SCM port; | |
781 | { | |
782 | int offset; | |
783 | scm_port *pt = SCM_PTAB_ENTRY (port); | |
784 | ||
785 | if (pt->read_buf == pt->putback_buf) | |
786 | { | |
787 | offset = pt->read_end - pt->read_pos; | |
788 | pt->read_buf = pt->saved_read_buf; | |
789 | pt->read_pos = pt->saved_read_pos; | |
790 | pt->read_end = pt->saved_read_end; | |
791 | pt->read_buf_size = pt->saved_read_buf_size; | |
792 | } | |
793 | else | |
794 | offset = 0; | |
795 | ||
796 | scm_ptobs[SCM_PTOBNUM (port)].read_flush (port, offset); | |
797 | } | |
798 | ||
ee149d03 JB |
799 | \f |
800 | ||
801 | ||
802 | void | |
803 | scm_ungetc (c, port) | |
804 | int c; | |
805 | SCM port; | |
806 | { | |
840ae05d JB |
807 | scm_port *pt = SCM_PTAB_ENTRY (port); |
808 | ||
6c951427 GH |
809 | if (pt->read_buf == pt->putback_buf) |
810 | /* already using the put-back buffer. */ | |
811 | { | |
812 | /* enlarge putback_buf if necessary. */ | |
813 | if (pt->read_end == pt->read_buf + pt->read_buf_size | |
814 | && pt->read_buf == pt->read_pos) | |
815 | { | |
816 | int new_size = pt->read_buf_size * 2; | |
817 | unsigned char *tmp = | |
818 | (unsigned char *) realloc (pt->putback_buf, new_size); | |
819 | ||
820 | if (tmp == NULL) | |
821 | scm_memory_error ("scm_ungetc"); | |
822 | pt->read_pos = pt->read_buf = pt->putback_buf = tmp; | |
823 | pt->read_end = pt->read_buf + pt->read_buf_size; | |
824 | pt->read_buf_size = pt->putback_buf_size = new_size; | |
825 | } | |
826 | ||
827 | /* shift any existing bytes to buffer + 1. */ | |
828 | if (pt->read_pos == pt->read_end) | |
829 | pt->read_end = pt->read_buf + 1; | |
830 | else if (pt->read_pos != pt->read_buf + 1) | |
831 | { | |
832 | int count = pt->read_end - pt->read_pos; | |
833 | ||
834 | memmove (pt->read_buf + 1, pt->read_pos, count); | |
835 | pt->read_end = pt->read_buf + 1 + count; | |
836 | } | |
837 | ||
838 | pt->read_pos = pt->read_buf; | |
839 | } | |
840 | else | |
841 | /* switch to the put-back buffer. */ | |
842 | { | |
843 | if (pt->putback_buf == NULL) | |
844 | { | |
845 | pt->putback_buf = (char *) malloc (pt->putback_buf_size); | |
846 | if (pt->putback_buf == NULL) | |
847 | scm_memory_error ("scm_ungetc"); | |
848 | pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE; | |
849 | } | |
850 | ||
851 | pt->saved_read_buf = pt->read_buf; | |
852 | pt->saved_read_pos = pt->read_pos; | |
853 | pt->saved_read_end = pt->read_end; | |
854 | pt->saved_read_buf_size = pt->read_buf_size; | |
855 | ||
856 | pt->read_pos = pt->read_buf = pt->putback_buf; | |
857 | pt->read_end = pt->read_buf + 1; | |
858 | pt->read_buf_size = pt->putback_buf_size; | |
859 | } | |
860 | ||
861 | *pt->read_buf = c; | |
ee149d03 | 862 | |
840ae05d JB |
863 | if (pt->rw_random) |
864 | pt->rw_active = SCM_PORT_READ; | |
865 | ||
ee149d03 JB |
866 | if (c == '\n') |
867 | { | |
868 | /* What should col be in this case? | |
869 | * We'll leave it at -1. | |
870 | */ | |
871 | SCM_LINUM (port) -= 1; | |
872 | } | |
873 | else | |
874 | SCM_COL(port) -= 1; | |
875 | } | |
876 | ||
877 | ||
878 | void | |
879 | scm_ungets (s, n, port) | |
880 | char *s; | |
881 | int n; | |
882 | SCM port; | |
883 | { | |
884 | /* This is simple minded and inefficient, but unreading strings is | |
885 | * probably not a common operation, and remember that line and | |
886 | * column numbers have to be handled... | |
887 | * | |
888 | * Please feel free to write an optimized version! | |
889 | */ | |
890 | while (n--) | |
891 | scm_ungetc (s[n], port); | |
892 | } | |
893 | ||
894 | ||
895 | SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); | |
896 | ||
897 | SCM | |
898 | scm_peek_char (port) | |
899 | SCM port; | |
900 | { | |
901 | int c; | |
902 | if (SCM_UNBNDP (port)) | |
903 | port = scm_cur_inp; | |
904 | else | |
905 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); | |
906 | c = scm_getc (port); | |
907 | if (EOF == c) | |
908 | return SCM_EOF_VAL; | |
909 | scm_ungetc (c, port); | |
910 | return SCM_MAKICHR (c); | |
3cb988bd TP |
911 | } |
912 | ||
0f2d19dd | 913 | SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); |
1cc91f1b | 914 | |
0f2d19dd JB |
915 | SCM |
916 | scm_unread_char (cobj, port) | |
917 | SCM cobj; | |
918 | SCM port; | |
0f2d19dd JB |
919 | { |
920 | int c; | |
921 | ||
922 | SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); | |
923 | ||
924 | if (SCM_UNBNDP (port)) | |
925 | port = scm_cur_inp; | |
926 | else | |
927 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); | |
928 | ||
929 | ||
930 | c = SCM_ICHR (cobj); | |
931 | ||
b7f3516f | 932 | scm_ungetc (c, port); |
0f2d19dd JB |
933 | return cobj; |
934 | } | |
935 | ||
ee1e7e13 MD |
936 | SCM_PROC (s_unread_string, "unread-string", 2, 0, 0, scm_unread_string); |
937 | ||
938 | SCM | |
939 | scm_unread_string (str, port) | |
940 | SCM str; | |
941 | SCM port; | |
942 | { | |
d1c90db5 | 943 | SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), |
ee1e7e13 MD |
944 | str, SCM_ARG1, s_unread_string); |
945 | ||
946 | if (SCM_UNBNDP (port)) | |
947 | port = scm_cur_inp; | |
948 | else | |
949 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), | |
950 | port, SCM_ARG2, s_unread_string); | |
951 | ||
d1c90db5 | 952 | scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port); |
ee1e7e13 MD |
953 | |
954 | return str; | |
955 | } | |
956 | ||
840ae05d JB |
957 | SCM_PROC (s_lseek, "lseek", 3, 0, 0, scm_lseek); |
958 | SCM | |
959 | scm_lseek (SCM object, SCM offset, SCM whence) | |
960 | { | |
961 | off_t off; | |
962 | off_t rv; | |
963 | int how; | |
964 | ||
965 | object = SCM_COERCE_OUTPORT (object); | |
966 | ||
967 | off = scm_num2long (offset, (char *)SCM_ARG2, s_lseek); | |
968 | SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_lseek); | |
969 | how = SCM_INUM (whence); | |
970 | if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) | |
971 | scm_out_of_range (s_lseek, whence); | |
972 | if (SCM_NIMP (object) && SCM_OPPORTP (object)) | |
973 | { | |
974 | scm_port *pt = SCM_PTAB_ENTRY (object); | |
975 | scm_ptobfuns *ptob = scm_ptobs + SCM_PTOBNUM (object); | |
976 | ||
977 | if (!ptob->seek) | |
978 | scm_misc_error (s_lseek, "port is not seekable", | |
979 | scm_cons (object, SCM_EOL)); | |
980 | else | |
981 | { | |
982 | if (pt->rw_active == SCM_PORT_READ) | |
283a1a0e | 983 | scm_read_flush (object); |
840ae05d JB |
984 | else if (pt->rw_active == SCM_PORT_WRITE) |
985 | ptob->fflush (object); | |
986 | ||
987 | rv = ptob->seek (object, off, how); | |
840ae05d JB |
988 | } |
989 | } | |
990 | else /* file descriptor?. */ | |
991 | { | |
992 | SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_lseek); | |
993 | rv = lseek (SCM_INUM (object), off, how); | |
994 | if (rv == -1) | |
995 | scm_syserror (s_lseek); | |
996 | } | |
997 | return scm_long2num (rv); | |
998 | } | |
999 | ||
1000 | SCM_PROC (s_ftruncate, "ftruncate", 1, 1, 0, scm_ftruncate); | |
1001 | ||
1002 | SCM | |
1003 | scm_ftruncate (SCM port, SCM length) | |
1004 | { | |
1005 | scm_port *pt; | |
1006 | scm_ptobfuns *ptob; | |
1007 | ||
1008 | port = SCM_COERCE_OUTPORT (port); | |
1009 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, | |
1010 | s_ftruncate); | |
1011 | pt = SCM_PTAB_ENTRY (port); | |
1012 | ptob = scm_ptobs + SCM_PTOBNUM (port); | |
1013 | if (!ptob->ftruncate) | |
1014 | scm_misc_error (s_ftruncate, "port is not truncatable", | |
1015 | scm_cons (port, SCM_EOL)); | |
1016 | if (SCM_UNBNDP (length)) | |
1017 | { | |
1018 | length = scm_lseek (port, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); | |
1019 | } | |
1020 | if (pt->rw_active == SCM_PORT_READ) | |
283a1a0e | 1021 | scm_read_flush (port); |
840ae05d JB |
1022 | else if (pt->rw_active == SCM_PORT_WRITE) |
1023 | ptob->fflush (port); | |
1024 | ||
3fe6190f GH |
1025 | { |
1026 | off_t c_length = scm_num2long (length, (char *)SCM_ARG2, s_ftruncate); | |
1027 | ||
1028 | if (c_length < 0) | |
1029 | scm_misc_error (s_ftruncate, "negative offset", | |
1030 | scm_cons (length, SCM_EOL)); | |
1031 | ||
1032 | ptob->ftruncate (port, c_length); | |
1033 | } | |
840ae05d JB |
1034 | return SCM_UNSPECIFIED; |
1035 | } | |
1036 | ||
360fc44c | 1037 | SCM_PROC (s_port_line, "port-line", 1, 0, 0, scm_port_line); |
1cc91f1b | 1038 | |
0f2d19dd | 1039 | SCM |
d14af9f2 | 1040 | scm_port_line (port) |
0f2d19dd | 1041 | SCM port; |
0f2d19dd | 1042 | { |
78446828 | 1043 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1044 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1045 | port, | |
1046 | SCM_ARG1, | |
1047 | s_port_line); | |
1048 | return SCM_MAKINUM (SCM_LINUM (port)); | |
0f2d19dd JB |
1049 | } |
1050 | ||
360fc44c | 1051 | SCM_PROC (s_set_port_line_x, "set-port-line!", 2, 0, 0, scm_set_port_line_x); |
d043d8c2 MD |
1052 | |
1053 | SCM | |
1054 | scm_set_port_line_x (port, line) | |
1055 | SCM port; | |
1056 | SCM line; | |
1057 | { | |
360fc44c MD |
1058 | port = SCM_COERCE_OUTPORT (port); |
1059 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1060 | port, | |
1061 | SCM_ARG1, | |
1062 | s_set_port_line_x); | |
1063 | SCM_ASSERT (SCM_INUMP (line), line, SCM_ARG2, s_set_port_line_x); | |
d043d8c2 MD |
1064 | return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); |
1065 | } | |
1066 | ||
360fc44c | 1067 | SCM_PROC (s_port_column, "port-column", 1, 0, 0, scm_port_column); |
1cc91f1b | 1068 | |
0f2d19dd | 1069 | SCM |
d14af9f2 | 1070 | scm_port_column (port) |
0f2d19dd | 1071 | SCM port; |
0f2d19dd | 1072 | { |
78446828 | 1073 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1074 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1075 | port, | |
1076 | SCM_ARG1, | |
1077 | s_port_column); | |
1078 | return SCM_MAKINUM (SCM_COL (port)); | |
0f2d19dd JB |
1079 | } |
1080 | ||
360fc44c | 1081 | SCM_PROC (s_set_port_column_x, "set-port-column!", 2, 0, 0, scm_set_port_column_x); |
d043d8c2 MD |
1082 | |
1083 | SCM | |
1084 | scm_set_port_column_x (port, column) | |
1085 | SCM port; | |
1086 | SCM column; | |
1087 | { | |
360fc44c MD |
1088 | port = SCM_COERCE_OUTPORT (port); |
1089 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1090 | port, | |
1091 | SCM_ARG1, | |
1092 | s_set_port_column_x); | |
1093 | SCM_ASSERT (SCM_INUMP (column), column, SCM_ARG2, s_set_port_column_x); | |
d043d8c2 MD |
1094 | return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); |
1095 | } | |
1096 | ||
360fc44c | 1097 | SCM_PROC (s_port_filename, "port-filename", 1, 0, 0, scm_port_filename); |
1cc91f1b | 1098 | |
0f2d19dd | 1099 | SCM |
d14af9f2 | 1100 | scm_port_filename (port) |
0f2d19dd | 1101 | SCM port; |
0f2d19dd | 1102 | { |
78446828 | 1103 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1104 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1105 | port, | |
1106 | SCM_ARG1, | |
1107 | s_port_filename); | |
1108 | return SCM_PTAB_ENTRY (port)->file_name; | |
0f2d19dd JB |
1109 | } |
1110 | ||
360fc44c | 1111 | SCM_PROC (s_set_port_filename_x, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x); |
1cc91f1b | 1112 | |
d14af9f2 MD |
1113 | SCM |
1114 | scm_set_port_filename_x (port, filename) | |
1115 | SCM port; | |
1116 | SCM filename; | |
d14af9f2 | 1117 | { |
360fc44c MD |
1118 | port = SCM_COERCE_OUTPORT (port); |
1119 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1120 | port, | |
1121 | SCM_ARG1, | |
1122 | s_set_port_filename_x); | |
1123 | /* We allow the user to set the filename to whatever he likes. */ | |
d14af9f2 MD |
1124 | return SCM_PTAB_ENTRY (port)->file_name = filename; |
1125 | } | |
1126 | ||
0f2d19dd JB |
1127 | #ifndef ttyname |
1128 | extern char * ttyname(); | |
1129 | #endif | |
1130 | ||
1cc91f1b | 1131 | |
0f2d19dd JB |
1132 | void |
1133 | scm_prinport (exp, port, type) | |
1134 | SCM exp; | |
1135 | SCM port; | |
1136 | char *type; | |
0f2d19dd | 1137 | { |
b7f3516f | 1138 | scm_puts ("#<", port); |
0f2d19dd | 1139 | if (SCM_CLOSEDP (exp)) |
b7f3516f | 1140 | scm_puts ("closed: ", port); |
0f2d19dd JB |
1141 | else |
1142 | { | |
1143 | if (SCM_RDNG & SCM_CAR (exp)) | |
b7f3516f | 1144 | scm_puts ("input: ", port); |
0f2d19dd | 1145 | if (SCM_WRTNG & SCM_CAR (exp)) |
b7f3516f | 1146 | scm_puts ("output: ", port); |
0f2d19dd | 1147 | } |
b7f3516f TT |
1148 | scm_puts (type, port); |
1149 | scm_putc (' ', port); | |
0f2d19dd | 1150 | if (SCM_OPFPORTP (exp)) |
ee149d03 JB |
1151 | { |
1152 | int fdes = (SCM_FSTREAM (exp))->fdes; | |
1153 | ||
1154 | if (isatty (fdes)) | |
1155 | scm_puts (ttyname (fdes), port); | |
1156 | else | |
1157 | scm_intprint (fdes, 10, port); | |
1158 | } | |
0f2d19dd | 1159 | else |
ee149d03 JB |
1160 | { |
1161 | scm_intprint (SCM_CDR (exp), 16, port); | |
1162 | } | |
b7f3516f | 1163 | scm_putc ('>', port); |
0f2d19dd JB |
1164 | } |
1165 | ||
1cc91f1b | 1166 | |
0f2d19dd JB |
1167 | void |
1168 | scm_ports_prehistory () | |
0f2d19dd JB |
1169 | { |
1170 | scm_numptob = 0; | |
1171 | scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); | |
1172 | ||
1173 | /* WARNING: These scm_newptob calls must be done in this order. | |
1174 | * They must agree with the port declarations in tags.h. | |
1175 | */ | |
1176 | /* scm_tc16_fport = */ scm_newptob (&scm_fptob); | |
ee149d03 | 1177 | /* scm_tc16_pipe was here */ scm_newptob (&scm_fptob); /* dummy. */ |
0f2d19dd JB |
1178 | /* scm_tc16_strport = */ scm_newptob (&scm_stptob); |
1179 | /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); | |
1180 | } | |
0f2d19dd JB |
1181 | |
1182 | \f | |
ee149d03 | 1183 | |
d68fee48 | 1184 | /* Void ports. */ |
0f2d19dd JB |
1185 | |
1186 | int scm_tc16_void_port = 0; | |
1187 | ||
1188 | static int | |
38cb0e9c | 1189 | print_void_port (SCM exp, SCM port, scm_print_state *pstate) |
0f2d19dd JB |
1190 | { |
1191 | scm_prinport (exp, port, "void"); | |
1192 | return 1; | |
1193 | } | |
1194 | ||
ee149d03 | 1195 | static void |
0f88a8f3 | 1196 | flush_void_port (SCM port) |
0f2d19dd | 1197 | { |
3cb988bd | 1198 | } |
1cc91f1b | 1199 | |
283a1a0e GH |
1200 | static void |
1201 | read_flush_void_port (SCM port, int offset) | |
1202 | { | |
1203 | } | |
1204 | ||
0f2d19dd | 1205 | static int |
0f88a8f3 | 1206 | close_void_port (SCM port) |
0f2d19dd JB |
1207 | { |
1208 | return 0; /* this is ignored by scm_close_port. */ | |
1209 | } | |
1210 | ||
1211 | ||
1cc91f1b | 1212 | |
0f2d19dd | 1213 | static int |
38cb0e9c | 1214 | noop0 (SCM stream) |
0f2d19dd JB |
1215 | { |
1216 | return 0; | |
1217 | } | |
1218 | ||
1219 | ||
0f88a8f3 | 1220 | static struct scm_ptobfuns void_port_ptob = |
0f2d19dd | 1221 | { |
dc53f026 | 1222 | 0, |
0f2d19dd JB |
1223 | noop0, |
1224 | print_void_port, | |
1225 | 0, /* equal? */ | |
0f2d19dd | 1226 | flush_void_port, |
283a1a0e | 1227 | read_flush_void_port, |
0f2d19dd | 1228 | close_void_port, |
ee149d03 JB |
1229 | 0, |
1230 | 0, | |
1231 | 0, | |
840ae05d | 1232 | 0, |
0f2d19dd JB |
1233 | }; |
1234 | ||
0f2d19dd JB |
1235 | SCM |
1236 | scm_void_port (mode_str) | |
1237 | char * mode_str; | |
0f2d19dd JB |
1238 | { |
1239 | int mode_bits; | |
1240 | SCM answer; | |
840ae05d | 1241 | scm_port * pt; |
0f2d19dd JB |
1242 | |
1243 | SCM_NEWCELL (answer); | |
1244 | SCM_DEFER_INTS; | |
1245 | mode_bits = scm_mode_bits (mode_str); | |
1246 | pt = scm_add_to_port_table (answer); | |
0f2d19dd | 1247 | SCM_SETPTAB_ENTRY (answer, pt); |
ee149d03 JB |
1248 | SCM_SETSTREAM (answer, 0); |
1249 | SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); | |
0f2d19dd JB |
1250 | SCM_ALLOW_INTS; |
1251 | return answer; | |
1252 | } | |
1253 | ||
1254 | ||
1255 | SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); | |
1cc91f1b | 1256 | |
0f2d19dd JB |
1257 | SCM |
1258 | scm_sys_make_void_port (mode) | |
1259 | SCM mode; | |
0f2d19dd | 1260 | { |
89958ad0 | 1261 | SCM_ASSERT (SCM_NIMP (mode) && SCM_ROSTRINGP (mode), mode, |
0f2d19dd JB |
1262 | SCM_ARG1, s_sys_make_void_port); |
1263 | ||
89958ad0 | 1264 | SCM_COERCE_SUBSTR (mode); |
0f2d19dd JB |
1265 | return scm_void_port (SCM_ROCHARS (mode)); |
1266 | } | |
1267 | ||
0f2d19dd | 1268 | \f |
89545eba | 1269 | /* Initialization. */ |
1cc91f1b | 1270 | |
0f2d19dd JB |
1271 | void |
1272 | scm_init_ports () | |
0f2d19dd | 1273 | { |
840ae05d JB |
1274 | /* lseek() symbols. */ |
1275 | scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); | |
1276 | scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); | |
1277 | scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); | |
1278 | ||
0f2d19dd JB |
1279 | scm_tc16_void_port = scm_newptob (&void_port_ptob); |
1280 | #include "ports.x" | |
1281 | } |