From: Chris Hanson Date: Wed, 25 Jan 2017 04:57:16 +0000 (-0800) Subject: Create synchronize-output-port and make it generic over all output ports. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~86 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=420f7b75e324655c9842fbb93b435f2c4b0a074b;p=mit-scheme.git Create synchronize-output-port and make it generic over all output ports. --- diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm index b0945903e..252a67568 100644 --- a/src/runtime/binary-port.scm +++ b/src/runtime/binary-port.scm @@ -475,6 +475,9 @@ USA. (define (flush-binary-output-port port) (flush-output-buffer (check-output-port port 'flush-output-port))) +(define (synchronize-binary-output-port port) + (synchronize-output-buffer (check-output-port port 'synchronize-output-port))) + (define (binary-output-port-buffered-byte-count port) (let ((ob (check-output-port port 'output-port-buffered-byte-count))) (fix:- (buffer-end ob) (buffer-start ob)))) @@ -619,8 +622,16 @@ USA. (set-buffer-end! ob (fix:- be bi)) bi) (else n)))))) - + (define (flush-output-buffer ob) + (if (fix:< (buffer-start ob) (buffer-end ob)) + (let ((channel (buffer-channel ob)) + (do-flush (lambda () (%flush-output-buffer ob)))) + (if channel + (with-channel-blocking channel #t do-flush) + (do-flush))))) + +(define (%flush-output-buffer ob) (let ((bv (buffer-bytes ob)) (bs (buffer-start ob)) (be (buffer-end ob)) @@ -640,6 +651,12 @@ USA. (bytevector-length bv)))) (fix:- bi bs)))) 0))) + +(define (synchronize-output-buffer ob) + (flush-output-buffer ob) + (let ((oc (buffer-channel ob))) + (if oc + (channel-synchronize oc)))) ;;;; Buffers diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index 6d18b42fd..eb039fbf4 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -77,10 +77,15 @@ USA. (else generic-type11))))) (define (generic-i/o-port->binary-port port) - (or (let ((ib (port-input-buffer port))) - (and ib - (input-buffer-binary-port ib))) - (output-buffer-binary-port (port-output-buffer port)))) + (if (port-input-buffer port) + (input-port->binary-port port) + (output-port->binary-port port))) + +(define (input-port->binary-port port) + (input-buffer-binary-port (port-input-buffer port))) + +(define (output-port->binary-port port) + (output-buffer-binary-port (port-output-buffer port))) (define (make-gstate source sink coder-name normalizer-name caller . extra) (let ((binary-port (make-binary-port source sink caller))) @@ -249,6 +254,13 @@ USA. (if (not ib) (error:bad-range-argument port #f)) (input-buffer-channel ib))) + +(define (generic-io/buffer-contents port) + (binary-input-port-buffer-contents (input-port->binary-port port))) + +(define (generic-io/set-buffer-contents port contents) + (set-binary-input-port-buffer-contents! (input-port->binary-port port) + contents)) ;;;; Output operations @@ -267,7 +279,7 @@ USA. (fix:- end start))))) (define (generic-io/flush-output port) - (flush-output-buffer (port-output-buffer port))) + (flush-binary-output-port (output-port->binary-port port))) (define (generic-io/output-column port) (output-buffer-column (port-output-buffer port))) @@ -279,13 +291,10 @@ USA. (output-buffer-channel ob))) (define (generic-io/synchronize-output port) - (let ((channel (generic-io/output-channel port))) - (if channel - (channel-synchronize channel)))) + (synchronize-binary-output-port (output-port->binary-port port))) (define (generic-io/buffered-output-bytes port) - (binary-output-port-buffered-byte-count - (output-buffer-binary-port (port-output-buffer port)))) + (binary-output-port-buffered-byte-count (output-port->binary-port port))) (define (generic-io/bytes-written port) (output-buffer-total (port-output-buffer port))) @@ -304,12 +313,10 @@ USA. (ob (close-binary-output-port (output-buffer-binary-port ob)))))) (define (generic-io/close-input port) - (close-binary-input-port - (input-buffer-binary-port (port-input-buffer port)))) + (close-binary-input-port (input-port->binary-port port))) (define (generic-io/close-output port) - (close-binary-output-port - (output-buffer-binary-port (port-output-buffer port)))) + (close-binary-output-port (output-port->binary-port port))) (define (generic-io/open? port) (and (let ((ib (port-input-buffer port))) @@ -610,15 +617,6 @@ USA. (define (input-buffer-at-eof? ib) (binary-input-port-at-eof? (input-buffer-binary-port ib))) -(define (generic-io/buffer-contents port) - (binary-input-port-buffer-contents - (input-buffer-binary-port (port-input-buffer port)))) - -(define (generic-io/set-buffer-contents port contents) - (set-binary-input-port-buffer-contents! - (input-buffer-binary-port (port-input-buffer port)) - contents)) - ;; Next two for use only in normalizers. (define (decode-char ib) @@ -704,15 +702,6 @@ USA. (define (%output-buffer-sink ob) (binary-output-port-sink (output-buffer-binary-port ob))) - -(define (flush-output-buffer ob) - (let ((channel (output-buffer-channel ob)) - (do-flush - (lambda () - (flush-binary-output-port (output-buffer-binary-port ob))))) - (if channel - (with-channel-blocking channel #t do-flush) - (do-flush)))) ;; Returns >0 if the character was written in its entirety. ;; Returns 0 if the character wasn't written at all. diff --git a/src/runtime/output.scm b/src/runtime/output.scm index 949a078e6..708226358 100644 --- a/src/runtime/output.scm +++ b/src/runtime/output.scm @@ -124,6 +124,12 @@ USA. (cond ((binary-output-port? port) (flush-binary-output-port port)) ((textual-output-port? port) (output-port/flush-output port)) (else (error:not-a output-port? port 'flush-output-port))))) + +(define (synchronize-output-port #!optional port) + (let ((port (optional-output-port port 'synchronize-output-port))) + (cond ((binary-output-port? port) (synchronize-binary-output-port port)) + ((textual-output-port? port) (output-port/synchronize-output port)) + (else (error:not-a output-port? port 'synchronize-output-port))))) (define (fresh-line #!optional port) (let ((port (optional-output-port port 'FRESH-LINE))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 903edae91..6d4dd39bc 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2574,14 +2574,16 @@ USA. output-sink-write-bytes set-binary-input-port-buffer-contents! set-input-source-port! - set-output-sink-port!) + set-output-sink-port! + synchronize-binary-output-port) (export (runtime file-i/o-port) binary-port-length binary-port-position binary-port-positionable? set-binary-port-position!) (export (runtime output-port) - flush-binary-output-port)) + flush-binary-output-port + synchronize-binary-output-port)) (define-package (runtime port) (files "port") @@ -2779,6 +2781,7 @@ USA. output-port/write-substring output-port/x-size output-port/y-size + synchronize-output-port write write-char write-line