From 450744bbed0cf7ed5100790ee4301a707e0f8dac Mon Sep 17 00:00:00 2001
From: Arthur Gleckler <edu/mit/csail/zurich/arthur>
Date: Wed, 9 Aug 2006 05:48:53 +0000
Subject: [PATCH] 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 ]=>
---
 v7/src/runtime/runtime.pkg |  3 ++-
 v7/src/runtime/strout.scm  | 27 ++++++++++++++++++++++-----
 2 files changed, 24 insertions(+), 6 deletions(-)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f6f5c79ee..63d9cbb7b 100644
--- 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 8ff6df2ed..ebf3371f7 100644
--- 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.
 
 (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
-- 
2.25.1