From 7c8203ed0a9666bcd9116b010015569b37a577f4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 24 Apr 2012 22:42:26 +0900 Subject: [PATCH] switching to first-class file descriptor type --- include/chibi/sexp.h | 19 ++++++++- lib/chibi/accept.c | 2 +- lib/chibi/filesystem.sld | 2 +- lib/chibi/filesystem.stub | 30 ++++++------- lib/chibi/net.stub | 12 +++--- lib/chibi/stty.stub | 6 +-- sexp.c | 88 ++++++++++++++++++++++++++++++++------- tools/chibi-ffi | 22 ++++++---- vm.c | 23 ++++++---- 9 files changed, 148 insertions(+), 56 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index b464eaaa..68c47be1 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -64,8 +64,9 @@ typedef unsigned long size_t; #include #include #include -#include +#include #include +#include #include #if SEXP_USE_FLONUMS #include @@ -132,6 +133,7 @@ enum sexp_types { #endif SEXP_IPORT, SEXP_OPORT, + SEXP_FILENO, SEXP_EXCEPTION, SEXP_PROCEDURE, SEXP_MACRO, @@ -327,7 +329,12 @@ struct sexp_struct { size_t size; sexp name; sexp cookie; + sexp fd; } port; + struct { + char openp, socketp, no_closep; + sexp_sint_t fd; + } fileno; struct { sexp kind, message, irritants, procedure, source; } exception; @@ -618,6 +625,7 @@ sexp sexp_make_flonum(sexp ctx, double f); #else #define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) #endif +#define sexp_filenop(x) (sexp_check_tag(x, SEXP_FILENO)) #if SEXP_USE_BIGNUMS #define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) #else @@ -866,6 +874,12 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_port_size(p) (sexp_pred_field(p, port, sexp_portp, size)) #define sexp_port_offset(p) (sexp_pred_field(p, port, sexp_portp, offset)) #define sexp_port_flags(p) (sexp_pred_field(p, port, sexp_portp, flags)) +#define sexp_port_fd(p) (sexp_pred_field(p, port, sexp_portp, fd)) + +#define sexp_fileno_fd(f) (sexp_pred_field(f, fileno, sexp_filenop, fd)) +#define sexp_fileno_openp(f) (sexp_pred_field(f, fileno, sexp_filenop, openp)) +#define sexp_fileno_socketp(f) (sexp_pred_field(f, fileno, sexp_filenop, socketp)) +#define sexp_fileno_no_closep(f) (sexp_pred_field(f, fileno, sexp_filenop, no_closep)) #define sexp_ratio_numerator(q) (sexp_pred_field(q, ratio, sexp_ratiop, numerator)) #define sexp_ratio_denominator(q) (sexp_pred_field(q, ratio, sexp_ratiop, denominator)) @@ -1219,7 +1233,7 @@ SEXP_API int sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char((ctx), '\n', (p)) #define sexp_at_eofp(p) (feof(sexp_port_stream(p))) -#define sexp_port_fileno(p) (fileno(sexp_port_stream(p))) +#define sexp_port_fileno(p) (sexp_port_stream(p) ? fileno(sexp_port_stream(p)) : sexp_filenop(sexp_port_fd(p)) ? sexp_fileno_fd(sexp_port_fd(p)) : -1) #if SEXP_USE_TRACK_ALLOC_SOURCE #define sexp_current_source_param , const char* source @@ -1270,6 +1284,7 @@ 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_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_make_non_null_input_port (sexp ctx, FILE* in, sexp name); diff --git a/lib/chibi/accept.c b/lib/chibi/accept.c index 9c8fa646..4b78c7c5 100644 --- a/lib/chibi/accept.c +++ b/lib/chibi/accept.c @@ -19,7 +19,7 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_ } } #endif - return sexp_make_integer(ctx, res); + return sexp_make_fileno(ctx, res, 1); } /* If we're listening on a socket from Scheme, we most likely want it */ diff --git a/lib/chibi/filesystem.sld b/lib/chibi/filesystem.sld index e00ab8cd..57326b7f 100644 --- a/lib/chibi/filesystem.sld +++ b/lib/chibi/filesystem.sld @@ -6,7 +6,7 @@ (define-library (chibi filesystem) (export open-input-file-descriptor open-output-file-descriptor - open-input-output-file-descriptor + ;; open-input-output-file-descriptor duplicate-file-descriptor duplicate-file-descriptor-to close-file-descriptor renumber-file-descriptor delete-file link-file symbolic-link-file rename-file diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub index c90ab69f..3d3616e0 100644 --- a/lib/chibi/filesystem.stub +++ b/lib/chibi/filesystem.stub @@ -68,17 +68,17 @@ ;;> Creates a new input-port from the file descriptor @var{int}. (define-c input-port (open-input-file-descriptor "fdopen") - (int (value "r" string))) + (fileno (value "r" string))) ;;> Creates a new output-port from the file descriptor @var{int}. (define-c output-port (open-output-file-descriptor "fdopen") - (int (value "w" string))) + (fileno (value "w" string))) -;;> Creates a new bidirectional port from the file descriptor @var{int}. +;; Creates a new bidirectional port from the file descriptor @var{int}. -(define-c input-output-port (open-input-output-file-descriptor "fdopen") - (int (value "r+" string))) +;; (define-c input-output-port (open-input-output-file-descriptor "fdopen") +;; (fileno (value "r+" string))) ;;> Unlinks the file named @var{string} from the filesystem. ;;> Returns @scheme{#t} on success and @scheme{#f} on failure. @@ -122,27 +122,27 @@ ;;> Duplicates the given file descriptor, returning he new value, ;; or -1 on failure. -(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c fileno (duplicate-file-descriptor "dup") (fileno)) ;;> Copies the first file descriptor to the second, closing ;;> it if needed. ;;> Returns @scheme{#t} on success and @scheme{#f} on failure. -(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (fileno fileno)) ;;> Closes the given file descriptor. ;;> Returns @scheme{#t} on success and @scheme{#f} on failure. -(define-c errno (close-file-descriptor "close") (int)) +(define-c errno (close-file-descriptor "close") (fileno)) ;;> Opens the given file and returns a file descriptor. -(define-c int open (string int (default #o644 int))) +(define-c fileno open (string int (default #o644 int))) ;;> Returns a list of 2 new file descriptors, the input and ;;> output end of a new pipe, respectively. -(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (open-pipe "pipe") ((result (array fileno 2)))) ;;> Creates a new named pipe in the given path. ;;> Returns @scheme{#t} on success and @scheme{#f} on failure. @@ -150,17 +150,17 @@ (define-c errno (make-fifo "mkfifo") (string (default #o644 int))) (define-c int (get-file-descriptor-flags "fcntl") - (int (value F_GETFD int))) + (fileno (value F_GETFD int))) (define-c errno (set-file-descriptor-flags! "fcntl") - (int (value F_SETFD int) long)) + (fileno (value F_SETFD int) long)) ;;> Get and set the flags for the given file descriptor. ;;/ (define-c int (get-file-descriptor-status "fcntl") - (int (value F_GETFL int))) + (fileno (value F_GETFL int))) (define-c errno (set-file-descriptor-status! "fcntl") - (int (value F_SETFL int) long)) + (fileno (value F_SETFL int) long)) ;;> Get and set the status for the given file descriptor. ;;/ @@ -187,4 +187,4 @@ ;;> Returns @scheme{#t} if the given port of file descriptor ;;> if backed by a TTY object, and @scheme{#f} otherwise. -(define-c boolean (is-a-tty? "isatty") (port-or-fd)) +(define-c boolean (is-a-tty? "isatty") (port-or-fileno)) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub index c2385230..b5cda7d9 100644 --- a/lib/chibi/net.stub +++ b/lib/chibi/net.stub @@ -28,7 +28,7 @@ ;;> Bind a name to a socket. -(define-c errno bind (int sockaddr int)) +(define-c errno bind (fileno sockaddr int)) ;;> Listen on a socket. @@ -38,15 +38,15 @@ ;;> Accept a connection on a socket. (define-c sexp (accept "sexp_accept") - ((value ctx sexp) (value self sexp) int sockaddr int)) + ((value ctx sexp) (value self sexp) fileno sockaddr int)) ;;> Create an endpoint for communication. -(define-c int socket (int int int)) +(define-c fileno socket (int int int)) ;;> Initiate a connection on a socket. -(define-c int connect (int sockaddr int)) +(define-c int connect (fileno sockaddr int)) (define-c-const int (address-family/unix "AF_UNIX")) (define-c-const int (address-family/inet "AF_INET")) @@ -62,14 +62,14 @@ (c-include "accept.c") (define-c errno getsockopt - (int int int (result int) (result (value (sizeof int) socklen_t)))) + (fileno int int (result int) (result (value (sizeof int) socklen_t)))) ;;> Set an option for the given socket. For example, to make the ;;> address reusable: ;;> @scheme{(set-socket-option! sock level/socket socket-opt/reuseaddr 1)} (define-c errno (set-socket-option! "setsockopt") - (int int int (pointer int) (value (sizeof int) socklen_t))) + (fileno int int (pointer int) (value (sizeof int) socklen_t))) (define-c-const int (level/socket "SOL_SOCKET")) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub index d51d3e9e..09d3fe36 100644 --- a/lib/chibi/stty.stub +++ b/lib/chibi/stty.stub @@ -18,7 +18,7 @@ (unsigned-short ws_row winsize-row) (unsigned-short ws_col winsize-col)) -(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) +(define-c errno ioctl (port-or-fileno unsigned-long (result winsize))) (define-c-const int TIOCGWINSZ) @@ -101,6 +101,6 @@ ;; (define-c-const unsigned-long VSTATUS) (define-c errno (get-terminal-attributes "tcgetattr") - (port-or-fd (result termios))) + (port-or-fileno (result termios))) (define-c errno (set-terminal-attributes! "tcsetattr") - (port-or-fd int termios)) + (port-or-fileno int termios)) diff --git a/sexp.c b/sexp.c index 70f50bd0..9f35c797 100644 --- a/sexp.c +++ b/sexp.c @@ -116,17 +116,41 @@ sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) { sexp_port_openp(port) = 0; if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) { fclose(sexp_port_stream(port)); - if (sexp_port_buf(port) && sexp_oportp(port)) + if (sexp_port_buf(port) + && (sexp_oportp(port) +#if !SEXP_USE_STRING_STREAMS + || (sexp_iportp(port) && sexp_truep(sexp_port_cookie(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 } } return SEXP_VOID; } +sexp sexp_finalize_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp fileno) { + if (sexp_fileno_openp(fileno) && !sexp_fileno_no_closep(fileno)) { + sexp_fileno_openp(fileno) = 0; + close(sexp_fileno_fd(fileno)); + } + return SEXP_VOID; +} + #if SEXP_USE_AUTOCLOSE_PORTS #define SEXP_FINALIZE_PORT sexp_finalize_port +#define SEXP_FINALIZE_FILENO sexp_finalize_fileno #else #define SEXP_FINALIZE_PORT NULL +#define SEXP_FINALIZE_FILENO NULL #endif #if SEXP_USE_DL @@ -165,6 +189,7 @@ static struct sexp_type_struct _sexp_type_specs[] = { #endif {SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_PORT}, {SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_PORT}, + {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_FILENO}, {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL}, {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, @@ -1302,33 +1327,49 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) { #define SEXP_PORT_BUFFER_SIZE 4096 int sexp_buffered_read_char (sexp ctx, sexp p) { + int res = 0; if (sexp_port_offset(p) < sexp_port_size(p)) { return sexp_port_buf(p)[sexp_port_offset(p)++]; - } else if (! sexp_port_stream(p)) { - return EOF; + } else if (sexp_port_stream(p)) { + res = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p)); + if (res >= 0) { + sexp_port_offset(p) = 0; + sexp_port_size(p) = res; + 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))) { + res = read(sexp_port_fileno(p), sexp_port_buf(p), SEXP_PORT_BUFFER_SIZE); + if (res >= 0) { + sexp_port_offset(p) = 0; + sexp_port_size(p) = res; + res = ((sexp_port_offset(p) < sexp_port_size(p)) + ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); + } } else { - sexp_port_size(p) - = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p)); - sexp_port_offset(p) = 0; - return ((sexp_port_offset(p) < sexp_port_size(p)) - ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); + res = EOF; } + return res; } int sexp_buffered_write_char (sexp ctx, int c, sexp p) { + int res; if (sexp_port_offset(p)+1 >= sexp_port_size(p)) - sexp_buffered_flush(ctx, p); + if ((res = sexp_buffered_flush(ctx, p))) + return res; sexp_port_buf(p)[sexp_port_offset(p)++] = c; return 0; } int sexp_buffered_write_string_n (sexp ctx, const char *str, - sexp_uint_t len, sexp p) { - int diff; + sexp_uint_t len, sexp p) { + int diff, res, written=0; 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_buffered_flush(ctx, p); + if ((res = sexp_buffered_flush(ctx, p))) + return written; + written += diff; str += diff; len -= diff; } @@ -1349,16 +1390,19 @@ int sexp_buffered_flush (sexp ctx, sexp p) { if (sexp_port_stream(p)) { fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), 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 = -1; sexp_gc_release1(ctx); } - sexp_port_offset(p) = 0; + if (res == 0) sexp_port_offset(p) = 0; return res; } @@ -1372,6 +1416,7 @@ 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; } @@ -1385,8 +1430,8 @@ sexp sexp_make_output_string_port_op (sexp ctx, sexp self, sexp_sint_t n) { sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; sexp_port_offset(res) = 0; sexp_port_cookie(res) = SEXP_NULL; + sexp_port_binaryp(res) = 0; } - sexp_port_binaryp(res) = 0; return res; } @@ -1414,6 +1459,15 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) { #endif +sexp sexp_make_fileno (sexp ctx, int fd, int socketp) { + sexp res = sexp_alloc_type(ctx, fileno, SEXP_FILENO); + if (!sexp_exceptionp(res)) { + sexp_fileno_fd(res) = fd; + sexp_fileno_socketp(res) = socketp; + } + return res; +} + sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); if (sexp_exceptionp(p)) return p; @@ -1422,6 +1476,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp_port_line(p) = 1; sexp_port_flags(p) = SEXP_PORT_UNKNOWN_FLAGS; sexp_port_buf(p) = NULL; + sexp_port_fd(p) = SEXP_FALSE; sexp_port_openp(p) = 1; sexp_port_bidirp(p) = 0; sexp_port_binaryp(p) = 1; @@ -1723,6 +1778,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { sexp_write_char(ctx, ')', out); break; #endif + case SEXP_FILENO: + sexp_write_string(ctx, "#', out); + break; default: i = sexp_pointer_tag(obj); if (i < 0 || i >= sexp_context_num_types(ctx)) { diff --git a/tools/chibi-ffi b/tools/chibi-ffi index 26a0e942..ebd356b6 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -505,6 +505,7 @@ ((eq? base 'input-port) "sexp_iportp") ((eq? base 'output-port) "sexp_oportp") ((eq? base 'input-output-port) "sexp_ioportp") + ((eq? base 'fileno) "sexp_filenop") (else #f)))) (define (type-name type) @@ -530,6 +531,7 @@ ((eq? base 'input-port) "SEXP_IPORT") ((eq? base 'output-port) "SEXP_OPORT") ((eq? base 'input-output-port) "SEXP_IPORT") + ((eq? base 'fileno) "SEXP_FILENO") ((void-pointer-type? type) "SEXP_CPOINTER") ((lookup-type base) ;; (string-append "sexp_type_tag(" (type-id-name base) ")") @@ -604,6 +606,8 @@ (cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)")) ((eq? 'input-output-port base) (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'fileno base) + (cat "sexp_make_fileno(ctx, " val ", 0)")) (else (let ((ctype (lookup-type base)) (void*? (void-pointer-type? type))) @@ -646,11 +650,13 @@ (cat "sexp_concat_env_string(" val ")")) ((string-type? base) (cat "sexp_string_data(" val ")")) - ((eq? base 'port-or-fd) - (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" - " : sexp_unbox_fixnum(" val "))")) + ((eq? base 'port-or-fileno) + (cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")" + " : sexp_fileno_fd(" val "))")) ((port-type? base) (cat "sexp_port_stream(" val ")")) + ((eq? base 'fileno) + (cat "sexp_fileno_fd(" val ")")) (else (let ((ctype (lookup-type base)) (void*? (void-pointer-type? type))) @@ -667,6 +673,7 @@ (define (base-type-c-name base) (case base ((string env-string non-null-string) (if *c++?* "string" "char*")) + ((fileno) "int") (else (symbol->string base)))) (define (type-struct-type type) @@ -705,7 +712,7 @@ (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg ")) && sexp_stringp(sexp_cdr(" arg ")))")) ((or (int-type? base) (float-type? base) - (string-type? base) (port-type? base)) + (string-type? base) (port-type? base) (eq? base 'fileno)) (cat (type-predicate type) "(" arg ")")) ((or (lookup-type base) (void-pointer-type? type)) (cat @@ -740,13 +747,14 @@ (cat " if (! sexp_nullp(res))\n" " return sexp_xtype_exception(ctx, self, \"not a list of " (type-name type) "s\", " arg ");\n"))) - ((eq? base-type 'port-or-fd) - (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + ((eq? base-type 'port-or-fileno) + (cat " if (! (sexp_portp(" arg ") || sexp_filenop(" arg ")))\n" " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) ((or (int-type? base-type) (float-type? base-type) (string-type? base-type) - (port-type? base-type)) + (port-type? base-type) + (eq? base-type 'fileno)) (cat " if (! " (lambda () (check-type arg type)) ")\n" " return sexp_type_exception(ctx, self, " diff --git a/vm.c b/vm.c index a5d98328..59a3d76e 100644 --- a/vm.c +++ b/vm.c @@ -1769,6 +1769,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_oportp(_ARG2)) sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); sexp_context_top(ctx) = top; +#if SEXP_USE_GREEN_THREADS + errno = 0; +#endif #if SEXP_USE_UTF8_STRINGS if (sexp_unbox_character(_ARG1) >= 0x80) i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); @@ -1777,10 +1780,10 @@ 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)) */ && (errno == EAGAIN) && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { - clearerr(sexp_port_stream(_ARG2)); + if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG2)); sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2); fuel = 0; ip--; /* try again */ @@ -1820,7 +1823,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { #if SEXP_USE_GREEN_THREADS if (i) { i = 0; - clearerr(sexp_port_stream(_ARG3)); + if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG3)); if (errno == EAGAIN) goto write_string_yield; } @@ -1864,6 +1867,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_iportp(_ARG1)) sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); sexp_context_top(ctx) = top; +#if SEXP_USE_GREEN_THREADS + errno = 0; +#endif i = sexp_read_char(ctx, _ARG1); #if SEXP_USE_UTF8_STRINGS if (i >= 0x80) @@ -1872,10 +1878,10 @@ 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)) */ && (errno == EAGAIN) && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { - clearerr(sexp_port_stream(_ARG1)); + if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1)); sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1); fuel = 0; ip--; /* try again */ @@ -1891,13 +1897,16 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_iportp(_ARG1)) sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); sexp_context_top(ctx) = top; +#if SEXP_USE_GREEN_THREADS + errno = 0; +#endif 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)) */ && (errno == EAGAIN) && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { - clearerr(sexp_port_stream(_ARG1)); + if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1)); sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1); fuel = 0; ip--; /* try again */