diff --git a/lib/chibi/io.sld b/lib/chibi/io.sld index 84184322..b8d4da82 100644 --- a/lib/chibi/io.sld +++ b/lib/chibi/io.sld @@ -5,6 +5,7 @@ port->list port->string-list port->sexp-list port->string file-position set-file-position! seek/set seek/cur seek/end make-custom-input-port make-custom-output-port + make-custom-binary-input-port make-custom-binary-output-port make-null-output-port make-null-input-port make-broadcast-port make-concatenated-port make-generated-input-port make-filtered-output-port diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm index 5ccdd4bc..5e2fad1a 100644 --- a/lib/chibi/io/io.scm +++ b/lib/chibi/io/io.scm @@ -228,19 +228,53 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; custom port utilities +;;> \var{read} is a procedure of three arguments: +;;> \scheme{(lambda (str start end) ...)} which should fill \var{str} from +;;> \var{start} to \var{end} with bytes, returning the actual number +;;> of bytes filled. + (define (make-custom-input-port read . o) (let ((seek (and (pair? o) (car o))) (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) (%make-custom-input-port read seek close))) +;;> \var{write} is a procedure of three arguments: +;;> \scheme{(lambda (str start end) ...)} which should write the bytes of +;;> \var{str} from \var{start} to \var{end}, returning the actual +;;> number of bytes written. + (define (make-custom-output-port write . o) (let ((seek (and (pair? o) (car o))) (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) (%make-custom-output-port write seek close))) +;;> Similar to \scheme{make-custom-input-port} but returns a binary +;;> port, and \var{read} receives a bytevector to fill instead of a +;;> string. + +(define (make-custom-binary-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-binary-input-port read seek close))) + +;;> Similar to \scheme{make-custom-output-port} but returns a binary +;;> port, and \var{write} receives data from a bytevector instead of a +;;> string. + +(define (make-custom-binary-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-binary-output-port write seek close))) + +;;> A simple /dev/null port which accepts and does nothing with any +;;> data written to it. + (define (make-null-output-port) (make-custom-output-port (lambda (str start end) 0))) +;;> A port to broadcast everything written to it to multiple output +;;> ports. + (define (make-broadcast-port . ports) (make-custom-output-port (lambda (str start end) @@ -249,6 +283,9 @@ (for-each (lambda (p) (%write-string str n p)) ports) n)))) +;;> An output port which runs all output (in arbitrary string chunks) +;;> through the \var{filter} procedure. + (define (make-filtered-output-port filter out) (make-custom-output-port (lambda (str start end) @@ -258,6 +295,9 @@ (if (string? s2) (%write-string s2 (string-length s2) out)))))) +;;> An input port which acts as all of the \var{ports} concatenated +;;> together in order. + (define (make-concatenated-port . ports) (make-custom-input-port (lambda (str start end) @@ -281,9 +321,16 @@ (string-copy! str i s 0 len)) (lp (+ i len))))))))))))) +;;> A /dev/null input port which always returns \scheme{eof-object}. + (define (make-null-input-port) (make-concatenated-port)) +;;> A utility to represent a port generated in chunks by the thunk +;;> \var{generator}, which should return a single string representing +;;> the next input to buffer, or \scheme{#f} when there is no more +;;> input. + (define (make-generated-input-port generator) (let ((buf "") (len 0) @@ -318,6 +365,9 @@ (string-copy! str i buf offset len) (lp (+ i (- len offset))))))))))))))) +;;> An input port which runs all input (in arbitrary string chunks) +;;> through the \var{filter} procedure. + (define (make-filtered-input-port filter in) (make-generated-input-port (lambda () diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub index 818a9ccc..e1b084bd 100644 --- a/lib/chibi/io/io.stub +++ b/lib/chibi/io/io.stub @@ -31,6 +31,12 @@ (define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") ((value ctx sexp) (value self sexp) sexp sexp sexp)) +(define-c sexp (%make-custom-binary-input-port "sexp_make_custom_binary_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-binary-output-port "sexp_make_custom_binary_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + (define-c sexp (open-input-bytevector "sexp_open_input_bytevector") ((value ctx sexp) (value self sexp) sexp)) (define-c sexp (open-output-bytevector "sexp_open_output_bytevector") diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c index 7116588c..a4639e12 100644 --- a/lib/chibi/io/port.c +++ b/lib/chibi/io/port.c @@ -181,6 +181,8 @@ static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = vec; /* for gc preserving */ } + if (mode && mode[0] == 'w') + sexp_pointer_tag(res) = SEXP_OPORT; sexp_gc_release1(ctx); return res; } @@ -234,6 +236,20 @@ sexp sexp_make_custom_output_port (sexp ctx, sexp self, return res; } +sexp sexp_make_custom_binary_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + sexp res = sexp_make_custom_input_port(ctx, self, read, seek, close); + sexp_port_binaryp(res) = 1; + return res; +} + +sexp sexp_make_custom_binary_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_output_port(ctx, self, write, seek, close); + sexp_port_binaryp(res) = 1; + return res; +} + sexp sexp_bytes_to_string (sexp ctx, sexp vec) { sexp res; #if SEXP_USE_PACKED_STRINGS diff --git a/sexp.c b/sexp.c index 27ceeae8..65745866 100644 --- a/sexp.c +++ b/sexp.c @@ -1441,7 +1441,7 @@ int sexp_buffered_read_char (sexp ctx, sexp p) { } else if (sexp_port_customp(p)) { sexp_gc_preserve1(ctx, tmp); tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE)); - tmp = sexp_cons(ctx, sexp_port_buffer(p), tmp); + tmp = sexp_cons(ctx, sexp_port_binaryp(p) ? sexp_string_bytes(sexp_port_buffer(p)) : sexp_port_buffer(p), tmp); tmp = sexp_apply(ctx, sexp_port_reader(p), tmp); if (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) { sexp_port_offset(p) = 0; @@ -1518,7 +1518,7 @@ int sexp_buffered_flush (sexp ctx, sexp p, int forcep) { sexp_gc_preserve1(ctx, tmp); if (sexp_port_customp(p)) { /* custom port */ tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(sexp_port_offset(p))); - tmp = sexp_cons(ctx, sexp_port_buffer(p), tmp); + tmp = sexp_cons(ctx, sexp_port_binaryp(p) ? sexp_string_bytes(sexp_port_buffer(p)) : sexp_port_buffer(p), tmp); tmp = sexp_apply(ctx, sexp_port_writer(p), tmp); res = (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) ? 0 : -1; } else { /* string port */ diff --git a/tests/io-tests.scm b/tests/io-tests.scm index 289362a3..74b631e2 100644 --- a/tests/io-tests.scm +++ b/tests/io-tests.scm @@ -1,6 +1,9 @@ (cond-expand - (modules (import (chibi io) (only (chibi test) test-begin test test-end))) + (modules + (import (chibi io) + (only (scheme base) read-bytevector write-bytevector) + (only (chibi test) test-begin test test-end))) (else #f)) (test-begin "io") @@ -86,4 +89,31 @@ (display "abc" out) (close-output-port out))))) +(let ((in (make-custom-binary-input-port + (let ((i 0)) + (lambda (bv start end) + (do ((j start (+ j 1))) + ((= j end)) + (bytevector-u8-set! bv j (modulo (+ j i) 256))) + (if (> end 0) + (set! i (bytevector-u8-ref bv (- end 1)))) + (- end start)))))) + (test #u8(0 1 2 3) (read-bytevector 4 in)) + (test #u8(4 5 6 7) (read-bytevector 4 in)) + (test 7 (bytevector-u8-ref (read-bytevector 256 in) 255)) + (test 6 (bytevector-u8-ref (read-bytevector 1024 in) 1022))) + +(let* ((sum 0) + (out (make-custom-binary-output-port + (lambda (bv start end) + (do ((i start (+ i 1)) + (x 0 (+ x (bytevector-u8-ref bv i)))) + ((= i end) (set! sum x))))))) + (write-bytevector #u8(0 1 2 3) out) + (flush-output out) + (test 6 sum) + (write-bytevector #u8(100) out) + (flush-output out) + (test 106 sum)) + (test-end)