From f849b804d5707300434681c80d32d4e49b2a87ed Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 4 Jan 2001 23:24:21 +0000
Subject: [PATCH] Implement input port from external string.

---
 v7/src/imail/imail-util.scm | 85 ++++++++++++++++++++++++++++++++++++-
 v7/src/imail/load.scm       |  4 +-
 2 files changed, 85 insertions(+), 4 deletions(-)

diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index f88d35b46..355a362a2 100644
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.29 2000/06/29 22:01:52 cph Exp $
+;;; $Id: imail-util.scm,v 1.30 2001/01/04 23:23:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -363,4 +363,85 @@
 	   condition
 	   (k #f))
        (lambda ()
-	 (file-directory? pathname))))))
\ No newline at end of file
+	 (file-directory? pathname))))))
+
+;;;; Extended-string input port
+
+(define (open-xstring-input-port xstring)
+  (make-port xstring-input-type
+	     (let ((state (make-xstring-input-state xstring)))
+	       (read-xstring-buffer state 0)
+	       state)))
+
+(define (call-with-input-xstring xstring receiver)
+  (let ((port (open-xstring-input-port xstring)))
+    (let ((value (receiver port)))
+      (close-port port)
+      value)))
+
+(define (xstring-input/read-char port)
+  (without-interrupts
+   (lambda ()
+     (let ((char (xstring-input/peek-char port))
+	   (state (port/state port)))
+       (if (char? char)
+	   (set-xstring-input-state/position!
+	    state
+	    (+ (xstring-input-state/position state) 1)))
+       char))))
+
+(define (xstring-input/peek-char port)
+  (let ((state (port/state port)))
+    (let ((position (xstring-input-state/position state)))
+      (if (>= position (xstring-input-state/buffer-end state))
+	  (read-xstring-buffer state))
+      (if (< position (xstring-input-state/buffer-end state))
+	  (string-ref (xstring-input-state/buffer state)
+		      (- position (xstring-input-state/buffer-start state)))
+	  (make-eof-object port)))))
+
+(define (xstring-input/length port)
+  (external-string-length (xstring-input-state/xstring (port/state port))))
+
+(define (xstring-input/position port)
+  (xstring-input-state/position (port/state port)))
+
+(define (xstring-input/eof? port)
+  (let ((state (port/state port)))
+    (= (xstring-input-state/buffer-start state)
+       (xstring-input-state/buffer-end state))))
+
+(define (xstring-input/close port)
+  (set-xstring-input-state/xstring! (port/state port) #f))
+
+(define xstring-input-type
+  (make-port-type `((READ-CHAR ,xstring-input/read-char)
+		    (PEEK-CHAR ,xstring-input/peek-char)
+		    (LENGTH ,xstring-input/length)
+		    (POSITION ,xstring-input/position)
+		    (EOF? ,xstring-input/eof?)
+		    (CLOSE ,xstring-input/close))
+		  #f))
+
+(define-structure (xstring-input-state
+		   (constructor make-xstring-input-state (xstring))
+		   (conc-name xstring-input-state/))
+  (xstring #f)
+  (position 0)
+  (buffer (make-string 512))
+  (buffer-start #f)
+  (buffer-end 0))
+
+(define (read-xstring-buffer state)
+  (let ((xstring (xstring-input-state/xstring state))
+	(buffer (xstring-input-state/buffer state))
+	(start (xstring-input-state/buffer-end state)))
+    (let ((xend (external-string-length xstring)))
+      (if (< start xend)
+	  (let ((end (max (+ start (string-length buffer)) xend)))
+	    (without-interrupts
+	     (lambda ()
+	       (set-xstring-input-state/buffer-start! state start)
+	       (set-xstring-input-state/buffer-end! state end)
+	       (substring-move-left! xstring start end buffer 0))))
+	  (set-xstring-input-state/buffer-start! state xend)))))
\ No newline at end of file
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 74cc8c2a6..1e38a9290 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.23 2000/12/29 03:40:32 cph Exp $
+;;; $Id: load.scm,v 1.24 2001/01/04 23:24:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -27,4 +27,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (package/system-loader "imail" '() 'QUERY))))
-(add-subsystem-identification! "IMAIL" '(1 8))
\ No newline at end of file
+(add-subsystem-identification! "IMAIL" '(1 9))
\ No newline at end of file
-- 
2.25.1