From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 11 Apr 1991 03:24:32 +0000 (+0000)
Subject: Implement new I/O port operations READ-SUBSTRING and WRITE-SUBSTRING
X-Git-Tag: 20090517-FFI~10763
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=be6ca24fe27c0bc8a84bb3f42fb44c83879fc545;p=mit-scheme.git

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 9be5c4981..c4b81f82c 100644
--- 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))))
-
+
 (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)
 
 (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 644565118..c5f1a9e2c 100644
--- 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 4424ebdd0..e90e17c43 100644
--- 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 bfb359375..5d181200b 100644
--- 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