From: Chris Hanson Date: Mon, 12 Dec 2005 21:55:44 +0000 (+0000) Subject: Generalize generic I/O interface so that it can work with ports that X-Git-Tag: 20090517-FFI~1169 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=adc1c68753c9fff32ea509926c12c01ca90cd19e;p=mit-scheme.git Generalize generic I/O interface so that it can work with ports that aren't backed by channels. Reimplement string I/O ports to work this way, so that they can take advantage of all the nice codecs. --- diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm index d9aaf379b..4fc6c55e3 100644 --- a/v7/src/runtime/fileio.scm +++ b/v7/src/runtime/fileio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fileio.scm,v 1.25 2005/10/24 05:35:26 cph Exp $ +$Id: fileio.scm,v 1.26 2005/12/12 21:41:23 cph Exp $ Copyright 1991,1993,1994,1995,1996,1999 Massachusetts Institute of Technology Copyright 2001,2004,2005 Massachusetts Institute of Technology @@ -35,12 +35,13 @@ USA. (LENGTH ,operation/length) (PATHNAME ,operation/pathname) (TRUENAME ,operation/truename)))) - (set! input-file-type - (make-port-type other-operations generic-input-type)) - (set! output-file-type - (make-port-type other-operations generic-output-type)) - (set! i/o-file-type - (make-port-type other-operations generic-i/o-type))) + (let ((make-type + (lambda (source sink) + (make-port-type other-operations + (generic-i/o-port-type source sink))))) + (set! input-file-type (make-type 'CHANNEL #f)) + (set! output-file-type (make-type #f 'CHANNEL)) + (set! i/o-file-type (make-type 'CHANNEL 'CHANNEL)))) unspecific) (define input-file-type) diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm index 5cab1743f..6b23c1a99 100644 --- a/v7/src/runtime/genio.scm +++ b/v7/src/runtime/genio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: genio.scm,v 1.34 2005/12/09 07:06:23 riastradh Exp $ +$Id: genio.scm,v 1.35 2005/12/12 21:45:36 cph Exp $ Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology Copyright 2003,2004,2005 Massachusetts Institute of Technology @@ -29,18 +29,49 @@ USA. (declare (usual-integrations)) -(define (make-generic-i/o-port input-channel output-channel) - (if (not (or input-channel output-channel)) - (error "Missing channel arguments.")) +(define (make-generic-i/o-port source sink) + (if (not (or source sink)) + (error "Missing arguments.")) (let ((port - (make-port (cond ((not input-channel) generic-output-type) - ((not output-channel) generic-input-type) - (else generic-i/o-type)) - (make-gstate input-channel output-channel 'TEXT)))) - (if input-channel (set-channel-port! input-channel port)) - (if output-channel (set-channel-port! output-channel port)) + (make-port (generic-i/o-port-type (source-type source) + (sink-type sink)) + (make-gstate source sink 'TEXT)))) + (let ((ib (port-input-buffer port))) + (if ib + ((source/set-port (input-buffer-source ib)) port))) + (let ((ob (port-output-buffer port))) + (if ob + ((sink/set-port (output-buffer-sink ob)) port))) port)) +(define (source-type source) + (cond ((not source) #f) + ((or (channel? source) ((source/get-channel source))) 'CHANNEL) + (else #t))) + +(define (sink-type sink) + (cond ((not sink) #f) + ((or (channel? sink) ((sink/get-channel sink))) 'CHANNEL) + (else #t))) + +(define (generic-i/o-port-type source sink) + (case source + ((#F) + (case sink + ((#F) generic-type00) + ((CHANNEL) generic-type02) + (else generic-type01))) + ((CHANNEL) + (case sink + ((#F) generic-type20) + ((CHANNEL) generic-type22) + (else generic-type21))) + (else + (case sink + ((#F) generic-type10) + ((CHANNEL) generic-type12) + (else generic-type11))))) + (define-structure (gstate (type vector) (constructor #f)) ;; Changes to this structure must be copied to "fileio.scm" and ;; "ttyio.scm", "strnin.scm", "strout.scm", and "strott.scm". @@ -49,10 +80,12 @@ USA. coding line-ending) -(define (make-gstate input-channel output-channel type . extra) +(define (make-gstate source sink type . extra) (list->vector - (cons* (and input-channel (make-input-buffer-1 input-channel type)) - (and output-channel (make-output-buffer-1 output-channel type)) + (cons* (and source + (make-input-buffer (->source source 'MAKE-GSTATE) type)) + (and sink + (make-output-buffer (->sink sink 'MAKE-GSTATE) type)) type type extra))) @@ -64,34 +97,36 @@ USA. (gstate-output-buffer (port/state port))) (define (initialize-package!) - (let ((input-operations + (let ((ops:in1 `((CHAR-READY? ,generic-io/char-ready?) (CLOSE-INPUT ,generic-io/close-input) (EOF? ,generic-io/eof?) - (INPUT-BLOCKING-MODE ,generic-io/input-blocking-mode) - (INPUT-CHANNEL ,generic-io/input-channel) (INPUT-OPEN? ,generic-io/input-open?) - (INPUT-TERMINAL-MODE ,generic-io/input-terminal-mode) (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))) + (ops:in2 + `((INPUT-BLOCKING-MODE ,generic-io/input-blocking-mode) + (INPUT-CHANNEL ,generic-io/input-channel) + (INPUT-TERMINAL-MODE ,generic-io/input-terminal-mode) (SET-INPUT-BLOCKING-MODE ,generic-io/set-input-blocking-mode) (SET-INPUT-TERMINAL-MODE ,generic-io/set-input-terminal-mode))) - (output-operations + (ops:out1 `((BUFFERED-OUTPUT-BYTES ,generic-io/buffered-output-bytes) (CLOSE-OUTPUT ,generic-io/close-output) (FLUSH-OUTPUT ,generic-io/flush-output) - (OUTPUT-BLOCKING-MODE ,generic-io/output-blocking-mode) - (OUTPUT-CHANNEL ,generic-io/output-channel) (OUTPUT-OPEN? ,generic-io/output-open?) - (OUTPUT-TERMINAL-MODE ,generic-io/output-terminal-mode) - (SET-OUTPUT-BLOCKING-MODE ,generic-io/set-output-blocking-mode) - (SET-OUTPUT-TERMINAL-MODE ,generic-io/set-output-terminal-mode) (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))) + (ops:out2 + `((OUTPUT-BLOCKING-MODE ,generic-io/output-blocking-mode) + (OUTPUT-CHANNEL ,generic-io/output-channel) + (OUTPUT-TERMINAL-MODE ,generic-io/output-terminal-mode) + (SET-OUTPUT-BLOCKING-MODE ,generic-io/set-output-blocking-mode) + (SET-OUTPUT-TERMINAL-MODE ,generic-io/set-output-terminal-mode))) (other-operations `((CLOSE ,generic-io/close) (CODING ,generic-io/coding) @@ -104,29 +139,32 @@ USA. (SET-LINE-ENDING ,generic-io/set-line-ending) (SUPPORTS-CODING? ,generic-io/supports-coding?) (WRITE-SELF ,generic-io/write-self)))) - (set! generic-input-type - (make-port-type (append input-operations - other-operations) - #f)) - (set! generic-output-type - (make-port-type (append output-operations - other-operations) - #f)) - (set! generic-i/o-type - (make-port-type (append input-operations - output-operations - other-operations) - #f)) - (set! generic-no-i/o-type - (make-port-type other-operations - #f))) + (let ((make-type + (lambda ops + (make-port-type (append (apply append ops) + other-operations) + #f)))) + (set! generic-type00 (make-type)) + (set! generic-type10 (make-type ops:in1)) + (set! generic-type20 (make-type ops:in1 ops:in2)) + (set! generic-type01 (make-type ops:out1)) + (set! generic-type02 (make-type ops:out1 ops:out2)) + (set! generic-type11 (make-type ops:in1 ops:out1)) + (set! generic-type21 (make-type ops:in1 ops:in2 ops:out1)) + (set! generic-type12 (make-type ops:in1 ops:out1 ops:out2)) + (set! generic-type22 (make-type ops:in1 ops:in2 ops:out1 ops:out2)))) (initialize-name-maps!) (initialize-conditions!)) -(define generic-input-type) -(define generic-output-type) -(define generic-i/o-type) -(define generic-no-i/o-type) +(define generic-type00) +(define generic-type10) +(define generic-type20) +(define generic-type01) +(define generic-type02) +(define generic-type11) +(define generic-type21) +(define generic-type12) +(define generic-type22) ;;;; Input operations @@ -163,31 +201,33 @@ USA. (input-buffer-channel ib))) (define (generic-io/input-blocking-mode port) - (if (channel-blocking? (generic-io/input-channel port)) - 'BLOCKING - 'NONBLOCKING)) + (let ((channel (generic-io/input-channel port))) + (if channel + (if (channel-blocking? channel) 'BLOCKING 'NONBLOCKING) + #f))) (define (generic-io/set-input-blocking-mode port mode) - (case mode - ((BLOCKING) (channel-blocking (generic-io/input-channel port))) - ((NONBLOCKING) (channel-nonblocking (generic-io/input-channel port))) - (else (error:wrong-type-datum mode "blocking mode")))) + (let ((channel (generic-io/input-channel port))) + (if channel + (case mode + ((BLOCKING) (channel-blocking channel)) + ((NONBLOCKING) (channel-nonblocking channel)) + (else (error:wrong-type-datum mode "blocking mode")))))) (define (generic-io/input-terminal-mode port) (let ((channel (generic-io/input-channel port))) - (cond ((not (channel-type=terminal? channel)) #f) - ((terminal-cooked-input? channel) 'COOKED) - (else 'RAW)))) + (if (and channel (channel-type=terminal? channel)) + (if (terminal-cooked-input? channel) 'COOKED 'RAW) + #f))) (define (generic-io/set-input-terminal-mode port mode) (let ((channel (generic-io/input-channel port))) - (if (channel-type=terminal? channel) + (if (and channel (channel-type=terminal? channel)) (case mode ((COOKED) (terminal-cooked-input channel)) ((RAW) (terminal-raw-input channel)) ((#F) unspecific) - (else (error:wrong-type-datum mode "terminal mode"))) - unspecific))) + (else (error:wrong-type-datum mode "terminal mode")))))) ;;;; Output operations @@ -220,31 +260,33 @@ USA. (output-buffer-channel ob))) (define (generic-io/output-blocking-mode port) - (if (channel-blocking? (generic-io/output-channel port)) - 'BLOCKING - 'NONBLOCKING)) + (let ((channel (generic-io/output-channel port))) + (if channel + (if (channel-blocking? channel) 'BLOCKING 'NONBLOCKING) + #f))) (define (generic-io/set-output-blocking-mode port mode) - (case mode - ((BLOCKING) (channel-blocking (generic-io/output-channel port))) - ((NONBLOCKING) (channel-nonblocking (generic-io/output-channel port))) - (else (error:wrong-type-datum mode "blocking mode")))) + (let ((channel (generic-io/output-channel port))) + (if channel + (case mode + ((BLOCKING) (channel-blocking channel)) + ((NONBLOCKING) (channel-nonblocking channel)) + (else (error:wrong-type-datum mode "blocking mode")))))) (define (generic-io/output-terminal-mode port) (let ((channel (generic-io/output-channel port))) - (cond ((not (channel-type=terminal? channel)) #f) - ((terminal-cooked-output? channel) 'COOKED) - (else 'RAW)))) + (if (and channel (channel-type=terminal? channel)) + (if (terminal-cooked-output? channel) 'COOKED 'RAW) + #f))) (define (generic-io/set-output-terminal-mode port mode) (let ((channel (generic-io/output-channel port))) - (if (channel-type=terminal? channel) + (if (and channel (channel-type=terminal? channel)) (case mode - ((COOKED) (terminal-cooked-output (generic-io/output-channel port))) - ((RAW) (terminal-raw-output (generic-io/output-channel port))) + ((COOKED) (terminal-cooked-output channel)) + ((RAW) (terminal-raw-output channel)) ((#F) unspecific) - (else (error:wrong-type-datum mode "terminal mode"))) - unspecific))) + (else (error:wrong-type-datum mode "terminal mode")))))) (define (generic-io/buffered-output-bytes port) (output-buffer-start (port-output-buffer port))) @@ -286,9 +328,7 @@ USA. (write (generic-io/input-channel port) output-port)) ((output-port? port) (write-string " for channel: " output-port) - (write (generic-io/output-channel port) output-port)) - (else - (write-string " for channel" output-port)))) + (write (generic-io/output-channel port) output-port)))) (define (generic-io/supports-coding? port) port @@ -324,12 +364,12 @@ USA. (define (generic-io/set-line-ending port name) (let ((state (port/state port))) - (let ((ib (gstate-input-buffer state)) - (ob (gstate-output-buffer state))) + (let ((ib (gstate-input-buffer state))) (if ib (set-input-buffer-line-ending! ib - (line-ending (input-buffer-channel ib) name #f))) + (line-ending (input-buffer-channel ib) name #f)))) + (let ((ob (gstate-output-buffer state))) (if ob (set-output-buffer-line-ending! ob @@ -354,7 +394,7 @@ USA. (and for-output? (known-input-line-ending? name) (not (known-output-line-ending? name)))) - (if (eq? 'TCP-STREAM-SOCKET (channel-type channel)) + (if (and channel (eq? 'TCP-STREAM-SOCKET (channel-type channel))) 'CRLF (default-line-ending)) name)) @@ -373,11 +413,11 @@ USA. environment (if (syntax-match? '(SYMBOL) (cdr form)) (let ((sing (cadr form))) - (let ((plur (symbol-append sing 'S)) - (proc (symbol-append 'DEFINE- sing))) - (let ((rev (symbol-append plur '-REVERSE)) - (aliases (symbol-append sing '-ALIASES)) - (aproc (symbol-append proc '-ALIAS))) + (let ((plur (symbol sing 'S)) + (proc (symbol 'DEFINE- sing))) + (let ((rev (symbol plur '-REVERSE)) + (aliases (symbol sing '-ALIASES)) + (aproc (symbol proc '-ALIAS))) `(BEGIN (DEFINE ,plur '()) (DEFINE ,rev) @@ -385,17 +425,18 @@ USA. (DEFINE (,proc NAME ,sing) (SET! ,plur (CONS (CONS NAME ,sing) ,plur)) NAME) - (DEFINE (,(symbol-append proc '/POST-BOOT) NAME ,sing) + (DEFINE (,(symbol proc '/POST-BOOT) NAME ,sing) (LET ((OLD (HASH-TABLE/GET ,plur NAME #F))) (IF OLD (HASH-TABLE/REMOVE! ,rev OLD))) - (HASH-TABLE/PUT! ,plur NAME ,sing)) + (HASH-TABLE/PUT! ,plur NAME ,sing) + (HASH-TABLE/PUT! ,rev ,sing NAME)) (DEFINE (,aproc NAME ALIAS) (SET! ,aliases (CONS (CONS NAME ALIAS) ,aliases)) NAME) - (DEFINE (,(symbol-append aproc '/POST-BOOT) NAME ALIAS) + (DEFINE (,(symbol aproc '/POST-BOOT) NAME ALIAS) (HASH-TABLE/PUT! ,aliases NAME ALIAS)) - (DEFINE (,(symbol-append 'NAME-> sing) NAME) + (DEFINE (,(symbol 'NAME-> sing) NAME) (LET LOOP ((NAME NAME)) (LET ((ALIAS (HASH-TABLE/GET ,aliases NAME #F))) (COND ((SYMBOL? ALIAS) (LOOP ALIAS)) @@ -463,17 +504,17 @@ USA. environment (if (syntax-match? '(SYMBOL) (cdr form)) (let ((sing (cadr form))) - (let ((plur (symbol-append sing 'S)) - (aliases (symbol-append sing '-ALIASES)) - (proc (symbol-append 'DEFINE- sing))) - (let ((aproc (symbol-append proc '-ALIAS))) + (let ((plur (symbol sing 'S)) + (aliases (symbol sing '-ALIASES)) + (proc (symbol 'DEFINE- sing))) + (let ((aproc (symbol proc '-ALIAS))) `(BEGIN - (SET! ,(symbol-append plur '-REVERSE) + (SET! ,(symbol plur '-REVERSE) (CONVERT-REVERSE ,plur)) (SET! ,plur (CONVERT-FORWARD ,plur)) - (SET! ,proc ,(symbol-append proc '/POST-BOOT)) + (SET! ,proc ,(symbol proc '/POST-BOOT)) (SET! ,aliases (CONVERT-FORWARD ,aliases)) - (SET! ,aproc ,(symbol-append aproc '/POST-BOOT)))))) + (SET! ,aproc ,(symbol aproc '/POST-BOOT)))))) (ill-formed-syntax form)))))) (initialize-name-map decoder) (initialize-name-map encoder) @@ -490,6 +531,81 @@ USA. (define binary-normalizer) (define binary-denormalizer) +(define-structure (source (constructor make-gsource) (conc-name source/)) + (get-channel #f read-only #t) + (get-port #f read-only #t) + (set-port #f read-only #t) + (open? #f read-only #t) + (close #f read-only #t) + (has-input? #f read-only #t) + (read #f read-only #t)) + +(define-guarantee source "byte source") + +(define (->source object #!optional caller) + (if (channel? object) + (make-channel-source object) + (begin + (guarantee-source object caller) + object))) + +(define (make-channel-source channel) + (make-gsource (lambda () channel) + (lambda () (channel-port channel)) + (lambda (port) (set-channel-port! channel port)) + (lambda () (channel-open? channel)) + (lambda () (channel-close channel)) + (lambda () (channel-has-input? channel)) + (lambda (string start end) + (channel-read channel string start end)))) + +(define (make-non-channel-source has-input? read-substring) + (let ((port #f) + (open? #t)) + (make-gsource (lambda () #f) + (lambda () port) + (lambda (port*) (set! port port*) unspecific) + (lambda () open?) + (lambda () (set! open? #f) unspecific) + has-input? + read-substring))) + +(define-structure (sink (constructor make-gsink) (conc-name sink/)) + (get-channel #f read-only #t) + (get-port #f read-only #t) + (set-port #f read-only #t) + (open? #f read-only #t) + (close #f read-only #t) + (write #f read-only #t)) + +(define-guarantee sink "byte sink") + +(define (->sink object #!optional caller) + (if (channel? object) + (make-channel-sink object) + (begin + (guarantee-sink object caller) + object))) + +(define (make-channel-sink channel) + (make-gsink (lambda () channel) + (lambda () (channel-port channel)) + (lambda (port) (set-channel-port! channel port)) + (lambda () (channel-open? channel)) + (lambda () (channel-close channel)) + (lambda (string start end) + (channel-write channel string start end)))) + +(define (make-non-channel-sink write-substring) + (let ((port #f) + (open? #t)) + (make-gsink (lambda () #f) + (lambda () port) + (lambda (port*) (set! port port*) unspecific) + (lambda () open?) + (lambda () (set! open? #f) unspecific) + write-substring))) + ;;;; Input buffer (define-integrable page-size #x1000) @@ -500,37 +616,35 @@ USA. (fix:- (fix:* max-char-bytes 2) 1))) (define-structure (input-buffer (constructor %make-input-buffer)) - (channel #f read-only #t) + (source #f read-only #t) (bytes #f read-only #t) start end decode normalize) -(define (make-input-buffer channel) - (make-input-buffer-1 channel 'TEXT)) - -(define (make-binary-input-buffer channel) - (make-input-buffer-1 channel 'BINARY)) - -(define (make-input-buffer-1 channel type) - (%make-input-buffer channel +(define (make-input-buffer source type) + (%make-input-buffer source (make-string byte-buffer-length) byte-buffer-length byte-buffer-length (name->decoder type) - (name->normalizer (line-ending channel type #f)))) + (name->normalizer + (line-ending ((source/get-channel source)) type #f)))) -(define-integrable (input-buffer-open? ib) - (channel-open? (input-buffer-channel ib))) +(define (input-buffer-open? ib) + ((source/open? (input-buffer-source ib)))) (define (close-input-buffer ib) (set-input-buffer-start! ib 0) (set-input-buffer-end! ib 0) - (channel-close (input-buffer-channel ib))) + ((source/close (input-buffer-source ib)))) -(define-integrable (input-buffer-port ib) - (channel-port (input-buffer-channel ib))) +(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)) @@ -565,7 +679,7 @@ USA. (set-input-buffer-start! ib bs) #t) (and (not (input-buffer-at-eof? ib)) - (channel-has-input? (input-buffer-channel ib)) + ((source/has-input? (input-buffer-source ib))) (begin (justify-input-buffer ib) (read-bytes ib) @@ -591,10 +705,10 @@ USA. (define (read-bytes ib) (let ((available (input-buffer-byte-count ib))) (let ((n - (channel-read (input-buffer-channel ib) - (input-buffer-bytes ib) - available - (fix:+ available page-size)))) + ((source/read (input-buffer-source ib)) + (input-buffer-bytes ib) + available + (fix:+ available page-size)))) (if n (begin (set-input-buffer-start! ib 0) @@ -650,7 +764,7 @@ USA. (%substring-move! bv bs be string start) (set-input-buffer-start! ib be) n)) - (channel-read (input-buffer-channel ib) string start end))) + ((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) @@ -664,7 +778,7 @@ USA. (xsubstring-move! bv bs be string start) (set-input-buffer-start! ib be) n)) - (channel-read (input-buffer-channel ib) string start end))) + ((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))) @@ -701,36 +815,35 @@ USA. ;;;; Output buffer (define-structure (output-buffer (constructor %make-output-buffer)) - (channel #f read-only #t) + (sink #f read-only #t) (bytes #f read-only #t) start encode denormalize) -(define (make-output-buffer channel) - (make-output-buffer-1 channel 'TEXT)) - -(define (make-binary-output-buffer channel) - (make-output-buffer-1 channel 'BINARY)) - -(define (make-output-buffer-1 channel type) - (%make-output-buffer channel +(define (make-output-buffer sink type) + (%make-output-buffer sink (make-string byte-buffer-length) 0 (name->encoder type) - (name->denormalizer (line-ending channel type #t)))) + (name->denormalizer + (line-ending ((sink/get-channel sink)) type #t)))) -(define-integrable (output-buffer-open? ob) - (channel-open? (output-buffer-channel ob))) +(define (output-buffer-open? ob) + ((sink/open? (output-buffer-sink ob)))) (define (close-output-buffer ob) - (if (output-buffer-open? ob) - (begin - (force-drain-output-buffer ob) - (channel-close (output-buffer-channel ob))))) + (let ((sink (output-buffer-sink ob))) + (if ((sink/open? sink)) + (begin + (force-drain-output-buffer ob) + ((sink/close sink)))))) + +(define (output-buffer-channel ob) + ((sink/get-channel (output-buffer-sink ob)))) -(define-integrable (output-buffer-port ob) - (channel-port (output-buffer-channel ob))) +(define (output-buffer-port ob) + ((sink/get-port (output-buffer-sink ob)))) (define-integrable (output-buffer-end ob) (string-length (output-buffer-bytes ob))) @@ -739,22 +852,26 @@ USA. (set-output-buffer-start! buffer 0)) (define (force-drain-output-buffer ob) - (with-channel-blocking (output-buffer-channel ob) #t - (lambda () - (let loop () - (drain-output-buffer ob) - (if (fix:> (output-buffer-start ob) 0) - (loop)))))) + (let ((channel (output-buffer-channel ob)) + (drain-buffer + (lambda () + (let loop () + (drain-output-buffer ob) + (if (fix:> (output-buffer-start ob) 0) + (loop)))))) + (if channel + (with-channel-blocking channel #t drain-buffer) + (drain-buffer)))) (define (drain-output-buffer ob) (let ((bs (output-buffer-start ob))) (if (fix:> bs 0) (let ((bv (output-buffer-bytes ob))) (let ((n - (channel-write (output-buffer-channel ob) - bv - 0 - (fix:min bs page-size)))) + ((sink/write (output-buffer-sink ob)) + bv + 0 + (fix:min bs page-size)))) (if (and n (fix:> n 0)) (do ((bi n (fix:+ bi 1)) (bj 0 (fix:+ bj 1))) @@ -874,8 +991,8 @@ USA. (let ((name (intern (string-append "iso-8859-" (number->string (cadr form)))))) - (let ((decoding-map (symbol-append 'DECODING-MAP: name)) - (encoding-map (symbol-append 'ENCODING-MAP: name))) + (let ((decoding-map (symbol 'DECODING-MAP: name)) + (encoding-map (symbol 'ENCODING-MAP: name))) `(BEGIN (DEFINE-DECODER ',name (LET ((,decoding-map diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 78cd5c33d..7317aa5fb 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.566 2005/11/29 06:46:06 cph Exp $ +$Id: runtime.pkg,v 14.567 2005/12/12 21:48:29 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -1724,7 +1724,7 @@ USA. (export () make-generic-i/o-port) (export (runtime console-i/o-port) - generic-i/o-type + generic-i/o-port-type generic-io/char-ready? generic-io/flush-output generic-io/read-char @@ -1733,19 +1733,20 @@ USA. port-input-buffer set-input-buffer-contents!) (export (runtime file-i/o-port) - generic-i/o-type - generic-input-type - generic-output-type + generic-i/o-port-type make-gstate) (export (runtime string-input) - generic-no-i/o-type - make-gstate) + generic-i/o-port-type + make-gstate + make-non-channel-source) (export (runtime string-output) - generic-no-i/o-type - make-gstate) + generic-i/o-port-type + make-gstate + make-non-channel-sink) (export (runtime truncated-string-output) - generic-no-i/o-type - make-gstate) + generic-i/o-port-type + make-gstate + make-non-channel-sink) (initialization (initialize-package!))) (define-package (runtime gensym) @@ -4035,6 +4036,7 @@ USA. (files "strott") (parent (runtime)) (export () + call-with-truncated-output-string with-output-to-truncated-string) (initialization (initialize-package!))) diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index 3a769a051..96484d95b 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strnin.scm,v 14.14 2005/11/29 06:50:59 cph Exp $ +$Id: strnin.scm,v 14.15 2005/12/12 21:52:35 cph Exp $ Copyright 1988,1990,1993,1999,2003,2004 Massachusetts Institute of Technology Copyright 2005 Massachusetts Institute of Technology @@ -44,37 +44,29 @@ USA. 0 (guarantee-substring-start-index start end 'OPEN-INPUT-STRING)))) (make-port input-string-port-type - (make-gstate #f #f 'TEXT string start end)))) + (make-gstate (make-string-source string start end) #f 'TEXT)))) + +(define (make-string-source string start end) + (let ((index start)) + (make-non-channel-source + (lambda () + (fix:< index end)) + (lambda (string* start* end*) + (let ((n + (fix:min (fix:- end index) + (fix:- end* start*)))) + (let ((limit (fix:+ index n))) + (substring-move! string index limit string* start) + (set! index limit)) + n))))) (define input-string-port-type) (define (initialize-package!) (set! input-string-port-type (make-port-type - `((CHAR-READY? - ,(lambda (port) - (let ((s (port/state port))) - (fix:< (istate-start s) (istate-end s))))) - (READ-CHAR - ,(lambda (port) - (let ((s (port/state port))) - (without-interrupts - (lambda () - (let ((start (istate-start s))) - (if (fix:< start (istate-end s)) - (begin - (set-istate-start! s (fix:+ start 1)) - (string-ref (istate-string s) start)) - (make-eof-object port)))))))) - (WRITE-SELF + `((WRITE-SELF ,(lambda (port output-port) port (write-string " from string" output-port)))) - generic-no-i/o-type)) - unspecific) - -(define-structure (istate (type vector) - (initial-offset 4) ;must match "genio.scm" - (constructor #f)) - (string #f read-only #t) - start - (end #f read-only #t)) \ No newline at end of file + (generic-i/o-port-type #t #f))) + unspecific) \ No newline at end of file diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm index 03ff27067..184c7aac6 100644 --- a/v7/src/runtime/strott.scm +++ b/v7/src/runtime/strott.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strott.scm,v 14.13 2005/11/29 06:52:28 cph Exp $ +$Id: strott.scm,v 14.14 2005/12/12 21:55:23 cph Exp $ Copyright 1988,1993,1999,2004,2005 Massachusetts Institute of Technology @@ -23,67 +23,107 @@ USA. |# -;;;; String Output Ports (Truncated) +;;;; String output ports (truncated) ;;; package: (runtime truncated-string-output) (declare (usual-integrations)) -(define (with-output-to-truncated-string max thunk) +(define (call-with-truncated-output-string limit generator) (call-with-current-continuation (lambda (k) - (let ((state - (make-gstate #f #f 'TEXT k max (make-string (fix:min max 128)) 0))) - (with-output-to-port (make-port output-string-port-type state) - thunk) - (cons #f - (without-interrupts - (lambda () - (string-head (astate-chars state) - (astate-index state))))))))) + (let ((port + (make-port output-string-port-type + (receive (sink extract extract!) + (make-accumulator-sink limit k) + (make-gstate #f sink 'TEXT extract extract!))))) + (generator port) + (cons #f (get-output-string port)))))) + +(define (with-output-to-truncated-string max thunk) + (call-with-truncated-output-string max + (lambda (port) + (with-output-to-port port thunk)))) + +(define-structure (astate (type vector) + (initial-offset 4) ;must match "genio.scm" + (constructor #f)) + extract + extract!) (define output-string-port-type) (define (initialize-package!) (set! output-string-port-type (make-port-type - `((WRITE-CHAR - ,(lambda (port char) - (guarantee-8-bit-char char) - (let ((state (port/state port))) - (without-interrupts - (lambda () - (let* ((n (astate-index state))) - (if (fix:< n (astate-max-length state)) - (let ((n* (fix:+ n 1))) - (if (fix:= n (string-length (astate-chars state))) - (grow-accumulator! state n*)) - (string-set! (astate-chars state) n char) - (set-astate-index! state n*)) - ((astate-return state) - (cons #t (string-copy (astate-chars state))))))))) - 1)) + `((EXTRACT-OUTPUT + ,(lambda (port) + (output-port/flush-output port) + ((astate-extract (port/state port))))) + (EXTRACT-OUTPUT! + ,(lambda (port) + (output-port/flush-output port) + ((astate-extract! (port/state port))))) (WRITE-SELF ,(lambda (port output-port) port (write-string " to string (truncating)" output-port)))) - generic-no-i/o-type)) + (generic-i/o-port-type #f #t))) unspecific) + +(define (make-accumulator-sink limit k) + (let ((chars #f) + (index 0)) -(define-structure (astate (type vector) - (initial-offset 4) ;must match "genio.scm" - (constructor #f)) - (return #f read-only #t) - (max-length #f read-only #t) - chars - index) - -(define (grow-accumulator! state min-size) - (let* ((old (astate-chars state)) - (n (string-length old)) - (new - (make-string - (let loop ((n (fix:+ n n))) - (if (fix:>= n min-size) - (fix:min n (astate-max-length state)) - (loop (fix:+ n n))))))) - (substring-move! old 0 n new 0) - (set-astate-chars! state new))) \ No newline at end of file + (define (normal-case string start end n) + (cond ((not chars) + (set! chars (new-chars 128 n))) + ((fix:> n (string-length chars)) + (let ((new (new-chars (string-length chars) n))) + (substring-move! chars 0 index new 0) + (set! chars new)))) + (substring-move! string start end chars index) + (set! index n) + (fix:- end start)) + + (define (new-chars start min-length) + (make-string + (let loop ((n start)) + (cond ((fix:>= n limit) limit) + ((fix:>= n min-length) n) + (else (loop (fix:+ n n))))))) + + (define (limit-case string start) + (let ((s + (cond ((not chars) (make-string limit)) + ((fix:> limit (string-length chars)) + (let ((s (make-string limit))) + (substring-move! chars 0 index s 0) + s)) + (else chars)))) + (substring-move! string start (fix:+ start (fix:- limit index)) + s index) + (set! chars #f) + (set! index 0) + (k (cons #t s)))) + + (values (make-non-channel-sink + (lambda (string start end) + (without-interrupts + (lambda () + (let ((n (fix:+ index (fix:- end start)))) + (if (fix:<= n limit) + (normal-case string start end n) + (limit-case string start))))))) + (lambda () + (if chars + (string-head chars index) + (make-string 0))) + (lambda () + (without-interrupts + (lambda () + (if chars + (let ((s chars)) + (set! chars #f) + (set! index 0) + (set-string-maximum-length! s index) + s) + (make-string 0)))))))) \ No newline at end of file diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm index d5977d0e3..cef6a7ed3 100644 --- a/v7/src/runtime/strout.scm +++ b/v7/src/runtime/strout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strout.scm,v 14.21 2005/11/29 06:54:11 cph Exp $ +$Id: strout.scm,v 14.22 2005/12/12 21:55:39 cph Exp $ Copyright 1988,1990,1993,1999,2000,2001 Massachusetts Institute of Technology Copyright 2003,2004,2005 Massachusetts Institute of Technology @@ -31,7 +31,8 @@ USA. (define (open-output-string) (make-port accumulator-output-port-type - (make-gstate #f #f 'TEXT #f #f))) + (receive (sink extract extract!) (make-accumulator-sink) + (make-gstate #f sink 'TEXT extract extract!)))) (define (get-output-string port) ((port/operation port 'EXTRACT-OUTPUT) port)) @@ -52,79 +53,70 @@ USA. (define-structure (astate (type vector) (initial-offset 4) ;must match "genio.scm" (constructor #f)) - chars - index) - -(define (maybe-reset-astate state) - (if (not (astate-chars state)) - (begin - (set-astate-chars! state (make-string 128)) - (set-astate-index! state 0)))) - -(define (maybe-grow-accumulator! state min-size) - (if (fix:> min-size (string-length (astate-chars state))) - (let* ((old (astate-chars state)) - (n (string-length old)) - (new - (make-string - (let loop ((n (fix:+ n n))) - (if (fix:>= n min-size) - n - (loop (fix:+ n n))))))) - (substring-move! old 0 n new 0) - (set-astate-chars! state new)))) - + extract + extract!) + (define accumulator-output-port-type) (define (initialize-package!) (set! accumulator-output-port-type (make-port-type `((EXTRACT-OUTPUT ,(lambda (port) - (let ((state (port/state port))) - (if (astate-chars state) - (string-head (astate-chars state) - (astate-index state)) - (make-string 0))))) + (output-port/flush-output port) + ((astate-extract (port/state port))))) (EXTRACT-OUTPUT! ,(lambda (port) - (let ((state (port/state port))) - (without-interrupts - (lambda () - (let ((s (astate-chars state))) - (if s - (begin - (set-astate-chars! state #f) - (set-string-maximum-length! s (astate-index state)) - s) - (make-string 0)))))))) - (WRITE-CHAR - ,(lambda (port char) - (guarantee-8-bit-char char) - (let ((state (port/state port))) - (without-interrupts - (lambda () - (maybe-reset-astate state) - (let* ((n (astate-index state)) - (n* (fix:+ n 1))) - (maybe-grow-accumulator! state n*) - (string-set! (astate-chars state) n char) - (set-astate-index! state n*))))) - 1)) - (WRITE-SUBSTRING - ,(lambda (port string start end) - (let ((state (port/state port))) - (without-interrupts - (lambda () - (maybe-reset-astate state) - (let* ((n (astate-index state)) - (n* (fix:+ n (fix:- end start)))) - (maybe-grow-accumulator! state n*) - (substring-move! string start end (astate-chars state) n) - (set-astate-index! state n*))))) - (fix:- end start))) + (output-port/flush-output port) + ((astate-extract! (port/state port))))) (WRITE-SELF ,(lambda (port output-port) port (write-string " to string" output-port)))) - generic-no-i/o-type)) - unspecific) \ No newline at end of file + (generic-i/o-port-type #f #t))) + unspecific) + +(define (make-accumulator-sink) + (let ((chars #f) + (index 0)) + + (define (write-substring string start end) + (let ((n (fix:+ index (fix:- end start)))) + (cond ((not chars) + (set! chars (new-chars 128 n))) + ((fix:> n (string-length chars)) + (set! chars + (let ((new (new-chars (string-length chars) n))) + (substring-move! chars 0 index new 0) + new)))) + (substring-move! string start end chars index) + (set! index n) + (fix:- end start))) + + (define (new-chars start min-length) + (make-string + (let loop ((n start)) + (if (fix:>= n min-length) + n + (loop (fix:+ n n)))))) + + (values (make-non-channel-sink + (lambda (string start end) + (without-interrupts + (lambda () + (write-substring string start end))))) + (lambda () + (without-interrupts + (lambda () + (if chars + (string-head chars index) + (make-string 0))))) + (lambda () + (without-interrupts + (lambda () + (if chars + (let ((s chars)) + (set! chars #f) + (set! index 0) + (set-string-maximum-length! s index) + s) + (make-string 0)))))))) \ No newline at end of file diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm index 5081c1d24..2f6bb6fa7 100644 --- a/v7/src/runtime/ttyio.scm +++ b/v7/src/runtime/ttyio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ttyio.scm,v 1.21 2005/03/20 16:09:46 cph Exp $ +$Id: ttyio.scm,v 1.22 2005/12/12 21:55:44 cph Exp $ Copyright 1991,1993,1996,1999,2003,2004 Massachusetts Institute of Technology Copyright 2005 Massachusetts Institute of Technology @@ -31,7 +31,8 @@ USA. (define (initialize-package!) (let ((input-channel (tty-input-channel)) - (output-channel (tty-output-channel))) + (output-channel (tty-output-channel)) + (gtype (generic-i/o-port-type 'CHANNEL 'CHANNEL))) (let ((type (make-port-type `((BEEP ,operation/beep) @@ -43,14 +44,17 @@ USA. (WRITE-SELF ,operation/write-self) (X-SIZE ,operation/x-size) (Y-SIZE ,operation/y-size)) - generic-i/o-type))) + gtype))) (let ((port (make-port type (make-cstate input-channel output-channel)))) (set-channel-port! input-channel port) (set-channel-port! output-channel port) (set! the-console-port port) (set-console-i/o-port! port) (set-current-input-port! port) - (set-current-output-port! port)))) + (set-current-output-port! port))) + (set! *char-ready? (port-type/char-ready? gtype)) + (set! *read-char (port-type/read-char gtype)) + (set! *unread-char (port-type/unread-char gtype))) (add-event-receiver! event:before-exit save-console-input) (add-event-receiver! event:after-restore reset-console)) @@ -96,6 +100,9 @@ USA. (define console-i/o-port) (define console-input-port) (define console-output-port) +(define *char-ready?) +(define *read-char) +(define *unread-char) (define (operation/read-char port) (let ((char (generic-io/read-char port))) @@ -111,14 +118,14 @@ USA. (define (operation/read-finish port) (let loop () - (if ((port-type/char-ready? generic-i/o-type) port) - (let ((char ((port-type/read-char generic-i/o-type) port))) + (if (*char-ready? port) + (let ((char (*read-char port))) (if (not (eof-object? char)) (begin (maybe-echo-input port char) (if (char-whitespace? char) (loop) - ((port-type/unread-char generic-i/o-type) port char))))))) + (*unread-char port char))))))) (output-port/discretionary-flush port)) (define (maybe-echo-input port char)