Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Various fixes for non-string-streams non-blocking i/o.

Browse source 
Moving open-input/output-file-descriptor to core.
This commit is contained in:
Alex Shinn 2012-05-06 14:02:31 +09:00
parent 686b5adcfc
commit cef6bb6794
8 changed files with 164 additions and 109 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
include/chibi/sexp.h
View file

@ -324,7 +324,8 @@ struct sexp_struct {
struct { struct {
FILE *stream; FILE *stream;
char *buf; 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; sexp_uint_t offset, line, flags;
size_t size; size_t size;
sexp name; sexp name;
@ -332,7 +333,7 @@ struct sexp_struct {
sexp fd; sexp fd;
} port; } port;
struct { struct {
char openp, socketp, no_closep; char openp, no_closep;
sexp_sint_t fd; sexp_sint_t fd;
} fileno; } fileno;
struct { 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_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_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_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_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_sourcep(p) (sexp_pred_field(p, port, sexp_portp, sourcep))
#define sexp_port_blockedp(p) (sexp_pred_field(p, port, sexp_portp, blockedp)) #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_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_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(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))) #define sexp_flush(x, p) (fflush(sexp_port_stream(p)))
#else #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_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_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(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))) #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); 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_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_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_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_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_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_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_output_port (sexp ctx, FILE* out, sexp name);
SEXP_API sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, 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_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_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_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_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_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)
#define sexp_length(ctx, x) sexp_length_op(ctx, NULL, 1, x) #define sexp_length(ctx, x) sexp_length_op(ctx, NULL, 1, x)

14
lib/chibi/accept.c
View file

@ -19,20 +19,18 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_
} }
} }
#endif #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 */ /* If we're listening on a socket from Scheme, we most likely want it */
/* to be non-blocking. */ /* 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; int fd, res;
if (! sexp_exact_integerp(arg0)) sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno);
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, backlog);
if (! sexp_exact_integerp(arg1)) fd = sexp_fileno_fd(fileno);
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); res = listen(fd, sexp_unbox_fixnum(backlog));
fd = sexp_sint_value(arg0);
res = listen(fd, sexp_sint_value(arg1));
#if SEXP_USE_GREEN_THREADS #if SEXP_USE_GREEN_THREADS
if (res >= 0) if (res >= 0)
fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK); fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK);

4
lib/chibi/filesystem.sld
View file

@ -5,9 +5,7 @@
;;> objects in a future release. ;;> objects in a future release.
(define-library (chibi filesystem) (define-library (chibi filesystem)
(export open-input-file-descriptor open-output-file-descriptor (export duplicate-file-descriptor duplicate-file-descriptor-to
;; open-input-output-file-descriptor
duplicate-file-descriptor duplicate-file-descriptor-to
close-file-descriptor renumber-file-descriptor close-file-descriptor renumber-file-descriptor
delete-file link-file symbolic-link-file rename-file delete-file link-file symbolic-link-file rename-file
directory-files directory-fold create-directory delete-directory directory-files directory-fold create-directory delete-directory

12
lib/chibi/filesystem.stub
View file

@ -65,15 +65,15 @@
(define-c errno fstat (int (result stat))) (define-c errno fstat (int (result stat)))
(define-c errno (file-link-status "lstat") (string (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") ;; (define-c input-port (open-input-file-descriptor "fdopen")
(fileno (value "r" string))) ;; (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") ;; (define-c output-port (open-output-file-descriptor "fdopen")
(fileno (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}.

32
lib/chibi/net.scm
View file

@ -19,9 +19,9 @@
;;> Opens a client net connection to @var{host}, a string, ;;> Opens a client net connection to @var{host}, a string,
;;> on port @var{service}, which can be a string such as ;;> on port @var{service}, which can be a string such as
;;> @scheme{"http"} or an integer. Returns a list of two ;;> @scheme{"http"} or an integer. Returns a list of three
;;> values on success - an input port and output port - ;;> values on success - the socket, an input port, and an
;;> or @scheme{#f} on failure. ;;> output port - or @scheme{#f} on failure.
(define (open-net-io host service) (define (open-net-io host service)
(let lp ((addr (get-address-info host service))) (let lp ((addr (get-address-info host service)))
@ -42,13 +42,8 @@
(cond-expand (cond-expand
(threads (set-file-descriptor-flags! sock open/non-block)) (threads (set-file-descriptor-flags! sock open/non-block))
(else #f)) (else #f))
(cond-expand (list (open-input-file-descriptor sock #t)
(bidir-ports (open-output-file-descriptor sock #t)))))))))
(let ((port (open-input-output-file-descriptor sock)))
(list port port)))
(else
(list (open-input-file-descriptor sock)
(open-output-file-descriptor sock)))))))))))
;;> Convenience wrapper around @scheme{open-net-io}, opens ;;> Convenience wrapper around @scheme{open-net-io}, opens
;;> the connection then calls @var{proc} with two arguments, ;;> the connection then calls @var{proc} with two arguments,
@ -61,9 +56,10 @@
(let ((io (open-net-io host service))) (let ((io (open-net-io host service)))
(if (not (pair? io)) (if (not (pair? io))
(error "couldn't find address" host service) (error "couldn't find address" host service)
(let ((res (proc (car io) (cadr io)))) (let ((res (proc (cadr io) (caddr io))))
(close-input-port (car io)) (close-input-port (cadr io))
(close-output-port (cadr io)) (close-output-port (caddr io))
(close-file-descriptor (car io))
res)))) res))))
;;> @subsubsubsection{@scheme{(make-listener-socket addrinfo [max-conn])}} ;;> @subsubsubsection{@scheme{(make-listener-socket addrinfo [max-conn])}}
@ -80,18 +76,18 @@
(address-info-socket-type addrinfo) (address-info-socket-type addrinfo)
(address-info-protocol addrinfo)))) (address-info-protocol addrinfo))))
(cond (cond
((negative? sock) ((not sock)
(error "couldn't create socket for: " addrinfo)) (error "couldn't create socket for: " addrinfo))
((not (set-socket-option! sock level/socket socket-opt/reuseaddr 1)) ((not (set-socket-option! sock level/socket socket-opt/reuseaddr 1))
(error "couldn't set the socket to be reusable" addrinfo)) (error "couldn't set the socket to be reusable" addrinfo))
((not (bind sock ((not (bind sock
(address-info-address addrinfo) (address-info-address addrinfo)
(address-info-address-length addrinfo))) (address-info-address-length addrinfo)))
(close-file-descriptor sock) (close-file-descriptor sock)
(error "couldn't bind socket for: " addrinfo)) (error "couldn't bind socket" sock addrinfo))
((not (listen sock max-connections)) ((not (listen sock max-connections))
(close-file-descriptor sock) (close-file-descriptor sock)
(error "couldn't listen on socket for: " addrinfo)) (error "couldn't listen on socket" sock addrinfo))
(else (else
sock)))) sock))))

3
opcodes.c
View file

@ -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, "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, "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, "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 #if SEXP_USE_IMMEDIATE_FLONUMS
_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op),
#else #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), _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_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), _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), _FN2OPT(_I(SEXP_OBJECT), _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), "register-optimization!", _I(600), sexp_register_optimization),
#if SEXP_USE_MATH #if SEXP_USE_MATH
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), _FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp),

132
sexp.c
View file

@ -112,10 +112,13 @@ sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sex
#endif #endif
sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) { sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
sexp res = SEXP_VOID;
if (sexp_port_openp(port)) { if (sexp_port_openp(port)) {
sexp_port_openp(port) = 0; sexp_port_openp(port) = 0;
if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) { if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) {
/* close the stream */
fclose(sexp_port_stream(port)); fclose(sexp_port_stream(port));
/* free the buffer if allocated */
if (sexp_port_buf(port) if (sexp_port_buf(port)
&& (sexp_oportp(port) && (sexp_oportp(port)
#if !SEXP_USE_STRING_STREAMS #if !SEXP_USE_STRING_STREAMS
@ -123,18 +126,23 @@ sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
#endif #endif
)) ))
free(sexp_port_buf(port)); 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) { 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 #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 */ #else /* ! SEXP_USE_STRING_STREAMS */
#define SEXP_PORT_BUFFER_SIZE 4096 #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)) res = ((sexp_port_offset(p) < sexp_port_size(p))
? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); ? 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); res = read(sexp_port_fileno(p), sexp_port_buf(p), SEXP_PORT_BUFFER_SIZE);
if (res >= 0) { if (res >= 0) {
sexp_port_offset(p) = 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)) { while (sexp_port_offset(p)+len >= sexp_port_size(p)) {
diff = sexp_port_size(p) - sexp_port_offset(p); diff = sexp_port_size(p) - sexp_port_offset(p);
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, diff); 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))) if ((res = sexp_buffered_flush(ctx, p)))
return written; return written + diff;
written += diff; written += sexp_port_size(p);
str += diff; str += diff;
len -= diff; len -= diff;
} }
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len);
sexp_port_offset(p) += len; sexp_port_offset(p) += len;
return 0; return written + len;
} }
int sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { 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 sexp_buffered_flush (sexp ctx, sexp p) {
int res; long res = 0, off;
sexp_gc_var1(tmp); sexp_gc_var1(tmp);
if (! (sexp_oportp(p) && sexp_port_openp(p))) if (! (sexp_oportp(p) && sexp_port_openp(p)))
return -1; return -1;
off = sexp_port_offset(p);
if (sexp_port_stream(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)); res = fflush(sexp_port_stream(p));
} else if (sexp_filenop(sexp_port_fd(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)); res = write(sexp_fileno_fd(sexp_port_fd(p)), sexp_port_buf(p), off);
} else if (sexp_port_offset(p) > 0) { if (res < off) {
sexp_gc_preserve1(ctx, tmp); if (res > 0) {
tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); memmove(sexp_port_buf(p), sexp_port_buf(p) + res, off - res);
res = 0; sexp_port_offset(p) = off - res;
if (tmp && sexp_stringp(tmp)) }
sexp_push(ctx, sexp_port_cookie(p), tmp);
else
res = -1; 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); sexp_gc_release1(ctx);
} }
if (res == 0) sexp_port_offset(p) = 0;
return res; 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_offset(res) = 0;
sexp_port_size(res) = sexp_string_length(str); sexp_port_size(res) = sexp_string_length(str);
sexp_port_binaryp(res) = 0; sexp_port_binaryp(res) = 0;
sexp_port_cookie(res) = SEXP_TRUE;
return res; return res;
} }
@ -1446,6 +1488,7 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
} else { } else {
ls = sexp_port_cookie(out); ls = sexp_port_cookie(out);
} }
res = SEXP_FALSE;
for (tmp = ls; sexp_pairp(tmp); tmp = sexp_cdr(tmp)) for (tmp = ls; sexp_pairp(tmp); tmp = sexp_cdr(tmp))
if (!sexp_stringp(sexp_car(tmp))) if (!sexp_stringp(sexp_car(tmp)))
res = sexp_xtype_exception(ctx, self, "not an output string port", out); 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; 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 sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp shutdownp) {
sexp res = sexp_alloc_type(ctx, fileno, SEXP_FILENO); 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)) { if (!sexp_exceptionp(res)) {
sexp_fileno_fd(res) = fd; sexp_fileno_fd(res) = fd;
sexp_fileno_socketp(res) = socketp; sexp_fileno_no_closep(res) = no_closep;
} }
return res; return res;
} }
@ -1480,6 +1551,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
sexp_port_openp(p) = 1; sexp_port_openp(p) = 1;
sexp_port_bidirp(p) = 0; sexp_port_bidirp(p) = 0;
sexp_port_binaryp(p) = 1; sexp_port_binaryp(p) = 1;
sexp_port_shutdownp(p) = 0;
sexp_port_no_closep(p) = 0; sexp_port_no_closep(p) = 0;
sexp_port_sourcep(p) = 0; sexp_port_sourcep(p) = 0;
sexp_port_blockedp(p) = 0; sexp_port_blockedp(p) = 0;

