Fix binary-port-position for output ports.

Not sure if it'll DTRT for combined i/o ports; need more tests!

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 2e67309caccdc966339103d427388e149c4cf187..c9e2e671e5d904f3307af73929ca710119f545b6 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -301,11 +301,22 @@ USA.
 
 (define (binary-port-position port)
   (guarantee positionable-binary-port? port 'port-position)
-  (let ((ib (port-input-buffer port)))
-    (if ib
-       (- (channel-file-position (buffer-channel ib))
-          (fix:- (buffer-end ib) (buffer-start ib)))
-       (channel-file-position (buffer-channel (port-output-buffer port))))))
+  (let ((ib (port-input-buffer port))
+       (ob (port-output-buffer port)))
+    (let ((buffered-input?
+          (and ib (fix:< (buffer-start ib) (buffer-end ib))))
+         (buffered-output?
+          (and ob (fix:< (buffer-start ob) (buffer-end ob)))))
+      (define (channel-position buffer)
+       (channel-file-position (buffer-channel buffer)))
+      (define (buffer-position buffer)
+       (fix:- (buffer-end buffer) (buffer-start buffer)))
+      (cond ((and buffered-input? buffered-output?)
+            (error "Input and output buffered simultaneously:" port))
+           (ib (- (channel-position ib) (buffer-position ib)))
+           (ob (+ (channel-position ob) (buffer-position ob)))
+           (else
+            (error "Port has neither input nor output buffer:" port))))))
 
 (define (set-binary-port-position! port position)
   (guarantee positionable-binary-port? port 'set-port-position!)

diff --git a/tests/runtime/test-binary-port.scm b/tests/runtime/test-binary-port.scm
index bc5308c0061f2cc80494518a3c0389a8e725d4c6..989c226df99172998f7c24f7914e844b8051d0bd 100644 (file)
--- a/tests/runtime/test-binary-port.scm
+++ b/tests/runtime/test-binary-port.scm
@@ -189,13 +189,9 @@ USA.
          (lambda (port)
            (assert-= (binary-port-position port) 0)
            (write-u8 42 port)
-           (expect-failure
-            (lambda ()
-              (assert-= (binary-port-position port) 1)))
+           (assert-= (binary-port-position port) 1)
            (write-bytevector (make-bytevector 1000 0) port)
-           (expect-failure
-            (lambda ()
-              (assert-= (binary-port-position port) 1001)))))
+           (assert-= (binary-port-position port) 1001)))
        (call-with-binary-input-file pathname
          (lambda (port)
            (assert-= (binary-port-position port) 0)