From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 11 Jul 2008 05:26:43 +0000 (+0000)
Subject: Change handling of PEEK-CHAR and UNREAD-CHAR so that it's done in the
X-Git-Tag: 20090517-FFI~280
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=67f85533c4e46e94941d6dee2888f5068245950d;p=mit-scheme.git

Change handling of PEEK-CHAR and UNREAD-CHAR so that it's done in the
generic I/O port operations.  This is easy to handle by simple hacking
of the byte-buffer indexes, and provides better semantics when the
port coding is changed on the fly.

This breaks transcripting, which must also be migrated to the generic
operations.

Add PEEK-CHAR and UNREAD-CHAR operations to ports that don't inherit
the generic operations.
---

diff --git a/v7/src/edwin/bufinp.scm b/v7/src/edwin/bufinp.scm
index 3d5222449..6217cac31 100644
--- a/v7/src/edwin/bufinp.scm
+++ b/v7/src/edwin/bufinp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: bufinp.scm,v 1.17 2008/01/30 20:01:58 cph Exp $
+$Id: bufinp.scm,v 1.18 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -81,6 +81,13 @@ USA.
 	 (let ((state (port/state port)))
 	   (fix:< (bstate-start state)
 		  (bstate-end state)))))
+     (PEEK-CHAR
+      ,(lambda (port)
+	 (let ((state (port/state port)))
+	   (let ((start (bstate-start state)))
+	     (if (fix:< start (bstate-end state))
+		 (group-right-char (bstate-group state) start)
+		 (eof-object))))))
      (READ-CHAR
       ,(lambda (port)
 	 (let ((state (port/state port)))
diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index f228f28be..4647e070f 100644
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: imail-util.scm,v 1.51 2008/01/30 20:02:10 cph Exp $
+$Id: imail-util.scm,v 1.52 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -527,10 +527,19 @@ USA.
 			  (loop p)
 			  p)))))))
 	(eof-object))))
