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

Added open-bytevector-output-port

This commit is contained in:
Abdulaziz Ghuloum 2007-12-02 22:59:08 -05:00
parent 5073b26fe9
commit 58fd9cbed8
4 changed files with 179 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scheme/ikarus.exceptions.ss
View File

@ -25,7 +25,6 @@
with-exception-handler raise raise-continuable
error assertion-violation))
(define handlers
(make-parameter
(list

173
scheme/ikarus.io.output-bytevectors.ss Normal file
View File

@ -0,0 +1,173 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus io output-bytevectors)
(export open-output-bytevector get-output-bytevector
with-output-to-bytevector open-bytevector-output-port)
(import
(ikarus system $bytevectors)
(ikarus system $chars)
(ikarus system $fx)
(ikarus system $pairs)
(ikarus system $ports)
(ikarus system $io)
(except (ikarus)
open-output-bytevector get-output-bytevector
with-output-to-bytevector open-bytevector-output-port))
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))
(define concat
(lambda (bv i ls)
(let ([n (sum i ls)])
(let ([outbv ($make-bytevector n)])
(let f ([n (copy outbv bv i n)] [ls ls])
(if (null? ls)
outbv
(let ([a ($car ls)])
(f (copy outbv a ($bytevector-length a) n) ($cdr ls)))))))))
(define sum
(lambda (ac ls)
(cond
[(null? ls) ac]
[else (sum ($fx+ ac ($bytevector-length ($car ls))) ($cdr ls))])))
(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)])
($bytevector-set! dst di ($bytevector-u8-ref src si))
(f di si))]))))
(define bv-copy
(lambda (src)
(let ([n ($bytevector-length src)])
(let f ([src src] [dst ($make-bytevector n)] [i 0] [n n])
(cond
[($fx= i n) dst]
[else
($bytevector-set! dst i ($bytevector-u8-ref src i))
(f src dst ($fxadd1 i) n)])))))
(define make-output-bytevector-handler
(lambda ()
(define buffer-list '())
(define open? #t)
(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)
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(begin
($bytevector-set! ($port-buffer p) idx b)
($set-port-index! p ($fxadd1 idx)))
(if open?
(let ([buff ($port-buffer p)])
(set! buffer-list (cons (bv-copy buff) buffer-list))
($bytevector-set! buff 0 b)
($set-port-index! p 1))
(error 'write-byte "port is closed" p))))
(error 'write-byte "not an output-port" p))
(error 'write-byte "not a byte" b))]
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([b ($char->fixnum c)])
(if ($fx<= b 127)
($write-byte b p)
(error 'write-char
"BUG: multibyte write of is not implemented" c)))
(error 'write-char "not an output-port" p))
(error 'write-char "not a character" c))]
[(flush-output-port p)
(void)]
[(close-port p)
(set! open? #f)]
[(port-name p) 'bytevector-port]
[(get-output-bytevector p)
(concat
($port-buffer p)
($port-index p)
buffer-list)]
[(reset-port p)
($set-port-index! p 0)
(set! buffer-list '())]
[else
(error 'bytevector-output-handler
"unhandled message" (cons msg args))])))
output-handler))
(define open-output-bytevector
(lambda ()
(make-output-port
(make-output-bytevector-handler)
($make-bytevector 59))))
(define get-output-bytevector
(lambda (p)
(if (output-port? p)
(($port-handler p) 'get-output-bytevector p)
(error 'get-output-bytevector "not an output port" p))))
(define with-output-to-bytevector
(lambda (f)
(unless (procedure? f)
(error 'with-output-to-bytevector "not a procedure" f))
(let ([p (open-output-bytevector)])
(parameterize ([current-output-port p]) (f))
(get-output-bytevector p))))
(define (open-bytevector-output-port)
(let ([p (open-output-bytevector)])
;;; FIXME: should empty string
(values p
(lambda ()
(let ([x (get-output-bytevector p)])
(($port-handler p) 'reset-port p)
x)))))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1170
1171

6
scheme/makefile.ss
View File

@ -72,6 +72,7 @@
"ikarus.io.output-files.ss"
"ikarus.io.input-strings.ss"
"ikarus.io.output-strings.ss"
"ikarus.io.output-bytevectors.ss"
"ikarus.hash-tables.ss"
"ikarus.writer.ss"
"ikarus.reader.ss"
@ -338,9 +339,12 @@
[set-port-mode! i]
[with-input-from-string i]
[open-output-string i]
[open-output-bytevector i]
[open-input-string i]
[get-output-string i]
[get-output-bytevector i]
[with-output-to-string i]
[with-output-to-bytevector i]
[console-input-port i]
[console-output-port i]
[reset-input-port! i]
@ -1123,7 +1127,7 @@
[native-eol-style i r ip]
[native-transcoder i r ip]
[open-bytevector-input-port r ip]
[open-bytevector-output-port r ip]
[open-bytevector-output-port i r ip]
[open-file-input-port r ip]
[open-file-input/output-port r ip]
[open-file-output-port r ip]