From cef6bb679464cf7e83527823f77aa2b4a74ec2bf Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 6 May 2012 14:02:31 +0900 Subject: [PATCH] Various fixes for non-string-streams non-blocking i/o. Moving open-input/output-file-descriptor to core. --- include/chibi/sexp.h | 14 ++-- lib/chibi/accept.c | 14 ++-- lib/chibi/filesystem.sld | 4 +- lib/chibi/filesystem.stub | 12 ++-- lib/chibi/net.scm | 32 ++++----- opcodes.c | 3 + sexp.c | 132 +++++++++++++++++++++++++++++--------- vm.c | 62 +++++++----------- 8 files changed, 164 insertions(+), 109 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 68c47be1..1a81cdc4 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -324,7 +324,8 @@ struct sexp_struct { struct { FILE *stream; char *buf; - char openp, bidirp, binaryp, no_closep, sourcep, blockedp, fold_casep; + char openp, bidirp, binaryp, shutdownp, no_closep, sourcep, + blockedp, fold_casep; sexp_uint_t offset, line, flags; size_t size; sexp name; @@ -332,7 +333,7 @@ struct sexp_struct { sexp fd; } port; struct { - char openp, socketp, no_closep; + char openp, no_closep; sexp_sint_t fd; } fileno; struct { @@ -865,6 +866,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_port_openp(p) (sexp_pred_field(p, port, sexp_portp, openp)) #define sexp_port_bidirp(p) (sexp_pred_field(p, port, sexp_portp, bidirp)) #define sexp_port_binaryp(p) (sexp_pred_field(p, port, sexp_portp, binaryp)) +#define sexp_port_shutdownp(p) (sexp_pred_field(p, port, sexp_portp, shutdownp)) #define sexp_port_no_closep(p) (sexp_pred_field(p, port, sexp_portp, no_closep)) #define sexp_port_sourcep(p) (sexp_pred_field(p, port, sexp_portp, sourcep)) #define sexp_port_blockedp(p) (sexp_pred_field(p, port, sexp_portp, blockedp)) @@ -1213,6 +1215,7 @@ enum sexp_context_globals { #define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) #define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) #define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_write_string_n(x, s, n, p) (fwrite(s, 1, n, sexp_port_stream(p))) #define sexp_flush(x, p) (fflush(sexp_port_stream(p))) #else @@ -1221,6 +1224,7 @@ enum sexp_context_globals { #define sexp_push_char(x, c, p) ((c!=EOF) && (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p)))) #define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), 0) : sexp_buffered_write_char(x, c, p)) : putc(c, sexp_port_stream(p))) #define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : fputs(s, sexp_port_stream(p))) +#define sexp_write_string_n(x, s, n, p) (sexp_port_buf(p) ? sexp_buffered_write_string_n(x, s, n, p) : fwrite(s, 1, n, sexp_port_stream(p))) #define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : fflush(sexp_port_stream(p))) SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); @@ -1284,9 +1288,11 @@ SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); SEXP_API sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp writer, sexp out); SEXP_API sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port); -SEXP_API sexp sexp_make_fileno (sexp ctx, int fd, int socketp); +SEXP_API sexp sexp_make_fileno (sexp ctx, int fd, int no_closep); SEXP_API sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name); SEXP_API sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name); +SEXP_API sexp sexp_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp socketp); +SEXP_API sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp socketp); SEXP_API sexp sexp_make_non_null_input_port (sexp ctx, FILE* in, sexp name); SEXP_API sexp sexp_make_non_null_output_port (sexp ctx, FILE* out, sexp name); SEXP_API sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, sexp name); @@ -1386,7 +1392,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj #define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out) #define sexp_display(ctx, obj, out) sexp_display_op(ctx, NULL, 2, obj, out) #define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out) -#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx, NULL, 1, out) +#define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out) #define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b) #define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x) #define sexp_length(ctx, x) sexp_length_op(ctx, NULL, 1, x) diff --git a/lib/chibi/accept.c b/lib/chibi/accept.c index 4b78c7c5..d6970e57 100644 --- a/lib/chibi/accept.c +++ b/lib/chibi/accept.c @@ -19,20 +19,18 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_ } } #endif - return sexp_make_fileno(ctx, res, 1); + return sexp_make_fileno(ctx, res, 0); } /* If we're listening on a socket from Scheme, we most likely want it */ /* to be non-blocking. */ -sexp sexp_listen (sexp ctx, sexp self, sexp arg0, sexp arg1) { +sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) { int fd, res; - if (! sexp_exact_integerp(arg0)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); - if (! sexp_exact_integerp(arg1)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); - fd = sexp_sint_value(arg0); - res = listen(fd, sexp_sint_value(arg1)); + sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, backlog); + fd = sexp_fileno_fd(fileno); + res = listen(fd, sexp_unbox_fixnum(backlog)); #if SEXP_USE_GREEN_THREADS if (res >= 0) fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK); diff --git a/lib/chibi/filesystem.sld b/lib/chibi/filesystem.sld index 57326b7f..894b4048 100644 --- a/lib/chibi/filesystem.sld +++ b/lib/chibi/filesystem.sld @@ -5,9 +5,7 @@ ;;> objects in a future release. (define-library (chibi filesystem) - (export open-input-file-descriptor open-output-file-descriptor - ;; open-input-output-file-descriptor - duplicate-file-descriptor duplicate-file-descriptor-to + (export duplicate-file-descriptor duplicate-file-descriptor-to close-file-descriptor renumber-file-descriptor delete-file link-file symbolic-link-file rename-file directory-files directory-fold create-directory delete-directory diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub index 3d3616e0..906bf317 100644 --- a/lib/chibi/filesystem.stub +++ b/lib/chibi/filesystem.stub @@ -65,15 +65,15 @@ (define-c errno fstat (int (result stat))) (define-c errno (file-link-status "lstat") (string (result stat))) -;;> Creates a new input-port from the file descriptor @var{int}. +;; Creates a new input-port from the file descriptor @var{int}. -(define-c input-port (open-input-file-descriptor "fdopen") - (fileno (value "r" string))) +;; (define-c input-port (open-input-file-descriptor "fdopen") +;; (fileno (value "r" string))) -;;> Creates a new output-port from the file descriptor @var{int}. +;; Creates a new output-port from the file descriptor @var{int}. -(define-c output-port (open-output-file-descriptor "fdopen") - (fileno (value "w" string))) +;; (define-c output-port (open-output-file-descriptor "fdopen") +;; (fileno (value "w" string))) ;; Creates a new bidirectional port from the file descriptor @var{int}. diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm index 22ec51b7..ced9882e 100644 --- a/lib/chibi/net.scm +++ b/lib/chibi/net.scm @@ -19,9 +19,9 @@ ;;> Opens a client net connection to @var{host}, a string, ;;> on port @var{service}, which can be a string such as -;;> @scheme{"http"} or an integer. Returns a list of two -;;> values on success - an input port and output port - -;;> or @scheme{#f} on failure. +;;> @scheme{"http"} or an integer. Returns a list of three +;;> values on success - the socket, an input port, and an +;;> output port - or @scheme{#f} on failure. (define (open-net-io host service) (let lp ((addr (get-address-info host service))) @@ -42,13 +42,8 @@ (cond-expand (threads (set-file-descriptor-flags! sock open/non-block)) (else #f)) - (cond-expand - (bidir-ports - (let ((port (open-input-output-file-descriptor sock))) - (list port port))) - (else - (list (open-input-file-descriptor sock) - (open-output-file-descriptor sock))))))))))) + (list (open-input-file-descriptor sock #t) + (open-output-file-descriptor sock #t))))))))) ;;> Convenience wrapper around @scheme{open-net-io}, opens ;;> the connection then calls @var{proc} with two arguments, @@ -61,9 +56,10 @@ (let ((io (open-net-io host service))) (if (not (pair? io)) (error "couldn't find address" host service) - (let ((res (proc (car io) (cadr io)))) - (close-input-port (car io)) - (close-output-port (cadr io)) + (let ((res (proc (cadr io) (caddr io)))) + (close-input-port (cadr io)) + (close-output-port (caddr io)) + (close-file-descriptor (car io)) res)))) ;;> @subsubsubsection{@scheme{(make-listener-socket addrinfo [max-conn])}} @@ -80,18 +76,18 @@ (address-info-socket-type addrinfo) (address-info-protocol addrinfo)))) (cond - ((negative? sock) + ((not sock) (error "couldn't create socket for: " addrinfo)) ((not (set-socket-option! sock level/socket socket-opt/reuseaddr 1)) (error "couldn't set the socket to be reusable" addrinfo)) ((not (bind sock - (address-info-address addrinfo) - (address-info-address-length addrinfo))) + (address-info-address addrinfo) + (address-info-address-length addrinfo))) (close-file-descriptor sock) - (error "couldn't bind socket for: " addrinfo)) + (error "couldn't bind socket" sock addrinfo)) ((not (listen sock max-connections)) (close-file-descriptor sock) - (error "couldn't listen on socket for: " addrinfo)) + (error "couldn't listen on socket" sock addrinfo)) (else sock)))) diff --git a/opcodes.c b/opcodes.c index 62841a30..dd534919 100644 --- a/opcodes.c +++ b/opcodes.c @@ -90,6 +90,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bytevector?", _I(SEXP_BYTES), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fileno?", _I(SEXP_FILENO), 0), #if SEXP_USE_IMMEDIATE_FLONUMS _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), #else @@ -170,6 +171,8 @@ _FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip _FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), _FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), _FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +_FN2OPT(_I(SEXP_IPORT), _I(SEXP_FIXNUM), _I(SEXP_BOOLEAN), "open-input-file-descriptor", SEXP_FALSE, sexp_open_input_file_descriptor), +_FN2OPT(_I(SEXP_OPORT), _I(SEXP_FIXNUM), _I(SEXP_BOOLEAN), "open-output-file-descriptor", SEXP_FALSE, sexp_open_output_file_descriptor), _FN2OPT(_I(SEXP_OBJECT), _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), "register-optimization!", _I(600), sexp_register_optimization), #if SEXP_USE_MATH _FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), diff --git a/sexp.c b/sexp.c index 9f35c797..7958edd0 100644 --- a/sexp.c +++ b/sexp.c @@ -112,10 +112,13 @@ sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sex #endif sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) { + sexp res = SEXP_VOID; if (sexp_port_openp(port)) { sexp_port_openp(port) = 0; if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) { + /* close the stream */ fclose(sexp_port_stream(port)); + /* free the buffer if allocated */ if (sexp_port_buf(port) && (sexp_oportp(port) #if !SEXP_USE_STRING_STREAMS @@ -123,18 +126,23 @@ sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) { #endif )) free(sexp_port_buf(port)); -#ifndef PLAN9 - } else if (sexp_filenop(sexp_port_fd(port)) - && sexp_fileno_socketp(sexp_port_fd(port)) - && !sexp_fileno_no_closep(sexp_port_fd(port))) { - if (sexp_iportp(port)) - shutdown(sexp_fileno_fd(sexp_port_fd(port)), SHUT_RD); - if (sexp_oportp(port)) - shutdown(sexp_fileno_fd(sexp_port_fd(port)), SHUT_WR); -#endif } +#ifndef PLAN9 + if (sexp_filenop(sexp_port_fd(port)) + && sexp_fileno_openp(sexp_port_fd(port))) { + if (sexp_oportp(port)) res = sexp_flush_output(ctx, port); + if (sexp_exceptionp(res)) return res; + if (sexp_port_shutdownp(port)) { + /* shutdown the socket if requested */ + if (sexp_iportp(port)) + shutdown(sexp_port_fileno(port), sexp_oportp(port) ? SHUT_RDWR : SHUT_RD); + if (sexp_oportp(port)) + shutdown(sexp_port_fileno(port), SHUT_WR); + } + } +#endif } - return SEXP_VOID; + return res; } sexp sexp_finalize_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp fileno) { @@ -1322,6 +1330,28 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) { #endif +sexp sexp_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) { + sexp res; + FILE* in; + sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno); + in = fdopen(sexp_fileno_fd(fileno), "r"); + if (!in) return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open fileno", fileno); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (!sexp_exceptionp(res)) sexp_port_shutdownp(res) = sexp_truep(shutdownp); + return res; +} + +sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) { + sexp res; + FILE* out; + sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno); + out = fdopen(sexp_fileno_fd(fileno), "w"); + if (!out) return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open fileno", fileno); + res = sexp_make_output_port(ctx, out, SEXP_FALSE); + if (!sexp_exceptionp(res)) sexp_port_shutdownp(res) = sexp_truep(shutdownp); + return res; +} + #else /* ! SEXP_USE_STRING_STREAMS */ #define SEXP_PORT_BUFFER_SIZE 4096 @@ -1338,7 +1368,7 @@ int sexp_buffered_read_char (sexp ctx, sexp p) { res = ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); } - } else if (sexp_filenop(sexp_port_fd(p)) && sexp_not(sexp_port_cookie(p))) { + } else if (sexp_filenop(sexp_port_fd(p))) { res = read(sexp_port_fileno(p), sexp_port_buf(p), SEXP_PORT_BUFFER_SIZE); if (res >= 0) { sexp_port_offset(p) = 0; @@ -1367,15 +1397,16 @@ int sexp_buffered_write_string_n (sexp ctx, const char *str, while (sexp_port_offset(p)+len >= sexp_port_size(p)) { diff = sexp_port_size(p) - sexp_port_offset(p); memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, diff); + sexp_port_offset(p) = sexp_port_size(p); if ((res = sexp_buffered_flush(ctx, p))) - return written; - written += diff; + return written + diff; + written += sexp_port_size(p); str += diff; len -= diff; } memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); sexp_port_offset(p) += len; - return 0; + return written + len; } int sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { @@ -1383,26 +1414,38 @@ int sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { } int sexp_buffered_flush (sexp ctx, sexp p) { - int res; + long res = 0, off; sexp_gc_var1(tmp); if (! (sexp_oportp(p) && sexp_port_openp(p))) return -1; + off = sexp_port_offset(p); if (sexp_port_stream(p)) { - fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + if (off > 0) fwrite(sexp_port_buf(p), 1, off, sexp_port_stream(p)); res = fflush(sexp_port_stream(p)); } else if (sexp_filenop(sexp_port_fd(p))) { - res = write(sexp_fileno_fd(sexp_port_fd(p)), sexp_port_buf(p), sexp_port_offset(p)); - } else if (sexp_port_offset(p) > 0) { - sexp_gc_preserve1(ctx, tmp); - tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); - res = 0; - if (tmp && sexp_stringp(tmp)) - sexp_push(ctx, sexp_port_cookie(p), tmp); - else + res = write(sexp_fileno_fd(sexp_port_fd(p)), sexp_port_buf(p), off); + if (res < off) { + if (res > 0) { + memmove(sexp_port_buf(p), sexp_port_buf(p) + res, off - res); + sexp_port_offset(p) = off - res; + } res = -1; + } else { + sexp_port_offset(p) = 0; + res = 0; + } + } else if (sexp_port_offset(p) > 0) { /* string port */ + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), off); + if (tmp && sexp_stringp(tmp)) { + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_port_offset(p) = 0; + res = 0; + } else { + res = -1; + } sexp_gc_release1(ctx); } - if (res == 0) sexp_port_offset(p) = 0; return res; } @@ -1416,7 +1459,6 @@ sexp sexp_make_input_string_port_op (sexp ctx, sexp self, sexp_sint_t n, sexp st sexp_port_offset(res) = 0; sexp_port_size(res) = sexp_string_length(str); sexp_port_binaryp(res) = 0; - sexp_port_cookie(res) = SEXP_TRUE; return res; } @@ -1446,6 +1488,7 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) { } else { ls = sexp_port_cookie(out); } + res = SEXP_FALSE; for (tmp = ls; sexp_pairp(tmp); tmp = sexp_cdr(tmp)) if (!sexp_stringp(sexp_car(tmp))) res = sexp_xtype_exception(ctx, self, "not an output string port", out); @@ -1457,13 +1500,41 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) { return res; } -#endif +sexp sexp_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) { + sexp_gc_var2(res, str); + sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno); + if (sexp_unbox_fixnum(fileno) < 0) + return sexp_user_exception(ctx, self, "invalid file descriptor", fileno); + sexp_gc_preserve2(ctx, res, str); + str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + res = sexp_make_input_string_port(ctx, str); + if (!sexp_exceptionp(res)) { + sexp_port_fd(res) = fileno; + sexp_port_offset(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_shutdownp(res) = sexp_truep(shutdownp); + } + sexp_gc_release2(ctx); + return res; +} -sexp sexp_make_fileno (sexp ctx, int fd, int socketp) { - sexp res = sexp_alloc_type(ctx, fileno, SEXP_FILENO); +sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) { + sexp res = sexp_open_input_file_descriptor(ctx, self, n, fileno, shutdownp); + if (!sexp_exceptionp(res)) { + sexp_pointer_tag(res) = SEXP_OPORT; + sexp_port_offset(res) = 0; + } + return res; +} + +#endif /* ! SEXP_USE_STRING_STREAMS */ + +sexp sexp_make_fileno (sexp ctx, int fd, int no_closep) { + sexp res; + if (fd < 0) return SEXP_FALSE; + res = sexp_alloc_type(ctx, fileno, SEXP_FILENO); if (!sexp_exceptionp(res)) { sexp_fileno_fd(res) = fd; - sexp_fileno_socketp(res) = socketp; + sexp_fileno_no_closep(res) = no_closep; } return res; } @@ -1480,6 +1551,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp_port_openp(p) = 1; sexp_port_bidirp(p) = 0; sexp_port_binaryp(p) = 1; + sexp_port_shutdownp(p) = 0; sexp_port_no_closep(p) = 0; sexp_port_sourcep(p) = 0; sexp_port_blockedp(p) = 0; diff --git a/vm.c b/vm.c index 59a3d76e..a92dd837 100644 --- a/vm.c +++ b/vm.c @@ -1780,7 +1780,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); if (i == EOF) { #if SEXP_USE_GREEN_THREADS - if (sexp_port_stream(_ARG2) /* && ferror(sexp_port_stream(_ARG2)) */ + if ((sexp_port_stream(_ARG2) ? ferror(sexp_port_stream(_ARG2)) : 1) && (errno == EAGAIN) && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG2)); @@ -1817,48 +1817,30 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_oportp(_ARG3)) sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3)); sexp_context_top(ctx) = top; - if (sexp_port_stream(_ARG3) && sexp_port_fileno(_ARG3) >= 0) { - /* first flush anything pending */ - i = fflush(sexp_port_stream(_ARG3)); #if SEXP_USE_GREEN_THREADS - if (i) { - i = 0; - if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG3)); - if (errno == EAGAIN) - goto write_string_yield; - } - errno = 0; - /* fwrite doesn't give reliable counts, use write(2) directly */ - i = write(sexp_port_fileno(_ARG3), sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2)); -#else - i = fwrite(sexp_bytes_data(tmp1), 1, sexp_unbox_fixnum(_ARG2), sexp_port_stream(_ARG3)); + errno = 0; #endif + i = sexp_write_string_n(ctx, sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2), _ARG3); #if SEXP_USE_GREEN_THREADS - if (i < sexp_unbox_fixnum(_ARG2)) { - /* modify stack in-place so we continue where we left off next time */ - if (i > 0) { - if (sexp_stringp(_ARG1)) - _ARG1 = sexp_substring(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE); - else - _ARG1 = sexp_subbytes(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE); - _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i); - } - /* yield if threads are enabled (otherwise busy loop) */ - write_string_yield: - if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { - sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3); - fuel = 0; - } - ip--; /* try again */ - goto loop; + if (i < sexp_unbox_fixnum(_ARG2)) { + if (sexp_port_stream(_ARG3)) clearerr(sexp_port_stream(_ARG3)); + /* modify stack in-place so we continue where we left off next time */ + if (i > 0) { + if (sexp_stringp(_ARG1)) + _ARG1 = sexp_substring(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE); + else + _ARG1 = sexp_subbytes(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE); + _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i); } -#endif - } else { /* not a stream-backed string, won't block */ - if (sexp_bytes_length(tmp1) != sexp_unbox_fixnum(_ARG2)) - tmp1 = sexp_subbytes(ctx, tmp1, SEXP_ZERO, _ARG2); - sexp_write_string(ctx, sexp_bytes_data(tmp1), _ARG3); - i = sexp_unbox_fixnum(_ARG2); + /* yield if threads are enabled (otherwise busy loop) */ + if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { + sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3); + fuel = 0; + } + ip--; /* try again */ + goto loop; } +#endif tmp1 = sexp_make_fixnum(i); /* return the number of bytes written */ top-=2; _ARG1 = tmp1; @@ -1878,7 +1860,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { #endif if (i == EOF) { #if SEXP_USE_GREEN_THREADS - if (sexp_port_stream(_ARG1) /* && ferror(sexp_port_stream(_ARG1)) */ + if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1) && (errno == EAGAIN) && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1)); @@ -1903,7 +1885,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { i = sexp_read_char(ctx, _ARG1); if (i == EOF) { #if SEXP_USE_GREEN_THREADS - if (sexp_port_stream(_ARG1) /* && ferror(sexp_port_stream(_ARG1)) */ + if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1) && (errno == EAGAIN) && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));