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

* output strings now use their own internal buffers

This commit is contained in:
Abdulaziz Ghuloum 2007-05-18 15:47:06 -04:00
parent ceecfd9251
commit 7e9e43bec1
4 changed files with 155 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

19
src/ikarus.fasl.write.ss
View File

@ -10,18 +10,17 @@
(define write-fixnum (define write-fixnum
(lambda (x p) (lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x)) (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
(write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p) (write-byte (fxsll (fxlogand x #x3F) 2) p)
(write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p) (write-byte (fxlogand (fxsra x 6) #xFF) p)
(write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p) (write-byte (fxlogand (fxsra x 14) #xFF) p)
(write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p))) (write-byte (fxlogand (fxsra x 22) #xFF) p)))
(define write-int (define write-int
(lambda (x p) (lambda (x p)
(unless (fixnum? x) (error 'write-int "not a fixnum ~s" x)) (unless (fixnum? x) (error 'write-int "not a fixnum ~s" x))
(write-char (integer->char (fxlogand x #xFF)) p) (write-byte (fxlogand x #xFF) p)
(write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p) (write-byte (fxlogand (fxsra x 8) #xFF) p)
(write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p) (write-byte (fxlogand (fxsra x 16) #xFF) p)
(write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p))) (write-byte (fxlogand (fxsra x 24) #xFF) p)))
(define fasl-write-immediate (define fasl-write-immediate
(lambda (x p) (lambda (x p)
(cond (cond
@ -76,7 +75,7 @@
(write-fixnum (code-freevars x) p) (write-fixnum (code-freevars x) p)
(let f ([i 0] [n (code-size x)]) (let f ([i 0] [n (code-size x)])
(unless (fx= i n) (unless (fx= i n)
(write-char (integer->char (code-ref x i)) p) (write-byte (code-ref x i) p)
(f (fxadd1 i) n))) (f (fxadd1 i) n)))
(fasl-write-object (code-reloc-vector x) p h m)] (fasl-write-object (code-reloc-vector x) p h m)]
[(record? x) [(record? x)

69
src/ikarus.io.output-files.ss
View File

@ -7,6 +7,8 @@
(ikarus system $ports) (ikarus system $ports)
(ikarus system $io) (ikarus system $io)
(ikarus system $strings) (ikarus system $strings)
(ikarus system $chars)
(ikarus system $bytevectors)
(ikarus system $fx) (ikarus system $fx)
(except (ikarus) (except (ikarus)
standard-output-port standard-error-port standard-output-port standard-error-port
@ -48,7 +50,7 @@
(close-output-port p) (close-output-port p)
(close-ports))]))) (close-ports))])))
(define do-write-buffer (define do-write-buffer-old
(lambda (fd port-name p caller) (lambda (fd port-name p caller)
(let ([bytes (foreign-call "ikrt_write_file" (let ([bytes (foreign-call "ikrt_write_file"
fd fd
@ -58,7 +60,14 @@
(set-port-output-index! p 0) (set-port-output-index! p 0)
(error caller "cannot write to file ~s: ~a" port-name bytes))))) (error caller "cannot write to file ~s: ~a" port-name bytes)))))
(define make-output-file-handler (define do-write-buffer
(lambda (fd port-name buff idx caller)
(let ([bytes (foreign-call "ikrt_write_file" fd buff idx)])
(if (fixnum? bytes)
bytes
(error caller "cannot write to file ~s: ~a" port-name bytes)))))
(define make-output-file-handler-old
(lambda (fd port-name) (lambda (fd port-name)
(define open? #t) (define open? #t)
(define output-file-handler (define output-file-handler
@ -98,6 +107,56 @@
"unhandled message ~s" (cons msg args))]))) "unhandled message ~s" (cons msg args))])))
output-file-handler)) output-file-handler))
(define make-output-file-handler
(lambda (fd port-name)
(define open? #t)
(define buff ($make-bytevector 4096))
(define idx 0)
(define size 4096)
(define output-file-handler
(lambda (msg . args)
(message-case msg args
[(write-byte b p)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p)
(if ($fx< idx size)
(begin
($bytevector-set! buff idx b)
(set! idx ($fxadd1 idx)))
(if open?
(let ([bytes (do-write-buffer fd port-name buff idx 'write-char)])
(set! idx 0)
($write-byte b p))
(error 'write-byte "port ~s is closed" p)))
(error 'write-byte "~s is not an output-port" p))
(error 'write-byte "~s is not a byte" b))]
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([b ($char->fixnum c)])
(if ($fx<= b 255)
($write-byte b p)
(error 'write-char "multibyte write of ~s not implemented" c)))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(if (output-port? p)
(if open?
(let ([bytes (do-write-buffer fd port-name buff idx 'flush-output-port)])
(set! idx 0))
(error 'flush-output-port "port ~s is closed" p))
(error 'flush-output-port "~s is not an output-port" p))]
[(close-port p)
(when open?
(flush-output-port p)
(set! size 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-output-port "cannot close ~s" port-name)))]
[(port-name p) port-name]
[else (error 'output-file-handler
"unhandled message ~s" (cons msg args))])))
output-file-handler))
(define (option-id x) (define (option-id x)
(case x (case x
[(error) 0] [(error) 0]
@ -117,7 +176,7 @@
(let ([port (let ([port
(make-output-port (make-output-port
(make-output-file-handler fd/error filename) (make-output-file-handler fd/error filename)
(make-string 4096))]) (make-string 0))])
(guardian port) (guardian port)
port) port)
(error 'open-output-file "cannot open ~s: ~a" filename fd/error))))) (error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
@ -191,9 +250,9 @@
(set! *standard-output-port* (set! *standard-output-port*
(make-output-port (make-output-port
(make-output-file-handler 1 '*stdout*) (make-output-file-handler 1 '*stdout*)
(make-string 4096))) (make-string 0)))
(set! *current-output-port* *standard-output-port*) (set! *current-output-port* *standard-output-port*)
(set! *standard-error-port* (set! *standard-error-port*
(make-output-port (make-output-port
(make-output-file-handler 2 '*stderr*) (make-output-file-handler 2 '*stderr*)
(make-string 4096))) ) (make-string 0))) )

88
src/ikarus.io.output-strings.ss
View File

@ -3,6 +3,8 @@
(export open-output-string get-output-string with-output-to-string) (export open-output-string get-output-string with-output-to-string)
(import (import
(ikarus system $strings) (ikarus system $strings)
(ikarus system $bytevectors)
(ikarus system $chars)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $ports) (ikarus system $ports)
@ -35,7 +37,7 @@
(lambda (s) (lambda (s)
(substring s 0 (string-length s)))) (substring s 0 (string-length s))))
(define concat (define concat-old
(lambda (str i ls) (lambda (str i ls)
(let ([n (sum i ls)]) (let ([n (sum i ls)])
(let ([outstr (make-string n)]) (let ([outstr (make-string n)])
@ -45,13 +47,28 @@
(let ([a ($car ls)]) (let ([a ($car ls)])
(f (copy outstr a (string-length a) n) ($cdr ls))))))))) (f (copy outstr a (string-length a) n) ($cdr ls)))))))))
(define concat
(lambda (bv i ls)
(let ([n (sum i ls)])
(let ([outstr (make-string n)])
(let f ([n (copy outstr bv i n)] [ls ls])
(if (null? ls)
outstr
(let ([a ($car ls)])
(f (copy outstr a ($bytevector-length a) n) ($cdr ls)))))))))
(define sum (define sum
(lambda (ac ls) (lambda (ac ls)
(cond (cond
[(null? ls) ac] [(null? ls) ac]
[else (sum ($fx+ ac (string-length ($car ls))) ($cdr ls))]))) [else (sum ($fx+ ac ($bytevector-length ($car ls))) ($cdr ls))])))
(define copy (define sum-old
(lambda (ac ls)
(cond
[(null? ls) ac]
[else (sum ($fx+ ac (string-length ($car ls))) ($cdr ls))])))
(define copy-old
(lambda (dst src n end) (lambda (dst src n end)
(let f ([di end] (let f ([di end]
[si n]) [si n])
@ -61,8 +78,21 @@
(let ([di ($fxsub1 di)] [si ($fxsub1 si)]) (let ([di ($fxsub1 di)] [si ($fxsub1 si)])
(string-set! dst di (string-ref src si)) (string-set! dst di (string-ref src si))
(f di si))])))) (f di si))]))))
(define make-output-string-handler (define copy
(lambda (dst src n end)
(let f ([di end]
[si n])
(cond
[($fx= si 0) di]
[else
(let ([di ($fxsub1 di)] [si ($fxsub1 si)])
(string-set! dst di
(integer->char ($bytevector-u8-ref src si)))
(f di si))]))))
(define make-output-string-handler-old
(lambda () (lambda ()
(define buffer-list '()) (define buffer-list '())
(define open? #t) (define open? #t)
@ -102,11 +132,57 @@
"unhandled message ~s" (cons msg args))]))) "unhandled message ~s" (cons msg args))])))
output-handler)) output-handler))
(define make-output-string-handler
(lambda ()
(define buffer-list '())
(define open? #t)
(define idx 0)
(define buff (make-bytevector 59))
(define size 59)
(define output-handler
(lambda (msg . args)
(message-case msg args
[(write-byte b p)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p)
(if ($fx< idx size)
(begin
($bytevector-set! buff idx b)
(set! idx ($fxadd1 idx)))
(if open?
(begin
(set! buffer-list (cons buff buffer-list))
(set! buff (make-bytevector 59))
($bytevector-set! buff 0 b)
(set! idx 1))
(error 'write-byte "port ~s is closed" p)))
(error 'write-byte "~s is not an output-port" p))
(error 'write-byte "~s is not a byte" b))]
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([b ($char->fixnum c)])
(if ($fx<= b 255)
($write-byte b p)
(error 'write-char "multibyte write of ~s is not implemented" c)))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(void)]
[(close-port p)
(set! open? #f)]
[(port-name p) 'string-port]
[(get-output-string p)
(concat buff idx buffer-list)]
[else (error 'output-handler
"unhandled message ~s" (cons msg args))])))
output-handler))
(define open-output-string (define open-output-string
(lambda () (lambda ()
(make-output-port (make-output-port
(make-output-string-handler) (make-output-string-handler)
(make-string 10)))) (make-string 0))))
(define get-output-string (define get-output-string
(lambda (p) (lambda (p)