From 53f55afeea16e66c4a1a4c2732d174bd40438b8a Mon Sep 17 00:00:00 2001 From: Chris Hanson 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