From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sun, 14 Jul 2019 20:40:41 +0000 (-0700)
Subject: Add subprocess-binary-i/o-port.
X-Git-Tag: mit-scheme-pucked-10.1.12~7^2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=57f4f307e799e4face83c4d5ef33ca37b54c77ea;p=mit-scheme.git

Add subprocess-binary-i/o-port.
---

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