Added new `port-position' procedure. On a port created using

`open-output-string', e.g. through `with-output-to-string', this
procedure returns the current position in the output buffer.  For
example:

  1 ]=> (define foo)

  ;Value: foo

  1 ]=> (with-output-to-string
	  (lambda ()
	    (write-string "foo")
	    (set! foo (port-position (current-output-port)))
            (write-string "bar")))
  ;Value 1: "foobar"

  1 ]=> foo

  ;Value: 3

  1 ]=>

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f6f5c79eeff4ac36713c8087b579a5102cbb22e4..63d9cbb7bfbf61c7a02c20635bd40198d7e387f9 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.591 2006/08/02 18:18:12 cph Exp $
+$Id: runtime.pkg,v 14.592 2006/08/09 05:48:53 savannah-arthur Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -4066,6 +4066,7 @@ USA.
          get-output-string!
          (make-accumulator-output-port open-output-string)
          open-output-string
+         port-position
          (with-string-output-port call-with-output-string)
          with-output-to-string)
   (initialization (initialize-package!)))

diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm
index 8ff6df2ed6c74589fb00d0ec83b66ed41a0a754f..ebf3371f7640caf52b0888d05c7c9c0ea201cf6e 100644 (file)
--- a/v7/src/runtime/strout.scm
+++ b/v7/src/runtime/strout.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: strout.scm,v 14.23 2005/12/14 05:44:49 cph Exp $
+$Id: strout.scm,v 14.24 2006/08/09 05:48:53 savannah-arthur Exp $
 
 Copyright 1988,1990,1993,1999,2000,2001 Massachusetts Institute of Technology
 Copyright 2003,2004,2005 Massachusetts Institute of Technology
@@ -31,8 +31,14 @@ USA.
 \f
 (define (open-output-string)
   (make-port accumulator-output-port-type
-            (receive (sink extract extract!) (make-accumulator-sink)
-              (make-gstate #f sink 'ISO-8859-1 'NEWLINE extract extract!))))
+            (receive (sink extract extract! position) (make-accumulator-sink)
+              (make-gstate #f
+                           sink
+                           'ISO-8859-1
+                           'NEWLINE
+                           extract
+                           extract!
+                           position))))
 
 (define (get-output-string port)
   ((port/operation port 'EXTRACT-OUTPUT) port))
@@ -40,6 +46,9 @@ USA.
 (define (get-output-string! port)
   ((port/operation port 'EXTRACT-OUTPUT!) port))
 
+(define (port-position port)
+  ((port/operation port 'POSITION) port))
+
 (define (call-with-output-string generator)
   (let ((port (open-output-string)))
     (generator port)
@@ -54,7 +63,8 @@ USA.
                          (initial-offset 4) ;must match "genio.scm"
                          (constructor #f))
   extract
-  extract!)
+  extract!
+  position)
 
 (define accumulator-output-port-type)
 (define (initialize-package!)
@@ -68,6 +78,10 @@ USA.
            ,(lambda (port)
               (output-port/flush-output port)
               ((astate-extract! (port/state port)))))
+          (POSITION
+           ,(lambda (port)
+              (output-port/flush-output port)
+              ((astate-position (port/state port)))))
           (WRITE-SELF
            ,(lambda (port output-port)
               port
@@ -119,4 +133,7 @@ USA.
                       (set! index 0)
                       (set-string-maximum-length! s index)
                       s)
-                    (make-string 0))))))))
\ No newline at end of file
+                    (make-string 0)))))
+           (lambda ()
+             (without-interrupts
+              (lambda () index))))))
\ No newline at end of file