Implement GET-OUTPUT-STRING!, which gets the accumulated output from

an string output port and resets the accumulator to zero.  Change
GET-OUTPUT-STRING so it doesn't reset the accumulator.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index af27f7ca5f8093073e6b98ab5348a7edbb89186d..bb55841366cb1ec7d9369ea0f97ddb73bfbadeac 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.548 2005/05/30 02:48:44 cph Exp $
+$Id: runtime.pkg,v 14.549 2005/05/30 04:10:29 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -3901,8 +3901,9 @@ USA.
   (parent (runtime))
   (export ()
          call-with-output-string
-         (get-output-from-accumulator get-output-string)
+         (get-output-from-accumulator get-output-string!)
          get-output-string
+         get-output-string!
          (make-accumulator-output-port open-output-string)
          open-output-string
          (with-string-output-port call-with-output-string)

diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm
index 9244b5da05bdc84ad06347b1a2f8a932e93ae8f2..0ba38a823faff4666e1c8b3aa2fa5cc9c2d0b7d3 100644 (file)
--- a/v7/src/runtime/strout.scm
+++ b/v7/src/runtime/strout.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: strout.scm,v 14.19 2004/02/16 05:38:49 cph Exp $
+$Id: strout.scm,v 14.20 2005/05/30 04:10:38 cph Exp $
 
 Copyright 1988,1990,1993,1999,2000,2001 Massachusetts Institute of Technology
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -30,9 +30,12 @@ USA.
 (declare (usual-integrations))
 \f
 (define (open-output-string)
-  (make-port accumulator-output-port-type (make-astate (make-string 128) 0)))
+  (make-port accumulator-output-port-type (make-astate)))
 
 (define (get-output-string port)
+  ((port/operation port 'EXTRACT-OUTPUT) port))
+
+(define (get-output-string! port)
   ((port/operation port 'EXTRACT-OUTPUT!) port))
 
 (define (call-with-output-string generator)
@@ -45,65 +48,80 @@ USA.
     (lambda (port)
       (with-output-to-port port thunk))))
 
+(define-structure (astate (type vector) (constructor make-astate ()))
+  (chars #f)
+  index)
+
+(define (maybe-reset-astate state)
+  (if (not (astate-chars state))
+      (begin
+       (set-astate-chars! state (make-string 128))
+       (set-astate-index! state 0))))
+
+(define (maybe-grow-accumulator! state min-size)
+  (if (fix:> min-size (string-length (astate-chars state)))
+      (let* ((old (astate-chars state))
+            (n (string-length old))
+            (new
+             (make-string
+              (let loop ((n (fix:+ n n)))
+                (if (fix:>= n min-size)
+                    n
+                    (loop (fix:+ n n)))))))
+       (substring-move! old 0 n new 0)
+       (set-astate-chars! state new))))
+\f
 (define accumulator-output-port-type)
 (define (initialize-package!)
   (set! accumulator-output-port-type
        (make-port-type
-        `((EXTRACT-OUTPUT!
+        `((EXTRACT-OUTPUT
+           ,(lambda (port)
+              (let ((state (port/state port)))
+                (if (astate-chars state)
+                    (string-head (astate-chars state)
+                                 (astate-index state))
+                    (make-string 0)))))
+          (EXTRACT-OUTPUT!
            ,(lambda (port)
               (let ((state (port/state port)))
                 (without-interrupts
                  (lambda ()
-                   (let ((s (astate-chars state))
-                         (n (astate-index state)))
-                     (set-astate-chars! state (make-string 128))
-                     (set-astate-index! state 0)
-                     (set-string-maximum-length! s n)
-                     s))))))
+                   (let ((s (astate-chars state)))
+                     (if s
+                         (begin
+                           (set-astate-chars! state #f)
+                           (set-string-maximum-length! s (astate-index state))
+                           s)
+                         (make-string 0))))))))
           (WRITE-CHAR
            ,(lambda (port char)
               (guarantee-8-bit-char char)
               (let ((state (port/state port)))
                 (without-interrupts
                  (lambda ()
+                   (maybe-reset-astate state)
                    (let* ((n (astate-index state))
                           (n* (fix:+ n 1)))
-                     (if (fix:> n* (string-length (astate-chars state)))
-                         (grow-accumulator! state n*))
+                     (maybe-grow-accumulator! state n*)
                      (string-set! (astate-chars state) n char)
                      (set-astate-index! state n*)))))
               1))
-          (WRITE-SELF
-           ,(lambda (port output-port)
-              port
-              (write-string " to string" output-port)))
           (WRITE-SUBSTRING
            ,(lambda (port string start end)
               (let ((state (port/state port)))
                 (without-interrupts
                  (lambda ()
+                   (maybe-reset-astate state)
                    (let* ((n (astate-index state))
                           (n* (fix:+ n (fix:- end start))))
-                     (if (fix:> n* (string-length (astate-chars state)))
-                         (grow-accumulator! state n*))
+                     (maybe-grow-accumulator! state n*)
                      (substring-move! string start end (astate-chars state) n)
                      (set-astate-index! state n*)))))
-              (fix:- end start))))
+              (fix:- end start)))
+          (WRITE-SELF
+           ,(lambda (port output-port)
+              port
+              (write-string " to string" output-port))))
         #f))
-  unspecific)
-
-(define-structure (astate (type vector))
-  chars
-  index)
-
-(define (grow-accumulator! state min-size)
-  (let* ((old (astate-chars state))
-        (n (string-length old))
-        (new
-         (make-string
-          (let loop ((n (fix:+ n n)))
-            (if (fix:>= n min-size)
-                n
-                (loop (fix:+ n n)))))))
-    (substring-move! old 0 n new 0)
-    (set-astate-chars! state new)))
\ No newline at end of file
+  unspecific)
\ No newline at end of file

