diff --git a/libguile/genio.h b/libguile/genio.h index 3ee691736..e69de29bb 100644 --- a/libguile/genio.h +++ b/libguile/genio.h @@ -1,61 +0,0 @@ -/* classes: h_files */ - -#ifndef GENIOH -#define GENIOH -/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - -#include "libguile/__scm.h" - - - -extern void scm_putc SCM_P ((int c, SCM port)); -extern void scm_puts SCM_P ((char *str_data, SCM port)); -extern void scm_lfwrite SCM_P ((char *ptr, scm_sizet size, SCM port)); -extern void scm_fflush SCM_P ((SCM port)); -extern int scm_getc SCM_P ((SCM port)); -extern void scm_ungetc SCM_P ((int c, SCM port)); -extern void scm_ungets SCM_P ((char *s, int n, SCM port)); -/* FIXME: this is a terrible name. */ -extern char *scm_do_read_line SCM_P ((SCM port, int *len)); - -#endif /* GENIOH */ diff --git a/libguile/init.c b/libguile/init.c index 9b0946c3c..bcffce1a3 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -252,7 +252,19 @@ check_config () /* initializing standard and current I/O ports */ -/* Create standard ports from stdio stdin, stdout, and stderr. */ +/* Like scm_fdes_to_port, except that: + - NAME is a standard C string, not a Guile string + - we set the revealed count for FILE's file descriptor to 1, so + that fdes won't be closed when the port object is GC'd. */ +static SCM +scm_standard_stream_to_port (int fdes, char *mode, char *name) +{ + SCM port = scm_fdes_to_port (fdes, mode, scm_makfrom0str (name)); + scm_set_port_revealed_x (port, SCM_MAKINUM (1)); + return port; +} + +/* Create standard ports from stdin, stdout, and stderr. */ static void scm_init_standard_ports () { @@ -269,12 +281,19 @@ scm_init_standard_ports () and scsh, read stdin unbuffered. Applications that can tolerate buffered input on stdin can reset \ex{(current-input-port)} to block buffering for higher performance. */ + + /* stdout and stderr are also now unbuffered if connected to + a terminal, since line buffered output is no longer available. */ scm_def_inp - = scm_standard_stream_to_port (stdin, - (isatty (fileno (stdin)) ? "r0" : "r"), + = scm_standard_stream_to_port (0, + isatty (0) ? "r0" : "r", "standard input"); - scm_def_outp = scm_standard_stream_to_port (stdout, "w", "standard output"); - scm_def_errp = scm_standard_stream_to_port (stderr, "w", "standard error"); + scm_def_outp = scm_standard_stream_to_port (1, + isatty (1) ? "wl" : "w", + "standard output"); + scm_def_errp = scm_standard_stream_to_port (2, + isatty (2) ? "w0" : "w", + "standard error"); scm_cur_inp = scm_def_inp; scm_cur_outp = scm_def_outp; diff --git a/libguile/ioext.c b/libguile/ioext.c index 73de33fa7..54edd547a 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -43,7 +43,7 @@ #include #include "_scm.h" -#include "genio.h" +#include "ports.h" #include "read.h" #include "fports.h" #include "unif.h" @@ -51,6 +51,8 @@ #include "ioext.h" +#include + #ifdef HAVE_STRING_H #include #endif @@ -138,8 +140,144 @@ scm_read_delimited_x (delims, buf, gobble, port, start, end) return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart)); } +static unsigned char * +scm_do_read_line (SCM port, int *len_p) +{ + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + unsigned char *end; + + /* I thought reading lines was simple. Mercy me. */ + + /* If there are any pushed-back characters, read the line character + by character. */ + if (SCM_CRDYP (port)) + { + int buf_size = 60; + /* Invariant: buf always has buf_size + 1 characters allocated; + the `+ 1' is for the final '\0'. */ + unsigned char *buf = malloc (buf_size + 1); + int buf_len = 0; + int c; + + while ((c = scm_getc (port)) != EOF) + { + if (buf_len >= buf_size) + { + buf = realloc (buf, buf_size * 2 + 1); + buf_size *= 2; + } + + buf[buf_len++] = c; + + if (c == '\n') + break; + } + + /* Since SCM_CRDYP returned true, we ought to have gotten at + least one character. */ + if (buf_len == 0) + abort (); + + buf[buf_len] = '\0'; + + *len_p = buf_len; + return buf; + } + + /* The common case: no unread characters, and the buffer contains + a complete line. This needs to be fast. */ + if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos))) + != 0) + { + int buf_len = (end + 1) - pt->read_pos; + /* Allocate a buffer of the perfect size. */ + unsigned char *buf = malloc (buf_len + 1); + + memcpy (buf, pt->read_pos, buf_len); + pt->read_pos += buf_len; + + buf[buf_len] = '\0'; + + *len_p = buf_len; + return buf; + } + + /* There are no unread characters, and the buffer contains no newlines. */ + { + /* When live, len is always the number of characters in the + current buffer that are part of the current line. */ + int len = (pt->read_end - pt->read_pos); + int buf_size = (len < 50) ? 60 : len * 2; + /* Invariant: buf always has buf_size + 1 characters allocated; + the `+ 1' is for the final '\0'. */ + unsigned char *buf = malloc (buf_size + 1); + int buf_len = 0; + int c; + + for (;;) + { + if (buf_len + len > buf_size) + { + int new_size = (buf_len + len) * 2; + buf = realloc (buf, new_size + 1); + buf_size = new_size; + } + + /* Copy what we've got out of the port, into our buffer. */ + memcpy (buf + buf_len, pt->read_pos, len); + buf_len += len; + pt->read_pos += len; + + /* If we had seen a newline, we're done now. */ + if (end) + break; + + /* Get more characters. I think having fill_buffer return a + character is not terribly graceful... */ + c = (scm_ptobs[SCM_PTOBNUM (port)].fill_buffer) (port); + if (c == EOF) + { + /* If we're missing a final newline in the file, return + what we did get, sans newline. */ + if (buf_len > 0) + break; + + free (buf); + return 0; + } + + /* ... because it makes us duplicate code here... */ + if (buf_len + 1 > buf_size) + { + int new_size = buf_size * 2; + buf = realloc (buf, new_size + 1); + buf_size = new_size; + } + + /* ... and this is really a duplication of the memcpy and + memchr calls, on a single-byte buffer. */ + buf[buf_len++] = c; + if (c == '\n') + break; + + /* Search the buffer for newlines. */ + if ((end = memchr (pt->read_pos, '\n', + (len = (pt->read_end - pt->read_pos)))) + != 0) + len = (end - pt->read_pos) + 1; + } + + /* I wonder how expensive this realloc is. */ + buf = realloc (buf, buf_len + 1); + buf[buf_len] = '\0'; + *len_p = buf_len; + return buf; + } +} + + /* - * %read-line uses a port's fgets method for fast line i/o. It + * %read-line * truncates any terminating newline from its input, and returns * a cons of the string read and its terminating character. Doing * so makes it easy to implement the hairy `read-line' options @@ -173,15 +311,16 @@ scm_read_line (port) if (s[slen-1] == '\n') { term = SCM_MAKICHR ('\n'); - line = scm_makfromstr (s, slen-1, 0); + s[slen-1] = '\0'; + line = scm_take_str (s, slen-1); + SCM_INCLINE (port); } else { /* Fix: we should check for eof on the port before assuming this. */ term = SCM_EOF_VAL; - line = scm_makfromstr (s, slen, 0); + line = scm_take_str (s, slen); } - free (s); } return scm_cons (line, term); @@ -204,29 +343,57 @@ SCM scm_ftell (object) SCM object; { - long pos; - - object = SCM_COERCE_OUTPORT (object); - - SCM_DEFER_INTS; - if (SCM_NIMP (object) && SCM_OPFPORTP (object)) + if (SCM_INUMP (object)) { - SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (object))); - if (pos > 0 && SCM_CRDYP (object)) - pos -= SCM_N_READY_CHARS (object); + int fdes = SCM_INUM (object); + fpos_t pos; + + pos = lseek (fdes, 0, SEEK_CUR); + if (pos == -1) + scm_syserror (s_ftell); + return scm_long2num (pos); } else { - SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_ftell); - SCM_SYSCALL (pos = lseek (SCM_INUM (object), 0, SEEK_CUR)); + struct scm_fport *fp; + struct scm_port_table *pt; + int fdes; + fpos_t pos; + + object = SCM_COERCE_OUTPORT (object); + SCM_ASSERT (SCM_NIMP (object) && SCM_OPFPORTP (object), + object, SCM_ARG1, s_ftell); + fp = SCM_FSTREAM (object); + pt = SCM_PTAB_ENTRY (object); + fdes = fp->fdes; + pos = lseek (fdes, 0, SEEK_CUR); + if (pos == -1) + scm_syserror (s_ftell); + /* the seek will only have succeeded if fdes is random access, + in which case only one buffer can be filled. */ + if (pt->write_pos > pt->write_buf) + { + pos += pt->write_pos - pt->write_buf; + } + else + { + pos -= pt->read_end - pt->read_pos; + if (SCM_CRDYP (object)) + pos -= SCM_N_READY_CHARS (object); + } + return scm_long2num (pos); } - if (pos < 0) - scm_syserror (s_ftell); - SCM_ALLOW_INTS; - return scm_long2num (pos); } - +/* clear the three buffers in a port. */ +#define SCM_CLEAR_BUFFERS(port, pt)\ +{\ + if (pt->write_pos > pt->write_buf)\ + scm_fflush (port);\ + pt->read_pos = pt->read_end = pt->read_buf;\ + pt->write_needs_seek = 0;\ + SCM_CLRDY (port);\ +} SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek); @@ -243,20 +410,28 @@ scm_fseek (object, offset, whence) loff = scm_num2long (offset, (char *)SCM_ARG2, s_fseek); SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_fseek); - SCM_DEFER_INTS; if (SCM_NIMP (object) && SCM_OPFPORTP (object)) { - SCM_CLRDY (object); /* Clear ungetted char */ - rv = fseek ((FILE *)SCM_STREAM (object), loff, SCM_INUM (whence)); + struct scm_fport *fp = SCM_FSTREAM (object); + struct scm_port_table *pt = SCM_PTAB_ENTRY (object); + + /* clear the three buffers. the write buffer should be flushed + before changing the position. */ + if (fp->random) + { + SCM_CLEAR_BUFFERS (object, pt); + } /* if not random, lseek will fail. */ + rv = lseek (fp->fdes, loff, SCM_INUM (whence)); + if (rv == -1) + scm_syserror (s_fseek); } else { SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fseek); rv = lseek (SCM_INUM (object), loff, SCM_INUM (whence)); + if (rv == -1) + scm_syserror (s_fseek); } - if (rv < 0) - scm_syserror (s_fseek); - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -268,23 +443,31 @@ scm_redirect_port (old, new) SCM new; { int ans, oldfd, newfd; + struct scm_fport *fp; old = SCM_COERCE_OUTPORT (old); new = SCM_COERCE_OUTPORT (new); - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (old) && SCM_OPPORTP (old), old, SCM_ARG1, s_redirect_port); - SCM_ASSERT (SCM_NIMP (new) && SCM_OPPORTP (new), new, SCM_ARG2, s_redirect_port); - oldfd = fileno ((FILE *)SCM_STREAM (old)); - if (oldfd == -1) - scm_syserror (s_redirect_port); - newfd = fileno ((FILE *)SCM_STREAM (new)); - if (newfd == -1) - scm_syserror (s_redirect_port); - SCM_SYSCALL (ans = dup2 (oldfd, newfd)); - if (ans == -1) - scm_syserror (s_redirect_port); - SCM_ALLOW_INTS; + SCM_ASSERT (SCM_NIMP (old) && SCM_OPFPORTP (old), old, SCM_ARG1, s_redirect_port); + SCM_ASSERT (SCM_NIMP (new) && SCM_OPFPORTP (new), new, SCM_ARG2, s_redirect_port); + oldfd = SCM_FPORT_FDES (old); + fp = SCM_FSTREAM (new); + newfd = fp->fdes; + if (oldfd != newfd) + { + struct scm_port_table *pt = SCM_PTAB_ENTRY (new); + + /* must flush to old fdes. don't clear all buffers here + in case dup2 fails. */ + if (pt->write_pos > pt->write_buf) + scm_fflush (new); + ans = dup2 (oldfd, newfd); + if (ans == -1) + scm_syserror (s_redirect_port); + fp->random = SCM_FDES_RANDOM_P (fp->fdes); + /* continue using existing buffers, even if inappropriate. */ + SCM_CLEAR_BUFFERS (new, pt); + } return SCM_UNSPECIFIED; } @@ -296,21 +479,18 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd) fd_or_port = SCM_COERCE_OUTPORT (fd_or_port); - SCM_DEFER_INTS; if (SCM_INUMP (fd_or_port)) oldfd = SCM_INUM (fd_or_port); else { - SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPPORTP (fd_or_port), + SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPFPORTP (fd_or_port), fd_or_port, SCM_ARG1, s_dup_to_fdes); - oldfd = fileno ((FILE *)SCM_STREAM (fd_or_port)); - if (oldfd == -1) - scm_syserror (s_dup_to_fdes); + oldfd = SCM_FPORT_FDES (fd_or_port); } if (SCM_UNBNDP (fd)) { - SCM_SYSCALL (newfd = dup (oldfd)); + newfd = dup (oldfd); if (newfd == -1) scm_syserror (s_dup_to_fdes); fd = SCM_MAKINUM (newfd); @@ -322,12 +502,11 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd) if (oldfd != newfd) { scm_evict_ports (newfd); /* see scsh manual. */ - SCM_SYSCALL (rv = dup2 (oldfd, newfd)); + rv = dup2 (oldfd, newfd); if (rv == -1) scm_syserror (s_dup_to_fdes); } } - SCM_ALLOW_INTS; return fd; } @@ -337,15 +516,10 @@ SCM scm_fileno (port) SCM port; { - int fd; - port = SCM_COERCE_OUTPORT (port); - - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_fileno); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_fileno); - return SCM_MAKINUM (fd); + SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, + s_fileno); + return SCM_MAKINUM (SCM_FPORT_FDES (port)); } SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p); @@ -360,10 +534,8 @@ scm_isatty_p (port) if (!(SCM_NIMP (port) && SCM_OPFPORTP (port))) return SCM_BOOL_F; - rv = fileno ((FILE *)SCM_STREAM (port)); - if (rv == -1) - scm_syserror (s_isatty); - rv = isatty (rv); + + rv = isatty (SCM_FPORT_FDES (port)); return rv ? SCM_BOOL_T : SCM_BOOL_F; } @@ -376,19 +548,13 @@ scm_fdopen (fdes, modes) SCM fdes; SCM modes; { - FILE *f; SCM port; SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen); SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_fdopen); SCM_COERCE_SUBSTR (modes); - SCM_DEFER_INTS; - f = fdopen (SCM_INUM (fdes), SCM_ROCHARS (modes)); - if (f == NULL) - scm_syserror (s_fdopen); - port = scm_stdio_to_port (f, SCM_ROCHARS (modes), SCM_BOOL_F); - SCM_ALLOW_INTS; + port = scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F); return port; } @@ -406,7 +572,7 @@ scm_primitive_move_to_fdes (port, fd) SCM port; SCM fd; { - FILE *stream; + struct scm_fport *stream; int old_fd; int new_fd; int rv; @@ -415,22 +581,19 @@ scm_primitive_move_to_fdes (port, fd) SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes); SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes); - SCM_DEFER_INTS; - stream = (FILE *)SCM_STREAM (port); - old_fd = fileno (stream); + stream = SCM_FSTREAM (port); + old_fd = stream->fdes; new_fd = SCM_INUM (fd); if (old_fd == new_fd) { - SCM_ALLOW_INTS; return SCM_BOOL_F; } scm_evict_ports (new_fd); rv = dup2 (old_fd, new_fd); if (rv == -1) scm_syserror (s_primitive_move_to_fdes); - scm_setfileno (stream, new_fd); + stream->fdes = new_fd; SCM_SYSCALL (close (old_fd)); - SCM_ALLOW_INTS; return SCM_BOOL_T; } @@ -448,14 +611,12 @@ scm_fdes_to_ports (fd) SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports); int_fd = SCM_INUM (fd); - SCM_DEFER_INTS; for (i = 0; i < scm_port_table_size; i++) { - if (SCM_FPORTP (scm_port_table[i]->port) - && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == int_fd) + if (SCM_OPFPORTP (scm_port_table[i]->port) + && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd) result = scm_cons (scm_port_table[i]->port, result); } - SCM_ALLOW_INTS; return result; } diff --git a/libguile/net_db.c b/libguile/net_db.c index bcb3f563d..1eb87c5bb 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -102,10 +102,8 @@ scm_inet_ntoa (inetid) char *s; SCM answer; addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa)); - SCM_DEFER_INTS; s = inet_ntoa (addr); answer = scm_makfromstr (s, strlen (s), 0); - SCM_ALLOW_INTS; return answer; } @@ -174,7 +172,6 @@ scm_gethost (name) int i = 0; if (SCM_UNBNDP (name)) { - SCM_DEFER_INTS; #ifdef HAVE_GETHOSTENT entry = gethostent (); #else @@ -188,23 +185,19 @@ scm_gethost (name) afterwards doesn't cut it, because, on Linux, it seems to try to contact some other server (YP?) and fails, which is a benign failure. */ - SCM_ALLOW_INTS; return SCM_BOOL_F; } } else if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) { SCM_COERCE_SUBSTR (name); - SCM_DEFER_INTS; entry = gethostbyname (SCM_ROCHARS (name)); } else { inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost)); - SCM_DEFER_INTS; entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); } - SCM_ALLOW_INTS; if (!entry) { char *errmsg; @@ -264,12 +257,10 @@ scm_getnet (name) ve = SCM_VELTS (ans); if (SCM_UNBNDP (name)) { - SCM_DEFER_INTS; errno = 0; entry = getnetent (); if (! entry) { - SCM_ALLOW_INTS; if (errno) scm_syserror (s_getnet); else @@ -279,17 +270,14 @@ scm_getnet (name) else if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) { SCM_COERCE_SUBSTR (name); - SCM_DEFER_INTS; entry = getnetbyname (SCM_ROCHARS (name)); } else { unsigned long netnum; netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet); - SCM_DEFER_INTS; entry = getnetbyaddr (netnum, AF_INET); } - SCM_ALLOW_INTS; if (!entry) scm_syserror_msg (s_getnet, "no such network %s", scm_listify (name, SCM_UNDEFINED), errno); @@ -316,12 +304,10 @@ scm_getproto (name) ve = SCM_VELTS (ans); if (SCM_UNBNDP (name)) { - SCM_DEFER_INTS; errno = 0; entry = getprotoent (); if (! entry) { - SCM_ALLOW_INTS; if (errno) scm_syserror (s_getproto); else @@ -331,17 +317,14 @@ scm_getproto (name) else if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) { SCM_COERCE_SUBSTR (name); - SCM_DEFER_INTS; entry = getprotobyname (SCM_ROCHARS (name)); } else { unsigned long protonum; protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto); - SCM_DEFER_INTS; entry = getprotobynumber (protonum); } - SCM_ALLOW_INTS; if (!entry) scm_syserror_msg (s_getproto, "no such protocol %s", scm_listify (name, SCM_UNDEFINED), errno); @@ -367,7 +350,6 @@ scm_return_entry (entry) ve[1] = scm_makfromstrs (-1, entry->s_aliases); ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L); ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0); - SCM_ALLOW_INTS; return ans; } @@ -382,10 +364,8 @@ scm_getserv (name, proto) struct servent *entry; if (SCM_UNBNDP (name)) { - SCM_DEFER_INTS; errno = 0; entry = getservent (); - SCM_ALLOW_INTS; if (!entry) { if (errno) @@ -400,19 +380,16 @@ scm_getserv (name, proto) if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) { SCM_COERCE_SUBSTR (name); - SCM_DEFER_INTS; entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto)); } else { SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv); - SCM_DEFER_INTS; entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto)); } if (!entry) scm_syserror_msg (s_getserv, "no such service %s", scm_listify (name, SCM_UNDEFINED), errno); - SCM_ALLOW_INTS; return scm_return_entry (entry); } #endif diff --git a/libguile/ports.c b/libguile/ports.c index a1b4a8f24..be425601a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -46,7 +46,6 @@ #include "genio.h" #include "chars.h" -#include "filesys.h" #include "fports.h" #include "strports.h" #include "vports.h" @@ -78,7 +77,7 @@ scm_ptobfuns *scm_ptobs; int scm_numptob; - +/* GC marker for a port with stream of SCM type. */ SCM scm_markstream (ptr) SCM ptr; @@ -92,7 +91,6 @@ scm_markstream (ptr) } - long scm_newptob (ptob) scm_ptobfuns *ptob; @@ -100,8 +98,7 @@ scm_newptob (ptob) char *tmp; if (255 <= scm_numptob) goto ptoberr; - SCM_DEFER_INTS; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns))); + tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)); if (tmp) { scm_ptobs = (scm_ptobfuns *) tmp; @@ -109,16 +106,12 @@ scm_newptob (ptob) scm_ptobs[scm_numptob].free = ptob->free; scm_ptobs[scm_numptob].print = ptob->print; scm_ptobs[scm_numptob].equalp = ptob->equalp; - scm_ptobs[scm_numptob].fputc = ptob->fputc; - scm_ptobs[scm_numptob].fputs = ptob->fputs; - scm_ptobs[scm_numptob].fwrite = ptob->fwrite; scm_ptobs[scm_numptob].fflush = ptob->fflush; - scm_ptobs[scm_numptob].fgetc = ptob->fgetc; - scm_ptobs[scm_numptob].fgets = ptob->fgets; scm_ptobs[scm_numptob].fclose = ptob->fclose; + scm_ptobs[scm_numptob].fill_buffer = ptob->fill_buffer; + scm_ptobs[scm_numptob].input_waiting_p = ptob->input_waiting_p; scm_numptob++; } - SCM_ALLOW_INTS; if (!tmp) ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); return scm_tc7_port + (scm_numptob - 1) * 256; @@ -138,13 +131,61 @@ scm_char_ready_p (port) SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p); - if (SCM_CRDYP (port) || !SCM_FPORTP (port)) + if (SCM_CRDYP (port)) return SCM_BOOL_T; - return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p) - ? SCM_BOOL_T - : SCM_BOOL_F); + else + { + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + + if (pt->read_pos < pt->read_end) + return SCM_BOOL_T; + else + { + scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + + if (ptob->input_waiting_p) + return ((ptob->input_waiting_p) (port)) ? SCM_BOOL_T : SCM_BOOL_F; + else + return SCM_BOOL_T; + } + } } +/* Clear a port's read buffer, returning the contents. */ +SCM_PROC (s_drain_input, "drain-input", 1, 0, 0, scm_drain_input); +SCM +scm_drain_input (SCM port) +{ + char *fp_buf = NULL; + int fp_count = 0; + + SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, + s_drain_input); + if (SCM_FPORTP (port)) + { + fp_buf = scm_fport_drain_input (port, &fp_count); + } + { + int p_count = (SCM_CRDYP (port)) ? SCM_N_READY_CHARS (port) : 0; + SCM result = scm_makstr (p_count + fp_count, 0); + char *dst = SCM_CHARS (result); + char *p_buf = SCM_PTAB_ENTRY (port)->cp; + + while (p_count > 0) + { + *dst++ = *p_buf--; + p_count--; + } + while (fp_count > 0) + { + *dst++ = *fp_buf++; + fp_count--; + } + + SCM_CLRDY (port); + return result; + } +} /* Standard ports --- current input, output, error, and more(!). */ @@ -224,13 +265,12 @@ scm_set_current_error_port (port) /* The port table --- a table of all the open ports. */ -/* Array of open ports, required for reliable MOVE->FDES etc. */ struct scm_port_table **scm_port_table; int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ int scm_port_table_room = 20; /* Size of the array. */ -/* Add a port to the table. Call with SCM_DEFER_INTS active. */ +/* Add a port to the table. */ struct scm_port_table * scm_add_to_port_table (port) @@ -238,11 +278,14 @@ scm_add_to_port_table (port) { if (scm_port_table_size == scm_port_table_room) { - scm_port_table = ((struct scm_port_table **) - realloc ((char *) scm_port_table, - (scm_sizet) (sizeof (struct scm_port_table *) - * scm_port_table_room * 2))); - /* !!! error checking */ + void *newt = realloc ((char *) scm_port_table, + (scm_sizet) (sizeof (struct scm_port_table *) + * scm_port_table_room * 2)); + if (newt == NULL) + { + scm_memory_error ("scm_add_to_port_table"); + } + scm_port_table = (struct scm_port_table **) newt; scm_port_table_room *= 2; } scm_port_table[scm_port_table_size] = ((struct scm_port_table *) @@ -259,10 +302,11 @@ scm_add_to_port_table (port) = scm_port_table[scm_port_table_size]->cbuf; scm_port_table[scm_port_table_size]->cbufend = &scm_port_table[scm_port_table_size]->cbuf[SCM_INITIAL_CBUF_SIZE]; + scm_port_table[scm_port_table_size]->write_needs_seek = 0; return scm_port_table[scm_port_table_size++]; } -/* Remove a port from the table. Call with SCM_DEFER_INTS active. */ +/* Remove a port from the table. */ void scm_remove_from_port_table (port) @@ -371,9 +415,7 @@ scm_set_port_revealed_x (port, rcount) port = SCM_COERCE_OUTPORT (port); SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); - SCM_DEFER_INTS; SCM_REVEALED (port) = SCM_INUM (rcount); - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -396,7 +438,8 @@ scm_mode_bits (modes) | ( strchr (modes, 'w') || strchr (modes, 'a') || strchr (modes, '+') ? SCM_WRTNG : 0) - | (strchr (modes, '0') ? SCM_BUF0 : 0)); + | (strchr (modes, '0') ? SCM_BUF0 : 0) + | (strchr (modes, 'l') ? SCM_BUFLINE : 0)); } @@ -452,19 +495,12 @@ scm_close_port (port) if (SCM_CLOSEDP (port)) return SCM_BOOL_F; i = SCM_PTOBNUM (port); - SCM_DEFER_INTS; if (scm_ptobs[i].fclose) - { - SCM_SYSCALL (rv = (scm_ptobs[i].fclose) (port)); - /* ports with a closed file descriptor can be reclosed without error. */ - if (rv < 0 && errno != EBADF) - scm_syserror (s_close_port); - } + rv = (scm_ptobs[i].fclose) (port); else rv = 0; scm_remove_from_port_table (port); SCM_SETAND_CAR (port, ~SCM_OPN); - SCM_ALLOW_INTS; return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; } @@ -476,7 +512,6 @@ scm_close_all_ports_except (ports) { int i = 0; SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); - SCM_DEFER_INTS; while (i < scm_port_table_size) { SCM thisport = scm_port_table[i]->port; @@ -498,7 +533,6 @@ scm_close_all_ports_except (ports) /* i is not to be incremented here. */ scm_close_port (thisport); } - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -552,11 +586,8 @@ scm_force_output (port) SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output); } - { - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fflush) (port)); - return SCM_UNSPECIFIED; - } + scm_fflush (port); + return SCM_UNSPECIFIED; } SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports); @@ -567,12 +598,8 @@ scm_flush_all_ports (void) for (i = 0; i < scm_port_table_size; i++) { - SCM port = scm_port_table[i]->port; - if (SCM_OPOUTPORTP (port)) - { - scm_sizet ptob = SCM_PTOBNUM (port); - (scm_ptobs[ptob].fflush) (port); - } + if (SCM_OPOUTPORTP (scm_port_table[i]->port)) + scm_fflush (scm_port_table[i]->port); } return SCM_UNSPECIFIED; } @@ -594,6 +621,191 @@ scm_read_char (port) return SCM_MAKICHR (c); } +int +scm_getc (port) + SCM port; +{ + int c; + + if (SCM_CRDYP (port)) + { + c = SCM_CGETUN (port); + SCM_TRY_CLRDY (port); /* Clear ungetted char */ + } + else + { + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + + if (pt->read_pos < pt->read_end) + { + c = *(pt->read_pos++); + } + else + { + scm_sizet i = SCM_PTOBNUM (port); + + c = (scm_ptobs [i].fill_buffer) (port); + } + } + + if (c == '\n') + { + SCM_INCLINE (port); + } + else if (c == '\t') + { + SCM_TABCOL (port); + } + else + { + SCM_INCCOL (port); + } + + return c; +} + +/* a macro used whenever writing to a port. in the case of fports, + if fdes is random access and the last access was a + read, then clear the read and put-back buffers and adjust the file position + to account for unread chars. */ +#define SCM_MAYBE_DRAIN_INPUT(port, pt, ptob)\ +{\ + if (pt->write_needs_seek)\ + {\ + int offset = pt->read_end - pt->read_pos;\ + if (SCM_CRDYP (port))\ + {\ + offset += SCM_N_READY_CHARS (port);\ + SCM_CLRDY (port);\ + }\ + if (offset > 0)\ + {\ + pt->read_pos = pt->read_end;\ + /* will throw error if unread-char used at beginning of file\ + then attempting to write. seems correct. */\ + if ((ptob->seek) (port, -offset, SEEK_CUR) == -1)\ + scm_syserror ("scm_maybe_drain_input");\ + }\ + pt->write_needs_seek = 0;\ + }\ +} + +void +scm_putc (c, port) + int c; + SCM port; +{ + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + + SCM_MAYBE_DRAIN_INPUT (port, pt, ptob) + *(pt->write_pos++) = (char) c; + if (pt->write_pos == pt->write_end + || (c == '\n' + && (SCM_CAR (port) & SCM_BUFLINE))) + { + (ptob->fflush) (port); + } +} + +void +scm_puts (s, port) + char *s; + SCM port; +{ + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + + SCM_MAYBE_DRAIN_INPUT (port, pt, ptob); + while (*s != 0) + { + *pt->write_pos++ = *s++; + if (pt->write_pos == pt->write_end) + (ptob->fflush) (port); + } + + /* If the port is line-buffered, flush it. */ + if ((SCM_CAR (port) & SCM_BUFLINE) + && memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf)) + (ptob->fflush) (port); +} + +void +scm_lfwrite (ptr, size, port) + char *ptr; + scm_sizet size; + SCM port; +{ + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + + SCM_MAYBE_DRAIN_INPUT (port, pt, ptob); + while (size > 0) + { + int space = pt->write_end - pt->write_pos; + int write_len = (size > space) ? space : size; + + strncpy (pt->write_pos, ptr, write_len); + pt->write_pos += write_len; + size -= write_len; + ptr += write_len; + if (write_len == space) + (ptob->fflush) (port); + } + + /* If the port is line-buffered, flush it. */ + if ((SCM_CAR (port) & SCM_BUFLINE) + && memchr (pt->write_buf, '\n', pt->write_pos - pt->write_buf)) + (ptob->fflush) (port); +} + + +void +scm_fflush (port) + SCM port; +{ + scm_sizet i = SCM_PTOBNUM (port); + (scm_ptobs[i].fflush) (port); +} + + + + +void +scm_ungetc (c, port) + int c; + SCM port; +{ + SCM_CUNGET (c, port); + + if (c == '\n') + { + /* What should col be in this case? + * We'll leave it at -1. + */ + SCM_LINUM (port) -= 1; + } + else + SCM_COL(port) -= 1; +} + + +void +scm_ungets (s, n, port) + char *s; + int n; + SCM port; +{ + /* This is simple minded and inefficient, but unreading strings is + * probably not a common operation, and remember that line and + * column numbers have to be handled... + * + * Please feel free to write an optimized version! + */ + while (n--) + scm_ungetc (s[n], port); +} + SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); @@ -613,70 +825,6 @@ scm_peek_char (port) return SCM_MAKICHR (c); } -/* - * A generic fgets method. We supply this method so that ports which - * can't use fgets(3) (like string ports or soft ports) can still use - * line-based i/o. The generic method calls the port's own fgetc method - * for input. It should be possible to write a more efficient - * method for any given port representation -- this is supplied just - * to ensure that you don't have to. - */ - -char * scm_generic_fgets SCM_P ((SCM port, int *len)); - -char * -scm_generic_fgets (port, len) - SCM port; - int *len; -{ - scm_sizet p = SCM_PTOBNUM (port); - - char *buf; - int limit = 80; /* current size of buffer */ - int c; - - /* FIXME: It would be nice to be able to check for EOF before anything. */ - - *len = 0; - buf = (char *) malloc (limit * sizeof(char)); - - /* If a char has been pushed onto the port with scm_ungetc, - read that first. */ - while (SCM_CRDYP (port)) - { - buf[*len] = SCM_CGETUN (port); - SCM_TRY_CLRDY (port); - if (buf[(*len)++] == '\n' || *len == limit - 1) - { - buf[*len] = '\0'; - return buf; - } - } - - while (1) { - if (*len >= limit-1) - { - buf = (char *) realloc (buf, sizeof(char) * limit * 2); - limit *= 2; - } - - c = (scm_ptobs[p].fgetc) (port); - if (c != EOF) - buf[(*len)++] = c; - - if (c == EOF || c == '\n') - { - if (*len) - { - buf[*len] = '\0'; - return buf; - } - free (buf); - return NULL; - } - } -} - SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); SCM @@ -834,23 +982,19 @@ scm_prinport (exp, port, type) } scm_puts (type, port); scm_putc (' ', port); -#ifndef MSDOS -#ifndef __EMX__ -#ifndef _DCC -#ifndef AMIGA -#ifndef THINK_C - if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) - scm_puts (ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); - else -#endif -#endif -#endif -#endif -#endif if (SCM_OPFPORTP (exp)) - scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); + { + int fdes = (SCM_FSTREAM (exp))->fdes; + + if (isatty (fdes)) + scm_puts (ttyname (fdes), port); + else + scm_intprint (fdes, 10, port); + } else - scm_intprint (SCM_CDR (exp), 16, port); + { + scm_intprint (SCM_CDR (exp), 16, port); + } scm_putc ('>', port); } @@ -865,12 +1009,13 @@ scm_ports_prehistory () * They must agree with the port declarations in tags.h. */ /* scm_tc16_fport = */ scm_newptob (&scm_fptob); - /* scm_tc16_pipe = */ scm_newptob (&scm_pipob); + /* scm_tc16_pipe was here */ scm_newptob (&scm_fptob); /* dummy. */ /* scm_tc16_strport = */ scm_newptob (&scm_stptob); /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); } + /* Void ports. */ int scm_tc16_void_port = 0; @@ -882,44 +1027,9 @@ print_void_port (SCM exp, SCM port, scm_print_state *pstate) return 1; } -static int -putc_void_port (int c, SCM port) -{ - return 0; /* vestigial return value */ -} - -static int -puts_void_port (char *s, SCM port) -{ - return 0; /* vestigial return value */ -} - -static scm_sizet -write_void_port (char *ptr, scm_sizet size, scm_sizet nitems, SCM port) -{ - int len; - len = size * nitems; - return len; -} - - -static int +static void flush_void_port (SCM port) { - return 0; -} - - -static int -getc_void_port (SCM port) -{ - return EOF; -} - -static char * -fgets_void_port (SCM port, int *len) -{ - return NULL; } static int @@ -943,13 +1053,11 @@ static struct scm_ptobfuns void_port_ptob = noop0, print_void_port, 0, /* equal? */ - putc_void_port, - puts_void_port, - write_void_port, flush_void_port, - getc_void_port, - fgets_void_port, close_void_port, + 0, + 0, + 0, }; SCM @@ -964,9 +1072,9 @@ scm_void_port (mode_str) SCM_DEFER_INTS; mode_bits = scm_mode_bits (mode_str); pt = scm_add_to_port_table (answer); - SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); SCM_SETPTAB_ENTRY (answer, pt); - SCM_SETSTREAM (answer, SCM_BOOL_F); + SCM_SETSTREAM (answer, 0); + SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); SCM_ALLOW_INTS; return answer; } @@ -985,8 +1093,6 @@ scm_sys_make_void_port (mode) return scm_void_port (SCM_ROCHARS (mode)); } - - /* Initialization. */ @@ -996,4 +1102,3 @@ scm_init_ports () scm_tc16_void_port = scm_newptob (&void_port_ptob); #include "ports.x" } - diff --git a/libguile/ports.h b/libguile/ports.h index 80dfe3077..d3f88720c 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -53,23 +53,53 @@ #define SCM_INITIAL_CBUF_SIZE 4 -struct scm_port_table +struct scm_port_table { - SCM port; /* Open port. */ + SCM port; /* Link back to the port object. */ int entry; /* Index in port table. */ int revealed; /* 0 not revealed, > 1 revealed. * Revealed ports do not get GC'd. */ - + /* ptob specific data. may be SCM data or cast to a pointer to C data. */ SCM stream; SCM file_name; /* debugging support. */ int line_number; /* debugging support. */ int column_number; /* debugging support. */ - char *cp; /* where to put and get unget chars */ - char *cbufend; /* points after this struct */ - char cbuf[SCM_INITIAL_CBUF_SIZE]; /* must be last: may grow */ + /* port buffers. the buffer(s) are set up for all ports. + in the case of string ports, the buffer is the string itself. + in the case of unbuffered file ports, the buffer is a + single char: shortbuf. */ + + /* this buffer is filled from read_buf to read_end using the ptob + buffer_fill. then input requests are taken from read_pos until + it reaches read_end. */ + + unsigned char *read_buf; /* buffer start. */ + unsigned char *read_pos; /* the next unread char. */ + unsigned char *read_end; /* pointer to last buffered char + 1. */ + int read_buf_size; /* size of the buffer. */ + + /* write requests are saved into this buffer at write_pos until it + reaches write_buf + write_buf_size, then the ptob flush is + called. */ + + unsigned char *write_buf; /* buffer start. */ + unsigned char *write_pos; /* pointer to last buffered char + 1. */ + unsigned char *write_end; /* pointer to end of buffer + 1. */ + int write_buf_size; /* size of the buffer. */ + + unsigned char shortbuf; /* buffer for "unbuffered" streams. */ + + int write_needs_seek; /* whether port position needs to be adjusted + before writing to it. */ + + /* a completely separate buffer which is only used for un-read chars + and strings. */ + unsigned char *cp; /* where to put and get unget chars */ + unsigned char *cbufend; /* points after this struct */ + unsigned char cbuf[SCM_INITIAL_CBUF_SIZE]; /* must be last: may grow */ }; extern struct scm_port_table **scm_port_table; @@ -88,9 +118,9 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_OPN (1L<<16) /* Is the port open? */ #define SCM_RDNG (2L<<16) /* Is it a readable port? */ #define SCM_WRTNG (4L<<16) /* Is it writable? */ -#define SCM_BUF0 (8L<<16) -#define SCM_NOFTELL (16L<<16) /* Does ftell work on this? Yuck! */ -#define SCM_CRDY (32L<<16) /* Should char-ready? return #t? */ +#define SCM_BUF0 (8L<<16) /* Is it unbuffered? */ +#define SCM_CRDY (32L<<16) /* Are there pushed back characters? */ +#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */ /* A mask used to clear the char-ready port flag. */ #define SCM_CUC (~SCM_CRDY) @@ -99,11 +129,6 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_OPPORTP(x) (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)) #define SCM_OPINPORTP(x) (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)) #define SCM_OPOUTPORTP(x) (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)) -#define SCM_FPORTP(x) (SCM_TYP16S(x)==scm_tc7_port) -#define SCM_OPFPORTP(x) (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)) -#define SCM_OPINFPORTP(x) (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)) -#define SCM_OPOUTFPORTP(x) (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)) - #define SCM_INPORTP(x) (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG)) #define SCM_OUTPORTP(x) (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG)) #define SCM_OPENP(x) (SCM_OPN & SCM_CAR(x)) @@ -111,7 +136,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_PTAB_ENTRY(x) ((struct scm_port_table *)SCM_CDR(x)) #define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent)) #define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream -#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s) +#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (SCM) s) #define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name #define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number #define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number @@ -168,16 +193,11 @@ typedef struct scm_ptobfuns int (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); - int (*fputc) (int, SCM port); - int (*fputs) (char *, SCM port); - scm_sizet (*fwrite) SCM_P ((char *ptr, - scm_sizet size, - scm_sizet nitems, - SCM port)); - int (*fflush) (SCM port); - int (*fgetc) (SCM port); - char * (*fgets) (SCM port, int *len); + void (*fflush) (SCM port); int (*fclose) (SCM port); + int (*fill_buffer) (SCM port); + off_t (*seek) (SCM port, off_t OFFSET, int WHENCE); + int (*input_waiting_p) (SCM port); } scm_ptobfuns; #define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)) @@ -193,6 +213,7 @@ extern int scm_port_table_room; extern SCM scm_markstream SCM_P ((SCM ptr)); extern long scm_newptob SCM_P ((scm_ptobfuns *ptob)); extern SCM scm_char_ready_p SCM_P ((SCM port)); +extern SCM scm_drain_input (SCM port); extern SCM scm_current_input_port SCM_P ((void)); extern SCM scm_current_output_port SCM_P ((void)); extern SCM scm_current_error_port SCM_P ((void)); @@ -218,6 +239,13 @@ extern SCM scm_eof_object_p SCM_P ((SCM x)); extern SCM scm_force_output SCM_P ((SCM port)); extern SCM scm_flush_all_ports SCM_P ((void)); extern SCM scm_read_char SCM_P ((SCM port)); +extern void scm_putc SCM_P ((int c, SCM port)); +extern void scm_puts SCM_P ((char *str_data, SCM port)); +extern void scm_lfwrite SCM_P ((char *ptr, scm_sizet size, SCM port)); +extern void scm_fflush SCM_P ((SCM port)); +extern int scm_getc SCM_P ((SCM port)); +extern void scm_ungetc SCM_P ((int c, SCM port)); +extern void scm_ungets SCM_P ((char *s, int n, SCM port)); extern SCM scm_peek_char SCM_P ((SCM port)); extern SCM scm_unread_char SCM_P ((SCM cobj, SCM port)); extern SCM scm_unread_string SCM_P ((SCM str, SCM port)); diff --git a/libguile/posix.c b/libguile/posix.c index 6b3fe5be6..975e36026 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -167,34 +167,14 @@ SCM scm_pipe () { int fd[2], rv; - FILE *f_rd, *f_wt; SCM p_rd, p_wt; rv = pipe (fd); if (rv) scm_syserror (s_pipe); - f_rd = fdopen (fd[0], "r"); - if (!f_rd) - { - SCM_SYSCALL (close (fd[0])); - SCM_SYSCALL (close (fd[1])); - scm_syserror (s_pipe); - } - f_wt = fdopen (fd[1], "w"); - if (!f_wt) - { - int en; - en = errno; - fclose (f_rd); - SCM_SYSCALL (close (fd[1])); - errno = en; - scm_syserror (s_pipe); - } - - p_rd = scm_stdio_to_port (f_rd, "r", sym_read_pipe); - p_wt = scm_stdio_to_port (f_wt, "w", sym_write_pipe); - - SCM_ALLOW_INTS; + + p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe); + p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe); return scm_cons (p_rd, p_wt); } @@ -220,15 +200,17 @@ scm_getgroups() val = getgroups(ngroups, groups); if (val < 0) { + int en = errno; scm_must_free((char *)groups); + errno = en; scm_syserror (s_getgroups); } SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); - SCM_ALLOW_INTS; ans = scm_make_vector (SCM_MAKINUM(ngroups), SCM_UNDEFINED); while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ + SCM_ALLOW_INTS; return ans; } } @@ -249,17 +231,14 @@ scm_getpwuid (user) ve = SCM_VELTS (result); if (SCM_UNBNDP (user) || SCM_FALSEP (user)) { - SCM_DEFER_INTS; SCM_SYSCALL (entry = getpwent ()); if (! entry) { - SCM_ALLOW_INTS; return SCM_BOOL_F; } } else if (SCM_INUMP (user)) { - SCM_DEFER_INTS; entry = getpwuid (SCM_INUM (user)); } else @@ -267,7 +246,6 @@ scm_getpwuid (user) SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid); if (SCM_SUBSTRP (user)) user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); - SCM_DEFER_INTS; entry = getpwnam (SCM_ROCHARS (user)); } if (!entry) @@ -286,7 +264,6 @@ scm_getpwuid (user) ve[6] = scm_makfrom0str (""); else ve[6] = scm_makfrom0str (entry->pw_shell); - SCM_ALLOW_INTS; return result; } @@ -320,13 +297,11 @@ scm_getgrgid (name) SCM *ve; result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); ve = SCM_VELTS (result); - SCM_DEFER_INTS; if (SCM_UNBNDP (name) || (name == SCM_BOOL_F)) { SCM_SYSCALL (entry = getgrent ()); if (! entry) { - SCM_ALLOW_INTS; return SCM_BOOL_F; } } @@ -346,7 +321,6 @@ scm_getgrgid (name) ve[1] = scm_makfrom0str (entry->gr_passwd); ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid); ve[3] = scm_makfromstrs (-1, entry->gr_mem); - SCM_ALLOW_INTS; return result; } @@ -644,9 +618,7 @@ scm_ttyname (port) SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname); if (scm_tc16_fport != SCM_TYP16 (port)) return SCM_BOOL_F; - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_ttyname); + fd = SCM_FPORT_FDES (port); SCM_SYSCALL (ans = ttyname (fd)); if (!ans) scm_syserror (s_ttyname); @@ -683,8 +655,8 @@ scm_tcgetpgrp (port) port = SCM_COERCE_OUTPORT (port); SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1) + fd = SCM_FPORT_FDES (port); + if ((pgid = tcgetpgrp (fd)) == -1) scm_syserror (s_tcgetpgrp); return SCM_MAKINUM (pgid); #else @@ -706,8 +678,8 @@ scm_tcsetpgrp (port, pgid) SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp); SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1) + fd = SCM_FPORT_FDES (port); + if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1) scm_syserror (s_tcsetpgrp); return SCM_UNSPECIFIED; #else @@ -729,7 +701,6 @@ scm_convert_exec_args (SCM args, int pos, const char *subr) SCM_ASSERT (SCM_NULLP (args) || (SCM_NIMP (args) && SCM_CONSP (args)), args, pos, subr); - SCM_DEFER_INTS; num_args = scm_ilength (args); execargv = (char **) scm_must_malloc ((num_args + 1) * sizeof (char *), subr); @@ -748,7 +719,6 @@ scm_convert_exec_args (SCM args, int pos, const char *subr) execargv[i] = dst; } execargv[i] = 0; - SCM_ALLOW_INTS; return execargv; } @@ -793,7 +763,6 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) char **result; int i = 0; - SCM_REDEFER_INTS; SCM_ASSERT (SCM_NULLP (envlist) || (SCM_NIMP (envlist) && SCM_CONSP (envlist)), envlist, arg, proc); @@ -820,7 +789,6 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) i++; } result[i] = 0; - SCM_REALLOW_INTS; return result; } @@ -867,7 +835,6 @@ scm_uname () struct utsname buf; SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); - SCM_DEFER_INTS; if (uname (&buf) < 0) scm_syserror (s_uname); ve[0] = scm_makfrom0str (buf.sysname); @@ -879,7 +846,6 @@ scm_uname () a linux special? ve[5] = scm_makfrom0str (buf.domainname); */ - SCM_ALLOW_INTS; return ans; #else scm_sysmissing (s_uname); @@ -900,7 +866,6 @@ scm_environ (env) { char **new_environ; - SCM_DEFER_INTS; new_environ = environ_list_to_c (env, SCM_ARG1, s_environ); /* Free the old environment, except when called for the first * time. @@ -917,7 +882,6 @@ scm_environ (env) first = 0; } environ = new_environ; - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } } @@ -934,60 +898,6 @@ SCM scm_tmpnam() } #endif -SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe); - -SCM -scm_open_pipe (pipestr, modes) - SCM pipestr; - SCM modes; -{ - FILE *f; - register SCM z; - struct scm_port_table * pt; - - SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, - SCM_ARG1, s_open_pipe); - if (SCM_SUBSTRP (pipestr)) - pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), - SCM_ROLENGTH (pipestr), 0); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, - s_open_pipe); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes))); - if (!f) - scm_syserror (s_open_pipe); - pt = scm_add_to_port_table (z); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN - | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG)); - SCM_SETSTREAM (z, (SCM)f); - SCM_ALLOW_INTS; - return z; -} - -SCM_PROC (s_close_pipe, "close-pipe", 1, 0, 0, scm_close_pipe); - -SCM -scm_close_pipe (port) - SCM port; -{ - int rv; - - SCM_ASSERT (SCM_NIMP (port) && SCM_TYP16(port) == scm_tc16_pipe - && SCM_OPENP (port), port, SCM_ARG1, s_close_pipe); - SCM_DEFER_INTS; - rv = pclose ((FILE *) SCM_STREAM (port)); - scm_remove_from_port_table (port); - SCM_SETAND_CAR (port, ~SCM_OPN); - if (rv == -1) - scm_syserror (s_close_pipe); - SCM_ALLOW_INTS; - return SCM_MAKINUM (rv); -} - SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime); SCM @@ -1140,12 +1050,10 @@ scm_mknod(path, type, perms, dev) else scm_out_of_range (s_mknod, type); - SCM_DEFER_INTS; SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms), SCM_INUM (dev))); if (val != 0) scm_syserror (s_mknod); - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; #else scm_sysmissing (s_mknod); diff --git a/libguile/print.c b/libguile/print.c index 6f376517e..f0cddb892 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -961,15 +961,6 @@ scm_newline (port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline); scm_putc ('\n', SCM_COERCE_OUTPORT (port)); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); - else -# endif -#endif - if (port == scm_cur_outp) - scm_fflush (port); return SCM_UNSPECIFIED; } diff --git a/libguile/readline.c b/libguile/readline.c index 90d2b5268..e69de29bb 100644 --- a/libguile/readline.c +++ b/libguile/readline.c @@ -1,478 +0,0 @@ -/* readline.c --- line editing support for Guile */ - -/* Copyright (C) 1997 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "_scm.h" -#if defined (HAVE_RL_GETC_FUNCTION) -#include -#include -#include -#include -#include - -#include -#include "iselect.h" - - -scm_option scm_readline_opts[] = { - { SCM_OPTION_BOOLEAN, "history-file", 1, - "Use history file." }, - { SCM_OPTION_INTEGER, "history-length", 200, - "History length." }, - { SCM_OPTION_INTEGER, "bounce-parens", 500, - "Time (ms) to show matching opening parenthesis (0 = off)."} -}; - -extern void stifle_history (int max); - -SCM_PROC (s_readline_options, "readline-options-interface", 0, 1, 0, scm_readline_options); - -SCM -scm_readline_options (setting) - SCM setting; -{ - SCM ans = scm_options (setting, - scm_readline_opts, - SCM_N_READLINE_OPTIONS, - s_readline_options); - stifle_history (SCM_HISTORY_LENGTH); - return ans; -} - -#ifndef HAVE_STRDUP -static char * -strdup (char *s) -{ - int len = strlen (s); - char *new = malloc (len + 1); - strcpy (new, s); - return new; -} -#endif /* HAVE_STRDUP */ - -#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL - -/* These are readline functions added in release 2.3. They will work - * together with readline-2.1 and 2.2. (The readline interface is - * disabled for earlier releases.) - * They are declared static; if we want to use them elsewhere, then - * we need external declarations for them, but at the moment, I don't - * think anything else in Guile ought to use these. - */ - -extern void _rl_clean_up_for_exit (); -extern void _rl_kill_kbd_macro (); -extern int _rl_init_argument (); - -static void -rl_cleanup_after_signal () -{ -#ifdef HAVE_RL_CLEAR_SIGNALS - _rl_clean_up_for_exit (); -#endif - (*rl_deprep_term_function) (); -#ifdef HAVE_RL_CLEAR_SIGNALS - rl_clear_signals (); -#endif - rl_pending_input = 0; -} - -static void -rl_free_line_state () -{ - register HIST_ENTRY *entry; - - free_undo_list (); - - entry = current_history (); - if (entry) - entry->data = (char *)NULL; - - _rl_kill_kbd_macro (); - rl_clear_message (); - _rl_init_argument (); -} - -#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */ - -static int promptp; -static SCM input_port; -static SCM before_read; - -static int -current_input_getc (FILE *in) -{ - SCM ans; - if (promptp && SCM_NIMP (before_read)) - { - scm_apply (before_read, SCM_EOL, SCM_EOL); - promptp = 0; - } - ans = scm_getc (input_port); - return ans; -} - -static void -redisplay () -{ - rl_redisplay (); - /* promptp = 1; */ -} - -SCM_PROC (s_readline, "readline", 0, 4, 0, scm_readline); - -static int in_readline = 0; -#ifdef USE_THREADS -static scm_mutex_t reentry_barrier_mutex; -#endif - -static void -reentry_barrier () -{ - int reentryp = 0; -#ifdef USE_THREADS - /* We should rather use scm_mutex_try_lock when it becomes available */ - scm_mutex_lock (&reentry_barrier_mutex); -#endif - if (in_readline) - reentryp = 1; - else - ++in_readline; -#ifdef USE_THREADS - scm_mutex_unlock (&reentry_barrier_mutex); -#endif - if (reentryp) - scm_misc_error (s_readline, "readline is not reentrant", SCM_EOL); -} - -static SCM -handle_error (void *data, SCM tag, SCM args) -{ - rl_free_line_state (); - rl_cleanup_after_signal (); - --in_readline; - scm_handle_by_throw (data, tag, args); - return SCM_UNSPECIFIED; /* never reached */ -} - -static SCM -internal_readline (SCM text) -{ - SCM ret; - char *s; - char *prompt = SCM_UNBNDP (text) ? "" : SCM_CHARS (text); - - promptp = 1; - s = readline (prompt); - if (s) - ret = scm_makfrom0str (s); - else - ret = SCM_EOF_VAL; - - free (s); - - return ret; -} - -SCM -scm_readline (SCM text, SCM inp, SCM outp, SCM read_hook) -{ - SCM ans; - - reentry_barrier (); - - before_read = SCM_BOOL_F; - - if (!SCM_UNBNDP (text)) - { - if (!(SCM_NIMP (text) && SCM_STRINGP (text))) - { - --in_readline; - scm_wrong_type_arg (s_readline, SCM_ARG1, text); - } - SCM_COERCE_SUBSTR (text); - } - - if (SCM_UNBNDP (inp)) - inp = scm_cur_inp; - - if (SCM_UNBNDP (outp)) - outp = scm_cur_outp; - - if (!(SCM_UNBNDP (read_hook) || SCM_FALSEP (read_hook))) - { - if (!(SCM_NFALSEP (scm_thunk_p (read_hook)))) - { - --in_readline; - scm_wrong_type_arg (s_readline, SCM_ARG4, read_hook); - } - before_read = read_hook; - } - - if (!(SCM_NIMP (inp) && SCM_OPINFPORTP (inp))) - { - --in_readline; - scm_misc_error (s_readline, - "Input port is not open or not a file port", - SCM_EOL); - } - if (!(SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))) - { - --in_readline; - scm_misc_error (s_readline, - "Output port is not open or not a file port", - SCM_EOL); - } - - input_port = inp; - rl_instream = (FILE *) SCM_STREAM (inp); - rl_outstream = (FILE *) SCM_STREAM (outp); - - ans = scm_internal_catch (SCM_BOOL_T, - (scm_catch_body_t) internal_readline, - (void *) text, - handle_error, 0); - --in_readline; - return ans; -} - -SCM_PROC (s_add_history, "add-history", 1, 0, 0, scm_add_history); - -SCM -scm_add_history (SCM text) -{ - char* s; - SCM_ASSERT ((SCM_NIMP(text) && SCM_STRINGP(text)), text, SCM_ARG1, - s_add_history); - SCM_COERCE_SUBSTR (text); - - s = SCM_CHARS (text); - add_history (strdup (s)); - - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_read_history, "read-history", 1, 0, 0, scm_read_history); - -SCM -scm_read_history (SCM file) -{ - SCM_ASSERT (SCM_NIMP (file) && SCM_STRINGP (file), - file, SCM_ARG1, s_read_history); - return read_history (SCM_ROCHARS (file)) ? SCM_BOOL_F : SCM_BOOL_T; -} - - -SCM_PROC (s_write_history, "write-history", 1, 0, 0, scm_write_history); - -SCM -scm_write_history (SCM file) -{ - SCM_ASSERT (SCM_NIMP (file) && SCM_STRINGP (file), - file, SCM_ARG1, s_write_history); - return write_history (SCM_ROCHARS (file)) ? SCM_BOOL_F : SCM_BOOL_T; -} - - -SCM_PROC (s_filename_completion_function, "filename-completion-function", 2, 0, 0, scm_filename_completion_function); - -SCM -scm_filename_completion_function (SCM text, SCM continuep) -{ - char *s; - SCM ans; - SCM_ASSERT (SCM_NIMP (text) && SCM_STRINGP (text), - text, - SCM_ARG1, - s_filename_completion_function); - SCM_COERCE_SUBSTR (text); - s = filename_completion_function (SCM_CHARS (text), SCM_NFALSEP (continuep)); - ans = scm_makfrom0str (s); - free (s); - return ans; -} - -/* - * The following has been modified from code contributed by - * Andrew Archibald - */ - -SCM scm_readline_completion_function_var; - -static char * -completion_function (char *text, int continuep) -{ - SCM compfunc = SCM_CDR (scm_readline_completion_function_var); - SCM res; - - if (SCM_FALSEP (compfunc)) - return NULL; /* #f => completion disabled */ - else - { - SCM t = scm_makfrom0str (text); - SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F; - res = scm_apply (compfunc, SCM_LIST2 (t, c), SCM_EOL); - - if (SCM_FALSEP (res)) - return NULL; - - if (!(SCM_NIMP (res) && SCM_STRINGP (res))) - scm_misc_error (s_readline, - "Completion function returned bogus value: %S", - SCM_LIST1 (res)); - SCM_COERCE_SUBSTR (res); - return strdup (SCM_CHARS (res)); - } -} - -/*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/ - -static void match_paren(int x, int k); -static int find_matching_paren(int k); -static void init_bouncing_parens(); - -static void -init_bouncing_parens() -{ - if(strncmp(rl_get_keymap_name(rl_get_keymap()), "vi", 2)) { - rl_bind_key(')', match_paren); - rl_bind_key(']', match_paren); - rl_bind_key('}', match_paren); - } -} - -static int -find_matching_paren(int k) -{ - register int i; - register char c = 0; - int end_parens_found = 0; - - /* Choose the corresponding opening bracket. */ - if (k == ')') c = '('; - else if (k == ']') c = '['; - else if (k == '}') c = '{'; - - for (i=rl_point-2; i>=0; i--) - { - /* Is the current character part of a character literal? */ - if (i - 2 >= 0 - && rl_line_buffer[i - 1] == '\\' - && rl_line_buffer[i - 2] == '#') - ; - else if (rl_line_buffer[i] == k) - end_parens_found++; - else if (rl_line_buffer[i] == '"') - { - /* Skip over a string literal. */ - for (i--; i >= 0; i--) - if (rl_line_buffer[i] == '"' - && ! (i - 1 >= 0 - && rl_line_buffer[i - 1] == '\\')) - break; - } - else if (rl_line_buffer[i] == c) - { - if (end_parens_found==0) return i; - else --end_parens_found; - } - } - return -1; -} - -static void -match_paren(int x, int k) -{ - int tmp; - fd_set readset; - struct timeval timeout; - - rl_insert(x, k); - if (!SCM_READLINE_BOUNCE_PARENS) - return; - - /* Did we just insert a quoted paren? If so, then don't bounce. */ - if (rl_point - 1 >= 1 - && rl_line_buffer[rl_point - 2] == '\\') - return; - - tmp = 1000 * SCM_READLINE_BOUNCE_PARENS; - timeout.tv_sec = tmp / 1000000; - timeout.tv_usec = tmp % 1000000; - FD_ZERO(&readset); - FD_SET(fileno(rl_instream), &readset); - - if(rl_point > 1) { - tmp = rl_point; - rl_point = find_matching_paren(k); - if(rl_point > -1) { - rl_redisplay(); - scm_internal_select(1, &readset, NULL, NULL, &timeout); - } - rl_point = tmp; - } -} - - -void -scm_init_readline () -{ -#include "readline.x" - scm_readline_completion_function_var - = scm_sysintern ("*readline-completion-function*", SCM_BOOL_F); - rl_getc_function = current_input_getc; - rl_redisplay_function = redisplay; - rl_completion_entry_function = (Function*) completion_function; - rl_basic_word_break_characters = "\t\n\"'`;()"; -#ifdef USE_THREADS - scm_mutex_init (&reentry_barrier_mutex); -#endif - scm_init_opts (scm_readline_options, - scm_readline_opts, - SCM_N_READLINE_OPTIONS); - init_bouncing_parens(); - scm_add_feature ("readline"); -} - -#endif diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 9723021f3..f3970eb20 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -113,6 +113,7 @@ static SIGRETTYPE (*orig_handlers)(int)[NSIG]; static SIGRETTYPE take_signal (int signum) { + int saved_errno = errno; SCM ignored; if (!scm_ints_disabled) { @@ -141,6 +142,7 @@ take_signal (int signum) } #endif scm_system_async_mark (signal_async); + errno = saved_errno; } static SCM diff --git a/libguile/simpos.c b/libguile/simpos.c index b252e8adc..acb8a7b2e 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -105,6 +105,7 @@ scm_getenv(nam) return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; } +/* simple exit, without unwinding the scheme stack or flushing ports. */ SCM_PROC (s_primitive_exit, "primitive-exit", 0, 1, 0, scm_primitive_exit); SCM scm_primitive_exit (SCM status) diff --git a/libguile/socket.c b/libguile/socket.c index d31d59d69..65133462c 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -75,18 +75,10 @@ scm_sock_fd_to_port (fd, proc) const char *proc; { SCM result; - FILE *f; if (fd == -1) scm_syserror (proc); - f = fdopen (fd, "r+"); - if (!f) - { - SCM_SYSCALL (close (fd)); - scm_syserror (proc); - } - result = scm_stdio_to_port (f, "r+0", sym_socket); - scm_setbuf0 (result); + result = scm_fdes_to_port (fd, "r+0", sym_socket); return result; } @@ -104,11 +96,8 @@ scm_socket (family, style, proto) SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket); SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket); SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket); - SCM_DEFER_INTS; fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto)); result = scm_sock_fd_to_port (fd, s_socket); - SCM_SETOR_CAR (result, SCM_NOFTELL); - SCM_ALLOW_INTS; return result; } @@ -134,13 +123,11 @@ scm_socketpair (family, style, proto) fam = SCM_INUM (family); - SCM_DEFER_INTS; if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1) scm_syserror (s_socketpair); a = scm_sock_fd_to_port (fd[0], s_socketpair); b = scm_sock_fd_to_port (fd[1], s_socketpair); - SCM_ALLOW_INTS; return scm_cons (a, b); } #endif @@ -170,12 +157,12 @@ scm_getsockopt (sock, level, optname) #endif sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_getsockopt); SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt); SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); ilevel = SCM_INUM (level); ioptname = SCM_INUM (optname); if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1) @@ -230,11 +217,11 @@ scm_setsockopt (sock, level, optname, value) #endif int ilevel, ioptname; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_setsockopt); SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt); SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); ilevel = SCM_INUM (level); ioptname = SCM_INUM (optname); if (0); @@ -300,11 +287,11 @@ scm_shutdown (sock, how) { int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_shutdown); SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how), how, SCM_ARG2, s_shutdown); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); if (shutdown (fd, SCM_INUM (how)) == -1) scm_syserror (s_shutdown); return SCM_UNSPECIFIED; @@ -386,15 +373,13 @@ scm_connect (sock, fam, address, args) scm_sizet size; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_connect); + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_connect); SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect); - fd = fileno ((FILE *)SCM_STREAM (sock)); - SCM_DEFER_INTS; + fd = SCM_FPORT_FDES (sock); soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size); if (connect (fd, soka, size) == -1) scm_syserror (s_connect); scm_must_free ((char *) soka); - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -413,10 +398,10 @@ scm_bind (sock, fam, address, args) int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_bind); + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_bind); SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind); soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); rv = bind (fd, soka, size); if (rv == -1) scm_syserror (s_bind); @@ -433,9 +418,9 @@ scm_listen (sock, backlog) { int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_listen); + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_listen); SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); if (listen (fd, SCM_INUM (backlog)) == -1) scm_syserror (s_listen); return SCM_UNSPECIFIED; @@ -515,9 +500,8 @@ scm_accept (sock) int tmp_size; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_accept); - fd = fileno ((FILE *)SCM_STREAM (sock)); - SCM_DEFER_INTS; + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_accept); + fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size); newsock = scm_sock_fd_to_port (newfd, s_accept); @@ -526,7 +510,6 @@ scm_accept (sock) else address = SCM_BOOL_F; - SCM_ALLOW_INTS; return scm_cons (newsock, address); } @@ -540,9 +523,8 @@ scm_getsockname (sock) int fd; SCM result; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getsockname); - fd = fileno ((FILE *)SCM_STREAM (sock)); - SCM_DEFER_INTS; + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_getsockname); + fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1) scm_syserror (s_getsockname); @@ -550,7 +532,6 @@ scm_getsockname (sock) result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname); else result = SCM_BOOL_F; - SCM_ALLOW_INTS; return result; } @@ -565,8 +546,7 @@ scm_getpeername (sock) SCM result; sock = SCM_COERCE_OUTPORT (sock); SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername); - fd = fileno ((FILE *)SCM_STREAM (sock)); - SCM_DEFER_INTS; + fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1) scm_syserror (s_getpeername); @@ -574,7 +554,6 @@ scm_getpeername (sock) result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername); else result = SCM_BOOL_F; - SCM_ALLOW_INTS; return result; } @@ -590,10 +569,10 @@ scm_recv (sock, buf, flags) int fd; int flg; - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_recv); + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_recv); SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); if (SCM_UNBNDP (flags)) flg = 0; else @@ -619,10 +598,10 @@ scm_send (sock, message, flags) int flg; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_send); + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_send); SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send); - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); if (SCM_UNBNDP (flags)) flg = 0; else @@ -652,7 +631,7 @@ scm_recvfrom (sock, buf, flags, start, end) int tmp_size; SCM address; - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, + SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_recvfrom); SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom); cend = SCM_LENGTH (buf); @@ -684,7 +663,7 @@ scm_recvfrom (sock, buf, flags, start, end) } } - fd = fileno ((FILE *)SCM_STREAM (sock)); + fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset, @@ -716,14 +695,14 @@ scm_sendto (sock, message, fam, address, args_and_flags) int flg; struct sockaddr *soka; scm_sizet size; + int save_err; sock = SCM_COERCE_OUTPORT (sock); SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto); SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_sendto); SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto); - fd = fileno ((FILE *)SCM_STREAM (sock)); - SCM_DEFER_INTS; + fd = SCM_FPORT_FDES (sock); soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4, s_sendto, &size); if (SCM_NULLP (args_and_flags)) @@ -736,10 +715,11 @@ scm_sendto (sock, message, fam, address, args_and_flags) } SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg, soka, size)); + save_err = errno; + scm_must_free ((char *) soka); + errno = save_err; if (rv == -1) scm_syserror (s_sendto); - scm_must_free ((char *) soka); - SCM_ALLOW_INTS; return SCM_MAKINUM (rv); } diff --git a/libguile/strings.c b/libguile/strings.c index 51b9647d3..358b8ab86 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -173,20 +173,34 @@ scm_makfromstrs (argc, argv) } +/* This function must only be applied to memory obtained via malloc, + since the GC is going to apply `free' to it when the string is + dropped. + Also, s[len] must be `\0', since we promise that strings are + null-terminated. Perhaps we could handle non-null-terminated + strings by claiming they're shared substrings of a string we just + made up. */ SCM -scm_take0str (it) - char * it; +scm_take_str (char *s, int len) { SCM answer; SCM_NEWCELL (answer); SCM_DEFER_INTS; - SCM_SETLENGTH (answer, strlen (it), scm_tc7_string); - SCM_SETCHARS (answer, it); + SCM_SETLENGTH (answer, len, scm_tc7_string); + scm_done_malloc (len + 1); + SCM_SETCHARS (answer, s); SCM_ALLOW_INTS; return answer; } +/* `s' must be a malloc'd string. See scm_take_str. */ +SCM +scm_take0str (char *s) +{ + return scm_take_str (s, strlen (s)); +} + SCM scm_makfromstr (src, len, slots) diff --git a/libguile/strings.h b/libguile/strings.h index 6722ddcdc..5f5334e13 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -67,7 +67,8 @@ extern SCM scm_read_only_string_p SCM_P ((SCM x)); extern SCM scm_string SCM_P ((SCM chrs)); extern SCM scm_makstr SCM_P ((long len, int slots)); extern SCM scm_makfromstrs SCM_P ((int argc, char **argv)); -extern SCM scm_take0str SCM_P ((char * it)); +extern SCM scm_take_str SCM_P ((char *s, int len)); +extern SCM scm_take0str SCM_P ((char *s)); extern SCM scm_makfromstr SCM_P ((const char *src, scm_sizet len, int slots)); extern SCM scm_makfrom0str SCM_P ((const char *src)); extern SCM scm_makfrom0str_opt SCM_P ((const char *src)); diff --git a/libguile/strports.c b/libguile/strports.c index 24c6ceb6f..a234eaa18 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -66,65 +66,46 @@ prinstpt (SCM exp, SCM port, scm_print_state *pstate) return !0; } - -static int -stputc (int c, SCM port) +static int +stfill_buffer (SCM port) { - SCM p = SCM_STREAM (port); - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - SCM_DEFER_INTS; - if (ind >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1))); - SCM_ALLOW_INTS; - SCM_CHARS (SCM_CDR (p))[ind] = c; - SCM_SETCAR (p, SCM_MAKINUM (ind + 1)); - return c; -} + SCM str = SCM_STREAM (port); + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + + pt->read_buf = SCM_ROCHARS (str); + pt->read_buf_size = SCM_ROLENGTH (str); + pt->read_end = pt->read_buf + pt->read_buf_size; - -static scm_sizet -stwrite (char *str, - scm_sizet siz, - scm_sizet num, - SCM port) -{ - SCM p = SCM_STREAM (port); - - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - scm_sizet len = siz * num; - char *dst; - SCM_DEFER_INTS; - if (ind + len >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1))); - SCM_ALLOW_INTS; - dst = &(SCM_CHARS (SCM_CDR (p))[ind]); - while (len--) - dst[len] = str[len]; - SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num)); - return num; -} - - -static int -stputs (char *s, SCM port) -{ - stwrite (s, 1, strlen (s), port); - return 0; -} - - -static int -stgetc (SCM port) -{ - SCM p = SCM_STREAM (port); - - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - if (ind >= SCM_ROLENGTH (SCM_CDR (p))) + if (pt->read_pos >= pt->read_end) return EOF; - SCM_SETCAR (p, SCM_MAKINUM (ind + 1)); - return SCM_ROUCHARS (SCM_CDR (p))[ind]; + else + return scm_return_first (*(pt->read_pos++), port); } +/* not a conventional "flush": it extends the string for more data. */ +static void +st_flush (SCM port) +{ + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + + if (pt->write_pos == pt->write_end) + { + pt->write_buf_size += pt->write_buf_size >> 1; + scm_vector_set_length_x (pt->stream, + SCM_MAKINUM (pt->write_buf_size)); + /* reset buffer in case reallocation moved the string. */ + { + int read = pt->read_pos - pt->read_buf; + int written = pt->write_pos - pt->write_buf; + + pt->read_buf = pt->write_buf = SCM_CHARS (pt->stream); + pt->read_pos = pt->read_buf + read; + pt->write_pos = pt->write_buf + written; + pt->write_end = pt->write_buf + pt->write_buf_size; + pt->read_end = pt->read_buf + pt->read_buf_size; + } + } +} SCM scm_mkstrport (pos, str, modes, caller) @@ -139,13 +120,21 @@ scm_mkstrport (pos, str, modes, caller) SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller); - stream = scm_cons(pos, str); + stream = str; SCM_NEWCELL (z); SCM_DEFER_INTS; pt = scm_add_to_port_table (z); SCM_SETCAR (z, scm_tc16_strport | modes); SCM_SETPTAB_ENTRY (z, pt); SCM_SETSTREAM (z, stream); + pt->write_buf = pt->read_buf = SCM_ROCHARS (str); + pt->write_pos = pt->read_pos = pt->read_buf + SCM_INUM (pos); + pt->read_buf_size = SCM_ROLENGTH (str); + pt->read_end = pt->read_buf + pt->read_buf_size; + /* after the last (normally NUL) character is written to, + the port will be "flushed". */ + pt->write_buf_size = pt->read_buf_size + 1; + pt->write_end = pt->write_buf + pt->write_buf_size; SCM_ALLOW_INTS; return z; } @@ -163,11 +152,11 @@ scm_call_with_output_string (proc) scm_apply (proc, p, scm_listofnull); { SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))), - SCM_INUM (SCM_CAR (SCM_STREAM (p))), + struct scm_port_table *pt = SCM_PTAB_ENTRY (p); + + answer = scm_makfromstr (SCM_CHARS (SCM_STREAM (p)), + pt->write_pos - pt->write_buf, 0); - SCM_ALLOW_INTS; return answer; } } @@ -189,12 +178,12 @@ scm_strprint_obj (obj) port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); scm_prin1 (obj, port, 1); { + struct scm_port_table *pt = SCM_PTAB_ENTRY (obj); SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))), - SCM_INUM (SCM_CAR (SCM_STREAM (port))), + + answer = scm_makfromstr (SCM_CHARS (SCM_STREAM (port)), + pt->write_pos - pt->write_buf, 0); - SCM_ALLOW_INTS; return answer; } } @@ -285,13 +274,11 @@ scm_ptobfuns scm_stptob = noop0, prinstpt, 0, - stputc, - stputs, - stwrite, - noop0, - stgetc, - scm_generic_fgets, - 0 + st_flush, + 0, + stfill_buffer, + 0, + 0, }; diff --git a/libguile/tags.h b/libguile/tags.h index b3aae2cd8..900b228c3 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -364,17 +364,13 @@ typedef long SCM; #define scm_tc7_lsubr 119 -/* There are 256 port subtypes. Here are the first four. +/* There are 256 port subtypes. Here are the first few. * These must agree with the init function in ports.c */ #define scm_tc7_port 125 -/* fports and pipes form an intended TYP16S equivelancy - * group (similar to a tc7 "couple". - */ #define scm_tc16_fport (scm_tc7_port + 0*256L) -#define scm_tc16_pipe (scm_tc7_port + 1*256L) - +/* scm_tc16_pipe was here. */ #define scm_tc16_strport (scm_tc7_port + 2*256L) #define scm_tc16_sfport (scm_tc7_port + 3*256L) diff --git a/libguile/throw.c b/libguile/throw.c index 05d506949..5f886637a 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -527,10 +527,14 @@ scm_handle_by_message (handler_data, tag, args) SCM args; { if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit"))))) - exit (scm_exit_status (args)); + { + exit (scm_exit_status (args)); + } handler_message (handler_data, tag, args); - + /* try to flush the error message first before the rest of the + ports: if any throw error, it currently causes a bus + exception. */ exit (2); } diff --git a/libguile/unif.c b/libguile/unif.c index 8fe0131f4..011c59433 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -44,7 +44,7 @@ #include "_scm.h" #include "chars.h" #include "eval.h" -#include "genio.h" +#include "fports.h" #include "smob.h" #include "strop.h" #include "feature.h" diff --git a/libguile/vports.c b/libguile/vports.c index 3341b5a1a..b3e3c6a35 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -72,71 +72,47 @@ prinsfpt (exp, port, pstate) return !0; } -/* sfputc sfwrite sfputs sfclose - * are called within a SCM_SYSCALL. - * - * So we need to set errno to 0 before returning. sfflush - * may be called within a SCM_SYSCALL. So we need to set errno to 0 - * before returning. - */ - - -static int -sfputc (int c, SCM port) -{ - SCM p = SCM_STREAM (port); - - scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull); - errno = 0; - return c; -} - - -static scm_sizet -sfwrite (char *str, scm_sizet siz, scm_sizet num, SCM port) -{ - SCM p = SCM_STREAM (port); - SCM sstr; - sstr = scm_makfromstr (str, siz * num, 0); - scm_apply (SCM_VELTS (p)[1], sstr, scm_listofnull); - errno = 0; - return num; -} - - -static int -sfputs (char *s, SCM port) -{ - sfwrite (s, 1, strlen (s), port); - return 0; -} - - -static int +/* called with a single char at most. */ +static void sfflush (SCM port) { - SCM stream = SCM_STREAM (port); + struct scm_port_table *pt = SCM_PTAB_ENTRY (port); + SCM stream = pt->stream; - SCM f = SCM_VELTS (stream)[2]; - if (SCM_BOOL_F == f) - return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); - errno = 0; - return SCM_BOOL_F == f ? EOF : 0; + if (pt->write_pos > pt->write_buf) + { + /* write the char. */ + scm_apply (SCM_VELTS (stream)[0], SCM_MAKICHR (*pt->write_buf), + scm_listofnull); + pt->write_pos = pt->write_buf; + + /* flush the output. */ + { + SCM f = SCM_VELTS (stream)[2]; + + if (f != SCM_BOOL_F) + scm_apply (f, SCM_EOL, SCM_EOL); + } + } } +/* string output proc (element 1) is no longer called. */ +/* calling the flush proc (element 2) is in case old code needs it, + but perhaps softports could the use port buffer in the same way as + fports. */ + +/* returns a single character. */ static int -sfgetc (SCM port) +sf_fill_buffer (SCM port) { SCM p = SCM_STREAM (port); - SCM ans; - ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); - errno = 0; + + ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); /* get char. */ if (SCM_FALSEP (ans) || SCM_EOF_OBJECT_P (ans)) return EOF; - SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "getc"); + SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "sf_fill_buffer"); return SCM_ICHR (ans); } @@ -173,6 +149,10 @@ scm_make_soft_port (pv, modes) SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_ROCHARS (modes))); SCM_SETPTAB_ENTRY (z, pt); SCM_SETSTREAM (z, pv); + pt->read_buf = pt->read_pos = pt->read_end = &pt->shortbuf; + pt->write_buf = pt->write_pos = &pt->shortbuf; + pt->read_buf_size = pt->write_buf_size = 1; + pt->write_end = pt->write_buf + pt->write_buf_size; SCM_ALLOW_INTS; return z; } @@ -191,13 +171,11 @@ scm_ptobfuns scm_sfptob = noop0, prinsfpt, 0, - sfputc, - sfputs, - sfwrite, sfflush, - sfgetc, - scm_generic_fgets, - sfclose + sfclose, + sf_fill_buffer, + 0, + 0, };