Implement new I/O port operations READ-SUBSTRING and WRITE-SUBSTRING

that do block I/O to or from part of a given string.

diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index 9be5c4981a8216a2c07331872c7f38dc7b24b10e..c4b81f82cd0393cd3221c52172fba4a53d1e4da8 100644 (file)
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.8 1990/11/02 02:06:32 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.9 1991/04/11 03:24:12 cph Exp $
 
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -56,6 +56,7 @@ MIT in each case. |#
   state
   (operation/write-char false read-only true)
   (operation/write-string false read-only true)
+  (operation/write-substring false read-only true)
   (operation/flush-output false read-only true)
   (custom-operations false read-only true)
   (operation-names false read-only true))
@@ -78,51 +79,71 @@ MIT in each case. |#
       (case name
        ((WRITE-CHAR) output-port/write-char)
        ((WRITE-STRING) output-port/write-string)
+       ((WRITE-SUBSTRING) output-port/write-substring)
        ((FLUSH-OUTPUT) output-port/flush-output)
        (else false))))
-
+\f
 (define (make-output-port operations state)
   (let ((operations
         (map (lambda (entry)
                (cons (car entry) (cadr entry)))
              operations)))
     (let ((operation
-          (lambda (name default)
+          (lambda (name)
             (let ((entry (assq name operations)))
-              (if entry
-                  (begin (set! operations (delq! entry operations))
-                         (cdr entry))
-                  (or default
-                      (error "MAKE-OUTPUT-PORT: missing operation" name)))))))
-      (let ((write-char (operation 'WRITE-CHAR false))
-           (write-string
-            (operation 'WRITE-STRING default-operation/write-string))
-           (flush-output
-            (operation 'FLUSH-OUTPUT default-operation/flush-output)))
-       (%make-output-port state write-char write-string flush-output
+              (and entry
+                   (begin
+                     (set! operations (delq! entry operations))
+                     (cdr entry)))))))
+      (let ((write-char (operation 'WRITE-CHAR))
+           (write-string (operation 'WRITE-STRING))
+           (write-substring (operation 'WRITE-SUBSTRING))
+           (flush-output (operation 'FLUSH-OUTPUT)))
+       (if (not (or write-char write-substring))
+           (error "Must specify at least one of the following:"
+                  '(WRITE-CHAR WRITE-SUBSTRING)))
+       (%make-output-port state
+                          (or write-char default-operation/write-char)
+                          (or write-string default-operation/write-string)
+                          (or write-substring
+                              default-operation/write-substring)
+                          (or flush-output default-operation/flush-output)
                           operations
-                          (append '(WRITE-CHAR WRITE-STRING FLUSH-OUTPUT)
+                          (append '(WRITE-CHAR WRITE-STRING WRITE-SUBSTRING
+                                               FLUSH-OUTPUT)
                                   (map car operations)))))))
 
+(define (default-operation/write-char port char)
+  ((output-port/operation/write-substring port) port (char->string char) 0 1))
+
 (define (default-operation/write-string port string)
-  (let ((write-char (output-port/operation/write-char port))
-       (end (string-length string)))
-    (let loop ((index 0))
+  ((output-port/operation/write-substring port)
+   port
+   string 0 (string-length string)))
+
+(define (default-operation/write-substring port string start end)
+  (let ((write-char (output-port/operation/write-char port)))
+    (let loop ((index start))
       (if (< index end)
-         (begin (write-char port (string-ref string index))
-                (loop (1+ index)))))))
+         (begin
+           (write-char port (string-ref string index))
+           (loop (+ index 1)))))))
 
 (define (default-operation/flush-output port)
   port
-  false)
+  unspecific)
 \f
 (define (output-port/write-char port char)
   ((output-port/operation/write-char port) port char))
 
 (define (output-port/write-string port string)
-  (let ((length (string-length string)))
-    (if (positive? length)
-       ((output-port/operation/write-string port) port string))))
+  ((output-port/operation/write-string port) port string))
+
+(define (output-port/write-substring port string start end)
+  ((output-port/operation/write-substring port) port string start end))
+
+(define (output-port/write-object port object)
+  (unparse-object/internal object port 0 true (current-unparser-table)))
 
 (define (output-port/flush-output port)
   ((output-port/operation/flush-output port) port))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 644565118423322876250ac1e7cd0b33e517e885..c5f1a9e2c0ba2ed81ef6fd83de882315aee0eccb 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.99 1991/03/14 04:29:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.100 1991/04/11 03:24:25 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -763,6 +763,7 @@ MIT in each case. |#
          operation/read-char
          operation/read-chars
          operation/read-string
+         operation/read-substring
          operation/set-buffer-size)
   (initialization (initialize-package!)))
 
@@ -785,7 +786,8 @@ MIT in each case. |#
          operation/flush-output
          operation/set-buffer-size
          operation/write-char
-         operation/write-string)
+         operation/write-string
+         operation/write-substring)
   (initialization (initialize-package!)))
 
 (define-package (runtime gensym)
@@ -1299,7 +1301,9 @@ MIT in each case. |#
          output-port/operation-names
          output-port/state
          output-port/write-char
+         output-port/write-object
          output-port/write-string
+         output-port/write-substring
          output-port/x-size
          output-port?
          set-current-output-port!
@@ -1552,6 +1556,7 @@ MIT in each case. |#
          output-buffer/size
          output-buffer/write-char-block
          output-buffer/write-string-block
+         output-buffer/write-substring-block
          set-channel-port!)
   (export (runtime file-input)
          input-buffer/chars-remaining

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 4424ebdd08698b5b8d06e0551ea6ab5e74a4d78f..e90e17c43b7011e55acac2ed450b0e612be45e1b 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.114 1991/04/08 22:34:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.115 1991/04/11 03:24:32 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 114))
+  (add-identification! "Runtime" 14 115))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index bfb3593757ab1565bc7e3e06832ba404ab0d9a0c..5d181200b7114993d9fb68fa32fb12f0e0be2bd1 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.99 1991/03/14 04:29:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.100 1991/04/11 03:24:25 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -763,6 +763,7 @@ MIT in each case. |#
          operation/read-char
          operation/read-chars
          operation/read-string
+         operation/read-substring
          operation/set-buffer-size)
   (initialization (initialize-package!)))
 
@@ -785,7 +786,8 @@ MIT in each case. |#
          operation/flush-output
          operation/set-buffer-size
          operation/write-char
-         operation/write-string)
+         operation/write-string
+         operation/write-substring)
   (initialization (initialize-package!)))
 
 (define-package (runtime gensym)
@@ -1299,7 +1301,9 @@ MIT in each case. |#
          output-port/operation-names
          output-port/state
          output-port/write-char
+         output-port/write-object
          output-port/write-string
+         output-port/write-substring
          output-port/x-size
          output-port?
          set-current-output-port!
@@ -1552,6 +1556,7 @@ MIT in each case. |#
          output-buffer/size
          output-buffer/write-char-block
          output-buffer/write-string-block
+         output-buffer/write-substring-block
          set-channel-port!)
   (export (runtime file-input)
          input-buffer/chars-remaining