From 39161c347dabc89f39b57b820a09cc4deadea3cb Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Sat, 8 Dec 2018 14:19:46 +0000 Subject: [PATCH] Fix binary-port-position for output ports. Not sure if it'll DTRT for combined i/o ports; need more tests! --- src/runtime/binary-port.scm | 21 ++++++++++++++++----- tests/runtime/test-binary-port.scm | 8 ++------ 2 files changed, 18 insertions(+), 11 deletions(-) diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm index dfb60f3e7..fd24da675 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 f2751f423..64f33aa19 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) -- 2.25.1