diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 00a7da49..24e94f9f 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1240,6 +1240,7 @@ SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); SEXP_API sexp sexp_make_bytes_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i); SEXP_API sexp sexp_make_string_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch); SEXP_API sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); +SEXP_API sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); SEXP_API sexp sexp_string_concatenate_op (sexp ctx, sexp self, sexp_sint_t n, sexp str_ls, sexp sep); SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); SEXP_API sexp sexp_string_to_symbol_op (sexp ctx, sexp self, sexp_sint_t n, sexp str); @@ -1382,6 +1383,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx, NULL, 2, l, c) #define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx, NULL, 3, a, b, c) #define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx, NULL, 3, a, b, c) +#define sexp_subbytes(ctx, a, b, c) sexp_subbytes_op(ctx, NULL, 3, a, b, c) #define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx, NULL, 2, ls, s) #define sexp_memq(ctx, a, b) sexp_memq_op(ctx, NULL, 2, a, b) #define sexp_assq(ctx, a, b) sexp_assq_op(ctx, NULL, 2, a, b) diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm index e787eda4..d366b0ca 100644 --- a/lib/scheme/extras.scm +++ b/lib/scheme/extras.scm @@ -58,7 +58,9 @@ (write-string (utf8->string vec) (bytevector-length vec) (if (pair? o) (car o) (current-output-port)))) (define (write-partial-bytevector vec start end . o) - (apply write-bytevector (bytevector-copy-partial vec start end) o)) + (if (zero? start) + (apply write-bytevector vec end o) + (apply write-bytevector (bytevector-copy-partial vec start end) o))) (define (make-list n . o) (let ((init (and (pair? o) (car o)))) @@ -120,10 +122,7 @@ (define (bytevector-copy! from to) (bytevector-copy-partial! from 0 (bytevector-length from) to 0)) -(define (bytevector-copy-partial bv start end) - (let ((res (make-bytevector (- end start)))) - (bytevector-copy-partial! bv start end res 0) - res)) +(define bytevector-copy-partial subbytes) (define (bytevector-copy-partial! from start end to at) (do ((i start (+ i 1))) diff --git a/opcodes.c b/opcodes.c index 0bcd3cd0..92b67921 100644 --- a/opcodes.c +++ b/opcodes.c @@ -198,6 +198,7 @@ _FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "sub #else _FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", SEXP_FALSE, sexp_substring_op), #endif +_FN3OPT(_I(SEXP_BYTES), _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "subbytes", SEXP_FALSE, sexp_subbytes_op), #if SEXP_USE_FOLD_CASE_SYMS _FN1(SEXP_VOID, _I(SEXP_IPORT), "port-fold-case?", 0, sexp_get_port_fold_case), _FN2(SEXP_VOID, _I(SEXP_IPORT), _I(SEXP_BOOLEAN), "set-port-fold-case!", 0, sexp_set_port_fold_case), diff --git a/sexp.c b/sexp.c index 3fa3b9e8..0f16a29e 100644 --- a/sexp.c +++ b/sexp.c @@ -967,6 +967,26 @@ sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start return res; } +sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp vec, sexp start, sexp end) { + sexp res; + sexp_gc_var1(str); + sexp_assert_type(ctx, sexp_bytesp, SEXP_BYTES, vec); + sexp_gc_preserve1(ctx, str); +#if SEXP_USE_PACKED_STRINGS + str = sexp_c_string(ctx, sexp_bytes_data(vec), sexp_bytes_length(vec)); +#else + str = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(str) = vec; + sexp_string_offset(str) = 0; + sexp_string_length(str) = sexp_bytes_length(vec); +#endif + res = sexp_substring_op(ctx, self, n, str, start, end); + if (!sexp_exceptionp(res)) + res = sexp_string_to_bytes(ctx, res); + sexp_gc_release1(ctx); + return res; +} + #if SEXP_USE_UTF8_STRINGS sexp sexp_utf8_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end) { sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); diff --git a/vm.c b/vm.c index 7a1dc581..026d0393 100644 --- a/vm.c +++ b/vm.c @@ -1783,45 +1783,53 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { _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_stringp(_ARG1)) +#if SEXP_USE_PACKED_STRINGS + tmp1 = _ARG1; +#else + tmp1 = sexp_string_bytes(_ARG1); +#endif + else if (sexp_bytesp(_ARG1)) + tmp1 = _ARG1; + else + sexp_raise("write-string: not a string or bytes", sexp_list1(ctx, _ARG1)); if (! sexp_fixnump(_ARG2)) { if (_ARG2 == SEXP_TRUE) - _ARG2 = sexp_make_fixnum(sexp_string_length(_ARG1)); + _ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1)); 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_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > sexp_bytes_length(tmp1)) + sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _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)); + i = fwrite(sexp_bytes_data(tmp1), 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); } + clearerr(sexp_port_stream(_ARG3)); + sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3); + fuel = 0; 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); + if (sexp_bytes_length(tmp1) != sexp_unbox_fixnum(_ARG2)) + tmp1 = sexp_subbytes(ctx, tmp1, SEXP_ZERO, _ARG2); + sexp_write_string(ctx, sexp_bytes_data(tmp1), _ARG3); } - i = _ARG2; + tmp1 = _ARG2; /* return the number of bytes written */ top-=2; - _ARG1 = sexp_make_fixnum(i); + _ARG1 = tmp1; break; case SEXP_OP_READ_CHAR: if (! sexp_iportp(_ARG1))