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 b0945903e43129a6c84e2dd2986def10af0bf565..252a675681b9a37db6607d6c9ece84dec8facf7b 100644 (file)
--- 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))))))
-
+\f
 (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))))
 \f
 ;;;; Buffers
 

diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm
index 6d18b42fd8948485b23dd973c334cff961b09ca9..eb039fbf4947e4bacae80778a0fe7a15d691b4ba 100644 (file)
--- 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)))
 \f
 (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))
 \f
 ;;;; 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)))
 \f
-(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))))
 \f
 ;; 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 949a078e608eb657813b746eff9b7f8f2fa9647d..7082263589106c7d52c4abae4756a4747ad0473a 100644 (file)
--- 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)))))
 \f
 (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 903edae91362ae2e9935e7fe9fb0c7ab18aecd94..6d4dd39bcc5098fb4f559c6b6c6880883f6dd43d 100644 (file)
--- 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