Make binary ports work independent of their buffer size.

Although they require a minimum size of 1 so that single-byte ops work.  Also
re-jigger names in preparation for reusing the sources and sinks for textual
ports.

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 8073081b0c4819660ff5bd3a8de8298d4c6a4b97..be9c2f783c1468c500ed6ab31ddb43e113167d74 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -245,7 +245,7 @@ USA.
 (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))
+       (and (input-source-has-bytes? (buffer-source/sink ib))
             (fill-input-buffer! ib)
             #t))))
 
@@ -266,8 +266,7 @@ USA.
   (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)))
+       ((filled) (bytevector-u8-ref (buffer-bytes ib) (buffer-start ib)))
        ((unfilled) (loop (fill-input-buffer! ib)))
        ((eof) (eof-object))
        (else #f)))))
@@ -284,7 +283,9 @@ USA.
   (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)))
+         (let ((n
+                (fix:min (bytevector-length contents)
+                         (bytevector-length bv))))
            (bytevector-copy! bv 0 contents 0 n)
            (set-buffer-start! ib 0)
            (set-buffer-end! ib n))))))
@@ -335,9 +336,9 @@ USA.
          (fix:+ index n)))))
 
   (define (read-from-source index)
-    ;; Always read at least page-size bytes; use the buffer if the caller
+    ;; Always read at least a buffer-full of bytes; use the buffer if the caller
     ;; wants less than that.
-    (if (fix:< (fix:- end index) page-size)
+    (if (fix:< (fix:- end index) (bytevector-length (buffer-bytes ib)))
        (case (fill-input-buffer! ib)
          ((filled) (fix:- (read-from-buffer index) start))
          ((eof) (eof index))
@@ -364,11 +365,9 @@ USA.
 \f
 ;;;; 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))
+  (make-buffer source page-size))
 
 (define (input-buffer-marked-eof? ib)
   (eq? 'eof (buffer-override ib)))
@@ -391,16 +390,17 @@ USA.
 
 (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))))
+  (let ((bytes (buffer-bytes ib)))
+    (let ((n (read-bytes! ib bytes 0 (bytevector-length bytes))))
+      (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)))
+  (let ((n (input-source-read-bytes! (buffer-source/sink ib) bv bs be)))
     (if (eqv? n 0)
        (mark-input-buffer-eof! ib))
     n))
@@ -463,59 +463,59 @@ USA.
                     (error:bad-range-argument start 'write-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 output-buffer-length)
-                ;; There's already some data in the buffer, so fill it, drain
-                ;; it, and write the rest directly.
-                (let ((index*
-                       (if (fix:> available 0)
-                           (write-to-buffer index available)
-                           index)))
-                  (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 index)))))
-
-      (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))))
+      (let ((bv-length (bytevector-length bv)))
+
+       (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 bv-length)
+                  ;; There's already some data in the buffer, so fill it, drain
+                  ;; it, and write the rest directly.
+                  (let ((index*
+                         (if (fix:> available 0)
+                             (write-to-buffer index available)
+                             index)))
+                    (let ((n (drain-output-buffer ob)))
+                      (if (and n (fix:> n 0))
+                          (if (fix:< n bv-length)
+                              ;; partial drain
+                              (loop index*)
+                              ;; full drain
+                              (write-to-sink index*))
+                          ;; no progress was made
+                          (fix:- index* start)))))
+                 (else
+                  (write-to-sink index)))))
+
+       (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
+                (output-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)))))
 \f
 ;;;; 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))
+  (make-buffer sink page-size))
 
 (define (close-output-buffer ob)
   (if (not (buffer-marked-closed? ob))
@@ -527,10 +527,10 @@ USA.
 (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)))
