From 8073aa0e1e64f302ec7f29ae392d93ef2cd79419 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sun, 2 Dec 2007 23:13:19 -0500 Subject: [PATCH] Partially fixes bug 173173: call-with-bytevector-output-port: primitive not supported yet --- scheme/Makefile.am | 2 +- scheme/Makefile.in | 8 ++--- scheme/ikarus.io.output-bytevectors.ss | 47 ++++++++++++++++++++------ scheme/last-revision | 2 +- scheme/makefile.ss | 2 +- 5 files changed, 44 insertions(+), 17 deletions(-) diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 1135e6c..1eefec1 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -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) diff --git a/scheme/Makefile.in b/scheme/Makefile.in index 7027aff..0c8f25b 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -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 \ diff --git a/scheme/ikarus.io.output-bytevectors.ss b/scheme/ikarus.io.output-bytevectors.ss index 2183b77..7c4cdf9 100644 --- a/scheme/ikarus.io.output-bytevectors.ss +++ b/scheme/ikarus.io.output-bytevectors.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)))]))) ) diff --git a/scheme/last-revision b/scheme/last-revision index 75fccd6..15c1c7c 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1171 +1172 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index ec8f212..1ab55ee 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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]