From 53f55afeea16e66c4a1a4c2732d174bd40438b8a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 4 Jan 2000 17:24:06 +0000
Subject: [PATCH] Change interface to string output ports: rename to
accumulator output port and provide separate operation to extract contents.
Port is reset when contents are extracted; previously contents remained in
the port.
---
v7/src/runtime/runtime.pkg | 4 +-
v7/src/runtime/strout.scm | 103 ++++++++++++++++++++-----------------
2 files changed, 60 insertions(+), 47 deletions(-)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 1ec1a529b..d44696be9 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.335 2000/01/04 05:14:26 cph Exp $
+$Id: runtime.pkg,v 14.336 2000/01/04 17:24:06 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
@@ -3033,6 +3033,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(files "strout")
(parent ())
(export ()
+ get-output-from-accumulator
+ make-accumulator-output-port
with-string-output-port
with-output-to-string)
(initialization (initialize-package!)))
diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm
index 0ead6a0ac..bf140d115 100644
--- a/v7/src/runtime/strout.scm
+++ b/v7/src/runtime/strout.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: strout.scm,v 14.12 1999/02/24 21:36:29 cph Exp $
+$Id: strout.scm,v 14.13 2000/01/04 17:24:00 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
@@ -24,70 +24,81 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(declare (usual-integrations))
+(define (make-accumulator-output-port)
+ (make-port accumulator-output-port-type
+ (make-accumulator-state (make-string 16) 0)))
+
+(define (get-output-from-accumulator port)
+ ((port/operation port 'EXTRACT-OUTPUT!) port))
+
+(define (with-output-to-string thunk)
+ (with-string-output-port (lambda (port) (with-output-to-port port thunk))))
+
+(define (with-string-output-port generator)
+ (let ((port (make-accumulator-output-port)))
+ (generator port)
+ (operation/extract-output! port)))
+
+(define accumulator-output-port-type)
(define (initialize-package!)
- (set! output-string-port-type
+ (set! accumulator-output-port-type
(make-port-type `((WRITE-SELF ,operation/write-self)
(WRITE-CHAR ,operation/write-char)
- (WRITE-SUBSTRING ,operation/write-substring))
+ (WRITE-SUBSTRING ,operation/write-substring)
+ (EXTRACT-OUTPUT! ,operation/extract-output!))
#f))
unspecific)
-(define (with-output-to-string thunk)
- (with-string-output-port
- (lambda (port)
- (with-output-to-port port thunk))))
-
-(define (with-string-output-port generator)
- (let ((state (make-output-string-state (make-string 16) 0)))
- (let ((port (make-port output-string-port-type state)))
- (generator port)
- (without-interrupts
- (lambda ()
- (string-head (output-string-state/accumulator state)
- (output-string-state/counter state)))))))
-
-(define output-string-port-type)
-
-(define-structure (output-string-state (type vector)
- (conc-name output-string-state/))
- accumulator
- counter)
-
-(define (grow-accumulator! state min-size)
- (let* ((old (output-string-state/accumulator 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-left! old 0 n new 0)
- (set-output-string-state/accumulator! state new)))
+(define (operation/write-self port output-port)
+ port
+ (write-string " to string" output-port))
(define (operation/write-char port char)
(without-interrupts
(lambda ()
(let* ((state (port/state port))
- (n (output-string-state/counter state))
+ (n (accumulator-state-counter state))
(n* (fix:+ n 1)))
- (if (fix:= (string-length (output-string-state/accumulator state)) n)
+ (if (fix:= n (string-length (accumulator-state-accumulator state)))
(grow-accumulator! state n*))
- (string-set! (output-string-state/accumulator state) n char)
- (set-output-string-state/counter! state n*)))))
+ (string-set! (accumulator-state-accumulator state) n char)
+ (set-accumulator-state-counter! state n*)))))
(define (operation/write-substring port string start end)
(without-interrupts
(lambda ()
(let* ((state (port/state port))
- (n (output-string-state/counter state))
+ (n (accumulator-state-counter state))
(n* (fix:+ n (fix:- end start))))
- (if (fix:> n* (string-length (output-string-state/accumulator state)))
+ (if (fix:> n* (string-length (accumulator-state-accumulator state)))
(grow-accumulator! state n*))
(substring-move-left! string start end
- (output-string-state/accumulator state) n)
- (set-output-string-state/counter! state n*)))))
+ (accumulator-state-accumulator state) n)
+ (set-accumulator-state-counter! state n*)))))
-(define (operation/write-self port output-port)
- port
- (write-string " to string" output-port))
\ No newline at end of file
+(define (operation/extract-output! port)
+ (without-interrupts
+ (lambda ()
+ (let ((state (port/state port)))
+ (let ((result
+ (string-head (accumulator-state-accumulator state)
+ (accumulator-state-counter state))))
+ (set-accumulator-state-accumulator! state (make-string 16))
+ (set-accumulator-state-counter! state 0)
+ result)))))
+
+(define-structure (accumulator-state (type vector))
+ accumulator
+ counter)
+
+(define (grow-accumulator! state min-size)
+ (let* ((old (accumulator-state-accumulator 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-left! old 0 n new 0)
+ (set-accumulator-state-accumulator! state new)))
\ No newline at end of file
--
2.25.1