From 60c8a738f8b636f2e2cb45cf2fc4aabf79b15aaa Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 9 Jan 2007 06:17:04 +0000
Subject: [PATCH] Fix echoing of input when standard input is redirected to a
 file. Eliminate separate implementation of DISCARD-CHAR; the top-level
 procedures are now aliases for READ-CHAR.

---
 v7/src/runtime/input.scm   |  8 +-------
 v7/src/runtime/parse.scm   | 22 +++++++++++-----------
 v7/src/runtime/port.scm    | 13 +------------
 v7/src/runtime/runtime.pkg | 12 +++++-------
 v7/src/runtime/ttyio.scm   | 29 ++++++++++-------------------
 5 files changed, 28 insertions(+), 56 deletions(-)

diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm
index 99d2a46ca..618e83087 100644
--- a/v7/src/runtime/input.scm
+++ b/v7/src/runtime/input.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: input.scm,v 14.33 2007/01/05 21:19:28 cph Exp $
+$Id: input.scm,v 14.34 2007/01/09 06:16:45 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -44,9 +44,6 @@ USA.
 (define (input-port/peek-char port)
   ((port/operation/peek-char port) port))
 
-(define (input-port/discard-char port)
-  ((port/operation/discard-char port) port))
-
 (define (input-port/read-string! port string)
   (input-port/read-substring! port string 0 (string-length string)))
 
@@ -173,9 +170,6 @@ USA.
     (let loop ()
       (or (input-port/peek-char port)
 	  (loop)))))
