From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 28 Apr 2017 05:42:24 +0000 (-0700)
Subject: Fix bug in textual->binary-port.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~122
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f951835ea5201ee187661930550fdea99129f7fa;p=mit-scheme.git

Fix bug in textual->binary-port.
---

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 10edd2410..dc8d16b4f 100644
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -201,15 +201,17 @@ USA.
 	   (lambda (bv bs be)
 	     (let loop ((bi bs))
 	       (if (fix:< bi be)
-		   (let ((char (peek-char textual-port)))
-		     (if (or (not char) (eof-object? char))
-			 (if (fix:> bi bs)
-			     (fix:- bi bs)
-			     char)
-			 (let ((bi* ((char-codec-encoder codec) bv bi be char)))
-			   (if bi*
-			       (loop bi*)
-			       (fix:- bi bs)))))
+		   (let ((char (read-char textual-port)))
+		     (cond ((not char) (if (fix:> bi bs) (fix:- bi bs) #f))
+			   ((eof-object? char) (fix:- bi bs))
+			   (else
+			    (let ((bi*
+				   ((char-codec-encoder codec) bv bi be char)))
+			      (if bi*
+				  (loop bi*)
+				  (begin
+				    (unread-char char textual-port)
+				    (fix:- bi bs)))))))
 		   (fix:- bi bs))))
 	   (lambda ()
 	     (close-input-port textual-port))))
@@ -228,7 +230,7 @@ USA.
 		   (fix:- bi bs))))
 	   (lambda ()
 	     (close-output-port textual-port))))
-     'textual-port->binary)))
+     'textual->binary-port)))
 
 ;;;; Closing operations