Implement input port from external string.

diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index f88d35b46876eedac0589f61a69b21e4f62f60cd..355a362a2d0ba3988b26586dda0d027ed3795467 100644 (file)
--- 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))))))
+\f
+;;;; 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 74cc8c2a60bc5eb3d611d3a4d72d77e5fb09963e..1e38a92904b604dd9a5bc0c8be8449387d2907bb 100644 (file)
--- 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