From c1fc167db82c37cebe52d74d345d22bb52d39121 Mon Sep 17 00:00:00 2001
From: "Taylor R. Campbell" <net/mumble/campbell>
Date: Sun, 25 Dec 2005 05:10:02 +0000
Subject: [PATCH] Fix bug in DISCARD-CHAR whereby it would fail if not
 immediately following a successful (non-EOF) PEEK-CHAR, while it should have
 the same effect as READ-CHAR, per the manual.  DISCARD-CHAR is now a port
 operation that may be supplied when constructing port types, but for which a
 default is provided in terms of READ-CHAR.  The DISCARD-CHAR feature now
 clobbers the unread character field only if it is already filled; otherwise,
 it defers to the supplied operation.

---
 v7/src/runtime/port.scm | 21 ++++++++++++++-------
 1 file changed, 14 insertions(+), 7 deletions(-)

diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index a5bbea293..26ee9e44a 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.39 2005/12/09 07:06:23 riastradh Exp $
+$Id: port.scm,v 1.40 2005/12/25 05:10:02 riastradh Exp $
 
 Copyright 1991,1992,1993,1994,1997,1999 Massachusetts Institute of Technology
 Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
@@ -212,7 +212,12 @@ USA.
 (define (provide-default-input-operations op)
   (let ((char-ready? (or (op 'CHAR-READY?) (lambda (port) port #t)))
 	(read-char (op 'READ-CHAR)))
-    (let ((read-substring
+    (let ((discard-char
+           (or (op 'DISCARD-CHAR)
+               (lambda (port)
+                 (read-char port)
+                 unspecific)))
+          (read-substring
 	   (or (op 'READ-SUBSTRING)
 	       (lambda (port string start end)
 		 (let ((char (read-char port)))
@@ -266,6 +271,7 @@ USA.
 	  (case name
 	    ((CHAR-READY?) char-ready?)
 	    ((READ-CHAR) read-char)
+            ((DISCARD-CHAR) discard-char)
 	    ((READ-SUBSTRING) read-substring)
 	    ((READ-WIDE-SUBSTRING) read-wide-substring)
 	    ((READ-EXTERNAL-SUBSTRING) read-external-substring)
@@ -366,11 +372,12 @@ USA.
 			 (transcribe-char char port)))
 		   char)))))
 	(discard-char
-	 (lambda (port)
-	   (if (not (port/unread port))
-	       (error "No character to discard:" port))
-	   (set-port/unread! port #f)
-	   unspecific))
+	 (let ((defer (op 'DISCARD-CHAR)))
+           (lambda (port)
+             (if (port/unread port)
+                 (set-port/unread! port #f)
+                 (defer port))
+             unspecific)))
 	(read-substring
 	 (let ((defer (op 'READ-SUBSTRING)))
 	   (lambda (port string start end)
-- 
2.25.1