Adding binary custom ports.

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

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 ()

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")

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

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 */

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)