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 d9aaf379b989a510080fd3a3d489921e012664cb..4fc6c55e32a357d84d2c89fc21c79104760dcb38 100644 (file)
--- 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 5cab1743f8260c790db0079625a05631cb52f892..6b23c1a99dab8f045f8291f4c736cf7f05978f5d 100644 (file)
--- 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))
 \f
-(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)))
 \f
 (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)
 \f
 ;;;; 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"))))))
 \f
 ;;;; 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))))
 \f
 (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)
 \f
+(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)))
+\f
 ;;;; 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))))
 \f
 (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 78cd5c33d44a1db4f4e9f83212be0df8f8133e98..7317aa5fb9c530e1486d9de975ca7e157901dd20 100644 (file)
--- 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 3a769a0513f60c67095c50a92a2d87215a23c823..96484d95b70715b15bfebc01bed27e385c488da7 100644 (file)
--- 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 03ff27067a9e082bebbaac059f28cf7b41879311..184c7aac6d8999be87f779fda8a3ea076843a302 100644 (file)
--- 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))
 \f
-(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)
+\f
+(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 d5977d0e3e76012d14abb3538b81ed944f33e614..cef6a7ed3353b1c4bfc2524f810b19f4ac2e7766 100644 (file)
--- 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.
 \f
 (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))))
-\f
+  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)
+\f
+(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 5081c1d247bd6a34db233a0da21d5542811fa2d8..2f6bb6fa7d0f859b364c2e3c2ab00d0dfead2d5d 100644 (file)
--- 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.
 \f
 (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)
 \f
 (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)