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

* output files now use bytevectors as their internal buffer.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-18 16:07:58 -04:00
parent 7e9e43bec1
commit 3f220faf13
5 changed files with 38 additions and 77 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.

16
src/ikarus.io-ports.ss
View File

@ -65,31 +65,29 @@
;;;
(define $make-output-port
(lambda (handler buffer)
($make-port/output handler #f 0 0 buffer 0 (string-length buffer))))
($make-port/output handler #f 0 0 buffer 0 ($bytevector-length buffer))))
;;;
(define make-output-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
(if (bytevector? buffer)
($make-output-port handler buffer)
(error 'make-output-port "~s is not a string" buffer))
(error 'make-output-port "~s is not a bytevector" buffer))
(error 'make-output-port "~s is not a procedure" handler))))
;;;
(define $make-input/output-port
(lambda (handler input-buffer output-buffer)
($make-port/both handler
input-buffer 0 ($bytevector-length input-buffer)
output-buffer 0 (string-length output-buffer))))
output-buffer 0 ($bytevector-length output-buffer))))
;;;
(define make-input/output-port
(lambda (handler input-buffer output-buffer)
(if (procedure? handler)
(if (bytevector? input-buffer)
(if (string? output-buffer)
(if (bytevector? output-buffer)
($make-input/output-port handler input-buffer output-buffer)
(error 'make-input/output-port
"~s is not a string"
output-buffer))
(error 'make-input/output-port "~s is not a bytevector" output-buffer))
(error 'make-input/output-port "~s is not a bytevector" input-buffer))
(error 'make-input/output-port "~s is not a procedure" handler))))
;;;
@ -178,7 +176,7 @@
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i (string-length ($port-output-buffer p)))
(if ($fx<= i ($bytevector-length ($port-output-buffer p)))
(begin
($set-port-output-index! p 0)
($set-port-output-size! p i))

15
src/ikarus.io-primitives.unsafe.ss
View File

@ -15,19 +15,20 @@
(lambda (c p)
(let ([idx (port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
(string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(let ([b ($char->fixnum c)])
(if ($fx< b 128)
(begin
($bytevector-set! ($port-output-buffer p) idx b)
($set-port-output-index! p ($fxadd1 idx)))
(($port-handler p) 'write-char c p)))
(($port-handler p) 'write-char c p)))))
(define $write-byte
(lambda (b p)
(let ([idx (port-output-index p)])
(if ($fx< idx ($port-output-size p))
(let ([buff ($port-output-buffer p)])
(if (string? buff)
(string-set! buff idx ($fixnum->char b))
($bytevector-set! buff idx b))
(begin
($bytevector-set! ($port-output-buffer p) idx b)
($set-port-output-index! p ($fxadd1 idx)))
(($port-handler p) 'write-byte b p)))))

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

@ -67,67 +67,26 @@
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
(lambda (msg . args)
(message-case msg args
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
(string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(do-write-buffer fd port-name p 'write-char)
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(write-byte b p) (output-file-handler 'write-char (integer->char b) p)]
[(flush-output-port p)
(if (output-port? p)
(if open?
(do-write-buffer fd port-name p 'flush-output-port)
(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-port-output-size! p 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 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)))
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($bytevector-set! ($port-output-buffer p) idx b)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(let ([bytes (do-write-buffer fd port-name
($port-output-buffer p) idx 'write-char)])
($set-port-output-index! p 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)
@ -142,14 +101,17 @@
[(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))
(let ([bytes (do-write-buffer fd port-name
($port-output-buffer p)
($port-output-index p)
'flush-output-port)])
($set-port-output-index! p 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-port-output-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-output-port "cannot close ~s" port-name)))]
@ -176,7 +138,7 @@
(let ([port
(make-output-port
(make-output-file-handler fd/error filename)
(make-string 0))])
($make-bytevector 4096))])
(guardian port)
port)
(error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
@ -250,9 +212,9 @@
(set! *standard-output-port*
(make-output-port
(make-output-file-handler 1 '*stdout*)
(make-string 0)))
($make-bytevector 4096)))
(set! *current-output-port* *standard-output-port*)
(set! *standard-error-port*
(make-output-port
(make-output-file-handler 2 '*stderr*)
(make-string 0))) )
($make-bytevector 4096))) )

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

@ -137,7 +137,7 @@
(define buffer-list '())
(define open? #t)
(define idx 0)
(define buff (make-bytevector 59))
(define buff ($make-bytevector 59))
(define size 59)
(define output-handler
(lambda (msg . args)
@ -152,7 +152,7 @@
(if open?
(begin
(set! buffer-list (cons buff buffer-list))
(set! buff (make-bytevector 59))
(set! buff ($make-bytevector 59))
($bytevector-set! buff 0 b)
(set! idx 1))
(error 'write-byte "port ~s is closed" p)))
@ -182,7 +182,7 @@
(lambda ()
(make-output-port
(make-output-string-handler)
(make-string 0))))
($make-bytevector 0))))
(define get-output-string
(lambda (p)