From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 8 Dec 2018 14:19:46 +0000 (+0000)
Subject: Fix binary-port-position for output ports.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~40^2~3
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0e23cb052ffe27155bafeef27822bdeadfe3a245;p=mit-scheme.git

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 2e67309ca..c9e2e671e 100644
--- 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 bc5308c00..989c226df 100644
--- 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)