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

Partially fixes bug 173173: call-with-bytevector-output-port: primitive not supported yet

This commit is contained in:
Abdulaziz Ghuloum 2007-12-02 23:13:19 -05:00
parent 58fd9cbed8
commit 8073aa0e1e
5 changed files with 44 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/Makefile.am
View File

@ -1,6 +1,6 @@
nodist_pkglib_DATA=ikarus.boot nodist_pkglib_DATA=ikarus.boot
EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.conditions.ss ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.io.output-bytevectors.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.conditions.ss ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
all: $(nodist_pkglib_DATA) all: $(nodist_pkglib_DATA)

8
scheme/Makefile.in
View File

@ -167,10 +167,10 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss \ ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss \
ikarus.io.input-files.ss ikarus.io.input-strings.ss \ ikarus.io.input-files.ss ikarus.io.input-strings.ss \
ikarus.io.output-files.ss ikarus.io.output-strings.ss \ ikarus.io.output-files.ss ikarus.io.output-strings.ss \
ikarus.lists.ss ikarus.load.ss ikarus.main.ss \ ikarus.io.output-bytevectors.ss ikarus.lists.ss ikarus.load.ss \
ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss \ ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss \
ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss \ ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
ikarus.promises.ss ikarus.reader.ss \ ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
ikarus.records.procedural.ss ikarus.conditions.ss \ ikarus.records.procedural.ss ikarus.conditions.ss \
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \ ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \ ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \

35
scheme/ikarus.io.output-bytevectors.ss
View File

@ -16,7 +16,8 @@
(library (ikarus io output-bytevectors) (library (ikarus io output-bytevectors)
(export open-output-bytevector get-output-bytevector (export open-output-bytevector get-output-bytevector
with-output-to-bytevector open-bytevector-output-port) with-output-to-bytevector open-bytevector-output-port
call-with-bytevector-output-port)
(import (import
(ikarus system $bytevectors) (ikarus system $bytevectors)
(ikarus system $chars) (ikarus system $chars)
@ -26,7 +27,8 @@
(ikarus system $io) (ikarus system $io)
(except (ikarus) (except (ikarus)
open-output-bytevector get-output-bytevector open-output-bytevector get-output-bytevector
with-output-to-bytevector open-bytevector-output-port)) with-output-to-bytevector open-bytevector-output-port
call-with-bytevector-output-port))
(define-syntax message-case (define-syntax message-case
(syntax-rules (else) (syntax-rules (else)
@ -160,14 +162,39 @@
(parameterize ([current-output-port p]) (f)) (parameterize ([current-output-port p]) (f))
(get-output-bytevector p)))) (get-output-bytevector p))))
(define (open-bytevector-output-port) (define open-bytevector-output-port
(case-lambda
[()
(let ([p (open-output-bytevector)]) (let ([p (open-output-bytevector)])
;;; FIXME: should empty string ;;; FIXME: should empty string
(values p (values p
(lambda () (lambda ()
(let ([x (get-output-bytevector p)]) (let ([x (get-output-bytevector p)])
(($port-handler p) 'reset-port p) (($port-handler p) 'reset-port p)
x))))) x))))]
[(transcoder)
(if (not transcoder)
(open-bytevector-output-port)
(error 'open-bytevector-output-port
(format "BUG: transcoder (~s) is not supported"
transcoder)))]))
(define call-with-bytevector-output-port
(let ([who 'call-with-bytevector-output-port])
(case-lambda
[(proc)
(unless (procedure? proc)
(error who "not a procedure" proc))
(let ([p (open-output-bytevector)])
(proc p) ;;; why is this useful again?
(let ([bv (get-output-bytevector p)])
(close-output-port p)
bv))]
[(proc transcoder)
(if (not transcoder)
(call-with-bytevector-output-port proc)
(error who
(format "BUG: transcoder (~s) is not supported"
transcoder)))])))
) )

2
scheme/last-revision
View File

@ -1 +1 @@
1171 1172

2
scheme/makefile.ss
View File

@ -1018,7 +1018,7 @@
[buffer-mode i r ip] [buffer-mode i r ip]
[buffer-mode? i r ip] [buffer-mode? i r ip]
[bytevector->string r ip] [bytevector->string r ip]
[call-with-bytevector-output-port r ip] [call-with-bytevector-output-port i r ip]
[call-with-port r ip] [call-with-port r ip]
[call-with-string-output-port r ip] [call-with-string-output-port r ip]
[assoc i r ls se] [assoc i r ls se]