62
vm.c
View file

@ -1780,7 +1780,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
if (i == EOF) { if (i == EOF) {
#if SEXP_USE_GREEN_THREADS #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) && (errno == EAGAIN)
&& sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) {
if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG2)); 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)) if (! sexp_oportp(_ARG3))
sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3)); sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));
sexp_context_top(ctx) = top; 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 SEXP_USE_GREEN_THREADS
if (i) { errno = 0;
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));
#endif #endif
i = sexp_write_string_n(ctx, sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2), _ARG3);
#if SEXP_USE_GREEN_THREADS #if SEXP_USE_GREEN_THREADS
if (i < sexp_unbox_fixnum(_ARG2)) { if (i < sexp_unbox_fixnum(_ARG2)) {
/* modify stack in-place so we continue where we left off next time */ if (sexp_port_stream(_ARG3)) clearerr(sexp_port_stream(_ARG3));
if (i > 0) { /* modify stack in-place so we continue where we left off next time */
if (sexp_stringp(_ARG1)) if (i > 0) {
_ARG1 = sexp_substring(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE); if (sexp_stringp(_ARG1))
else _ARG1 = sexp_substring(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE);
_ARG1 = sexp_subbytes(ctx, _ARG1, sexp_make_fixnum(i), SEXP_FALSE); else
_ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i); _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;
} }
#endif /* yield if threads are enabled (otherwise busy loop) */
} else { /* not a stream-backed string, won't block */ if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) {
if (sexp_bytes_length(tmp1) != sexp_unbox_fixnum(_ARG2)) sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3);
tmp1 = sexp_subbytes(ctx, tmp1, SEXP_ZERO, _ARG2); fuel = 0;
sexp_write_string(ctx, sexp_bytes_data(tmp1), _ARG3); }
i = sexp_unbox_fixnum(_ARG2); ip--; /* try again */
goto loop;
} }
#endif
tmp1 = sexp_make_fixnum(i); /* return the number of bytes written */ tmp1 = sexp_make_fixnum(i); /* return the number of bytes written */
top-=2; top-=2;
_ARG1 = tmp1; _ARG1 = tmp1;
@ -1878,7 +1860,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
#endif #endif
if (i == EOF) { if (i == EOF) {
#if SEXP_USE_GREEN_THREADS #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) && (errno == EAGAIN)
&& sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) {
if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1)); 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); i = sexp_read_char(ctx, _ARG1);
if (i == EOF) { if (i == EOF) {
#if SEXP_USE_GREEN_THREADS #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) && (errno == EAGAIN)
&& sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) {
if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1)); if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));