From: Chris Hanson Date: Mon, 30 May 2005 04:10:47 +0000 (+0000) Subject: Implement GET-OUTPUT-STRING!, which gets the accumulated output from X-Git-Tag: 20090517-FFI~1295 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0efa8a0c8b108dacb361660f338417d894004a7f;p=mit-scheme.git 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 af27f7ca5..bb5584136 100644 --- 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 9244b5da0..0ba38a823 100644 --- 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)) (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)))) + (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 80981ccb1..8ed5b3a96 100644 --- 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)))