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

switching to first-class file descriptor type

Browse source
This commit is contained in:
Alex Shinn 2012-04-24 22:42:26 +09:00
parent 94037929be
commit 7c8203ed0a
9 changed files with 148 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
include/chibi/sexp.h
View file

@ -64,8 +64,9 @@ typedef unsigned long size_t;
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <stdarg.h> #include <stdarg.h>
#include <sys/types.h> #include <sys/socket.h>
#include <sys/stat.h> #include <sys/stat.h>
#include <sys/types.h>
#include <math.h> #include <math.h>
#if SEXP_USE_FLONUMS #if SEXP_USE_FLONUMS
#include <float.h> #include <float.h>
@ -132,6 +133,7 @@ enum sexp_types {
#endif #endif
SEXP_IPORT, SEXP_IPORT,
SEXP_OPORT, SEXP_OPORT,
SEXP_FILENO,
SEXP_EXCEPTION, SEXP_EXCEPTION,
SEXP_PROCEDURE, SEXP_PROCEDURE,
SEXP_MACRO, SEXP_MACRO,
@ -327,7 +329,12 @@ struct sexp_struct {
size_t size; size_t size;
sexp name; sexp name;
sexp cookie; sexp cookie;
sexp fd;
} port; } port;
struct {
char openp, socketp, no_closep;
sexp_sint_t fd;
} fileno;
struct { struct {
sexp kind, message, irritants, procedure, source; sexp kind, message, irritants, procedure, source;
} exception; } exception;
@ -618,6 +625,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
#else #else
#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) #define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT))
#endif #endif
#define sexp_filenop(x) (sexp_check_tag(x, SEXP_FILENO))
#if SEXP_USE_BIGNUMS #if SEXP_USE_BIGNUMS
#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) #define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM))
#else #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_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_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_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_numerator(q) (sexp_pred_field(q, ratio, sexp_ratiop, numerator))
#define sexp_ratio_denominator(q) (sexp_pred_field(q, ratio, sexp_ratiop, denominator)) #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_newline(ctx, p) sexp_write_char((ctx), '\n', (p))
#define sexp_at_eofp(p) (feof(sexp_port_stream(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 #if SEXP_USE_TRACK_ALLOC_SOURCE
#define sexp_current_source_param , const char* 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_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_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_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);

2
lib/chibi/accept.c
View file

@ -19,7 +19,7 @@ sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_
} }
} }
#endif #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 */ /* If we're listening on a socket from Scheme, we most likely want it */

2
lib/chibi/filesystem.sld
View file

