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

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

@ -7,6 +7,8 @@
(ikarus system $ports)
(ikarus system $io)
(ikarus system $strings)
(ikarus system $chars)
(ikarus system $bytevectors)
(ikarus system $fx)
(except (ikarus)
standard-output-port standard-error-port
@ -48,7 +50,7 @@
(close-output-port p)
(close-ports))])))
(define do-write-buffer
(define do-write-buffer-old
(lambda (fd port-name p caller)
(let ([bytes (foreign-call "ikrt_write_file"
fd
@ -58,7 +60,14 @@
(set-port-output-index! p 0)
(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)
(define open? #t)
(define output-file-handler
@ -98,6 +107,56 @@
"unhandled message ~s" (cons msg args))])))
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)
(case x
[(error) 0]
@ -117,7 +176,7 @@
(let ([port
(make-output-port
(make-output-file-handler fd/error filename)
(make-string 4096))])
(make-string 0))])
(guardian port)
port)
(error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
@ -191,9 +250,9 @@
(set! *standard-output-port*
(make-output-port
(make-output-file-handler 1 '*stdout*)
(make-string 4096)))
(make-string 0)))
(set! *current-output-port* *standard-output-port*)
(set! *standard-error-port*
(make-output-port
(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)
(import
(ikarus system $strings)
(ikarus system $bytevectors)
(ikarus system $chars)
(ikarus system $fx)
(ikarus system $pairs)
(ikarus system $ports)
@ -35,7 +37,7 @@
(lambda (s)
(substring s 0 (string-length s))))
(define concat
(define concat-old
(lambda (str i ls)
(let ([n (sum i ls)])
(let ([outstr (make-string n)])
@ -45,13 +47,28 @@
(let ([a ($car 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
(lambda (ac ls)
(cond
[(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)
(let f ([di end]
[si n])
@ -61,8 +78,21 @@
(let ([di ($fxsub1 di)] [si ($fxsub1 si)])
(string-set! dst di (string-ref src 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 ()
(define buffer-list '())
(define open? #t)
@ -102,11 +132,57 @@
"unhandled message ~s" (cons msg args))])))
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
(lambda ()
(make-output-port
(make-output-string-handler)
(make-string 10))))
(make-string 0))))
(define get-output-string
(lambda (p)