Re-use string output port within read

* module/ice-9/read.scm (read): Just have one string output port during
  the read.

module/ice-9/read.scm

@@ -134,6 +134,14 @@
   (define (peek) (lookahead-char port))
   (define filename (port-filename port))
   (define (get-pos) (cons (port-line port) (port-column port)))
+  (define accumulator (open-output-string))
+  (define-syntax-rule (accumulate proc)
+    (begin
+      (proc (lambda (ch) (put-char accumulator ch)))
+      (let ((str (get-output-string accumulator)))
+        (seek accumulator 0 SEEK_SET)
+        (truncate-file accumulator 0)
+        str)))
 
   (define (annotate line column datum)
     ;; FIXME: Return a syntax object instead, so we can avoid the
@@ -161,16 +169,13 @@
        (else (read-semicolon-comment)))))
 
   (define-syntax-rule (take-until first pred)
-    (let ((acc (open-output-string)))
+    (accumulate
-      (put-char acc first)
+     (lambda (put)
+       (put first)
        (let lp ()
          (let ((ch (peek)))
-          (cond
+           (unless (or (eof-object? ch) (pred ch))
-           ((or (eof-object? ch)
+             (put ch)
-                (pred ch))
-            (get-output-string acc))
-           (else
-            (put-char acc ch)
              (next)
              (lp)))))))
   (define-syntax-rule (take-while first pred)
@@ -288,14 +293,14 @@
               (input-error "invalid character in escape sequence: ~S" ch)))))))
 
   (define (read-string rdelim)
-    (let ((acc (open-output-string)))
+    (accumulate
+     (lambda (put)
        (let lp ()
          (let ((ch (next)))
+           (unless (eqv? ch rdelim)
              (cond
               ((eof-object? ch)
                (input-error "unexpected end of input while reading string"))
-           ((eqv? ch rdelim)
-            (get-output-string acc))
               ((eqv? ch #\\)
                (let ((ch (next)))
                  (when (eof-object? ch)
@@ -314,32 +319,32 @@
                    ;; Accept "\(" for use at the beginning of
                    ;; lines in multiline strings to avoid
                    ;; confusing emacs lisp modes.
-                ((#\| #\\ #\() (put-char acc ch))
+                   ((#\| #\\ #\() (put ch))
-                ((#\0)         (put-char acc #\nul))
+                   ((#\0)         (put #\nul))
-                ((#\f)         (put-char acc #\ff))
+                   ((#\f)         (put #\ff))
-                ((#\n)         (put-char acc #\newline))
+                   ((#\n)         (put #\newline))
-                ((#\r)         (put-char acc #\return))
+                   ((#\r)         (put #\return))
-                ((#\t)         (put-char acc #\tab))
+                   ((#\t)         (put #\tab))
-                ((#\a)         (put-char acc #\alarm))
+                   ((#\a)         (put #\alarm))
-                ((#\v)         (put-char acc #\vtab))
+                   ((#\v)         (put #\vtab))
-                ((#\b)         (put-char acc #\backspace))
+                   ((#\b)         (put #\backspace))
                    ((#\x)
                     (let ((ch (if (or (r6rs-escapes?) (eqv? rdelim #\|))
                                   (read-r6rs-hex-escape)
                                   (read-fixed-hex-escape 2))))
-                   (put-char acc ch)))
+                      (put ch)))
                    ((#\u)
-                 (put-char acc (read-fixed-hex-escape 4)))
+                    (put (read-fixed-hex-escape 4)))
                    ((#\U)
-                 (put-char acc (read-fixed-hex-escape 8)))
+                    (put (read-fixed-hex-escape 8)))
                    (else
                     (unless (eqv? ch rdelim)
                       (input-error "invalid character in escape sequence: ~S" ch))
-                 (put-char acc ch)))
+                    (put ch)))
                  (lp)))
               (else
-            (put-char acc ch)
+               (put ch)
-            (lp)))))))
+               (lp)))))))))
 
   (define (read-character)
     (let ((ch (next)))