+  (let ((bv (buffer-bytes ob))
+       (bs (buffer-start ob))
+       (be (buffer-end ob)))
+    (fix:- (bytevector-length bv)
           (if (fix:> bs 0)
               (let ((be* (fix:- be bs)))
                 (bytevector-copy! bv 0 bv bs be)
@@ -543,12 +543,12 @@ USA.
   ;; assert (fix:= 0 (output-buffer-available ob caller))
   ;; implies
   ;;   (and (fix:= (buffer-start ob) 0)
-  ;;        (fix:= (buffer-end ob) output-buffer-length))
+  ;;        (fix:= (buffer-end ob) (bytevector-length (buffer-bytes ob))))
   (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)))
+      (let ((n (output-sink-write-bytes sink bv bi be)))
        (cond ((and n (fix:> n 0))
               (let ((bi* (fix:+ bi n)))
                 (if (fix:< bi* be)
@@ -573,7 +573,7 @@ USA.
        (sink (buffer-source/sink ob)))
     (if (fix:< bs be)
        (let loop ((bi bs))
-         (let ((n (sink-write-bytes sink bv bi be)))
+         (let ((n (output-sink-write-bytes sink bv bi be)))
            (if (and n (fix:> n 0))
                (let ((bi* (fix:+ bi n)))
                  (if (fix:< bi* be)
@@ -583,7 +583,7 @@ USA.
                      (begin
                        (set-buffer-start! ob 0)
                        (set-buffer-end! ob 0)
-                       output-buffer-length)))
+                       (bytevector-length bv))))
                (fix:- bi bs))))
        0)))
 \f
@@ -607,7 +607,7 @@ USA.
   (source/sink-channel (buffer-source/sink buffer)))
 
 (define (buffer-port buffer)
-  ((source/sink-operation:get-port (buffer-source/sink buffer))))
+  (source/sink-port (buffer-source/sink buffer)))
 
 (define (buffer-marked-eof? buffer)
   (eq? 'eof (buffer-override buffer)))
@@ -623,13 +623,13 @@ USA.
 
 (define (buffer-open? buffer)
   (and (not (buffer-marked-closed? buffer))
-       (or ((source/sink-operation:open? (buffer-source/sink buffer)))
+       (or (source/sink-open? (buffer-source/sink buffer))
           (begin
             (mark-buffer-closed! buffer)
             #f))))
 
 (define (close-buffer buffer)
-  ((source/sink-operation:close (buffer-source/sink buffer))))
+  (close-source/sink (buffer-source/sink buffer)))
 \f
 ;;;; Sources and sinks
 
@@ -664,21 +664,19 @@ USA.
                      (lambda () (set! open? #f) unspecific)
                      (list->vector custom))))
 
+(define (source/sink-port source/sink)
+  ((source/sink-operation:get-port source/sink)))
+
 (define (set-source/sink-port! source/sink port)
   ((source/sink-operation:set-port! source/sink) port))
-\f
-(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))))
+(define (source/sink-open? source/sink)
+  ((source/sink-operation:open? source/sink)))
 
-(add-boot-init!
- (lambda ()
-   (register-predicate! input-source? 'input-source '<= source/sink?)
-   (register-predicate! output-sink? 'output-sink '<= source/sink?)))
+(define (close-source/sink source/sink)
+  ((source/sink-operation:close source/sink)))
+\f
+;;;; Input source
 
 (define (make-channel-input-source channel)
   (make-channel-ss 'source
@@ -689,10 +687,24 @@ USA.
 (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)
+(define (input-source? object)
+  (and (source/sink? object)
+       (eq? 'source (source/sink-flavor object))))
+
+(add-boot-init!
+ (lambda ()
+   (register-predicate! input-source? 'input-source '<= source/sink?)))
+
+(define input-source-channel source/sink-channel)
+(define input-source-port source/sink-port)
+(define set-input-source-port! set-source/sink-port!)
+(define input-source-open? source/sink-open?)
+(define close-input-source close-source/sink)
+
+(define (input-source-has-bytes? source)
   ((vector-ref (source/sink-custom source) 0)))
 
-(define (source-read-bytes! source bv bs be)
+(define (input-source-read-bytes! source bv bs be)
   ((vector-ref (source/sink-custom source) 1) bv bs be))
 
 (define (input-source-custom-length source)
@@ -701,6 +713,8 @@ USA.
 (define (input-source-custom-ref source index)
   (vector-ref (source/sink-custom source) (fix:+ index 2)))
 
+;;;; Output sink
+
 (define (make-channel-output-sink channel)
   (make-channel-ss 'sink
                   channel
@@ -709,7 +723,21 @@ USA.
 (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)
+(define (output-sink? object)
+  (and (source/sink? object)
+       (eq? 'sink (source/sink-flavor object))))
+
+(add-boot-init!
+ (lambda ()
+   (register-predicate! output-sink? 'output-sink '<= source/sink?)))
+
+(define output-sink-channel source/sink-channel)
+(define output-sink-port source/sink-port)
+(define set-output-sink-port! set-source/sink-port!)
+(define output-sink-open? source/sink-open?)
+(define close-output-sink close-source/sink)
+
+(define (output-sink-write-bytes sink bv bs be)
   ((vector-ref (source/sink-custom sink) 0) bv bs be))
 
 (define (output-sink-custom-length sink)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0f3eef8259381fa25b50cc6f80b693b2f8746e68..398ad632e1717606cb004b2875ab933ad5d6d3af 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2529,10 +2529,11 @@ USA.
          write-bytevector
          write-u8)
   (export (runtime)
-         (input-source-channel source/sink-channel)
-         (output-source-channel source/sink-channel)
+         input-source-channel
          input-source-custom-length
          input-source-custom-ref
+         input-source-open?
+         input-source-port
          input-source?
          make-binary-i/o-port
          make-binary-input-port
@@ -2541,8 +2542,10 @@ USA.
          make-channel-output-sink
          make-non-channel-input-source
          make-non-channel-output-sink
+         output-sink-channel
          output-sink-custom-length
          output-sink-custom-ref
+         output-sink-port
          output-sink?)
   (export (runtime port)
          binary-input-port-channel
@@ -2555,6 +2558,16 @@ USA.
          close-binary-input-port
          close-binary-output-port
          close-binary-port)
+  (export (runtime generic-i/o-port)
+         close-input-source
+         close-output-sink
+         input-source-has-bytes?
+         input-source-open?
+         input-source-read-bytes!
+         output-sink-open?
+         output-sink-write-bytes
+         set-input-source-port!
+         set-output-sink-port!)
   (export (runtime output-port)
          flush-binary-output-port))