From 67f85533c4e46e94941d6dee2888f5068245950d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 11 Jul 2008 05:26:43 +0000 Subject: [PATCH] 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. --- v7/src/edwin/bufinp.scm | 9 +- v7/src/imail/imail-util.scm | 22 ++++- v7/src/runtime/fileio.scm | 8 +- v7/src/runtime/genio.scm | 188 ++++++++++++++++++++++-------------- v7/src/runtime/port.scm | 104 ++++++-------------- v7/src/runtime/runtime.pkg | 6 +- v7/src/runtime/ttyio.scm | 4 +- v7/src/runtime/unicode.scm | 39 ++++++-- 8 files changed, 210 insertions(+), 170 deletions(-) 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) -- 2.25.1