From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 11 Jan 2017 01:18:43 +0000 (-0800)
Subject: Implement binary I/O ports.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~169
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2a852795fab59adc34a54e04ddd3c4f63aa98eb6;p=mit-scheme.git
Implement binary I/O ports.
Tests to follow.
Existing ports are all "textual" ports according to R7RS, so some naming needs
to be shuffled around, as well as integration between the two.
---
diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
new file mode 100644
index 000000000..eeaa85b27
--- /dev/null
+++ b/src/runtime/binary-port.scm
@@ -0,0 +1,693 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Binary I/O ports
+;;; package: (runtime port)
+
+(declare (usual-integrations))
+
+(define-record-type <binary-port>
+ (make-binary-port input-buffer output-buffer)
+ binary-port?
+ (input-buffer port-input-buffer)
+ (output-buffer port-output-buffer))
+
+(define (make-binary-input-port source caller)
+ (let ((port
+ (make-binary-port (make-input-buffer source caller)
+ #f)))
+ (set-source/sink-port! source port)
+ port))
+
+(define (make-binary-output-port sink caller)
+ (let ((port
+ (make-binary-port #f
+ (make-output-buffer sink caller))))
+ (set-source/sink-port! sink port)
+ port))
+
+(define (make-binary-i/o-port source sink caller)
+ (let ((port
+ (make-binary-port (make-input-buffer source caller)
+ (make-output-buffer sink caller))))
+ (set-source/sink-port! source port)
+ (set-source/sink-port! sink port)
+ port))
+
+(define (binary-input-port? object)
+ (and (binary-port? object)
+ (port-input-buffer object)
+ #t))
+
+(define (binary-output-port? object)
+ (and (binary-port? object)
+ (port-output-buffer object)
+ #t))
+
+(define (binary-i/o-port? object)
+ (and (binary-port? object)
+ (port-input-buffer object)
+ (port-output-buffer object)
+ #t))
+
+(add-boot-init!
+ (lambda ()
+ (register-predicate! binary-input-port? 'binary-input-port
+ '<= binary-port?)
+ (register-predicate! binary-output-port? 'binary-output-port
+ '<= binary-port?)
+ (register-predicate! binary-i/o-port? 'binary-i/o-port
+ '<= (list binary-input-port? binary-output-port?))))
+
+;;;; Bytevector input ports
+
+(define (open-input-bytevector bytevector #!optional start end)
+ (let* ((end
+ (if (default-object? end)
+ (bytevector-length bytevector)
+ (begin
+ (guarantee index-fixnum? end 'open-input-bytevector)
+ (if (not (fix:<= end (bytevector-length bytevector)))
+ (error:bad-range-argument end 'open-input-bytevector))
+ end)))
+ (start
+ (if (default-object? start)
+ 0
+ (begin
+ (guarantee index-fixnum? start 'open-input-bytevector)
+ (if (not (fix:<= start end))
+ (error:bad-range-argument start 'open-input-bytevector))
+ start))))
+ (make-binary-input-port
+ (make-non-channel-input-source
+ (lambda ()
+ (fix:< start end))
+ (lambda (bv bs be)
+ (let ((n (fix:min (fix:- end start) (fix:- be bs))))
+ (let ((start* (fix:+ start n)))
+ (bytevector-copy! bv bs bytevector start start*)
+ (set! start start*))
+ n)))
+ 'open-input-bytevector)))
+
+;;;; Bytevector output ports
+
+(define (open-output-bytevector #!optional initial-size)
+ (let* ((size
+ (if (or (default-object? initial-size)
+ (eqv? 0 initial-size))
+ 64
+ (begin
+ (guarantee index-fixnum? initial-size 'open-input-bytevector)
+ initial-size)))
+ (bytevector (make-bytevector size))
+ (index 0))
+ (make-binary-output-port
+ (make-non-channel-output-sink
+ (lambda (bv bs be)
+ (let ((index* (fix:+ index (fix:- be bs))))
+ (let ((size*
+ (let loop ((size* size))
+ (if (fix:<= index* size*)
+ size*
+ (loop (fix:* 2 size*))))))
+ (if (fix:> size* size)
+ (let ((bytevector* (make-bytevector size*)))
+ (bytevector-copy! bytevector* 0 bytevector 0 index)
+ (set! size size*)
+ (set! bytevector bytevector*))))
+ (bytevector-copy! bytevector index bv bs be)
+ (set! index index*)
+ (fix:- be bs)))
+ bytevector-output-port-tag
+ (lambda ()
+ (bytevector-copy bytevector 0 index)))
+ 'open-output-bytevector)))
+
+(define (get-output-bytevector port)
+ (guarantee bytevector-output-port? port 'get-output-bytevector)
+ ((sink-custom-ref (buffer-source/sink (port-output-buffer port)) 1)))
+
+(define (bytevector-output-port? object)
+ (and (binary-output-port? object)
+ (let ((sink (buffer-source/sink (port-output-buffer object))))
+ (and (fix:= (sink-custom-length sink) 2)
+ (eq? bytevector-output-port-tag (sink-custom-ref sink 0))))))
+
+(define bytevector-output-port-tag
+ (list 'bytevector-output-port-tag))
+
+(add-boot-init!
+ (lambda ()
+ (register-predicate! bytevector-output-port? 'bytevector-output-port
+ '<= binary-output-port?)))
+
+;;;; Closing operations
+
+(define (close-binary-port port)
+ (let ((ib (port-input-buffer port))
+ (ob (port-output-buffer port)))
+ (if ib (close-input-buffer ib))
+ (if ob (close-output-buffer ob))
+ (let ((ic (and ib (buffer-channel ib)))
+ (oc (and ob (buffer-channel ob))))
+ (cond (ic
+ (channel-close ic)
+ (if (and oc (not (eqv? oc ic)))
+ (channel-close oc)))
+ (oc
+ (channel-close oc))))))
+
+(define (close-binary-input-port port)
+ (let ((ib (port-input-buffer port)))
+ (if (not ib)
+ (error:not-a binary-input-port? port 'close-input-port))
+ (close-input-buffer ib)
+ (let ((ic (buffer-channel ib)))
+ (if (and ic
+ (let ((ob (port-output-buffer port)))
+ (or (not ob)
+ (and (eqv? ic (buffer-channel ob))
+ (buffer-marked-closed? ob)))))
+ (channel-close ic)))))
+
+(define (close-binary-output-port port)
+ (let ((ob (port-output-buffer port)))
+ (if (not ob)
+ (error:not-a binary-output-port? port 'close-output-port))
+ (close-output-buffer ob)
+ (let ((oc (buffer-channel ob)))
+ (if (and oc
+ (let ((ib (port-input-buffer port)))
+ (or (not ib)
+ (and (eqv? oc (buffer-channel ib))
+ (buffer-marked-closed? ib)))))
+ (channel-close oc)))))
+
+;;;; Input operations
+
+(define (binary-input-port-open? port)
+ (let ((ib (port-input-buffer port)))
+ (if (not ib)
+ (error:not-a binary-input-port? port 'input-port-open?))
+ (buffer-open? ib)))
+
+(define (check-input-port port caller)
+ (let* ((port (if (default-object? port) (current-input-port) port))
+ (ib (port-input-buffer port)))
+ (if (not ib)
+ (error:not-a binary-input-port? port caller))
+ (if (not (buffer-open? ib))
+ (error:bad-range-argument port caller))
+ ib))
+
+(define (u8-ready? #!optional port)
+ (let ((ib (check-input-port port 'u8-ready?)))
+ (or (not (eq? 'unfilled (input-buffer-state ib 'u8-ready?)))
+ (and (source-has-bytes? (buffer-source/sink ib))
+ (fill-input-buffer! ib)
+ #t))))
+
+(define (read-u8 #!optional port)
+ (let ((ib (check-input-port port 'read-u8)))
+ (let loop ((state (input-buffer-state ib 'read-u8)))
+ (case state
+ ((filled)
+ (let* ((start (buffer-start ib))
+ (byte (bytevector-u8-ref (buffer-bytes ib) start)))
+ (set-buffer-start! ib (fix:+ start 1))
+ byte))
+ ((unfilled) (loop (fill-input-buffer! ib)))
+ ((eof) (eof-object))
+ (else #f)))))
+
+(define (peek-u8 #!optional port)
+ (let ((ib (check-input-port port 'peek-u8)))
+ (let loop ((state (input-buffer-state ib 'peek-u8)))
+ (case state
+ ((filled)
+ (bytevector-u8-ref (buffer-bytes ib) (buffer-start ib)))
+ ((unfilled) (loop (fill-input-buffer! ib)))
+ ((eof) (eof-object))
+ (else #f)))))
+
+(define (binary-input-port:buffer-contents port)
+ (let ((ib (check-input-port port 'input-port-buffer-contents)))
+ (if (eq? 'filled (input-buffer-state ib 'input-port-buffer-contents))
+ (bytevector-copy (buffer-bytes ib)
+ (buffer-start ib)
+ (buffer-end ib))
+ (make-bytevector 0))))
+
+(define (binary-input-port:set-buffer-contents! port contents)
+ (let ((ib (check-input-port port 'set-input-port-buffer-contents!)))
+ (if (eq? 'unfilled (input-buffer-state ib 'set-input-port-buffer-contents!))
+ (let ((bv (buffer-bytes ib)))
+ (let ((n (fix:min (bytevector-length contents) input-buffer-length)))
+ (bytevector-copy! bv 0 contents 0 n)
+ (set-buffer-start! ib 0)
+ (set-buffer-end! ib n))))))
+
+(define (read-bytevector k #!optional port)
+ (guarantee index-fixnum? k 'read-bytevector)
+ (let ((ib (check-input-port port 'read-bytevector)))
+ (if (fix:> k 0)
+ (let ((bytevector (make-bytevector k)))
+ (let ((n (%read-bytevector! ib bytevector 0 k 'read-bytevector)))
+ (cond ((or (not n) (eof-object? n)) n)
+ ((fix:< n k) (bytevector-copy bytevector 0 n))
+ (else bytevector))))
+ (make-bytevector 0))))
+
+(define (read-bytevector! bytevector #!optional port start end)
+ (let ((ib (check-input-port port 'read-bytevector!))
+ (end
+ (if (default-object? end)
+ (bytevector-length bytevector)
+ (begin
+ (guarantee index-fixnum? end 'read-bytevector!)
+ (if (not (fix:<= end (bytevector-length bytevector)))
+ (error:bad-range-argument end 'read-bytevector))
+ end))))
+ (let ((start
+ (if (default-object? start)
+ 0
+ (begin
+ (guarantee index-fixnum? start 'read-bytevector!)
+ (if (not (fix:<= start end))
+ (error:bad-range-argument start 'read-bytevector!))
+ start))))
+ (if (fix:< start end)
+ (%read-bytevector! ib bytevector start end 'read-bytevector!)
+ 0))))
+
+(define (%read-bytevector! ib bytevector start end caller)
+
+ (define (read-from-buffer index)
+ (let ((bv (buffer-bytes ib))
+ (bs (buffer-start ib))
+ (be (buffer-end ib)))
+ (let ((n (fix:min (fix:- end index) (fix:- be bs))))
+ (let ((bs* (fix:+ bs n)))
+ (bytevector-copy! bytevector index bv bs bs*)
+ (set-buffer-start! ib bs*)
+ (fix:+ index n)))))
+
+ (define (read-from-source index)
+ ;; Always read at least page-size bytes; use the buffer if the caller
+ ;; wants less than that.
+ (if (fix:< (fix:- end index) page-size)
+ (case (fill-input-buffer! ib)
+ ((filled) (fix:- (read-from-buffer index) start))
+ ((eof) (eof index))
+ (else (would-block index)))
+ (let ((n (read-bytes! ib bytevector index end)))
+ (cond ((not n) (would-block index))
+ ((fix:> n 0) (fix:- (fix:+ index n) start))
+ (else (eof index))))))
+
+ (define (eof index)
+ (if (fix:< start index) (fix:- index start) (eof-object)))
+
+ (define (would-block index)
+ (if (fix:< start index) (fix:- index start) #f))
+
+ (case (input-buffer-state ib caller)
+ ((filled)
+ (let ((index* (read-from-buffer start)))
+ (if (fix:< index* end)
+ (read-from-source index*)
+ (fix:- end start))))
+ ((unfilled) (read-from-source start))
+ (else (eof-object))))
+
+;;;; Input buffers
+
+(define-integrable input-buffer-length page-size)
+
+(define (make-input-buffer source caller)
+ (guarantee input-source? source caller)
+ (make-buffer source input-buffer-length))
+
+(define (input-buffer-marked-eof? ib)
+ (eq? 'eof (buffer-override ib)))
+
+(define (mark-input-buffer-eof! ib)
+ (set-buffer-override! ib 'eof))
+
+(define (close-input-buffer ib)
+ (if (not (buffer-marked-closed? ib))
+ (begin
+ (close-buffer ib)
+ (mark-buffer-closed! ib))))
+
+(define (input-buffer-state ib caller)
+ (if (buffer-marked-closed? ib)
+ (error:bad-range-argument (buffer-port ib) caller))
+ (cond ((input-buffer-marked-eof? ib) 'eof)
+ ((fix:< (buffer-start ib) (buffer-end ib)) 'filled)
+ (else 'unfilled)))
+
+(define (fill-input-buffer! ib)
+ ;; assert (eq? 'unfilled (input-buffer-state ib caller))
+ (let ((n (read-bytes! ib (buffer-bytes ib) 0 input-buffer-length)))
+ (set-buffer-start! ib 0)
+ (set-buffer-end! ib (or n 0))
+ (cond ((not n) #f)
+ ((fix:> n 0) 'filled)
+ (else 'eof))))
+
+(define (read-bytes! ib bv bs be)
+ ;; assert (eq? 'unfilled (input-buffer-state ib caller))
+ (let ((n (source-read-bytes! (buffer-source/sink ib) bv bs be)))
+ (if (eqv? n 0)
+ (mark-input-buffer-eof! ib))
+ n))
+
+;;;; Output operations
+
+(define (binary-output-port-open? port)
+ (let ((ob (port-output-buffer port)))
+ (if (not ob)
+ (error:not-a binary-output-port? port 'output-port-open?))
+ (buffer-open? ob)))
+
+(define (check-output-port port caller)
+ (let* ((port (if (default-object? port) (current-output-port) port))
+ (ob (port-output-buffer port)))
+ (if (not ob)
+ (error:not-a binary-output-port? port caller))
+ (if (not (buffer-open? ob))
+ (error:bad-range-argument port caller))
+ ob))
+
+(define (flush-binary-output-port #!optional port)
+ (flush-output-buffer (check-output-port port 'flush-output-port)))
+
+(define (write-u8 byte #!optional port)
+ (guarantee byte? byte 'write-u8)
+ (let ((ob (check-output-port port 'write-u8)))
+ (let ((write
+ (lambda ()
+ (let ((bi (buffer-end ob)))
+ (bytevector-u8-set! (buffer-bytes ob) bi byte)
+ (set-buffer-end! ob (fix:+ bi 1))
+ 1))))
+ (if (fix:> (output-buffer-available ob 'write-u8) 0)
+ (write)
+ (let ((n (drain-output-buffer ob)))
+ (if (and n (fix:> n 0))
+ (write)
+ n))))))
+
+(define (write-bytevector bytevector #!optional port start end)
+ (let ((ob (check-output-port port 'write-bytevector))
+ (end
+ (if (default-object? end)
+ (bytevector-length bytevector)
+ (begin
+ (guarantee index-fixnum? end 'read-bytevector!)
+ (if (not (fix:<= end (bytevector-length bytevector)))
+ (error:bad-range-argument end 'read-bytevector))
+ end))))
+ (let ((start
+ (if (default-object? start)
+ 0
+ (begin
+ (guarantee index-fixnum? start 'read-bytevector!)
+ (if (not (fix:<= start end))
+ (error:bad-range-argument start 'read-bytevector!))
+ start)))
+ (bv (buffer-bytes ob)))
+
+ (define (loop index)
+ (let ((remaining (fix:- end index))
+ (available (output-buffer-available ob 'write-bytevector)))
+ (cond ((fix:<= remaining available)
+ (fix:- (write-to-buffer index remaining) start))
+ ((fix:> available 0)
+ (let ((index* (write-to-buffer index available)))
+ (let ((n (drain-output-buffer ob)))
+ (if (and n (fix:> n 0))
+ (if (fix:< n output-buffer-length)
+ ;; partial drain
+ (loop index*)
+ ;; full drain
+ (write-to-sink index))
+ ;; no progress was made
+ (fix:- index* start)))))
+ (else
+ (write-to-sink start)))))
+
+ (define (write-to-buffer index n)
+ (let ((bi (buffer-end ob))
+ (index* (fix:+ index n)))
+ (bytevector-copy! bv bi bytevector index index*)
+ (set-buffer-end! ob (fix:+ bi n))
+ index*))
+
+ (define (write-to-sink index)
+ (let ((n
+ (sink-write-bytes (buffer-source/sink ob) bytevector index end)))
+ (if (and n (fix:> n 0))
+ (let ((index* (fix:+ index n)))
+ (if (fix:< index* end)
+ (write-to-sink index*)
+ (fix:- end start)))
+ (if (fix:< start index)
+ (fix:- index start)
+ n))))
+
+ (loop start))))
+
+;;;; Output buffers
+
+(define-integrable output-buffer-length page-size)
+
+(define (make-output-buffer sink caller)
+ (guarantee output-sink? sink caller)
+ (make-buffer sink output-buffer-length))
+
+(define (close-output-buffer ob)
+ (if (not (buffer-marked-closed? ob))
+ (begin
+ (flush-output-buffer ob)
+ (close-buffer ob)
+ (mark-buffer-closed! ob))))
+
+(define (output-buffer-available ob caller)
+ (if (buffer-marked-closed? ob)
+ (error:bad-range-argument (buffer-port ob) caller))
+ (fix:- output-buffer-length
+ (let ((bv (buffer-bytes ob))
+ (bs (buffer-start ob))
+ (be (buffer-end ob)))
+ (if (fix:> bs 0)
+ (let ((be* (fix:- be bs)))
+ (bytevector-copy! bv 0 bv bs be)
+ (set-buffer-start! ob 0)
+ (set-buffer-end! ob be*)
+ be*)
+ be))))
+
+(define (drain-output-buffer ob)
+ ;; assert (fix:= 0 (output-buffer-available ob caller))
+ ;; implies
+ ;; (and (fix:= (buffer-start ob) 0)
+ ;; (fix:= (buffer-end ob) output-buffer-length))
+ (let ((bv (buffer-bytes ob))
+ (be (buffer-end ob))
+ (sink (buffer-source/sink ob)))
+ (let loop ((bi 0))
+ (let ((n (sink-write-bytes sink bv bi be)))
+ (cond ((and n (fix:> n 0))
+ (let ((bi* (fix:+ bi n)))
+ (if (fix:< bi* be)
+ (begin
+ (set-buffer-start! ob bi*)
+ (loop bi*))
+ (begin
+ (set-buffer-start! ob 0)
+ (set-buffer-end! ob 0)
+ be))))
+ ((fix:> bi 0)
+ (bytevector-copy! bv 0 bv bi be)
+ (set-buffer-start! ob 0)
+ (set-buffer-end! ob (fix:- be bi))
+ bi)
+ (else n))))))
+
+(define (flush-output-buffer ob)
+ (let ((bv (buffer-bytes ob))
+ (bs (buffer-start ob))
+ (be (buffer-end ob))
+ (sink (buffer-source/sink ob)))
+ (if (fix:< bs be)
+ (let loop ((bi bs))
+ (let ((n (sink-write-bytes sink bv bi be)))
+ (if (and n (fix:> n 0))
+ (let ((bi* (fix:+ bi n)))
+ (if (fix:< bi* be)
+ (begin
+ (set-buffer-start! ob bi*)
+ (loop bi*))
+ (begin
+ (set-buffer-start! ob 0)
+ (set-buffer-end! ob 0)
+ output-buffer-length)))
+ (fix:- bi bs))))
+ 0)))
+
+;;;; Buffers
+
+(define-integrable page-size #x1000)
+
+(define-record-type <buffer>
+ (%make-buffer source/sink bytes start end override)
+ buffer?
+ (source/sink buffer-source/sink)
+ (bytes buffer-bytes)
+ (start buffer-start set-buffer-start!)
+ (end buffer-end set-buffer-end!)
+ (override buffer-override set-buffer-override!))
+
+(define (make-buffer source/sink buffer-length)
+ (%make-buffer source/sink (make-bytevector buffer-length) 0 0 #f))
+
+(define (buffer-channel buffer)
+ (source/sink-channel (buffer-source/sink buffer)))
+
+(define (buffer-port buffer)
+ ((source/sink-operation:get-port (buffer-source/sink buffer))))
+
+(define (buffer-marked-eof? buffer)
+ (eq? 'eof (buffer-override buffer)))
+
+(define (mark-buffer-eof! buffer)
+ (set-buffer-override! buffer 'eof))
+
+(define (buffer-marked-closed? buffer)
+ (eq? 'closed (buffer-override buffer)))
+
+(define (mark-buffer-closed! buffer)
+ (set-buffer-override! buffer 'closed))
+
+(define (buffer-open? buffer)
+ (and (not (buffer-marked-closed? buffer))
+ (or ((source/sink-operation:open? (buffer-source/sink buffer)))
+ (begin
+ (mark-buffer-closed! buffer)
+ #f))))
+
+(define (close-buffer buffer)
+ ((source/sink-operation:close (buffer-source/sink buffer))))
+
+;;;; Sources and sinks
+
+(define-record-type <source/sink>
+ (make-source/sink flavor channel get-port set-port! open? close custom)
+ source/sink?
+ (flavor source/sink-flavor)
+ (channel source/sink-channel)
+ (get-port source/sink-operation:get-port)
+ (set-port! source/sink-operation:set-port!)
+ (open? source/sink-operation:open?)
+ (close source/sink-operation:close)
+ (custom source/sink-custom))
+
+(define (make-channel-ss flavor channel . custom)
+ (make-source/sink flavor
+ (lambda () channel)
+ (lambda () (channel-port channel))
+ (lambda (port) (set-channel-port! channel port))
+ (lambda () (channel-open? channel))
+ (lambda () unspecific)
+ (list->vector custom)))
+
+(define (make-non-channel-ss flavor . custom)
+ (let ((port #f)
+ (open? #t))
+ (make-source/sink flavor
+ (lambda () #f)
+ (lambda () port)
+ (lambda (port*) (set! port port*) unspecific)
+ (lambda () open?)
+ (lambda () (set! open? #f) unspecific)
+ (list->vector custom))))
+
+(define (set-source/sink-port! source/sink port)
+ ((source/sink-operation:set-port! source/sink) port))
+
+(define (input-source? object)
+ (and (source/sink? object)
+ (eq? 'source (source/sink-flavor object))))
+
+(define (output-sink? object)
+ (and (source/sink? object)
+ (eq? 'sink (source/sink-flavor object))))
+
+(add-boot-init!
+ (lambda ()
+ (register-predicate! input-source? 'input-source '<= source/sink?)
+ (register-predicate! output-sink? 'output-sink '<= source/sink?)))
+
+(define (make-channel-input-source channel)
+ (make-channel-ss 'source
+ channel
+ (lambda () (channel-has-input? channel))
+ (lambda (bv bs be) (channel-read channel bv bs be))))
+
+(define (make-non-channel-input-source has-bytes? read-bytes! . custom)
+ (apply make-non-channel-ss 'source has-bytes? read-bytes! custom))
+
+(define (source-has-bytes? source)
+ ((vector-ref (source/sink-custom source) 0)))
+
+(define (source-read-bytes! source bv bs be)
+ ((vector-ref (source/sink-custom source) 1) bv bs be))
+
+(define (source-custom-length source)
+ (fix:- (vector-length (source/sink-custom source)) 2))
+
+(define (source-custom-ref source index)
+ (vector-ref (source/sink-custom source) (fix:+ index 2)))
+
+(define (make-channel-output-sink channel)
+ (make-channel-ss 'sink
+ channel
+ (lambda (bv bs be) (channel-write channel bv bs be))))
+
+(define (make-non-channel-output-sink write-bytes . custom)
+ (apply make-non-channel-ss 'sink write-bytes custom))
+
+(define (sink-write-bytes sink bv bs be)
+ ((vector-ref (source/sink-custom sink) 0) bv bs be))
+
+(define (sink-custom-length sink)
+ (fix:- (vector-length (source/sink-custom sink)) 1))
+
+(define (sink-custom-ref sink index)
+ (vector-ref (source/sink-custom sink) (fix:+ index 1)))
\ No newline at end of file
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 99bc39596..14828d339 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -488,6 +488,7 @@ USA.
(RUNTIME FLOATING-POINT-ENVIRONMENT)
((RUNTIME THREAD) INITIALIZE-HIGH!)
;; I/O
+ (RUNTIME BINARY-PORT)
(RUNTIME PORT)
(RUNTIME OUTPUT-PORT)
(RUNTIME GENERIC-I/O-PORT)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1125727b6..a8ff1a9d7 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2420,6 +2420,45 @@ USA.
uncompress
compress-ports))
+(define-package (runtime binary-port)
+ (files "binary-port")
+ (parent (runtime))
+ (export ()
+ binary-i/o-port?
+ binary-input-port?
+ binary-output-port?
+ binary-port?
+ get-output-bytevector
+ open-input-bytevector
+ open-output-bytevector
+ peek-u8
+ read-bytevector
+ read-bytevector!
+ read-u8
+ u8-ready?
+ write-bytevector
+ write-u8)
+ (export (runtime)
+ (input-source-channel source/sink-channel)
+ (output-source-channel source/sink-channel)
+ input-source?
+ make-binary-i/o-port
+ make-binary-input-port
+ make-binary-output-port
+ make-channel-input-source
+ make-channel-output-sink
+ make-non-channel-input-source
+ make-non-channel-output-sink
+ output-sink?)
+ (export (runtime port)
+ binary-input-port-open?
+ binary-input-port:buffer-contents
+ binary-input-port:set-buffer-contents!
+ binary-output-port-open?
+ close-binary-input-port
+ close-binary-output-port
+ close-binary-port))
+
(define-package (runtime port)
(files "port")
(parent (runtime))