From 957c8840dd2b76400361758a5a154fc9d8b18a57 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 26 Jul 2008 05:12:20 +0000 Subject: [PATCH] Eliminate port operations {READ,WRITE}-{WIDE,EXTERNAL}-SUBSTRING by pushing the functionality into the {READ,WRITE}-SUBSTRING operations. --- v7/src/edwin/artdebug.scm | 6 +- v7/src/edwin/bufout.scm | 9 +- v7/src/edwin/intmod.scm | 9 +- v7/src/edwin/winout.scm | 46 ++--- v7/src/runtime/genio.scm | 212 ++++++++++----------- v7/src/runtime/input.scm | 12 +- v7/src/runtime/mime-codec.scm | 32 ++-- v7/src/runtime/output.scm | 9 +- v7/src/runtime/port.scm | 334 ++++++++++++---------------------- v7/src/runtime/runtime.pkg | 14 +- v7/src/runtime/stringio.scm | 12 +- 11 files changed, 279 insertions(+), 416 deletions(-) diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 8efb06ed3..506323b8d 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -1304,7 +1304,9 @@ Prefix argument means do not kill the debugger buffer." (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)))) diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm index 35eda921b..91883041d 100644 --- a/v7/src/edwin/bufout.scm +++ b/v7/src/edwin/bufout.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -79,8 +79,11 @@ USA. 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))) diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 0de770d7d..7d1a7669a 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -882,8 +882,11 @@ If this is an error, the debugger examines the error condition." 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! diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm index 5e32233be..b385a0c16 100644 --- a/v7/src/edwin/winout.scm +++ b/v7/src/edwin/winout.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -67,27 +67,29 @@ USA. (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))) diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm index 1668a7d2d..5c7aeba53 100644 --- a/v7/src/runtime/genio.scm +++ b/v7/src/runtime/genio.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -125,9 +125,7 @@ USA. (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) @@ -143,9 +141,7 @@ USA. (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) @@ -225,13 +221,7 @@ USA. (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)) (define (generic-io/eof? port) (input-buffer-at-eof? (port-input-buffer port))) @@ -284,13 +274,7 @@ USA. 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))) @@ -858,62 +842,61 @@ USA. (set-input-buffer-end! ib n))) n)))))) -(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!)))) (define (input-buffer-in-8-bit-mode? ib) (and (eq? (input-buffer-decode ib) binary-decoder) @@ -1054,45 +1037,46 @@ USA. (define (set-output-buffer-line-ending! ob name) (set-output-buffer-denormalize! ob (name->denormalizer name))) -(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)))) ;;;; 8-bit codecs diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index e8fff0d84..874c12b4a 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -49,15 +49,7 @@ USA. (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)) (define (input-port/read-line port) diff --git a/v7/src/runtime/mime-codec.scm b/v7/src/runtime/mime-codec.scm index a1d45e768..9eb5a52b5 100644 --- a/v7/src/runtime/mime-codec.scm +++ b/v7/src/runtime/mime-codec.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -30,19 +30,23 @@ USA. (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)) ;;;; Encode quoted-printable diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index dbb282fb5..efc089129 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -39,12 +39,7 @@ USA. (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)) diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index 41e5690e6..d6ed67c12 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -44,13 +44,9 @@ USA. (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) @@ -158,12 +154,8 @@ USA. (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) @@ -202,147 +194,89 @@ USA. 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)) -;;;; 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)))))))) - -;;;; 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))))) ;;;; Input features @@ -368,20 +302,6 @@ USA. 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) @@ -393,8 +313,6 @@ USA. ((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) @@ -423,36 +341,12 @@ USA. 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))) @@ -463,27 +357,27 @@ USA. (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))))))) ;;;; Port object @@ -535,29 +429,25 @@ USA. (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)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index ed83e2873..b6c21b128 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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, @@ -1923,6 +1923,8 @@ USA. 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 @@ -1950,14 +1952,10 @@ USA. 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 @@ -2014,9 +2012,7 @@ USA. 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 @@ -2024,9 +2020,7 @@ USA. 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!) diff --git a/v7/src/runtime/stringio.scm b/v7/src/runtime/stringio.scm index 32fe89f2a..374b4a019 100644 --- a/v7/src/runtime/stringio.scm +++ b/v7/src/runtime/stringio.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -86,9 +86,7 @@ USA. (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)) @@ -181,9 +179,7 @@ USA. (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)) @@ -237,8 +233,8 @@ USA. (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)) @@ -462,9 +458,7 @@ USA. (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) -- 2.25.1