-
+
 (define xstring-input-type
   (make-port-type
-   `((READ-CHAR
+   `((PEEK-CHAR
+      ,(lambda (port)
+	 (let ((state (port/state port)))
+	   (let ((position (istate-position state)))
+	     (if (or (< position (istate-buffer-end state))
+		     (read-xstring-buffer state))
+		 (string-ref (istate-buffer state)
+			     (- position (istate-buffer-start state)))
+		 (eof-object))))))
+     (READ-CHAR
       ,(lambda (port)
 	 (let ((state (port/state port)))
 	   (let ((position (istate-position state)))
@@ -542,6 +551,13 @@ USA.
 		   (set-istate-position! state (+ position 1))
 		   char)
 		 (eof-object))))))
+     (UNREAD-CHAR
+      ,(lambda (port char)
+	 char
+	 (let ((state (port/state port)))
+	   (let ((position (istate-position state)))
+	     (if (> position (istate-buffer-start state))
+		 (set-istate-position! state (- position 1)))))))
      (EOF?
       ,(lambda (port)
 	 (let ((state (port/state port)))
diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm
index 81102e9d7..b345513d3 100644
--- a/v7/src/runtime/fileio.scm
+++ b/v7/src/runtime/fileio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fileio.scm,v 1.37 2008/02/02 04:28:43 cph Exp $
+$Id: fileio.scm,v 1.38 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -69,11 +69,7 @@ USA.
   (if (input-port? port)
       (let ((input-buffer (port-input-buffer port)))
 	(- (channel-file-position (port/input-channel port))
-	   (input-buffer-free-bytes input-buffer)
-	   (let ((unread-char (port/unread port)))
-	     (if unread-char
-		 (input-buffer-encoded-character-size input-buffer unread-char)
-		 0))))
+	   (input-buffer-free-bytes input-buffer)))
       (channel-file-position (port/output-channel port))))
 
 (define (operation/set-position! port position)
diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index 11d82a155..fda393bb5 100644
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.62 2008/07/08 10:36:17 cph Exp $
+$Id: genio.scm,v 1.63 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -123,10 +123,12 @@ USA.
 	   (CLOSE-INPUT ,generic-io/close-input)
 	   (EOF? ,generic-io/eof?)
 	   (INPUT-OPEN? ,generic-io/input-open?)
+	   (PEEK-CHAR ,generic-io/peek-char)
 	   (READ-CHAR ,generic-io/read-char)
 	   (READ-EXTERNAL-SUBSTRING ,generic-io/read-external-substring)
 	   (READ-SUBSTRING ,generic-io/read-substring)
-	   (READ-WIDE-SUBSTRING ,generic-io/read-wide-substring)))
+	   (READ-WIDE-SUBSTRING ,generic-io/read-wide-substring)
+	   (UNREAD-CHAR ,generic-io/unread-char)))
 	(ops:in2
 	 `((INPUT-BLOCKING-MODE ,generic-io/input-blocking-mode)
 	   (INPUT-CHANNEL ,generic-io/input-channel)
@@ -195,16 +197,34 @@ USA.
 (define (generic-io/char-ready? port)
   (buffer-has-input? (port-input-buffer port)))
 
-(define (generic-io/read-char port)
+(define (generic-io/peek-char port) (peek-or-read port #t))
+(define (generic-io/read-char port) (peek-or-read port #f))
+
+(define (peek-or-read port peek?)
   (let ((ib (port-input-buffer port)))
     (let loop ()
-      (or (read-next-char ib)
-	  (let ((r (fill-input-buffer ib)))
-	    (case r
-	      ((OK) (loop))
-	      ((WOULD-BLOCK) #f)
-	      ((EOF) (eof-object))
-	      (else (error "Unknown result:" r))))))))
+      (let* ((bs (input-buffer-start ib))
+	     (char (read-next-char ib)))
+	(if char
+	    (begin
+	      (if peek?
+		  (set-input-buffer-start! ib bs)
+		  (set-input-buffer-prev! ib bs))
+	      char)
+	    (let ((r (fill-input-buffer ib)))
+	      (case r
+		((OK) (loop))
+		((WOULD-BLOCK) #f)
+		((EOF) (eof-object))
+		(else (error "Unknown result:" r)))))))))
+
+(define (generic-io/unread-char port char)
+  char					;ignored
+  (let ((ib (port-input-buffer port)))
+    (let ((bp (input-buffer-prev ib)))
+      (if (not (fix:< bp (input-buffer-start ib)))
+	  (error "No char to unread:" port))
+      (set-input-buffer-start! ib bp))))
 
 (define (generic-io/read-substring port string start end)
   (read-substring:string (port-input-buffer port) string start end))
@@ -214,8 +234,8 @@ USA.
 
 (define (generic-io/read-external-substring port string start end)
   (read-substring:external-string (port-input-buffer port) string start end))
-
-(define-integrable (generic-io/eof? port)
+
+(define (generic-io/eof? port)
   (input-buffer-at-eof? (port-input-buffer port)))
 
 (define (generic-io/input-channel port)
@@ -681,11 +701,12 @@ USA.
 
 (define-integrable byte-buffer-length
   (fix:+ page-size
-	 (fix:- (fix:* max-char-bytes 2) 1)))
+	 (fix:- (fix:* max-char-bytes 4) 1)))
 
 (define-structure (input-buffer (constructor %make-input-buffer))
   (source #f read-only #t)
   (bytes #f read-only #t)
+  prev
   start
   end
   decode
@@ -697,6 +718,7 @@ USA.
 		      (make-string byte-buffer-length)
 		      byte-buffer-length
 		      byte-buffer-length
+		      byte-buffer-length
 		      (name->decoder coder-name)
 		      (name->normalizer
 		       (line-ending ((source/get-channel source))
@@ -712,24 +734,25 @@ USA.
   (fix:>= (input-buffer-end ib) 0))
 
 (define (clear-input-buffer ib)
+  (set-input-buffer-prev! ib byte-buffer-length)
   (set-input-buffer-start! ib byte-buffer-length)
   (set-input-buffer-end! ib byte-buffer-length))
 
 (define (close-input-buffer ib)
+  (set-input-buffer-prev! ib -1)
   (set-input-buffer-start! ib -1)
   (set-input-buffer-end! ib -1))
-
+
 (define (input-buffer-channel ib)
   ((source/get-channel (input-buffer-source ib))))
 
 (define (input-buffer-port ib)
   ((source/get-port (input-buffer-source ib))))
 
-(define-integrable (input-buffer-at-eof? ib)
-  (fix:<= (input-buffer-end ib) 0))
-
-(define-integrable (input-buffer-byte-count ib)
-  (fix:- (input-buffer-end ib) (input-buffer-start ib)))
+(define (input-buffer-at-eof? ib)
+  (or (fix:<= (input-buffer-end ib) 0)
+      (and (fix:= (input-buffer-prev ib) 0)
+	   (fix:= (input-buffer-start ib) (input-buffer-end ib)))))
 
 (define (input-buffer-encoded-character-size ib char)
   ((input-buffer-compute-encoded-character-size ib) ib char))
@@ -742,66 +765,21 @@ USA.
        (let ((cp ((input-buffer-decode ib) ib)))
 	 (and cp
 	      (integer->char cp)))))
-
-(define (fill-input-buffer ib)
-  (if (input-buffer-at-eof? ib)
-      'EOF
-      (begin
-	(justify-input-buffer ib)
-	(let ((n (read-bytes ib)))
-	  (cond ((not n) 'WOULD-BLOCK)
-		((fix:> n 0) 'OK)
-		(else 'EOF))))))
 
-(define (buffer-has-input? ib)
-  (let ((bs (input-buffer-start ib)))
-    (cond ((read-next-char ib)
-	   (set-input-buffer-start! ib bs)
-	   #t)
-	  ((input-buffer-at-eof? ib) #t)
-	  (else
-	   (and ((source/has-input? (input-buffer-source ib)))
-		(begin
-		  (justify-input-buffer ib)
-		  (read-bytes ib)
-		  (let ((bs (input-buffer-start ib)))
-		    (and (read-next-char ib)
-			 (begin
-			   (set-input-buffer-start! ib bs)
-			   #t)))))))))
-
-(define (justify-input-buffer ib)
-  (let ((bs (input-buffer-start ib))
-	(be (input-buffer-end ib)))
-    (if (and (fix:< 0 bs) (fix:< bs be))
-	(let ((bv (input-buffer-bytes ib)))
-	  (do ((i bs (fix:+ i 1))
-	       (j 0 (fix:+ j 1)))
-	      ((not (fix:< i be))
-	       (set-input-buffer-start! ib 0)
-	       (set-input-buffer-end! ib j)
-	       j)
-	    (string-set! bv j (string-ref bv i)))))))
-
-(define (read-bytes ib)
-  (let ((available (input-buffer-byte-count ib)))
-    (let ((n
-	   ((source/read (input-buffer-source ib))
-	    (input-buffer-bytes ib)
-	    available
-	    (fix:+ available page-size))))
-      (if n
-	  (begin
-	    (set-input-buffer-start! ib 0)
-	    (set-input-buffer-end! ib (fix:+ available n))))
-      n)))
+(define (reset-prev-char ib)
+  (set-input-buffer-prev! ib (input-buffer-start ib)))
 
 (define (set-input-buffer-coding! ib coding)
+  (reset-prev-char ib)
   (set-input-buffer-decode! ib (name->decoder coding)))
 
 (define (set-input-buffer-line-ending! ib name)
+  (reset-prev-char ib)
   (set-input-buffer-normalize! ib (name->normalizer name)))
 
+(define (input-buffer-using-binary-normalizer? ib)
+  (eq? (input-buffer-normalize ib) binary-normalizer))
+
 (define (input-buffer-contents ib)
   (substring (input-buffer-bytes ib)
 	     (input-buffer-start ib)
@@ -812,17 +790,75 @@ USA.
   (let ((bv (input-buffer-bytes ib)))
     (let ((n (fix:min (string-length contents) (string-length bv))))
       (substring-move! contents 0 n bv 0)
+      (set-input-buffer-prev! ib 0)
       (set-input-buffer-start! ib 0)
       (set-input-buffer-end! ib n))))
 
 (define (input-buffer-free-bytes ib)
   (fix:- (input-buffer-end ib)
 	 (input-buffer-start ib)))
+
+(define (fill-input-buffer ib)
+  (if (input-buffer-at-eof? ib)
+      'EOF
+      (let ((n (read-bytes ib)))
+	(cond ((not n) 'WOULD-BLOCK)
+	      ((fix:> n 0) 'OK)
+	      (else 'EOF)))))
 
-(define (input-buffer-using-binary-normalizer? ib)
-  (eq? (input-buffer-normalize ib) binary-normalizer))
+(define (buffer-has-input? ib)
+  (or (next-char-ready? ib)
+      (input-buffer-at-eof? ib)
+      (and ((source/has-input? (input-buffer-source ib)))
+	   (begin
+	     (read-bytes ib)
+	     (next-char-ready? ib)))))
+
+(define (next-char-ready? ib)
+  (let ((bs (input-buffer-start ib)))
+    (and (read-next-char ib)
+	 (begin
+	   (set-input-buffer-start! ib bs)
+	   #t))))
+
+(define (read-bytes ib)
+  ;; assumption: (not (input-buffer-at-eof? ib))
+  (let ((bv (input-buffer-bytes ib)))
+    (let ((do-read
+	   (lambda (be)
+	     (let ((be* (fix:+ be page-size)))
+	       (if (not (fix:<= be* (vector-8b-length bv)))
+		   (error "Input buffer overflow:" ib))
+	       ((source/read (input-buffer-source ib)) bv be be*)))))
+      (let ((bp (input-buffer-prev ib))
+	    (be (input-buffer-end ib)))
+	(if (fix:< bp be)
+	    (begin
+	      (if (fix:> bp 0)
+		  (do ((i bp (fix:+ i 1))
+		       (j 0 (fix:+ j 1)))
+		      ((not (fix:< i be))
+		       (set-input-buffer-prev! ib 0)
+		       (set-input-buffer-start! ib
+						(fix:- (input-buffer-start ib)
+						       bp))
+		       (set-input-buffer-end! ib j))
+		    (string-set! bv j (string-ref bv i))))
+	      (let ((be (input-buffer-end ib)))
+		(let ((n (do-read be)))
+		  (if n
+		      (set-input-buffer-end! ib (fix:+ be n)))
+		  n)))
+	    (let ((n (do-read 0)))
+	      (if n
+		  (begin
+		    (set-input-buffer-prev! ib 0)
+		    (set-input-buffer-start! ib 0)
+		    (set-input-buffer-end! ib n)))
+	      n))))))
 
 (define (read-substring:wide-string ib string start end)
+  (reset-prev-char ib)
   (let ((v (wide-string-contents string)))
     (let loop ((i start))
       (cond ((not (fix:< i end))
@@ -842,6 +878,7 @@ USA.
 		 (else (error "Unknown result:" r)))))))))
 
 (define (read-substring:string ib string start end)
+  (reset-prev-char ib)
   (if (input-buffer-in-8-bit-mode? ib)
       (let ((bv (input-buffer-bytes ib))
 	    (bs (input-buffer-start ib))
@@ -850,12 +887,14 @@ USA.
 	    (let ((n (fix:min (fix:- be bs) (fix:- end start))))
 	      (let ((be (fix:+ bs n)))
 		(%substring-move! bv bs be string start)
+		(set-input-buffer-prev! ib be)
 		(set-input-buffer-start! ib be)
 		n))
 	    ((source/read (input-buffer-source ib)) string start end)))
       (read-to-8-bit ib string start end)))
 
 (define (read-substring:external-string ib string start end)
+  (reset-prev-char ib)
   (if (input-buffer-in-8-bit-mode? ib)
       (let ((bv (input-buffer-bytes ib))
 	    (bs (input-buffer-start ib))
@@ -864,6 +903,7 @@ USA.
 	    (let ((n (min (fix:- be bs) (- end start))))
 	      (let ((be (fix:+ bs n)))
 		(xsubstring-move! bv bs be string start)
+		(set-input-buffer-prev! ib be)
 		(set-input-buffer-start! ib be)
 		n))
 	    ((source/read (input-buffer-source ib)) string start end)))
@@ -873,7 +913,7 @@ USA.
 	  (if (and n (fix:> n 0))
 	      (xsubstring-move! bounce 0 n string start))
 	  n))))
-
+
 (define (input-buffer-in-8-bit-mode? ib)
   (and (eq? (input-buffer-decode ib) binary-decoder)
        (eq? (input-buffer-normalize ib) binary-normalizer)))
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 0b1c7e4ee..e51b27c26 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.54 2008/05/02 03:20:36 riastradh Exp $
+$Id: port.scm,v 1.55 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -199,10 +199,12 @@ USA.
 
 (define standard-input-operation-names
   '(CHAR-READY?
+    PEEK-CHAR
     READ-CHAR
     READ-SUBSTRING
     READ-WIDE-SUBSTRING
-    READ-EXTERNAL-SUBSTRING))
+    READ-EXTERNAL-SUBSTRING
+    UNREAD-CHAR))
 
 (define standard-output-operation-names
   '(WRITE-CHAR
@@ -217,7 +219,16 @@ 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 ((peek-char
+	   (or (op 'PEEK-CHAR)
+	       (let ((unread-char (op 'UNREAD-CHAR)))
+		 (and unread-char
+		      (lambda (port)
+			(let ((char (read-char port)))
+			  (if (char? char)
+			      (unread-char port char))
+			  char))))))
+	  (read-substring
 	   (or (op 'READ-SUBSTRING)
 	       (lambda (port string start end)
 		 (let ((char (read-char port)))
@@ -270,7 +281,7 @@ USA.
 	(lambda (name)
 	  (case name
 	    ((CHAR-READY?) char-ready?)
-	    ((READ-CHAR) read-char)
+	    ((PEEK-CHAR) peek-char)
 	    ((READ-SUBSTRING) read-substring)
 	    ((READ-WIDE-SUBSTRING) read-wide-substring)
 	    ((READ-EXTERNAL-SUBSTRING) read-external-substring)
@@ -336,87 +347,37 @@ USA.
 ;;;; Input features
 
 (define (provide-input-features op)
-  (let ((char-ready?
-	 (let ((defer (op 'CHAR-READY?)))
-	   (lambda (port)
-	     (if (port/unread port)
-		 #t
-		 (defer port)))))
-	(read-char
-	 (let ((defer (op 'READ-CHAR)))
-	   (lambda (port)
-	     (let ((char (port/unread port)))
-	       (if char
-		   (begin
-		     (set-port/unread! port #f)
-		     char)
-		   (let ((char (defer port)))
-		     (if (char? char)
-			 (transcribe-char char port))
-		     char))))))
-	(unread-char
-	 (lambda (port char)
-	   (if (port/unread port)
-	       (error "Can't unread second character:" char port))
-	   (set-port/unread! port char)
-	   unspecific))
-	(peek-char
+  (let ((read-char
 	 (let ((defer (op 'READ-CHAR)))
 	   (lambda (port)
-	     (or (port/unread port)
-		 (let ((char (defer port)))
-		   (if (char? char)
-		       (begin
-			 (set-port/unread! port char)
-			 (transcribe-char char port)))
-		   char)))))
+	     (let ((char (defer port)))
+	       (if (char? char)
+		   (transcribe-char char port))
+	       char))))
 	(read-substring
 	 (let ((defer (op 'READ-SUBSTRING)))
 	   (lambda (port string start end)
-	     (if (port/unread port)
-		 (begin
-		   (guarantee-8-bit-char (port/unread port))
-		   (string-set! string start (port/unread port))
-		   (set-port/unread! port #f)
-		   1)
-		 (let ((n (defer port string start end)))
-		   (if (and n (fix:> n 0))
-		       (transcribe-substring string start (fix:+ start n)
-					     port))
-		   n)))))
+	     (let ((n (defer port string start end)))
+	       (if (and n (fix:> n 0))
+		   (transcribe-substring string start (fix:+ start n) port))
+	       n))))
 	(read-wide-substring
 	 (let ((defer (op 'READ-WIDE-SUBSTRING)))
 	   (lambda (port string start end)
-	     (if (port/unread port)
-		 (begin
-		   (wide-string-set! string start (port/unread port))
-		   (set-port/unread! port #f)
-		   1)
-		 (let ((n (defer port string start end)))
-		   (if (and n (fix:> n 0))
-		       (transcribe-substring string start (fix:+ start n)
-					     port))
-		   n)))))
+	     (let ((n (defer port string start end)))
+	       (if (and n (fix:> n 0))
+		   (transcribe-substring string start (fix:+ start n) port))
+	       n))))
 	(read-external-substring
 	 (let ((defer (op 'READ-EXTERNAL-SUBSTRING)))
 	   (lambda (port string start end)
-	     (if (port/unread port)
-		 (begin
-		   (guarantee-8-bit-char (port/unread port))
-		   (xsubstring-move! (make-string 1 (port/unread port)) 0 1
-				     string start)
-		   (set-port/unread! port #f)
-		   1)
-		 (let ((n (defer port string start end)))
-		   (if (and n (fix:> n 0))
-		       (transcribe-substring string start (+ start n) port))
-		   n))))))
+	     (let ((n (defer port string start end)))
+	       (if (and n (fix:> n 0))
+		   (transcribe-substring string start (+ start n) port))
+	       n)))))
     (lambda (name)
       (case name
-	((CHAR-READY?) char-ready?)
 	((READ-CHAR) read-char)
-	((UNREAD-CHAR) unread-char)
-	((PEEK-CHAR) peek-char)
 	((READ-SUBSTRING) read-substring)
 	((READ-WIDE-SUBSTRING) read-wide-substring)
 	((READ-EXTERNAL-SUBSTRING) read-external-substring)
@@ -506,7 +467,6 @@ USA.
   %type
   %state
   (%thread-mutex (make-thread-mutex))
-  (unread #f)
   (previous #f)
   (properties '()))
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 88341c981..bb238a235 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.647 2008/07/08 06:14:43 cph Exp $
+$Id: runtime.pkg,v 14.648 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1758,7 +1758,9 @@ USA.
 	  generic-io/close-input
 	  generic-io/close-output
 	  generic-io/flush-output
+	  generic-io/peek-char
 	  generic-io/read-char
+	  generic-io/unread-char
 	  make-generic-i/o-port
 	  make-non-channel-port-sink
 	  make-non-channel-port-source)
@@ -2008,8 +2010,6 @@ USA.
 	  with-notification-output-port
 	  with-output-to-port
 	  with-trace-output-port)
-  (export (runtime file-i/o-port)
-	  port/unread)
   (export (runtime input-port)
 	  port/operation/char-ready?
 	  port/operation/peek-char
diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm
index aee4b755e..40d95d7e1 100644
--- a/v7/src/runtime/ttyio.scm
+++ b/v7/src/runtime/ttyio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ttyio.scm,v 1.29 2008/02/02 04:28:49 cph Exp $
+$Id: ttyio.scm,v 1.30 2008/07/11 05:26:42 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -41,8 +41,10 @@ USA.
 	      (CLEAR ,operation/clear)
 	      (DISCRETIONARY-WRITE-CHAR ,operation/discretionary-write-char)
 	      (DISCRETIONARY-FLUSH-OUTPUT ,generic-io/flush-output)
+	      (PEEK-CHAR ,generic-io/peek-char)
 	      (READ-CHAR ,operation/read-char)
 	      (READ-FINISH ,operation/read-finish)
+	      (UNREAD-CHAR ,generic-io/unread-char)
 	      (WRITE-SELF ,operation/write-self)
 	      (X-SIZE ,operation/x-size)
 	      (Y-SIZE ,operation/y-size))
diff --git a/v7/src/runtime/unicode.scm b/v7/src/runtime/unicode.scm
index 0b91789ed..9488b80e6 100644
--- a/v7/src/runtime/unicode.scm
+++ b/v7/src/runtime/unicode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unicode.scm,v 1.36 2008/01/30 20:02:36 cph Exp $
+$Id: unicode.scm,v 1.37 2008/07/11 05:26:43 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1250,10 +1250,17 @@ Not used at the moment.
   (set! open-wide-input-string
 	(let ((type
 	       (make-port-type
-		`((READ-CHAR
+		`((PEEK-CHAR
 		   ,(lambda (port)
-		      (or ((port/state port))
+		      (or ((port/state port) 'PEEK)
 			  (eof-object))))
+		  (READ-CHAR
+		   ,(lambda (port)
+		      (or ((port/state port) 'READ)
+			  (eof-object))))
+		  (UNREAD-CHAR
+		   ,(lambda (port)
+		      ((port/state port) 'UNREAD)))
 		  (WRITE-SELF
 		   ,(lambda (port output-port)
 		      port
@@ -1267,7 +1274,7 @@ Not used at the moment.
 						 end
 						 'OPEN-WIDE-INPUT-STRING)))))
   unspecific)
-
+
 (define (call-with-wide-output-string generator)
   (let ((port (open-wide-output-string)))
     (generator port)
@@ -1292,7 +1299,7 @@ Not used at the moment.
     (call-with-output-byte-buffer
      (lambda (sink)
        (let loop ()
-	 (let ((char (source)))
+	 (let ((char (source 'READ)))
 	   (if char
 	       (begin
 		 (sink-char char sink)
@@ -1412,13 +1419,25 @@ Not used at the moment.
 	  (if (if (default-object? start) #f start)
 	      (guarantee-limited-index start end caller)
 	      0)))
-    (lambda ()
+    (lambda (operation)
       (without-interrupts
        (lambda ()
-	 (and (fix:< index end)
-	      (let ((object (vector-ref objects index)))
-		(set! index (fix:+ index 1))
-		object)))))))
+	 (case operation
+	   ((PEEK)
+	    (and (fix:< index end)
+		 (vector-ref objects index)))
+	   ((READ)
+	    (and (fix:< index end)
+		 (let ((object (vector-ref objects index)))
+		   (set! index (fix:+ index 1))
+		   object)))
+	   ((UNREAD)
+	    (if (not (fix:< start index))
+		(error "No char to unread."))
+	    (set! index (fix:- index 1))
+	    unspecific)
+	   (else
+	    (error "Unknown operation:" operation))))))))
 
 (define (guarantee-limited-index index limit caller)
   (guarantee-index-fixnum index caller)