From 57f4f307e799e4face83c4d5ef33ca37b54c77ea Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sun, 14 Jul 2019 13:40:41 -0700
Subject: [PATCH] Add subprocess-binary-i/o-port.

---
 src/runtime/process.scm | 27 +++++++++++++++++++--------
 src/runtime/runtime.pkg |  1 +
 2 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/src/runtime/process.scm b/src/runtime/process.scm
index 45e0b454d..ff1aa64d5 100644
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -79,6 +79,9 @@ USA.
 (define (subprocess-remove! process key)
   (1d-table/remove! (subprocess-properties process) key))
 
+(define (subprocess-binary-i/o-port process)
+  (%subprocess-binary-i/o-port process 'subprocess-binary-i/o-port))
+
 (define (subprocess-i/o-port process)
   (%subprocess-i/o-port process 'subprocess-i/o-port))
 
@@ -93,6 +96,17 @@ USA.
 	 port)))
 
 (define (%subprocess-i/o-port process caller)
+  (without-interruption
+   (lambda ()
+     (or (subprocess-%i/o-port process)
+	 (let* ((binary-port (%subprocess-binary-i/o-port process caller))
+		(port (and binary-port
+			   (make-generic-i/o-port binary-port (default-object)
+						  caller))))
+	   (set-subprocess-%i/o-port! process port)
+	   port)))))
+
+(define (%subprocess-binary-i/o-port process caller)
   (without-interruption
    (lambda ()
      (or (subprocess-%i/o-port process)
@@ -100,14 +114,11 @@ USA.
 		(let ((input-channel (subprocess-input-channel process))
 		      (output-channel (subprocess-output-channel process)))
 		  (and (or input-channel output-channel)
-		       (make-generic-i/o-port
-			(make-binary-port
-			 (and input-channel
-			      (make-channel-input-source input-channel))
-			 (and output-channel
-			      (make-channel-output-sink output-channel))
-			 caller)
-			(default-object)
+		       (make-binary-port
+			(and input-channel
+			     (make-channel-input-source input-channel))
+			(and output-channel
+			     (make-channel-output-sink output-channel))
 			caller)))))
 	   (set-subprocess-%i/o-port! process port)
 	   port)))))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8aee73893..028eb888d 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4289,6 +4289,7 @@ USA.
 	  start-pty-subprocess
 	  start-subprocess-in-background
 	  subprocess-arguments
+	  subprocess-binary-i/o-port
 	  subprocess-continue-background
 	  subprocess-continue-foreground
 	  subprocess-delete
-- 
2.25.1