pushing the functionality into the {READ,WRITE}-SUBSTRING operations.
#| -*-Scheme-*-
-$Id: artdebug.scm,v 1.39 2008/01/30 20:01:58 cph Exp $
+$Id: artdebug.scm,v 1.40 2008/07/26 05:12:19 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(region-insert-char! (port/state port) char))
(define (operation/write-substring port string start end)
- (region-insert-substring! (port/state port) string start end))
+ (if (string? string)
+ (region-insert-substring! (port/state port) string start end)
+ (generic-port-operation:write-substring port string start end)))
(define (operation/x-size port)
(let ((buffer (mark-buffer (port/state port))))
#| -*-Scheme-*-
-$Id: bufout.scm,v 1.20 2008/01/30 20:01:58 cph Exp $
+$Id: bufout.scm,v 1.21 2008/07/26 05:12:19 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
1)
(define (operation/write-substring port string start end)
- (region-insert-substring! (port/mark port) string start end)
- (fix:- end start))
+ (if (string? string)
+ (begin
+ (region-insert-substring! (port/mark port) string start end)
+ (fix:- end start))
+ (generic-port-operation:write-substring port string start end)))
(define (operation/close port)
(mark-temporary! (port/mark port)))
#| -*-Scheme-*-
-$Id: intmod.scm,v 1.129 2008/01/30 20:02:02 cph Exp $
+$Id: intmod.scm,v 1.130 2008/07/26 05:12:19 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
1)
(define (operation/write-substring port string start end)
- (enqueue-output-string! port (substring string start end))
- (fix:- end start))
+ (if (string? string)
+ (begin
+ (enqueue-output-string! port (substring string start end))
+ (fix:- end start))
+ (generic-port-operation:write-substring port string start end)))
(define (operation/beep port)
(enqueue-output-operation!
#| -*-Scheme-*-
-$Id: winout.scm,v 1.21 2008/01/30 20:02:07 cph Exp $
+$Id: winout.scm,v 1.22 2008/07/26 05:12:19 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(region-insert-char! point char)))))
(define (operation/write-substring port string start end)
- (let ((window (port/state port)))
- (let ((buffer (window-buffer window))
- (point (window-point window)))
- (if (and (null? (cdr (buffer-windows buffer)))
- (line-end? point)
- (buffer-auto-save-modified? buffer)
- (or (not (window-needs-redisplay? window))
- (window-direct-update! window #f))
- (let loop ((i (- end 1)))
- (or (< i start)
- (let ((char (string-ref string i)))
- (and (not (char=? char #\newline))
- (not (char=? char #\tab))
- (let ((image (window-char->image window char)))
- (and (= (string-length image) 1)
- (char=? (string-ref image 0) char)
- (loop (- i 1))))))))
- (< (+ (- end start) (window-point-x window))
- (window-x-size window)))
- (window-direct-output-insert-substring! window string start end)
- (region-insert-substring! point string start end)))))
+ (if (string? string)
+ (let ((window (port/state port)))
+ (let ((buffer (window-buffer window))
+ (point (window-point window)))
+ (if (and (null? (cdr (buffer-windows buffer)))
+ (line-end? point)
+ (buffer-auto-save-modified? buffer)
+ (or (not (window-needs-redisplay? window))
+ (window-direct-update! window #f))
+ (let loop ((i (- end 1)))
+ (or (< i start)
+ (let ((char (string-ref string i)))
+ (and (not (char=? char #\newline))
+ (not (char=? char #\tab))
+ (let ((image (window-char->image window char)))
+ (and (= (string-length image) 1)
+ (char=? (string-ref image 0) char)
+ (loop (- i 1))))))))
+ (< (+ (- end start) (window-point-x window))
+ (window-x-size window)))
+ (window-direct-output-insert-substring! window string start end)
+ (region-insert-substring! point string start end))))
+ (generic-port-operation:write-substring port string start end)))
(define (operation/flush-output port)
(let ((window (port/state port)))
#| -*-Scheme-*-
-$Id: genio.scm,v 1.65 2008/07/18 10:20:30 cph Exp $
+$Id: genio.scm,v 1.66 2008/07/26 05:12:19 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(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)
(UNREAD-CHAR ,generic-io/unread-char)))
(ops:in2
`((INPUT-BLOCKING-MODE ,generic-io/input-blocking-mode)
(OUTPUT-COLUMN ,generic-io/output-column)
(OUTPUT-OPEN? ,generic-io/output-open?)
(WRITE-CHAR ,generic-io/write-char)
- (WRITE-EXTERNAL-SUBSTRING ,generic-io/write-external-substring)
- (WRITE-SUBSTRING ,generic-io/write-substring)
- (WRITE-WIDE-SUBSTRING ,generic-io/write-wide-substring)))
+ (WRITE-SUBSTRING ,generic-io/write-substring)))
(ops:out2
`((OUTPUT-BLOCKING-MODE ,generic-io/output-blocking-mode)
(OUTPUT-CHANNEL ,generic-io/output-channel)
(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))
-
-(define (generic-io/read-wide-substring port string start end)
- (read-substring:wide-string (port-input-buffer port) string start end))
-
-(define (generic-io/read-external-substring port string start end)
- (read-substring:external-string (port-input-buffer port) string start end))
+ (read-substring (port-input-buffer port) string start end))
\f
(define (generic-io/eof? port)
(input-buffer-at-eof? (port-input-buffer port)))
n))))))
(define (generic-io/write-substring port string start end)
- (write-substring:string (port-output-buffer port) string start end))
-
-(define (generic-io/write-wide-substring port string start end)
- (write-substring:wide-string (port-output-buffer port) string start end))
-
-(define (generic-io/write-external-substring port string start end)
- (write-substring:external-string (port-output-buffer port) string start end))
+ (write-substring (port-output-buffer port) string start end))
(define (generic-io/flush-output port)
(force-drain-output-buffer (port-output-buffer port)))
(set-input-buffer-end! ib n)))
n))))))
\f
-(define (read-substring:wide-string ib string start end)
+(define (read-substring ib string start end)
(reset-prev-char ib)
- (let ((v (wide-string-contents string)))
- (let loop ((i start))
- (cond ((not (fix:< i end))
- (fix:- i start))
- ((read-next-char ib)
- => (lambda (char)
- (vector-set! v i char)
- (loop (fix:+ i 1))))
- ((fix:> i start)
- (fix:- i start))
- (else
- (let ((r (fill-input-buffer ib)))
- (case r
- ((OK) (loop i))
- ((WOULD-BLOCK) #f)
- ((EOF) 0)
- (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))
- (be (input-buffer-end ib)))
- (if (fix:< bs be)
- (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))
- (be (input-buffer-end ib)))
- (if (fix:< bs be)
- (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)))
- (let ((bounce (make-string page-size))
- (be (min page-size (- end start))))
- (let ((n (read-to-8-bit ib bounce 0 be)))
- (if (and n (fix:> n 0))
- (xsubstring-move! bounce 0 n string start))
- n))))
+ (cond ((string? string)
+ (if (input-buffer-in-8-bit-mode? ib)
+ (let ((bv (input-buffer-bytes ib))
+ (bs (input-buffer-start ib))
+ (be (input-buffer-end ib)))
+ (if (fix:< bs be)
+ (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)))
+ ((wide-string? string)
+ (let ((v (wide-string-contents string)))
+ (let loop ((i start))
+ (cond ((not (fix:< i end))
+ (fix:- i start))
+ ((read-next-char ib)
+ => (lambda (char)
+ (vector-set! v i char)
+ (loop (fix:+ i 1))))
+ ((fix:> i start)
+ (fix:- i start))
+ (else
+ (let ((r (fill-input-buffer ib)))
+ (case r
+ ((OK) (loop i))
+ ((WOULD-BLOCK) #f)
+ ((EOF) 0)
+ (else (error "Unknown result:" r)))))))))
+ ((external-string? string)
+ (if (input-buffer-in-8-bit-mode? ib)
+ (let ((bv (input-buffer-bytes ib))
+ (bs (input-buffer-start ib))
+ (be (input-buffer-end ib)))
+ (if (fix:< bs be)
+ (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)))
+ (let ((bounce (make-string page-size))
+ (be (min page-size (- end start))))
+ (let ((n (read-to-8-bit ib bounce 0 be)))
+ (if (and n (fix:> n 0))
+ (xsubstring-move! bounce 0 n string start))
+ n))))
+ (else
+ (error:not-string string 'INPUT-PORT/READ-SUBSTRING!))))
\f
(define (input-buffer-in-8-bit-mode? ib)
(and (eq? (input-buffer-decode ib) binary-decoder)
(define (set-output-buffer-line-ending! ob name)
(set-output-buffer-denormalize! ob (name->denormalizer name)))
\f
-(define (write-substring:string ob string start end)
- (let loop ((i start))
- (if (fix:< i end)
- (if (write-next-char ob (string-ref string i))
- (loop (fix:+ i 1))
- (let ((n (drain-output-buffer ob)))
- (cond ((not n) (and (fix:> i start) (fix:- i start)))
- ((fix:> n 0) (loop i))
- (else (fix:- i start)))))
- (fix:- end start))))
-
-(define (write-substring:wide-string ob string start end)
- (let ((v (wide-string-contents string)))
- (let loop ((i start))
- (if (fix:< i end)
- (if (write-next-char ob (vector-ref v i))
- (loop (fix:+ i 1))
- (let ((n (drain-output-buffer ob)))
- (cond ((not n) (and (fix:> i start) (fix:- i start)))
- ((fix:> n 0) (loop i))
- (else (fix:- i start)))))
- (fix:- end start)))))
-
-(define (write-substring:external-string ob string start end)
- (let ((bounce (make-string #x1000)))
- (let loop ((i start))
- (if (< i end)
- (let ((n (min (- end i) #x1000)))
- (xsubstring-move! string i (+ i n) bounce 0)
- (let ((m (write-substring:string ob bounce 0 n)))
- (cond ((not m)
- (and (> i start)
- (- i start)))
- ((fix:> m 0)
- (if (fix:< m n)
- (- (+ i m) start)
- (loop (+ i n))))
- (else (- i start)))))
- (- end start)))))
+(define (write-substring ob string start end)
+ (cond ((string? string)
+ (let loop ((i start))
+ (if (fix:< i end)
+ (if (write-next-char ob (string-ref string i))
+ (loop (fix:+ i 1))
+ (let ((n (drain-output-buffer ob)))
+ (cond ((not n) (and (fix:> i start) (fix:- i start)))
+ ((fix:> n 0) (loop i))
+ (else (fix:- i start)))))
+ (fix:- end start))))
+ ((wide-string? string)
+ (let ((v (wide-string-contents string)))
+ (let loop ((i start))
+ (if (fix:< i end)
+ (if (write-next-char ob (vector-ref v i))
+ (loop (fix:+ i 1))
+ (let ((n (drain-output-buffer ob)))
+ (cond ((not n) (and (fix:> i start) (fix:- i start)))
+ ((fix:> n 0) (loop i))
+ (else (fix:- i start)))))
+ (fix:- end start)))))
+ ((external-string? string)
+ (let ((bounce (make-string #x1000)))
+ (let loop ((i start))
+ (if (< i end)
+ (let ((n (min (- end i) #x1000)))
+ (xsubstring-move! string i (+ i n) bounce 0)
+ (let ((m (write-substring ob bounce 0 n)))
+ (cond ((not m)
+ (and (> i start)
+ (- i start)))
+ ((fix:> m 0)
+ (if (fix:< m n)
+ (- (+ i m) start)
+ (loop (+ i n))))
+ (else (- i start)))))
+ (- end start)))))
+ (else
+ (error:not-string string 'OUTPUT-PORT/WRITE-SUBSTRING))))
\f
;;;; 8-bit codecs
#| -*-Scheme-*-
-$Id: input.scm,v 14.40 2008/07/23 11:12:34 cph Exp $
+$Id: input.scm,v 14.41 2008/07/26 05:12:20 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (input-port/read-substring! port string start end)
(if (< start end)
- ((cond ((string? string)
- (port/operation/read-substring port))
- ((wide-string? string)
- (port/operation/read-wide-substring port))
- ((external-string? string)
- (port/operation/read-external-substring port))
- (else
- (error:not-string string 'INPUT-PORT/READ-SUBSTRING!)))
- port string start end)
+ ((port/operation/read-substring port) port string start end)
0))
\f
(define (input-port/read-line port)
#| -*-Scheme-*-
-$Id: mime-codec.scm,v 14.20 2008/01/30 20:02:32 cph Exp $
+$Id: mime-codec.scm,v 14.21 2008/07/26 05:12:20 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
(define (make-decoding-port-type update finalize)
- (make-port-type `((WRITE-CHAR
- ,(lambda (port char)
- (guarantee-8-bit-char char)
- (update (port/state port) (string char) 0 1)
- 1))
- (WRITE-SUBSTRING
- ,(lambda (port string start end)
- (update (port/state port) string start end)
- (fix:- end start)))
- (CLOSE-OUTPUT
- ,(lambda (port)
- (finalize (port/state port)))))
- #f))
+ (make-port-type
+ `((WRITE-CHAR
+ ,(lambda (port char)
+ (guarantee-8-bit-char char)
+ (update (port/state port) (string char) 0 1)
+ 1))
+ (WRITE-SUBSTRING
+ ,(lambda (port string start end)
+ (if (string? string)
+ (begin
+ (update (port/state port) string start end)
+ (fix:- end start))
+ (generic-port-operation:write-substring port string start end))))
+ (CLOSE-OUTPUT
+ ,(lambda (port)
+ (finalize (port/state port)))))
+ #f))
\f
;;;; Encode quoted-printable
#| -*-Scheme-*-
-$Id: output.scm,v 14.42 2008/07/23 11:12:34 cph Exp $
+$Id: output.scm,v 14.43 2008/07/26 05:12:20 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(output-port/write-substring port string 0 (xstring-length string)))
(define (output-port/write-substring port string start end)
- ((cond ((string? string) (port/operation/write-substring port))
- ((wide-string? string) (port/operation/write-wide-substring port))
- ((external-string? string)
- (port/operation/write-external-substring port))
- (else (error:not-string string 'OUTPUT-PORT/WRITE-SUBSTRING)))
- port string start end))
+ ((port/operation/write-substring port) port string start end))
(define (output-port/fresh-line port)
((port/operation/fresh-line port) port))
#| -*-Scheme-*-
-$Id: port.scm,v 1.57 2008/07/24 06:58:08 cph Exp $
+$Id: port.scm,v 1.58 2008/07/26 05:12:20 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(unread-char #f read-only #t)
(peek-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)
;; output operations:
(write-char #f read-only #t)
(write-substring #f read-only #t)
- (write-wide-substring #f read-only #t)
- (write-external-substring #f read-only #t)
(fresh-line #f read-only #t)
(line-start? #f read-only #t)
(flush-output #f read-only #t)
(op 'UNREAD-CHAR)
(op 'PEEK-CHAR)
(op 'READ-SUBSTRING)
- (op 'READ-WIDE-SUBSTRING)
- (op 'READ-EXTERNAL-SUBSTRING)
(op 'WRITE-CHAR)
(op 'WRITE-SUBSTRING)
- (op 'WRITE-WIDE-SUBSTRING)
- (op 'WRITE-EXTERNAL-SUBSTRING)
(op 'FRESH-LINE)
(op 'LINE-START?)
(op 'FLUSH-OUTPUT)
PEEK-CHAR
READ-CHAR
READ-SUBSTRING
- READ-WIDE-SUBSTRING
- READ-EXTERNAL-SUBSTRING
UNREAD-CHAR))
(define standard-output-operation-names
'(WRITE-CHAR
WRITE-SUBSTRING
- WRITE-WIDE-SUBSTRING
- WRITE-EXTERNAL-SUBSTRING
FLUSH-OUTPUT
DISCRETIONARY-FLUSH-OUTPUT))
\f
-;;;; Default input operations
+;;;; Default I/O operations
+
+(define (required-operation op name)
+ (if (not (op name))
+ (error "Missing required operation:" name)))
(define (provide-default-input-operations op)
- (let ((char-ready? (or (op 'CHAR-READY?) (lambda (port) port #t)))
- (read-char (op 'READ-CHAR)))
- (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)))
- (cond ((not char) #f)
- ((eof-object? char) 0)
- (else
- (guarantee-8-bit-char char)
- (string-set! string start char)
- (let loop ((index (fix:+ start 1)))
- (if (and (fix:< index end)
- (char-ready? port))
- (let ((char (read-char port)))
- (cond ((or (not char)
- (eof-object? char))
- (fix:- index start))
- (else
- (guarantee-8-bit-char char)
- (string-set! string index char)
- (loop (fix:+ index 1)))))
- (fix:- index start)))))))))
- (read-wide-substring
- (or (op 'READ-WIDE-SUBSTRING)
- (lambda (port string start end)
- (let ((char (read-char port)))
- (cond ((not char) #f)
- ((eof-object? char) 0)
- (else
- (wide-string-set! string start char)
- (let loop ((index (fix:+ start 1)))
- (if (and (fix:< index end)
- (char-ready? port))
- (let ((char (read-char port)))
- (if (or (not char) (eof-object? char))
- (fix:- index start)
- (begin
- (wide-string-set! string
- index
- char)
- (loop (fix:+ index 1)))))
- (fix:- index start))))))))))
- (let ((read-external-substring
- (or (op 'READ-EXTERNAL-SUBSTRING)
- (lambda (port string start end)
- (let ((l (min (- end start) #x1000)))
- (let ((bounce (make-string l)))
- (let ((n (read-substring port bounce 0 l)))
- (if (and n (fix:> n 0))
- (xsubstring-move! bounce 0 n string start))
- n)))))))
- (lambda (name)
- (case name
- ((CHAR-READY?) char-ready?)
- ((PEEK-CHAR) peek-char)
- ((READ-SUBSTRING) read-substring)
- ((READ-WIDE-SUBSTRING) read-wide-substring)
- ((READ-EXTERNAL-SUBSTRING) read-external-substring)
- (else (op name))))))))
-\f
-;;;; Default output operations
+ (required-operation op 'READ-CHAR)
+ (if (and (or (op 'UNREAD-CHAR)
+ (op 'PEEK-CHAR))
+ (not (and (op 'UNREAD-CHAR)
+ (op 'PEEK-CHAR))))
+ (error "Must provide both UNREAD-CHAR and PEEK-CHAR operations."))
+ (let ((char-ready?
+ (or (op 'CHAR-READY?)
+ (lambda (port) port #t)))
+ (read-substring
+ (or (op 'READ-SUBSTRING)
+ generic-port-operation:read-substring)))
+ (lambda (name)
+ (case name
+ ((CHAR-READY?) char-ready?)
+ ((READ-SUBSTRING) read-substring)
+ (else (op name))))))
+
+(define (generic-port-operation:read-substring port string start end)
+ (let ((char-ready? (port/operation/char-ready? port))
+ (read-char (port/operation/read-char port)))
+ (let ((char (read-char port)))
+ (cond ((not char) #f)
+ ((eof-object? char) 0)
+ (else
+ (xstring-set! string start char)
+ (let loop ((index (+ start 1)))
+ (if (and (< index end)
+ (char-ready? port))
+ (let ((char (read-char port)))
+ (if (or (not char) (eof-object? char))
+ (- index start)
+ (begin
+ (xstring-set! string index char)
+ (loop (+ index 1)))))
+ (- index start))))))))
(define (provide-default-output-operations op)
- (let ((write-char (op 'WRITE-CHAR))
- (no-flush (lambda (port) port unspecific)))
- (let ((write-substring
- (or (op 'WRITE-SUBSTRING)
- (lambda (port string start end)
- (let loop ((i start))
- (if (fix:< i end)
- (let ((n (write-char port (string-ref string i))))
- (cond ((not n)
- (and (fix:> i start)
- (fix:- i start)))
- ((fix:> n 0) (loop (fix:+ i 1)))
- (else (fix:- i start))))
- (fix:- i start))))))
- (write-wide-substring
- (or (op 'WRITE-WIDE-SUBSTRING)
- (lambda (port string start end)
- (let loop ((i start))
- (if (fix:< i end)
- (let ((n
- (write-char port
- (wide-string-ref string i))))
- (cond ((not n)
- (and (fix:> i start)
- (fix:- i start)))
- ((fix:> n 0) (loop (fix:+ i 1)))
- (else (fix:- i start))))
- (fix:- i start))))))
- (flush-output (or (op 'FLUSH-OUTPUT) no-flush))
- (discretionary-flush-output
- (or (op 'DISCRETIONARY-FLUSH-OUTPUT) no-flush)))
- (let ((write-external-substring
- (or (op 'WRITE-EXTERNAL-SUBSTRING)
- (lambda (port string start end)
- (let ((bounce (make-string #x1000)))
- (let loop ((i start))
- (if (< i end)
- (let ((m (min (- end i) #x1000)))
- (xsubstring-move! string i (+ i m) bounce 0)
- (let ((n (write-substring port bounce 0 m)))
- (cond ((not n) (and (> i start) (- i start)))
- ((fix:> n 0) (loop (+ i n)))
- (else (- i start)))))
- (- end start))))))))
- (lambda (name)
- (case name
- ((WRITE-CHAR) write-char)
- ((WRITE-SUBSTRING) write-substring)
- ((WRITE-WIDE-SUBSTRING) write-wide-substring)
- ((WRITE-EXTERNAL-SUBSTRING) write-external-substring)
- ((FLUSH-OUTPUT) flush-output)
- ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
- (else (op name))))))))
+ (required-operation op 'WRITE-CHAR)
+ (let ((write-substring
+ (or (op 'WRITE-SUBSTRING)
+ generic-port-operation:write-substring))
+ (flush-output
+ (or (op 'FLUSH-OUTPUT)
+ no-flush))
+ (discretionary-flush-output
+ (or (op 'DISCRETIONARY-FLUSH-OUTPUT)
+ no-flush)))
+ (lambda (name)
+ (case name
+ ((WRITE-SUBSTRING) write-substring)
+ ((FLUSH-OUTPUT) flush-output)
+ ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
+ (else (op name))))))
+
+(define (no-flush port)
+ port
+ unspecific)
+
+(define (generic-port-operation:write-substring port string start end)
+ (let ((write-char (port/operation/write-char port)))
+ (let loop ((i start))
+ (if (< i end)
+ (let ((n (write-char port (xstring-ref string i))))
+ (cond ((not n) (and (> i start) (- i start)))
+ ((> n 0) (loop (+ i 1)))
+ (else (- i start))))
+ (- i start)))))
\f
;;;; Input features
char))))
(read-substring
(let ((defer (op 'READ-SUBSTRING)))
- (lambda (port string start end)
- (let ((n (defer port string start end)))
- (transcribe-input-substring string start n port)
- (set-port/unread?! port #f)
- n))))
- (read-wide-substring
- (let ((defer (op 'READ-WIDE-SUBSTRING)))
- (lambda (port string start end)
- (let ((n (defer port string start end)))
- (transcribe-input-substring string start n port)
- (set-port/unread?! port #f)
- n))))
- (read-external-substring
- (let ((defer (op 'READ-EXTERNAL-SUBSTRING)))
(lambda (port string start end)
(let ((n (defer port string start end)))
(transcribe-input-substring string start n port)
((UNREAD-CHAR) unread-char)
((PEEK-CHAR) peek-char)
((READ-SUBSTRING) read-substring)
- ((READ-WIDE-SUBSTRING) read-wide-substring)
- ((READ-EXTERNAL-SUBSTRING) read-external-substring)
(else (op name))))))
(define (transcribe-input-char char port)
n))))
(write-substring
(let ((defer (op 'WRITE-SUBSTRING)))
- (lambda (port string start end)
- (let ((n (defer port string start end)))
- (if (and n (fix:> n 0))
- (begin
- (set-port/previous!
- port
- (string-ref string (fix:+ start (fix:- n 1))))
- (transcribe-substring string start (fix:+ start n) port)))
- n))))
- (write-wide-substring
- (let ((defer (op 'WRITE-WIDE-SUBSTRING)))
- (lambda (port string start end)
- (let ((n (defer port string start end)))
- (if (and n (fix:> n 0))
- (begin
- (set-port/previous!
- port
- (wide-string-ref string (fix:+ start (fix:- n 1))))
- (transcribe-substring string start (fix:+ start n) port)))
- n))))
- (write-external-substring
- (let ((defer (op 'WRITE-EXTERNAL-SUBSTRING)))
(lambda (port string start end)
(let ((n (defer port string start end)))
(if (and n (> n 0))
- (let ((i (+ start n))
- (bounce (make-string 1)))
- (xsubstring-move! string (- i 1) i bounce 0)
- (set-port/previous! port (string-ref bounce 0))
- (transcribe-substring string start i port)))
+ (let ((end (+ start n)))
+ (set-port/previous! port (xstring-ref string (- end 1)))
+ (transcribe-substring string start end port)))
n))))
(flush-output
(let ((defer (op 'FLUSH-OUTPUT)))
(let ((defer (op 'DISCRETIONARY-FLUSH-OUTPUT)))
(lambda (port)
(defer port)
- (discretionary-flush-transcript port)))))
- (lambda (name)
- (case name
- ((WRITE-CHAR) write-char)
- ((WRITE-SUBSTRING) write-substring)
- ((WRITE-WIDE-SUBSTRING) write-wide-substring)
- ((WRITE-EXTERNAL-SUBSTRING) write-external-substring)
- ((FRESH-LINE)
- (lambda (port)
- (if (and (port/previous port)
- (not (char=? (port/previous port) #\newline)))
- (write-char port #\newline)
- 0)))
- ((LINE-START?)
+ (discretionary-flush-transcript port))))
+ (line-start?
(lambda (port)
(if (port/previous port)
(char=? (port/previous port) #\newline)
- 'UNKNOWN)))
- ((FLUSH-OUTPUT) flush-output)
- ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
- (else (op name))))))
+ 'UNKNOWN))))
+ (let ((fresh-line
+ (lambda (port)
+ (if (and (port/previous port)
+ (not (char=? (port/previous port) #\newline)))
+ (write-char port #\newline)
+ 0))))
+ (lambda (name)
+ (case name
+ ((WRITE-CHAR) write-char)
+ ((WRITE-SUBSTRING) write-substring)
+ ((FRESH-LINE) fresh-line)
+ ((LINE-START?) line-start?)
+ ((FLUSH-OUTPUT) flush-output)
+ ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
+ (else (op name)))))))
\f
;;;; Port object
(define (port/operation port name)
(port-type/operation (port/type port) name))
-(let-syntax
- ((define-port-operation
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(DEFINE (,(symbol-append 'PORT/OPERATION/ name) PORT)
- (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment)
- (PORT/TYPE PORT))))))))
- (define-port-operation char-ready?)
- (define-port-operation read-char)
- (define-port-operation unread-char)
- (define-port-operation peek-char)
- (define-port-operation read-substring)
- (define-port-operation read-wide-substring)
- (define-port-operation read-external-substring)
- (define-port-operation write-char)
- (define-port-operation write-substring)
- (define-port-operation write-wide-substring)
- (define-port-operation write-external-substring)
- (define-port-operation fresh-line)
- (define-port-operation line-start?)
- (define-port-operation flush-output)
- (define-port-operation discretionary-flush-output))
+(define-syntax define-port-operation
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE (,(symbol-append 'PORT/OPERATION/ name) PORT)
+ (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment)
+ (PORT/TYPE PORT)))))))
+
+(define-port-operation char-ready?)
+(define-port-operation read-char)
+(define-port-operation unread-char)
+(define-port-operation peek-char)
+(define-port-operation read-substring)
+(define-port-operation write-char)
+(define-port-operation write-substring)
+(define-port-operation fresh-line)
+(define-port-operation line-start?)
+(define-port-operation flush-output)
+(define-port-operation discretionary-flush-output)
(define (port-position port)
((port/operation port 'POSITION) port))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.650 2008/07/23 11:12:34 cph Exp $
+$Id: runtime.pkg,v 14.651 2008/07/26 05:12:20 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
close-port
current-input-port
current-output-port
+ generic-port-operation:read-substring
+ generic-port-operation:write-substring
guarantee-i/o-port
guarantee-input-port
guarantee-output-port
port-type/parent
port-type/peek-char
port-type/read-char
- port-type/read-external-substring
port-type/read-substring
- port-type/read-wide-substring
port-type/unread-char
port-type/write-char
- port-type/write-external-substring
port-type/write-substring
- port-type/write-wide-substring
port-type?
port/coding
port/copy
port/operation/char-ready?
port/operation/peek-char
port/operation/read-char
- port/operation/read-external-substring
port/operation/read-substring
- port/operation/read-wide-substring
port/operation/unread-char)
(export (runtime output-port)
port/operation/discretionary-flush-output
port/operation/fresh-line
port/operation/line-start?
port/operation/write-char
- port/operation/write-external-substring
- port/operation/write-substring
- port/operation/write-wide-substring)
+ port/operation/write-substring)
(export (runtime transcript)
port/transcript
set-port/transcript!)
#| -*-Scheme-*-
-$Id: stringio.scm,v 14.1 2008/07/19 01:41:16 cph Exp $
+$Id: stringio.scm,v 14.2 2008/07/26 05:12:20 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(EOF? ,internal-in/eof?)
(PEEK-CHAR ,peek-char)
(READ-CHAR ,read-char)
- (READ-EXTERNAL-SUBSTRING ,internal-in/read-substring)
(READ-SUBSTRING ,internal-in/read-substring)
- (READ-WIDE-SUBSTRING ,internal-in/read-substring)
(UNREAD-CHAR ,unread-char)
(WRITE-SELF ,string-in/write-self))
#f))
(EOF? ,external-in/eof?)
(PEEK-CHAR ,external-in/peek-char)
(READ-CHAR ,external-in/read-char)
- (READ-EXTERNAL-SUBSTRING ,external-in/read-substring)
(READ-SUBSTRING ,external-in/read-substring)
- (READ-WIDE-SUBSTRING ,external-in/read-substring)
(UNREAD-CHAR ,external-in/unread-char)
(WRITE-SELF ,string-in/write-self))
#f))
(source->sink! (string-source string start end)
(wide-string-sink string* start* end*)))
(else
- (xsubstring-move! string start end string* start*))))
- n))
+ (xsubstring-move! string start end string* start*)
+ n)))))
(define (source->sink! source sink)
(let loop ((n 0))
\f
(define (make-string-out-type write-char extract-output extract-output!)
(make-port-type `((WRITE-CHAR ,write-char)
- (WRITE-EXTERNAL-SUBSTRING ,string-out/write-substring)
(WRITE-SUBSTRING ,string-out/write-substring)
- (WRITE-WIDE-SUBSTRING ,string-out/write-substring)
(EXTRACT-OUTPUT ,extract-output)
(EXTRACT-OUTPUT! ,extract-output!)
(OUTPUT-COLUMN ,string-out/output-column)
projects / mit-scheme.git / commitdiff