diff --git a/eval.c b/eval.c index e4dd8bd5..63a26956 100644 --- a/eval.c +++ b/eval.c @@ -1039,6 +1039,9 @@ sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) { } while (!out && sexp_out_of_file_descriptors() && !count++); if (!out) return sexp_user_exception(ctx, self, "couldn't open output file", path); +#if SEXP_USE_GREEN_THREADS + fcntl(fileno(out), F_SETFL, O_NONBLOCK); +#endif return sexp_make_output_port(ctx, out, path); } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index bd6af2e8..00a7da49 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1297,7 +1297,7 @@ SEXP_API void sexp_init(void); SEXP_API sexp sexp_string_index_to_offset (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp index); SEXP_API sexp sexp_utf8_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); SEXP_API void sexp_utf8_encode_char (unsigned char* p, int len, int c); -SEXP_API void sexp_write_utf8_char (sexp ctx, int c, sexp out); +SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out); #endif #if SEXP_USE_GREEN_THREADS @@ -1474,7 +1474,7 @@ enum sexp_opcode_names { SEXP_OP_CHAR_UPCASE, SEXP_OP_CHAR_DOWNCASE, SEXP_OP_WRITE_CHAR, - SEXP_OP_NEWLINE, + SEXP_OP_WRITE_STRING, SEXP_OP_READ_CHAR, SEXP_OP_PEEK_CHAR, SEXP_OP_YIELD, diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index b019a232..7c538b2f 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -34,7 +34,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { if (sexp_procedurep(bc)) { bc = sexp_procedure_code(bc); } else if (sexp_opcodep(bc)) { - sexp_display(ctx, sexp_opcode_name(bc), out); + sexp_write(ctx, sexp_opcode_name(bc), out); sexp_write_string(ctx, " is a primitive\n", out); return SEXP_VOID; } else if (! sexp_bytecodep(bc)) { @@ -138,7 +138,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_FCALL4: sexp_write_pointer(ctx, ((sexp*)ip)[0], out); sexp_write_char(ctx, ' ', out); - sexp_display(ctx, sexp_opcode_name(((sexp*)ip)[0]), out); + sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out); ip += sizeof(sexp); break; case SEXP_OP_SLOT_REF: diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index ded708bb..af873ce2 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -41,7 +41,7 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { } else { print_name: sexp_write_string(ctx, "#<", out); - sexp_display(ctx, sexp_object_type_name(ctx, x), out); + sexp_write(ctx, sexp_object_type_name(ctx, x), out); sexp_write_string(ctx, ">", out); } } diff --git a/lib/chibi/io.sld b/lib/chibi/io.sld index d8fc87eb..ab53e3c2 100644 --- a/lib/chibi/io.sld +++ b/lib/chibi/io.sld @@ -1,6 +1,6 @@ (define-library (chibi io) - (export read-string read-string! write-string read-line write-line + (export read-string read-string! read-line write-line port-fold port-fold-right port-map port->list port->string-list port->sexp-list port->string file-position set-file-position! seek/set seek/cur seek/end diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub index 629d02c0..f26040d5 100644 --- a/lib/chibi/io/io.stub +++ b/lib/chibi/io/io.stub @@ -10,8 +10,7 @@ (define-c size_t (%read-string! "fread") (string (value 1 size_t) size_t (default (current-input-port) input-port))) - (define-c size_t (write-string "fwrite") - (string (value 1 size_t) size_t (default (current-output-port) output-port))))) + )) (define-c-const int (seek/set "SEEK_SET")) (define-c-const int (seek/cur "SEEK_CUR")) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c index c294d4b1..981f633b 100644 --- a/lib/chibi/io/port.c +++ b/lib/chibi/io/port.c @@ -302,7 +302,8 @@ sexp sexp_write_u8 (sexp ctx, sexp self, sexp u8, sexp out) { sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); if (!sexp_port_binaryp(out)) return sexp_xtype_exception(ctx, self, "not a binary port", out); - sexp_write_char(ctx, sexp_unbox_fixnum(u8), out); + if (sexp_write_char(ctx, sexp_unbox_fixnum(u8), out) == EOF) + return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR); return SEXP_VOID; } diff --git a/lib/init-7.scm b/lib/init-7.scm index 13d2e465..89d97a46 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -479,6 +479,15 @@ ;; I/O utils +(define (display x . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (cond ((char? x) (write-char x out)) + ((string? x) (write-string x #t out)) + (else (write x out))))) + +(define (newline . o) + (write-char #\newline (if (pair? o) (car o) (current-output-port)))) + (define (port? x) (or (input-port? x) (output-port? x))) (define textual-port? port?) diff --git a/main.c b/main.c index 9c5109b9..510eadbe 100644 --- a/main.c +++ b/main.c @@ -255,6 +255,10 @@ static sexp sexp_load_standard_params (sexp ctx, sexp e) { #if SEXP_USE_GREEN_THREADS p = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)); if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1); + p = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)); + if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1); + p = sexp_param_ref(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); + if (sexp_portp(p)) sexp_maybe_block_port(ctx, p, 1); #endif res = sexp_make_env(ctx); sexp_env_parent(res) = e; diff --git a/opcodes.c b/opcodes.c index 32e35a5a..0bcd3cd0 100644 --- a/opcodes.c +++ b/opcodes.c @@ -117,19 +117,17 @@ _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), #if SEXP_USE_NATIVE_X86 _FN2OPTP(SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), "write-char", (sexp)"current-output-port", sexp_write_char_op), -_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "newline", (sexp)"current-output-port", sexp_newline_op), _FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "read-char", (sexp)"current-input-port", sexp_read_char_op), _FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "peek-char", (sexp)"current-input-port", sexp_peek_char_op), _FN5(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "five", 0, sexp_five), #else _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"current-output-port", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"current-output-port", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_STRING, 2, 3, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_OPORT), 0, "write-string", (sexp)"current-output-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"current-input-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"current-input-port", NULL), #endif _FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"current-input-port", sexp_read_op), _FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"current-output-port", sexp_write_op), -_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"current-output-port", sexp_display_op), _FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"current-output-port", sexp_flush_output_op), _FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), _FN3(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?/bounded", 0, sexp_equalp_bound), diff --git a/opt/opcode_names.h b/opt/opcode_names.h index 27b9baca..1f01044f 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -17,6 +17,6 @@ static const char* reverse_opcode_names[] = "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", - "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "WRITE-CHAR", "WRITE-STRING", "READ-CHAR", "PEEK-CHAR", "YIELD", "FORCE", "RET", "DONE", }; diff --git a/sexp.c b/sexp.c index 3aea0479..3fa3b9e8 100644 --- a/sexp.c +++ b/sexp.c @@ -563,7 +563,7 @@ sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp } } else if (sexp_opcodep(sexp_exception_procedure(exn))) { sexp_write_string(ctx, " in ", out); - sexp_display(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + sexp_write(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); } } ls = sexp_exception_source(exn); @@ -1467,6 +1467,54 @@ sexp sexp_set_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in, sexp } #endif +#if SEXP_USE_GREEN_THREADS +int sexp_maybe_block_port (sexp ctx, sexp in, int forcep) { + sexp f; + int c; + if (sexp_port_stream(in) && sexp_port_fileno(in) >= 0) { + if (sexp_port_flags(in) == SEXP_PORT_UNKNOWN_FLAGS) + sexp_port_flags(in) = fcntl(sexp_port_fileno(in), F_GETFL); + if (sexp_port_flags(in) & O_NONBLOCK) { + if (!forcep + && (((c = sexp_read_char(ctx, in)) == EOF) + && sexp_port_stream(in) + && ferror(sexp_port_stream(in)) && (errno == EAGAIN))) { + clearerr(sexp_port_stream(in)); + f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER); + if (sexp_opcodep(f)) { + ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, in); + return 1; + } + } + if (!forcep) sexp_push_char(ctx, c, in); + sexp_port_blockedp(in) = 1; + fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in) & ~O_NONBLOCK); + } + } + return 0; +} + +int sexp_maybe_block_output_port (sexp ctx, sexp out) { + if (sexp_port_stream(out) && sexp_port_fileno(out) >= 0) { + if (sexp_port_flags(out) == SEXP_PORT_UNKNOWN_FLAGS) + sexp_port_flags(out) = fcntl(sexp_port_fileno(out), F_GETFL); + if (sexp_port_flags(out) & O_NONBLOCK) { + sexp_port_blockedp(out) = 1; + fcntl(sexp_port_fileno(out), F_SETFL, sexp_port_flags(out) & ~O_NONBLOCK); + return 1; + } + } + return 0; +} + +void sexp_maybe_unblock_port (sexp ctx, sexp port) { + if (sexp_port_blockedp(port)) { + sexp_port_blockedp(port) = 0; + fcntl(sexp_port_fileno(port), F_SETFL, sexp_port_flags(port)); + } +} +#endif + #define NUMBUF_LEN 32 static struct {const char* name; char ch;} sexp_char_names[] = { @@ -1568,7 +1616,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { break; case SEXP_TYPE: sexp_write_string(ctx, "#", out); break; case SEXP_STRING: @@ -1635,7 +1683,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { #endif case SEXP_OPCODE: sexp_write_string(ctx, "#', out); break; #if SEXP_USE_BYTEVECTOR_LITERALS @@ -1665,7 +1713,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } else { #endif sexp_write_string(ctx, "#<", out); - sexp_display(ctx, sexp_type_name(x), out); + sexp_write(ctx, sexp_type_name(x), out); sexp_write_char(ctx, '>', out); #if SEXP_USE_TYPE_PRINTERS } @@ -1755,36 +1803,27 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out) { + sexp res; sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); - return sexp_write_one(ctx, obj, out); -} - -#if SEXP_USE_UTF8_STRINGS -void sexp_write_utf8_char (sexp ctx, int c, sexp out) { - unsigned char buf[8]; - int len = sexp_utf8_char_byte_count(c); - sexp_utf8_encode_char(buf, len, c); - buf[len] = 0; - sexp_write_string(ctx, (char*)buf, out); -} -#endif - -sexp sexp_display_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out) { - sexp res=SEXP_VOID; - sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); - if (sexp_stringp(obj)) - sexp_write_string(ctx, sexp_string_data(obj), out); - else if (sexp_charp(obj)) -#if SEXP_USE_UTF8_STRINGS - sexp_write_utf8_char(ctx, sexp_unbox_character(obj), out); -#else - sexp_write_char(ctx, sexp_unbox_character(obj), out); -#endif - else - res = sexp_write_one(ctx, obj, out); + sexp_maybe_block_output_port(ctx, out); + res = sexp_write_one(ctx, obj, out); + sexp_maybe_unblock_port(ctx, out); return res; } +#if SEXP_USE_UTF8_STRINGS +int sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c), i; + sexp_utf8_encode_char(buf, len, c); + buf[len] = 0; + i = sexp_write_char(ctx, buf[0], out); + if (i == EOF) return EOF; + sexp_write_string(ctx, (char*)buf+1, out); + return len; +} +#endif + sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) { sexp_flush(ctx, out); return SEXP_VOID; @@ -2166,41 +2205,6 @@ static int sexp_decode_utf8_char(const unsigned char* s) { } #endif -#if SEXP_USE_GREEN_THREADS -int sexp_maybe_block_port (sexp ctx, sexp in, int forcep) { - sexp f; - int c; - if (sexp_port_stream(in) && sexp_port_fileno(in) >= 0) { - if (sexp_port_flags(in) == SEXP_PORT_UNKNOWN_FLAGS) - sexp_port_flags(in) = fcntl(sexp_port_fileno(in), F_GETFL); - if (sexp_port_flags(in) & O_NONBLOCK) { - if (!forcep - && (((c = sexp_read_char(ctx, in)) == EOF) - && sexp_port_stream(in) - && ferror(sexp_port_stream(in)) && (errno == EAGAIN))) { - clearerr(sexp_port_stream(in)); - f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER); - if (sexp_opcodep(f)) { - ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, in); - return 1; - } - } - if (!forcep) sexp_push_char(ctx, c, in); - sexp_port_blockedp(in) = 1; - fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in) & ~O_NONBLOCK); - } - } - return 0; -} - -void sexp_maybe_unblock_port (sexp ctx, sexp in) { - if (sexp_port_blockedp(in)) { - sexp_port_blockedp(in) = 0; - fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in)); - } -} -#endif - sexp sexp_read_raw (sexp ctx, sexp in) { char *str; int c1, c2, line; diff --git a/tools/chibi-ffi b/tools/chibi-ffi index f9997a68..d4604933 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -1020,7 +1020,7 @@ (define (write-result-adjustment result) (cond - ((memq (type-base result) '(input-port input-output-port)) + ((memq (type-base result) '(input-port output-port input-output-port)) (let ((res (string-append "res" (type-index-string result)))) (cat "#ifdef SEXP_USE_GREEN_THREADS\n" " if (sexp_portp(" res "))\n" diff --git a/vm.c b/vm.c index 2c219f05..7a1dc581 100644 --- a/vm.c +++ b/vm.c @@ -1761,18 +1761,67 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp_context_top(ctx) = top; #if SEXP_USE_UTF8_STRINGS if (sexp_unbox_character(_ARG1) >= 0x80) - sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); else #endif - sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); - top-=2; - break; - case SEXP_OP_NEWLINE: - if (! sexp_oportp(_ARG1)) - sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); - sexp_context_top(ctx) = top; - sexp_newline(ctx, _ARG1); + 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)) + && (errno == EAGAIN) + && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { + clearerr(sexp_port_stream(_ARG2)); + sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2); + fuel = 0; + ip--; /* try again */ + goto loop; + } else +#endif + sexp_raise("failed to write char to port", _ARG2); + } top--; + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_WRITE_STRING: + if (! sexp_stringp(_ARG1)) + sexp_raise("write-string: not a string", sexp_list1(ctx, _ARG1)); + if (! sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_TRUE) + _ARG2 = sexp_make_fixnum(sexp_string_length(_ARG1)); + else + sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2)); + } + if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > sexp_string_length(_ARG1)) + sexp_raise("write-string: not a valid string count", sexp_list2(ctx, _ARG1, _ARG2)); + 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)) { + i = fwrite(sexp_string_data(_ARG1), 1, sexp_unbox_fixnum(_ARG2), sexp_port_stream(_ARG3)); +#if SEXP_USE_GREEN_THREADS + if ((i < sexp_unbox_fixnum(_ARG2)) && ferror(sexp_port_stream(_ARG3)) + && (errno == EAGAIN) + && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { + clearerr(sexp_port_stream(_ARG3)); + sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3); + fuel = 0; + if (i > 0) { + /* modify stack in-place so we continue where we left off next time */ + _ARG1 = sexp_substring(ctx, _ARG1, SEXP_ZERO, sexp_make_fixnum(i)); + _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i); + } + ip--; /* try again */ + goto loop; + } +#endif + } else { /* not a stream-backed string */ + if (sexp_string_length(_ARG1) != sexp_unbox_fixnum(_ARG2)) + _ARG1 = sexp_substring(ctx, _ARG1, SEXP_ZERO, _ARG2); + sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG3); + } + i = _ARG2; + top-=2; + _ARG1 = sexp_make_fixnum(i); break; case SEXP_OP_READ_CHAR: if (! sexp_iportp(_ARG1))