Partially fixes bug 173173: call-with-bytevector-output-port: primitive not supported yet
This commit is contained in:
Abdulaziz Ghuloum
parent
58fd9cbed8
commit
8073aa0e1e
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -167,10 +167,10 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.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.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 \
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@
|
|||
|
||||
(library (ikarus io output-bytevectors)
|
||||
(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
|
||||
(ikarus system $bytevectors)
|
||||
(ikarus system $chars)
|
||||
|
|
@ -26,7 +27,8 @@
|
|||
(ikarus system $io)
|
||||
(except (ikarus)
|
||||
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
|
||||
(syntax-rules (else)
|
||||
|
|
@ -160,14 +162,39 @@
|
|||
(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)))))
|
||||
(define open-bytevector-output-port
|
||||
(case-lambda
|
||||
[()
|
||||
(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))))]
|
||||
[(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)))])))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1171
|
||||
1172
|
||||
|
|
|
|||
|
|
@ -1018,7 +1018,7 @@
|
|||
[buffer-mode i r ip]
|
||||
[buffer-mode? i 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-string-output-port r ip]
|
||||
[assoc i r ls se]
|
||||
|
|
|
|||
Loading…
Reference in New Issue