@ -6,7 +6,7 @@
(define-library (chibi filesystem) (define-library (chibi filesystem)
(export open-input-file-descriptor open-output-file-descriptor (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 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

30
lib/chibi/filesystem.stub
View file

@ -68,17 +68,17 @@
;;> 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")
(int (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")
(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") ;; (define-c input-output-port (open-input-output-file-descriptor "fdopen")
(int (value "r+" string))) ;; (fileno (value "r+" string)))
;;> Unlinks the file named @var{string} from the filesystem. ;;> Unlinks the file named @var{string} from the filesystem.
;;> Returns @scheme{#t} on success and @scheme{#f} on failure. ;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
@ -122,27 +122,27 @@
;;> Duplicates the given file descriptor, returning he new value, ;;> Duplicates the given file descriptor, returning he new value,
;; or -1 on failure. ;; 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 ;;> Copies the first file descriptor to the second, closing
;;> it if needed. ;;> it if needed.
;;> Returns @scheme{#t} on success and @scheme{#f} on failure. ;;> 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. ;;> Closes the given file descriptor.
;;> Returns @scheme{#t} on success and @scheme{#f} on failure. ;;> 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. ;;> 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 ;;> Returns a list of 2 new file descriptors, the input and
;;> output end of a new pipe, respectively. ;;> 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. ;;> Creates a new named pipe in the given path.
;;> Returns @scheme{#t} on success and @scheme{#f} on failure. ;;> 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 errno (make-fifo "mkfifo") (string (default #o644 int)))
(define-c int (get-file-descriptor-flags "fcntl") (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") (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. ;;> Get and set the flags for the given file descriptor.
;;/ ;;/
(define-c int (get-file-descriptor-status "fcntl") (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") (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. ;;> Get and set the status for the given file descriptor.
;;/ ;;/
@ -187,4 +187,4 @@
;;> Returns @scheme{#t} if the given port of file descriptor ;;> Returns @scheme{#t} if the given port of file descriptor
;;> if backed by a TTY object, and @scheme{#f} otherwise. ;;> 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))

12
lib/chibi/net.stub
View file

@ -28,7 +28,7 @@
;;> Bind a name to a socket. ;;> Bind a name to a socket.
(define-c errno bind (int sockaddr int)) (define-c errno bind (fileno sockaddr int))
;;> Listen on a socket. ;;> Listen on a socket.
@ -38,15 +38,15 @@
;;> Accept a connection on a socket. ;;> Accept a connection on a socket.
(define-c sexp (accept "sexp_accept") (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. ;;> 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. ;;> 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/unix "AF_UNIX"))
(define-c-const int (address-family/inet "AF_INET")) (define-c-const int (address-family/inet "AF_INET"))
@ -62,14 +62,14 @@
(c-include "accept.c") (c-include "accept.c")
(define-c errno getsockopt (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 ;;> Set an option for the given socket. For example, to make the
;;> address reusable: ;;> address reusable:
;;> @scheme{(set-socket-option! sock level/socket socket-opt/reuseaddr 1)} ;;> @scheme{(set-socket-option! sock level/socket socket-opt/reuseaddr 1)}
(define-c errno (set-socket-option! "setsockopt") (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")) (define-c-const int (level/socket "SOL_SOCKET"))

6
lib/chibi/stty.stub
View file

@ -18,7 +18,7 @@
(unsigned-short ws_row winsize-row) (unsigned-short ws_row winsize-row)
(unsigned-short ws_col winsize-col)) (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) (define-c-const int TIOCGWINSZ)
@ -101,6 +101,6 @@
;; (define-c-const unsigned-long VSTATUS) ;; (define-c-const unsigned-long VSTATUS)
(define-c errno (get-terminal-attributes "tcgetattr") (define-c errno (get-terminal-attributes "tcgetattr")
(port-or-fd (result termios))) (port-or-fileno (result termios)))
(define-c errno (set-terminal-attributes! "tcsetattr") (define-c errno (set-terminal-attributes! "tcsetattr")
(port-or-fd int termios)) (port-or-fileno int termios))

88
sexp.c
View file

@ -116,17 +116,41 @@ sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp 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)) {
fclose(sexp_port_stream(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)); 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; 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 #if SEXP_USE_AUTOCLOSE_PORTS
#define SEXP_FINALIZE_PORT sexp_finalize_port #define SEXP_FINALIZE_PORT sexp_finalize_port
#define SEXP_FINALIZE_FILENO sexp_finalize_fileno
#else #else
#define SEXP_FINALIZE_PORT NULL #define SEXP_FINALIZE_PORT NULL
#define SEXP_FINALIZE_FILENO NULL
#endif #endif
#if SEXP_USE_DL #if SEXP_USE_DL
@ -165,6 +189,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
#endif #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_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_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_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_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}, {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 #define SEXP_PORT_BUFFER_SIZE 4096
int sexp_buffered_read_char (sexp ctx, sexp p) { int sexp_buffered_read_char (sexp ctx, sexp p) {
int res = 0;
if (sexp_port_offset(p) < sexp_port_size(p)) { if (sexp_port_offset(p) < sexp_port_size(p)) {
return sexp_port_buf(p)[sexp_port_offset(p)++]; return sexp_port_buf(p)[sexp_port_offset(p)++];
} else if (! sexp_port_stream(p)) { } else if (sexp_port_stream(p)) {
return EOF; 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 { } else {
sexp_port_size(p) res = EOF;
= 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);
} }
return res;
} }
int sexp_buffered_write_char (sexp ctx, int c, sexp p) { int sexp_buffered_write_char (sexp ctx, int c, sexp p) {
int res;
if (sexp_port_offset(p)+1 >= sexp_port_size(p)) 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; sexp_port_buf(p)[sexp_port_offset(p)++] = c;
return 0; return 0;
} }
int sexp_buffered_write_string_n (sexp ctx, const char *str, int sexp_buffered_write_string_n (sexp ctx, const char *str,
sexp_uint_t len, sexp p) { sexp_uint_t len, sexp p) {
int diff; int diff, res, written=0;
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_buffered_flush(ctx, p); if ((res = sexp_buffered_flush(ctx, p)))
return written;
written += diff;
str += diff; str += diff;
len -= diff; len -= diff;
} }
@ -1349,16 +1390,19 @@ int sexp_buffered_flush (sexp ctx, sexp 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)); fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p));
res = fflush(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) { } else if (sexp_port_offset(p) > 0) {
sexp_gc_preserve1(ctx, tmp); sexp_gc_preserve1(ctx, tmp);
tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p));
res = 0;
if (tmp && sexp_stringp(tmp)) if (tmp && sexp_stringp(tmp))
sexp_push(ctx, sexp_port_cookie(p), tmp); sexp_push(ctx, sexp_port_cookie(p), tmp);
else else
res = -1; res = -1;
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
} }
sexp_port_offset(p) = 0; if (res == 0) sexp_port_offset(p) = 0;
return res; 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_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;
} }
@ -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_size(res) = SEXP_PORT_BUFFER_SIZE;
sexp_port_offset(res) = 0; sexp_port_offset(res) = 0;
sexp_port_cookie(res) = SEXP_NULL; sexp_port_cookie(res) = SEXP_NULL;
sexp_port_binaryp(res) = 0;
} }
sexp_port_binaryp(res) = 0;
return res; return res;
} }
@ -1414,6 +1459,15 @@ sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
#endif #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 sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT);
if (sexp_exceptionp(p)) return p; 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_line(p) = 1;
sexp_port_flags(p) = SEXP_PORT_UNKNOWN_FLAGS; sexp_port_flags(p) = SEXP_PORT_UNKNOWN_FLAGS;
sexp_port_buf(p) = NULL; sexp_port_buf(p) = NULL;
sexp_port_fd(p) = SEXP_FALSE;
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;
@ -1723,6 +1778,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
sexp_write_char(ctx, ')', out); sexp_write_char(ctx, ')', out);
break; break;
#endif #endif
case SEXP_FILENO:
sexp_write_string(ctx, "#<fileno ", out);
sexp_write(ctx, sexp_make_fixnum(sexp_fileno_fd(obj)), out);
sexp_write_char(ctx, '>', out);
break;
default: default:
i = sexp_pointer_tag(obj); i = sexp_pointer_tag(obj);
if (i < 0 || i >= sexp_context_num_types(ctx)) { if (i < 0 || i >= sexp_context_num_types(ctx)) {

22
tools/chibi-ffi
View file

@ -505,6 +505,7 @@
((eq? base 'input-port) "sexp_iportp") ((eq? base 'input-port) "sexp_iportp")
((eq? base 'output-port) "sexp_oportp") ((eq? base 'output-port) "sexp_oportp")
((eq? base 'input-output-port) "sexp_ioportp") ((eq? base 'input-output-port) "sexp_ioportp")
((eq? base 'fileno) "sexp_filenop")
(else #f)))) (else #f))))
(define (type-name type) (define (type-name type)
@ -530,6 +531,7 @@
((eq? base 'input-port) "SEXP_IPORT") ((eq? base 'input-port) "SEXP_IPORT")
((eq? base 'output-port) "SEXP_OPORT") ((eq? base 'output-port) "SEXP_OPORT")
((eq? base 'input-output-port) "SEXP_IPORT") ((eq? base 'input-output-port) "SEXP_IPORT")
((eq? base 'fileno) "SEXP_FILENO")
((void-pointer-type? type) "SEXP_CPOINTER") ((void-pointer-type? type) "SEXP_CPOINTER")
((lookup-type base) ((lookup-type base)
;; (string-append "sexp_type_tag(" (type-id-name 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)")) (cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)"))
((eq? 'input-output-port base) ((eq? 'input-output-port base)
(cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)")) (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
((eq? 'fileno base)
(cat "sexp_make_fileno(ctx, " val ", 0)"))
(else (else
(let ((ctype (lookup-type base)) (let ((ctype (lookup-type base))
(void*? (void-pointer-type? type))) (void*? (void-pointer-type? type)))
@ -646,11 +650,13 @@
(cat "sexp_concat_env_string(" val ")")) (cat "sexp_concat_env_string(" val ")"))
((string-type? base) ((string-type? base)
(cat "sexp_string_data(" val ")")) (cat "sexp_string_data(" val ")"))
((eq? base 'port-or-fd) ((eq? base 'port-or-fileno)
(cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" (cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")"
" : sexp_unbox_fixnum(" val "))")) " : sexp_fileno_fd(" val "))"))
((port-type? base) ((port-type? base)
(cat "sexp_port_stream(" val ")")) (cat "sexp_port_stream(" val ")"))
((eq? base 'fileno)
(cat "sexp_fileno_fd(" val ")"))
(else (else
(let ((ctype (lookup-type base)) (let ((ctype (lookup-type base))
(void*? (void-pointer-type? type))) (void*? (void-pointer-type? type)))
@ -667,6 +673,7 @@
(define (base-type-c-name base) (define (base-type-c-name base)
(case base (case base
((string env-string non-null-string) (if *c++?* "string" "char*")) ((string env-string non-null-string) (if *c++?* "string" "char*"))
((fileno) "int")
(else (symbol->string base)))) (else (symbol->string base))))
(define (type-struct-type type) (define (type-struct-type type)
@ -705,7 +712,7 @@
(cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg
")) && sexp_stringp(sexp_cdr(" arg ")))")) ")) && sexp_stringp(sexp_cdr(" arg ")))"))
((or (int-type? base) (float-type? base) ((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 ")")) (cat (type-predicate type) "(" arg ")"))
((or (lookup-type base) (void-pointer-type? type)) ((or (lookup-type base) (void-pointer-type? type))
(cat (cat
@ -740,13 +747,14 @@
(cat " if (! sexp_nullp(res))\n" (cat " if (! sexp_nullp(res))\n"
" return sexp_xtype_exception(ctx, self, \"not a list of " " return sexp_xtype_exception(ctx, self, \"not a list of "
(type-name type) "s\", " arg ");\n"))) (type-name type) "s\", " arg ");\n")))
((eq? base-type 'port-or-fd) ((eq? base-type 'port-or-fileno)
(cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" (cat " if (! (sexp_portp(" arg ") || sexp_filenop(" arg ")))\n"
" return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n"))
((or (int-type? base-type) ((or (int-type? base-type)
(float-type? base-type) (float-type? base-type)
(string-type? base-type) (string-type? base-type)
(port-type? base-type)) (port-type? base-type)
(eq? base-type 'fileno))
(cat (cat
" if (! " (lambda () (check-type arg type)) ")\n" " if (! " (lambda () (check-type arg type)) ")\n"
" return sexp_type_exception(ctx, self, " " return sexp_type_exception(ctx, self, "

23
vm.c
View file

@ -1769,6 +1769,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (! sexp_oportp(_ARG2)) if (! sexp_oportp(_ARG2))
sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2));
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
#if SEXP_USE_GREEN_THREADS
errno = 0;
#endif
#if SEXP_USE_UTF8_STRINGS #if SEXP_USE_UTF8_STRINGS
if (sexp_unbox_character(_ARG1) >= 0x80) if (sexp_unbox_character(_ARG1) >= 0x80)
i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); 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); 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)) */
&& (errno == EAGAIN) && (errno == EAGAIN)
&& sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { && 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); sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2);
fuel = 0; fuel = 0;
ip--; /* try again */ ip--; /* try again */
@ -1820,7 +1823,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
#if SEXP_USE_GREEN_THREADS #if SEXP_USE_GREEN_THREADS
if (i) { if (i) {
i = 0; i = 0;
clearerr(sexp_port_stream(_ARG3)); if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG3));
if (errno == EAGAIN) if (errno == EAGAIN)
goto write_string_yield; goto write_string_yield;
} }
@ -1864,6 +1867,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (! sexp_iportp(_ARG1)) if (! sexp_iportp(_ARG1))
sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1));
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
#if SEXP_USE_GREEN_THREADS
errno = 0;
#endif
i = sexp_read_char(ctx, _ARG1); i = sexp_read_char(ctx, _ARG1);
#if SEXP_USE_UTF8_STRINGS #if SEXP_USE_UTF8_STRINGS
if (i >= 0x80) if (i >= 0x80)
@ -1872,10 +1878,10 @@ 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)) */
&& (errno == EAGAIN) && (errno == EAGAIN)
&& sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { && 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); sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1);
fuel = 0; fuel = 0;
ip--; /* try again */ ip--; /* try again */
@ -1891,13 +1897,16 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (! sexp_iportp(_ARG1)) if (! sexp_iportp(_ARG1))
sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1));
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
#if SEXP_USE_GREEN_THREADS
errno = 0;
#endif
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)) */
&& (errno == EAGAIN) && (errno == EAGAIN)
&& sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { && 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); sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1);
fuel = 0; fuel = 0;
ip--; /* try again */ ip--; /* try again */