-
-(define (discard-char #!optional port)
-  (input-port/discard-char (optional-input-port port 'DISCARD-CHAR)))
 
 (define (read-char-no-hang #!optional port)
   (let ((port (optional-input-port port 'READ-CHAR-NO-HANG)))
diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm
index 8c813edac..04de22faf 100644
--- a/v7/src/runtime/parse.scm
+++ b/v7/src/runtime/parse.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: parse.scm,v 14.65 2007/01/05 21:19:28 cph Exp $
+$Id: parse.scm,v 14.66 2007/01/09 06:16:49 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -270,7 +270,7 @@ USA.
 	       (begin
 		 (set! prefix (cdr prefix))
 		 unspecific)
-	       (discard-char port)))))
+	       (read-char port)))))
     (let read-unquoted ((quoted? #f))
       (let ((char (%peek)))
 	(if (or (eof-object? char)
@@ -420,7 +420,7 @@ USA.
   ctx char
   (if (char=? (peek-char/no-eof port) #\@)
       (begin
-	(discard-char port)
+	(read-char port)
 	(list 'UNQUOTE-SPLICING (read-object port db)))
       (list 'UNQUOTE (read-object port db))))
 
@@ -574,9 +574,14 @@ USA.
   (list 'NON-SHARED-OBJECT))
 
 (define (read-char port)
-  (let loop ()
-    (or (input-port/read-char port)
-	(loop))))
+  (let ((char
+	 (let loop ()
+	   (or (input-port/read-char port)
+	       (loop))))
+	(op (port/operation port 'DISCRETIONARY-WRITE-CHAR)))
+    (if op
+	(op char port))
+    char))
 
 (define (read-char/no-eof port)
   (let ((char (read-char port)))
@@ -584,11 +589,6 @@ USA.
 	(error:premature-eof port))
     char))
 
-(define (discard-char port)
-  (let loop ()
-    (if (not (input-port/discard-char port))
-	(loop))))
-
 (define (peek-char port)
   (let loop ()
     (or (input-port/peek-char port)
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 1a497594b..5a6ee663f 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.49 2007/01/07 09:11:11 cph Exp $
+$Id: port.scm,v 1.50 2007/01/09 06:16:53 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -42,7 +42,6 @@ USA.
   (read-char #f read-only #t)
   (unread-char #f read-only #t)
   (peek-char #f read-only #t)
-  (discard-char #f read-only #t)
   (read-substring #f read-only #t)
   (read-wide-substring #f read-only #t)
   (read-external-substring #f read-only #t)
@@ -154,7 +153,6 @@ USA.
 		       (op 'READ-CHAR)
 		       (op 'UNREAD-CHAR)
 		       (op 'PEEK-CHAR)
-		       (op 'DISCARD-CHAR)
 		       (op 'READ-SUBSTRING)
 		       (op 'READ-WIDE-SUBSTRING)
 		       (op 'READ-EXTERNAL-SUBSTRING)
@@ -368,13 +366,6 @@ USA.
 			 (set-port/unread! port char)
 			 (transcribe-char char port)))
 		   char)))))
-	(discard-char
-	 (let ((defer (op 'READ-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)
@@ -422,7 +413,6 @@ USA.
 	((READ-CHAR) read-char)
 	((UNREAD-CHAR) unread-char)
 	((PEEK-CHAR) peek-char)
-	((DISCARD-CHAR) discard-char)
 	((READ-SUBSTRING) read-substring)
 	((READ-WIDE-SUBSTRING) read-wide-substring)
 	((READ-EXTERNAL-SUBSTRING) read-external-substring)
@@ -566,7 +556,6 @@ USA.
   (define-port-operation read-char)
   (define-port-operation unread-char)
   (define-port-operation peek-char)
-  (define-port-operation discard-char)
   (define-port-operation read-substring)
   (define-port-operation read-wide-substring)
   (define-port-operation read-external-substring)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 00fab67a7..cf20cca21 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.609 2007/01/07 09:11:18 cph Exp $
+$Id: runtime.pkg,v 14.610 2007/01/09 06:16:59 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1933,7 +1933,6 @@ USA.
 	  output-port?
 	  port-position
 	  port-type/char-ready?
-	  port-type/discard-char
 	  port-type/discretionary-flush-output
 	  port-type/flush-output
 	  port-type/fresh-line
@@ -2007,7 +2006,6 @@ USA.
 	  port/unread)
   (export (runtime input-port)
 	  port/operation/char-ready?
-	  port/operation/discard-char
 	  port/operation/peek-char
 	  port/operation/read-char
 	  port/operation/read-external-substring
@@ -2041,18 +2039,18 @@ USA.
   (files "input")
   (parent (runtime))
   (export ()
+	  (discard-char read-char)
+	  (input-port/discard-char input-port/read-char)
 	  char-ready?
-	  discard-char
 	  eof-object?
 	  input-port/char-ready?
-	  input-port/discard-char
 	  input-port/discard-chars
 	  input-port/peek-char
 	  input-port/read-char
-	  input-port/read-line
-	  input-port/read-string
 	  input-port/read-external-string!
 	  input-port/read-external-substring!
+	  input-port/read-line
+	  input-port/read-string
 	  input-port/read-string!
 	  input-port/read-substring!
 	  input-port/read-wide-string!
diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm
index 63562b290..44c928b95 100644
--- a/v7/src/runtime/ttyio.scm
+++ b/v7/src/runtime/ttyio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ttyio.scm,v 1.25 2007/01/05 21:19:28 cph Exp $
+$Id: ttyio.scm,v 1.26 2007/01/09 06:17:04 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -39,6 +39,7 @@ USA.
 	    `((BEEP ,operation/beep)
 	      (CHAR-READY? ,generic-io/char-ready?)
 	      (CLEAR ,operation/clear)
+	      (DISCRETIONARY-WRITE-CHAR ,operation/discretionary-write-char)
 	      (DISCRETIONARY-FLUSH-OUTPUT ,generic-io/flush-output)
 	      (READ-CHAR ,operation/read-char)
 	      (READ-FINISH ,operation/read-finish)
@@ -52,10 +53,7 @@ USA.
 	(set! the-console-port port)
 	(set-console-i/o-port! port)
 	(set-current-input-port! port)
-	(set-current-output-port! port)))
-    (set! *char-ready? (port-type/char-ready? gtype))
-    (set! *read-char (port-type/read-char gtype))
-    (set! *unread-char (port-type/unread-char gtype)))
+	(set-current-output-port! port))))
   (add-event-receiver! event:before-exit save-console-input)
   (add-event-receiver! event:after-restore reset-console))
 
@@ -102,9 +100,6 @@ USA.
 (define console-i/o-port)
 (define console-input-port)
 (define console-output-port)
-(define *char-ready?)
-(define *read-char)
-(define *unread-char)
 
 (define (operation/read-char port)
   (let ((char (generic-io/read-char port)))
@@ -115,24 +110,20 @@ USA.
 		(fresh-line port)
 		(write-string "End of input stream reached." port)))
 	  (%exit)))
-    (maybe-echo-input port char)
     char))
 
 (define (operation/read-finish port)
   (let loop ()
-    (if (*char-ready? port)
-	(let ((char (*read-char port)))
+    (if (char-ready? port)
+	(let ((char (read-char port)))
 	  (if (not (eof-object? char))
-	      (begin
-		(maybe-echo-input port char)
-		(if (char-whitespace? char)
-		    (loop)
-		    (*unread-char port char)))))))
+	      (if (char-whitespace? char)
+		  (loop)
+		  (unread-char char port))))))
   (output-port/discretionary-flush port))
 
-(define (maybe-echo-input port char)
-  (if (and char
-	   (cstate-echo-input? (port/state port))
+(define (operation/discretionary-write-char char port)
+  (if (and (cstate-echo-input? (port/state port))
 	   (not (nearest-cmdl/batch-mode?)))
       (output-port/write-char port char)))
 
-- 
2.25.1