conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Reimplemented open-output-string and get-output-string.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-26 02:16:02 -05:00
parent 798381ee1d
commit b8ed235308
2 changed files with 64 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
scheme/ikarus.io.ss
View File

@ -46,6 +46,7 @@
call-with-bytevector-output-port call-with-bytevector-output-port
open-string-output-port with-output-to-string open-string-output-port with-output-to-string
call-with-string-output-port call-with-string-output-port
open-output-string get-output-string
standard-output-port standard-error-port standard-output-port standard-error-port
current-output-port current-error-port current-output-port current-error-port
open-file-output-port open-output-file open-file-output-port open-output-file
@ -95,6 +96,7 @@
call-with-bytevector-output-port call-with-bytevector-output-port
open-string-output-port with-output-to-string open-string-output-port with-output-to-string
call-with-string-output-port call-with-string-output-port
open-output-string get-output-string
standard-output-port standard-error-port standard-output-port standard-error-port
current-output-port current-error-port current-output-port current-error-port
open-file-output-port open-output-file open-file-output-port open-output-file
@ -439,45 +441,67 @@
(proc)) (proc))
(extract))) (extract)))
(define-struct output-string-cookie (strings))
(define (open-output-string)
(define who 'open-output-string)
(let ([cookie (make-output-string-cookie '())]
[buffer-size 256])
($make-port
(fxior textual-output-port-bits fast-char-text-tag)
0 buffer-size (make-string buffer-size)
#t ;;; transcoder
"*string-output-port*"
#f
(lambda (str i c)
(unless (= c 0)
(let ([x (make-string c)])
(string-copy! str i x 0 c)
(set-output-string-cookie-strings! cookie
(cons x (output-string-cookie-strings cookie)))))
c)
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f
cookie)))
(define (open-string-output-port) (define (open-string-output-port)
(define who 'open-string-output-port) (let ([p (open-output-string)])
(let ([buf* '()] [buffer-size 256]) (values
(let ([p p
($make-port (lambda ()
(fxior textual-output-port-bits fast-char-text-tag) (let ([str (get-output-string p)])
0 buffer-size (make-string buffer-size) (set-output-string-cookie-strings! ($port-cookie p) '())
#t ;;; transcoder str)))))
"*string-output-port*"
#f (define (get-output-string-cookie-data cookie)
(lambda (str i c) (define (append-str-buf* ls)
(unless (= c 0) (let f ([ls ls] [i 0])
(let ([x (make-string c)]) (cond
(string-copy! str i x 0 c) [(null? ls)
(set! buf* (cons x buf*)))) (values (make-string i) 0)]
c) [else
#f ;;; FIXME: get-position (let* ([a (car ls)]
#f ;;; FIXME: set-position! [n (string-length a)])
#f (let-values ([(bv i) (f (cdr ls) (fx+ i n))])
#f)]) (string-copy! a 0 bv i n)
(values (values bv (fx+ i n))))])))
p (let ([buf* (output-string-cookie-strings cookie)])
(lambda () (let-values ([(bv len) (append-str-buf* buf*)])
(define (append-str-buf* ls) bv)))
(let f ([ls ls] [i 0])
(cond (define (get-output-string p)
[(null? ls) (if (port? p)
(values (make-string i) 0)] (let ([cookie ($port-cookie p)])
[else (cond
(let* ([a (car ls)] [(output-string-cookie? cookie)
[n (string-length a)]) (unless ($port-closed? p)
(let-values ([(bv i) (f (cdr ls) (fx+ i n))]) (flush-output-port p))
(string-copy! a 0 bv i n) (get-output-string-cookie-data cookie)]
(values bv (fx+ i n))))]))) [else
(unless ($port-closed? p) (die 'get-output-string "not an output-string port" p)]))
(flush-output-port p)) (die 'get-output-string "not a port" p)))
(let-values ([(bv len) (append-str-buf* buf*)])
(set! buf* '())
bv))))))
(define (open-string-input-port str) (define (open-string-input-port str)
(unless (string? str) (unless (string? str)

2
scheme/last-revision
View File

@ -1 +1 @@
1286 1288