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 3d5222449e50b3136fc851406f32ebf9bd39ac9a..6217cac311cb1a8d2bd0d650fffb03fd4d1cf8a0 100644 (file)
--- 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 f228f28beb60c173ec6c5e99b09141c786515ffd..4647e070f5a626570c2175ec2f63845292692a7a 100644 (file)
--- 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))))
-
+\f
 (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 81102e9d708287aa4ed8c2fe4ecf0d6941c45600..b345513d36810990d848bd157c52e2e6fed1ef97 100644 (file)
--- 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 11d82a155828b1d6b80b141fcf55e638306824b3..fda393bb5ec947b99edfa6301205dd87f0ce9e7a 100644 (file)
--- 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)
+\f
+(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))
-
+\f
 (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)))))
-\f
-(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)))
+\f
+(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))))))
 \f
 (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))))
-
+\f
 (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 0b1c7e4ee77dd8f78c7c5a77e265dc78f8faabc9..e51b27c2670c445abb248a03b661995d3dc62d36 100644 (file)
--- 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 88341c98165c45742406e09678fa113b0bc02d7b..bb238a235979f6b8c5a199757585e0f91099a829 100644 (file)
--- 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 aee4b755e57804136dd11eeb39d0ee05f12d0e11..40d95d7e1ac14f5dad98ec401ebf1be750ed2c63 100644 (file)
--- 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 0b91789eddfce98f7e06fc662aa73e22f0f9182f..9488b80e66aa564da327ecebe860a8fba09c14ed 100644 (file)
--- 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)
-
+\f
 (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)