1 /* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
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)
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.
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
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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.
40 * If you do not wish that, delete this exception notice. */
62 SCM_PROC (s_read_delimited_x
, "%read-delimited!", 3, 3, 0, scm_read_delimited_x
);
65 scm_read_delimited_x (delims
, buf
, gobble
, port
, start
, end
)
81 SCM_ASSERT (SCM_NIMP (delims
) && SCM_ROSTRINGP (delims
),
82 delims
, SCM_ARG1
, s_read_delimited_x
);
83 cdelims
= SCM_ROCHARS (delims
);
84 num_delims
= SCM_ROLENGTH (delims
);
85 SCM_ASSERT (SCM_NIMP (buf
) && SCM_STRINGP (buf
),
86 buf
, SCM_ARG2
, s_read_delimited_x
);
87 cbuf
= SCM_CHARS (buf
);
88 cend
= SCM_LENGTH (buf
);
89 if (SCM_UNBNDP (port
))
93 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPINPORTP (port
),
94 port
, SCM_ARG1
, s_read_delimited_x
);
97 if (SCM_UNBNDP (start
))
101 cstart
= scm_num2long (start
,
102 (char *) SCM_ARG5
, s_read_delimited_x
);
103 if (cstart
< 0 || cstart
>= cend
)
104 scm_out_of_range (s_read_delimited_x
, start
);
106 if (!SCM_UNBNDP (end
))
108 long tend
= scm_num2long (end
, (char *) SCM_ARG6
,
110 if (tend
<= cstart
|| tend
> cend
)
111 scm_out_of_range (s_read_delimited_x
, end
);
116 for (j
= cstart
; j
< cend
; j
++)
120 c
= scm_gen_getc (port
);
121 for (k
= 0; k
< num_delims
; k
++)
125 if (SCM_FALSEP (gobble
))
126 scm_gen_ungetc (c
, port
);
128 return scm_cons (SCM_MAKICHR (c
),
129 scm_long2num (j
- cstart
));
133 return scm_cons (SCM_EOF_VAL
,
134 scm_long2num (j
- cstart
));
138 return scm_cons (SCM_BOOL_F
, scm_long2num (j
- cstart
));
141 SCM_PROC (s_write_line
, "write-line", 1, 1, 0, scm_write_line
);
144 scm_write_line (obj
, port
)
148 scm_display (obj
, port
);
149 return scm_newline (port
);
152 SCM_PROC (s_ftell
, "ftell", 1, 0, 0, scm_ftell
);
159 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPFPORTP (port
), port
, SCM_ARG1
, s_ftell
);
160 SCM_SYSCALL (pos
= ftell ((FILE *)SCM_STREAM (port
)));
162 scm_syserror (s_ftell
);
163 if (pos
> 0 && SCM_CRDYP (port
))
165 return scm_long2num (pos
);
170 SCM_PROC (s_fseek
, "fseek", 3, 0, 0, scm_fseek
);
173 scm_fseek (port
, offset
, whence
)
181 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPFPORTP (port
), port
, SCM_ARG1
, s_fseek
);
182 loff
= scm_num2long (offset
, (char *)SCM_ARG2
, s_fseek
);
183 SCM_ASSERT (SCM_INUMP (whence
) && (SCM_INUM (whence
) < 3) && (SCM_INUM (whence
) >= 0),
184 whence
, SCM_ARG3
, s_fseek
);
186 SCM_CLRDY (port
); /* Clear ungetted char */
187 /* Values of whence are interned in scm_init_ioext. */
188 rv
= fseek ((FILE *)SCM_STREAM (port
), loff
, SCM_INUM (whence
));
190 scm_syserror (s_fseek
);
191 return SCM_UNSPECIFIED
;
196 SCM_PROC (s_freopen
, "freopen", 3, 0, 0, scm_freopen
);
199 scm_freopen (filename
, modes
, port
)
205 SCM_ASSERT (SCM_NIMP (filename
) && SCM_ROSTRINGP (filename
), filename
,
206 SCM_ARG1
, s_freopen
);
207 SCM_ASSERT (SCM_NIMP (modes
) && SCM_ROSTRINGP (modes
), modes
, SCM_ARG2
,
210 SCM_COERCE_SUBSTR (filename
);
211 SCM_COERCE_SUBSTR (modes
);
213 SCM_ASSERT (SCM_NIMP (port
) && SCM_FPORTP (port
), port
, SCM_ARG3
, s_freopen
);
214 SCM_SYSCALL (f
= freopen (SCM_ROCHARS (filename
), SCM_ROCHARS (modes
),
215 (FILE *)SCM_STREAM (port
)));
220 port
= SCM_MAKINUM (errno
);
221 SCM_SETAND_CAR (p
, ~SCM_OPN
);
222 scm_remove_from_port_table (p
);
226 SCM_SETCAR (port
, scm_tc16_fport
| scm_mode_bits (SCM_ROCHARS (modes
)));
227 SCM_SETSTREAM (port
, (SCM
)f
);
228 SCM_SETCAR (port
, scm_tc16_fport
| scm_mode_bits (SCM_ROCHARS (modes
)));
229 if (SCM_BUF0
& SCM_CAR (port
))
238 SCM_PROC (s_duplicate_port
, "duplicate-port", 2, 0, 0, scm_duplicate_port
);
241 scm_duplicate_port (oldpt
, modes
)
249 SCM_ASSERT (SCM_NIMP (oldpt
) && SCM_OPPORTP (oldpt
), oldpt
, SCM_ARG1
,
251 SCM_ASSERT (SCM_NIMP (modes
) && SCM_ROSTRINGP (modes
), modes
, SCM_ARG2
,
254 SCM_COERCE_SUBSTR (modes
);
257 oldfd
= fileno ((FILE *)SCM_STREAM (oldpt
));
259 scm_syserror (s_duplicate_port
);
260 SCM_SYSCALL (newfd
= dup (oldfd
));
262 scm_syserror (s_duplicate_port
);
263 f
= fdopen (newfd
, SCM_ROCHARS (modes
));
266 SCM_SYSCALL (close (newfd
));
267 scm_syserror (s_duplicate_port
);
270 struct scm_port_table
* pt
;
271 pt
= scm_add_to_port_table (newpt
);
272 SCM_SETPTAB_ENTRY (newpt
, pt
);
273 SCM_SETCAR (newpt
, scm_tc16_fport
| scm_mode_bits (SCM_ROCHARS (modes
)));
274 SCM_SETSTREAM (newpt
, (SCM
)f
);
275 if (SCM_BUF0
& SCM_CAR (newpt
))
277 SCM_PTAB_ENTRY (newpt
)->file_name
= SCM_PTAB_ENTRY (oldpt
)->file_name
;
285 SCM_PROC (s_redirect_port
, "redirect-port", 2, 0, 0, scm_redirect_port
);
288 scm_redirect_port (old
, new)
292 int ans
, oldfd
, newfd
;
295 SCM_ASSERT (SCM_NIMP (old
) && SCM_OPPORTP (old
), old
, SCM_ARG1
, s_redirect_port
);
296 SCM_ASSERT (SCM_NIMP (new) && SCM_OPPORTP (new), new, SCM_ARG2
, s_redirect_port
);
297 oldfd
= fileno ((FILE *)SCM_STREAM (old
));
299 scm_syserror (s_redirect_port
);
300 newfd
= fileno ((FILE *)SCM_STREAM (new));
302 scm_syserror (s_redirect_port
);
303 SCM_SYSCALL (ans
= dup2 (oldfd
, newfd
));
305 scm_syserror (s_redirect_port
);
307 return SCM_UNSPECIFIED
;
310 SCM_PROC (s_primitive_dup
, "primitive-dup", 1, 0, 0, scm_primitive_dup
);
312 scm_primitive_dup (SCM fd_or_port
)
317 if (SCM_INUMP (fd_or_port
))
318 fd
= SCM_INUM (fd_or_port
);
321 SCM_ASSERT (SCM_NIMP (fd_or_port
) && SCM_OPPORTP (fd_or_port
),
322 fd_or_port
, SCM_ARG1
, s_primitive_dup
);
323 fd
= fileno ((FILE *)SCM_STREAM (fd_or_port
));
325 scm_syserror (s_primitive_dup
);
327 SCM_SYSCALL (newfd
= dup (fd
));
329 scm_syserror (s_primitive_dup
);
331 return SCM_MAKINUM (newfd
);
334 SCM_PROC (s_primitive_dup2
, "primitive-dup2", 2, 0, 0, scm_primitive_dup2
);
336 scm_primitive_dup2 (SCM fd_or_port
, SCM fd
)
338 int oldfd
, newfd
, rv
;
341 if (SCM_INUMP (fd_or_port
))
342 oldfd
= SCM_INUM (fd_or_port
);
345 SCM_ASSERT (SCM_NIMP (fd_or_port
) && SCM_OPPORTP (fd_or_port
),
346 fd_or_port
, SCM_ARG1
, s_primitive_dup2
);
347 oldfd
= fileno ((FILE *)SCM_STREAM (fd_or_port
));
349 scm_syserror (s_primitive_dup2
);
352 SCM_ASSERT (SCM_INUMP (newfd
), newfd
, SCM_ARG2
, s_primitive_dup2
);
353 newfd
= SCM_INUM (fd
);
354 scm_evict_ports (newfd
); /* see scsh manual. */
355 SCM_SYSCALL (rv
= dup2 (oldfd
, newfd
));
357 scm_syserror (s_primitive_dup2
);
359 return SCM_UNSPECIFIED
;
362 SCM_PROC (s_fileno
, "fileno", 1, 0, 0, scm_fileno
);
369 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPFPORTP (port
), port
, SCM_ARG1
, s_fileno
);
370 fd
= fileno ((FILE *)SCM_STREAM (port
));
372 scm_syserror (s_fileno
);
373 return SCM_MAKINUM (fd
);
376 SCM_PROC (s_isatty
, "isatty?", 1, 0, 0, scm_isatty_p
);
383 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPFPORTP (port
), port
, SCM_ARG1
, s_isatty
);
384 rv
= fileno ((FILE *)SCM_STREAM (port
));
386 scm_syserror (s_isatty
);
388 return rv
? SCM_BOOL_T
: SCM_BOOL_F
;
393 SCM_PROC (s_fdopen
, "fdopen", 2, 0, 0, scm_fdopen
);
396 scm_fdopen (fdes
, modes
)
402 struct scm_port_table
* pt
;
404 SCM_ASSERT (SCM_INUMP (fdes
), fdes
, SCM_ARG1
, s_fdopen
);
405 SCM_ASSERT (SCM_NIMP (modes
) && SCM_ROSTRINGP (modes
), modes
, SCM_ARG2
,
407 SCM_COERCE_SUBSTR (modes
);
410 f
= fdopen (SCM_INUM (fdes
), SCM_ROCHARS (modes
));
412 scm_syserror (s_fdopen
);
413 pt
= scm_add_to_port_table (port
);
414 SCM_SETPTAB_ENTRY (port
, pt
);
415 SCM_SETCAR (port
, scm_tc16_fport
| scm_mode_bits (SCM_ROCHARS (modes
)));
416 if (SCM_BUF0
& SCM_CAR (port
))
418 SCM_SETSTREAM (port
, (SCM
)f
);
425 /* Move a port's underlying file descriptor to a given value.
426 * Returns #f if fdes is already the given value.
428 * MOVE->FDES is implemented in Scheme and calls this primitive.
430 SCM_PROC (s_primitive_move_to_fdes
, "primitive-move->fdes", 2, 0, 0, scm_primitive_move_to_fdes
);
433 scm_primitive_move_to_fdes (port
, fd
)
442 SCM_ASSERT (SCM_NIMP (port
) && SCM_OPFPORTP (port
), port
, SCM_ARG1
, s_primitive_move_to_fdes
);
443 SCM_ASSERT (SCM_INUMP (fd
), fd
, SCM_ARG2
, s_primitive_move_to_fdes
);
445 stream
= (FILE *)SCM_STREAM (port
);
446 old_fd
= fileno (stream
);
447 new_fd
= SCM_INUM (fd
);
448 if (old_fd
== new_fd
)
453 scm_evict_ports (new_fd
);
454 rv
= dup2 (old_fd
, new_fd
);
456 scm_syserror (s_primitive_move_to_fdes
);
457 scm_setfileno (stream
, new_fd
);
458 SCM_SYSCALL (close (old_fd
));
464 #define SET_FILE_FD_FIELD(F,D) ((F)->FD_SETTER = (D))
468 scm_setfileno (fs
, fd
)
472 #ifdef SET_FILE_FD_FIELD
473 SET_FILE_FD_FIELD(fs
, fd
);
475 scm_misc_error ("scm_setfileno", "Not fully implemented on this platform",
480 /* Return a list of ports using a given file descriptor. */
481 SCM_PROC(s_fdes_to_ports
, "fdes->ports", 1, 0, 0, scm_fdes_to_ports
);
484 scm_fdes_to_ports (fd
)
487 SCM result
= SCM_EOL
;
491 SCM_ASSERT (SCM_INUMP (fd
), fd
, SCM_ARG1
, s_fdes_to_ports
);
492 int_fd
= SCM_INUM (fd
);
495 for (i
= 0; i
< scm_port_table_size
; i
++)
497 if (SCM_FPORTP (scm_port_table
[i
]->port
)
498 && fileno ((FILE *)SCM_STREAM (scm_port_table
[i
]->port
)) == int_fd
)
499 result
= scm_cons (scm_port_table
[i
]->port
, result
);
509 /* fseek() symbols. */
510 scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET
));
511 scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR
));
512 scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END
));