diff --git a/v7/src/runtime/unicode.scm b/v7/src/runtime/unicode.scm
index 80981ccb199a50f65aea83f56fbfd29c8d0eaa30..8ed5b3a965f3a11c1766e0cf30b61dca1aa4ced0 100644 (file)
--- a/v7/src/runtime/unicode.scm
+++ b/v7/src/runtime/unicode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unicode.scm,v 1.22 2005/05/24 04:50:43 cph Exp $
+$Id: unicode.scm,v 1.23 2005/05/30 04:10:47 cph Exp $
 
 Copyright 2001,2003,2004,2005 Massachusetts Institute of Technology
 
@@ -1216,10 +1216,14 @@ USA.
                   ,(lambda (port char)
                      (guarantee-wide-char char 'WRITE-CHAR)
                      ((port/state port) char)))
-                 (EXTRACT-OUTPUT!
+                 (EXTRACT-OUTPUT
                   ,(lambda (port)
                      (%make-wide-string
                       (get-output-objects (port/state port)))))
+                 (EXTRACT-OUTPUT!
+                  ,(lambda (port)
+                     (%make-wide-string
+                      (get-output-objects! (port/state port)))))
                  (WRITE-SELF
                   ,(lambda (port port*)
                      port
@@ -1324,9 +1328,12 @@ USA.
                (guarantee-wide-char char 'WRITE-CHAR)
                (sink-char char (port/state port))
                1))
-           (EXTRACT-OUTPUT!
+           (EXTRACT-OUTPUT
             ,(lambda (port)
                (get-output-bytes (port/state port))))
+           (EXTRACT-OUTPUT!
+            ,(lambda (port)
+               (get-output-bytes! (port/state port))))
            (WRITE-SELF
             ,(let ((suffix (string-append " to " coding-name " string")))
                (lambda (port port*)
@@ -1383,7 +1390,12 @@ USA.
   (let ((bytes #f)
        (index))
     (lambda (byte)
-      (if (eq? byte 'EXTRACT-OUTPUT!)
+      (case byte
+       ((EXTRACT-OUTPUT)
+        (if bytes
+            (string-head bytes index)
+            (make-string 0)))
+       ((EXTRACT-OUTPUT!)
          (without-interrupts
           (lambda ()
             (if bytes
@@ -1391,23 +1403,24 @@ USA.
                   (set! bytes #f)
                   (set-string-maximum-length! bytes* index)
                   bytes*)
-                (make-string 0))))
-         (without-interrupts
-          (lambda ()
-            (cond ((not bytes)
-                   (set! bytes (make-string 128))
-                   (set! index 0))
-                  ((not (fix:< index (string-length bytes)))
-                   (let ((bytes*
-                          (make-string (fix:* (string-length bytes) 2))))
-                     (string-move! bytes bytes* 0)
-                     (set! bytes bytes*))))
-            (vector-8b-set! bytes index byte)
-            (set! index (fix:+ index 1))
-            unspecific))))))
-
-(define (get-output-bytes buffer)
-  (buffer 'EXTRACT-OUTPUT!))
+                (make-string 0)))))
+       (else
+        (without-interrupts
+         (lambda ()
+           (cond ((not bytes)
+                  (set! bytes (make-string 128))
+                  (set! index 0))
+                 ((not (fix:< index (string-length bytes)))
+                  (let ((bytes*
+                         (make-string (fix:* (string-length bytes) 2))))
+                    (string-move! bytes bytes* 0)
+                    (set! bytes bytes*))))
+           (vector-8b-set! bytes index byte)
+           (set! index (fix:+ index 1))
+           unspecific)))))))
+
+(define (get-output-bytes buffer) (buffer 'EXTRACT-OUTPUT))
+(define (get-output-bytes! buffer) (buffer 'EXTRACT-OUTPUT!))
 
 (define (call-with-output-byte-buffer generator)
   (let ((buffer (open-output-byte-buffer)))
@@ -1437,34 +1450,39 @@ USA.
   (let ((objects #f)
        (index))
     (lambda (object)
-      (if (eq? object extract-output-tag)
-         (without-interrupts
-          (lambda ()
+      (cond ((eq? object extract-output-tag)
             (if objects
-                (let ((objects* objects))
-                  (set! objects #f)
-                  (if (fix:< index (vector-length objects*))
-                      (vector-head objects* index)
-                      objects*))
-                (make-vector 0))))
-         (without-interrupts
-          (lambda ()
-            (cond ((not objects)
-                   (set! objects (make-vector 128))
-                   (set! index 0))
-                  ((not (fix:< index (vector-length objects)))
-                   (set! objects
-                         (vector-grow objects
-                                      (fix:* (vector-length objects) 2)))))
-            (vector-set! objects index object)
-            (set! index (fix:+ index 1))
-            unspecific))))))
-
-(define (get-output-objects buffer)
-  (buffer extract-output-tag))
-
-(define extract-output-tag
-  (list 'EXTRACT-OUTPUT!))
+                (vector-head objects index)
+                (make-vector 0)))
+           ((eq? object extract-output!-tag)
+            (without-interrupts
+             (lambda ()
+               (if objects
+                   (let ((objects* objects))
+                     (set! objects #f)
+                     (if (fix:< index (vector-length objects*))
+                         (vector-head objects* index)
+                         objects*))
+                   (make-vector 0)))))
+           (else
+            (without-interrupts
+             (lambda ()
+               (cond ((not objects)
+                      (set! objects (make-vector 128))
+                      (set! index 0))
+                     ((not (fix:< index (vector-length objects)))
+                      (set! objects
+                            (vector-grow objects
+                                         (fix:* (vector-length objects) 2)))))
+               (vector-set! objects index object)
+               (set! index (fix:+ index 1))
+               unspecific)))))))
+
+(define (get-output-objects buffer) (buffer extract-output-tag))
+(define (get-output-objects! buffer) (buffer extract-output!-tag))
+
+(define extract-output-tag (list 'EXTRACT-OUTPUT))
+(define extract-output!-tag (list 'EXTRACT-OUTPUT!))
 
 (define (call-with-output-object-buffer generator)
   (let ((buffer (open-output-object-buffer)))