From 4dd202b9606db76fb2fa05b76b17ae883d5e0357 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Nov 2008 21:11:48 +0000 Subject: [PATCH] , svn: r12430 --- collects/scheme/main.ss | 2 + collects/scheme/port.ss | 63 ++++++++++++++++++- collects/scribblings/reference/port-lib.scrbl | 62 +++++++++++++++++- collects/tests/mzscheme/portlib.ss | 26 ++++++++ doc/release-notes/mzscheme/HISTORY.txt | 7 ++- src/mzscheme/src/schvers.h | 4 +- 6 files changed, 158 insertions(+), 6 deletions(-) diff --git a/collects/scheme/main.ss b/collects/scheme/main.ss index f62734c422..37a3902031 100644 --- a/collects/scheme/main.ss +++ b/collects/scheme/main.ss @@ -15,6 +15,7 @@ scheme/function scheme/path scheme/file + scheme/port scheme/cmdline scheme/promise scheme/bool @@ -39,6 +40,7 @@ scheme/function scheme/path scheme/file + scheme/port scheme/cmdline scheme/promise scheme/bool diff --git a/collects/scheme/port.ss b/collects/scheme/port.ss index 6da4408f75..016bb03529 100644 --- a/collects/scheme/port.ss +++ b/collects/scheme/port.ss @@ -8,7 +8,17 @@ port->bytes port->lines port->bytes-lines - display-lines) + display-lines + + with-output-to-string + with-output-to-bytes + call-with-output-string + call-with-output-bytes + + with-input-from-string + with-input-from-bytes + call-with-input-string + call-with-input-bytes) (define (port->string-port who p) (unless (input-port? p) @@ -34,4 +44,53 @@ (raise-type-error 'display-lines "list" l)) (unless (output-port? p) (raise-type-error 'display-lines "output-port" p)) - (do-lines->port l p newline))) + (do-lines->port l p newline)) + + (define (with-output-to-x who n proc) + (unless (and (procedure? proc) + (procedure-arity-includes? proc n)) + (raise-type-error who (format "procedure (arity ~a)" n) proc)) + (let ([s (open-output-bytes)]) + ;; Use `dup-output-port' to hide string-port-ness of s: + (if (zero? n) + (parameterize ([current-output-port (dup-output-port s #t)]) + (proc)) + (proc (dup-output-port s #t))) + s)) + + (define (with-output-to-string proc) + (get-output-string (with-output-to-x 'with-output-to-string 0 proc))) + + (define (with-output-to-bytes proc) + (get-output-bytes (with-output-to-x 'with-output-to-bytes 0 proc) #t)) + + (define (call-with-output-string proc) + (get-output-string (with-output-to-x 'call-with-output-string 1 proc))) + + (define (call-with-output-bytes proc) + (get-output-bytes (with-output-to-x 'call-with-output-bytes 1 proc) #t)) + + (define (with-input-from-x who n b? str proc) + (unless (if b? (bytes? str) (string? str)) + (raise-type-error who (if b? "byte string" "string") 0 str proc)) + (unless (and (procedure? proc) + (procedure-arity-includes? proc n)) + (raise-type-error who (format "procedure (arity ~a)" n) 1 str proc)) + (let ([s (if b? (open-input-bytes str) (open-input-string str))]) + (if (zero? n) + (parameterize ([current-input-port s]) + (proc)) + (proc s)))) + + (define (with-input-from-string str proc) + (with-input-from-x 'with-input-from-string 0 #f str proc)) + + (define (with-input-from-bytes str proc) + (with-input-from-x 'with-input-from-bytes 0 #t str proc)) + + (define (call-with-input-string str proc) + (with-input-from-x 'call-with-input-string 1 #f str proc)) + + (define (call-with-input-bytes str proc) + (with-input-from-x 'call-with-input-bytes 1 #t str proc))) + diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index 3bb948465b..adee4416e4 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/collects/scribblings/reference/port-lib.scrbl @@ -4,7 +4,7 @@ @title[#:tag "port-lib"]{More Port Constructors, Procedures, and Events} -@note-lib-only[scheme/port] +@note-lib[scheme/port] @; ---------------------------------------------------------------------- @@ -42,6 +42,66 @@ lines like @scheme[read-bytes-line].} Use @scheme[display] to each each element of @scheme[lst] to @scheme[out], adding @scheme[separator] after each element.} +@defproc[(call-with-output-string [proc (output-port? . -> . any)]) string?]{ + +Calls @scheme[proc] with an output port that accumulates all output +into a string, and returns the string. + +The port passed to @scheme[proc] is like the one created by +@scheme[open-output-string], except that it is wrapped via +@scheme[dup-output-port], so that @scheme[proc] cannot access the +port's content using @scheme[get-output-string]. If control jumps back +into @scheme[proc], the port continues to accumulate new data, and +@scheme[call-with-output-string] returns both the old data and newly +accumulated data.} + +@defproc[(call-with-output-bytes [proc (output-port? . -> . any)]) bytes?]{ + +Like @scheme[call-with-output-string], but returns accumulated results +in a @tech{byte string} instead of a string. Furthermore, the port's +content is emptied when @scheme[call-with-output-bytes] returns, so +that if control jumps back into @scheme[proc] and returns a second +time, only the newly accumulated bytes are returned.} + +@defproc[(with-output-to-string [proc (-> any)]) string?]{ + +Equivalent to + +@schemeblock[(call-with-output-string + (lambda (p) (parameterize ([current-output-port p]) + (proc))))]} + +@defproc[(with-output-to-bytes [proc (-> any)]) bytes?]{ + +Equivalent to + +@schemeblock[(call-with-output-bytes + (lambda (p) (parameterize ([current-output-port p]) + (proc))))]} + +@defproc[(call-with-input-string [str string?][proc (input-port? . -> . any)]) any]{ + +Equivalent to @scheme[(proc (open-input-string str))].} + +@defproc[(call-with-input-bytes [bstr bytes?][proc (input-port? . -> . any)]) any]{ + +Equivalent to @scheme[(proc (open-input-bytes bstr))].} + +@defproc[(with-input-from-string [str string?][proc (-> any)]) any]{ + +Equivalent to + +@schemeblock[(parameterize ([current-input-port (open-input-string str)]) + (proc))]} + +@defproc[(with-input-from-bytes [bstr bytes?][proc (-> any)]) any]{ + +Equivalent to + +@schemeblock[(parameterize ([current-input-port (open-input-bytes str)]) + (proc))]} + + @; ---------------------------------------------------------------------- @section{Creating Ports} diff --git a/collects/tests/mzscheme/portlib.ss b/collects/tests/mzscheme/portlib.ss index 6bd7dad3e3..312d725a7d 100644 --- a/collects/tests/mzscheme/portlib.ss +++ b/collects/tests/mzscheme/portlib.ss @@ -33,6 +33,32 @@ ;; ---------------------------------------- +(let () + (define (test-with cw-in cw-out s wrap-in wrap-out) + (test 'cat cw-in s (wrap-in (lambda (p) (read p)))) + (test s cw-out (wrap-out (lambda (p) (write 'cat p))))) + (test-with call-with-input-bytes call-with-output-bytes #"cat" values values) + (test-with call-with-input-string call-with-output-string "cat" values values) + (let ([wrap-in (lambda (f) (lambda () (f (current-input-port))))] + [wrap-out (lambda (f) (lambda () (f (current-output-port))))]) + (test-with with-input-from-bytes with-output-to-bytes #"cat" wrap-in wrap-out) + (test-with with-input-from-string with-output-to-string "cat" wrap-in wrap-out))) + +(err/rt-test (call-with-input-bytes "x" values)) +(err/rt-test (call-with-input-string #"x" values)) +(err/rt-test (with-input-from-bytes "x" values)) +(err/rt-test (with-input-from-string #"x" values)) +(err/rt-test (call-with-input-bytes #"x" (lambda () 'x))) +(err/rt-test (call-with-input-string "x" (lambda () 'x))) +(err/rt-test (with-input-from-bytes #"x" add1)) +(err/rt-test (with-input-from-string "x" add1)) +(err/rt-test (call-with-output-bytes (lambda () 'x))) +(err/rt-test (call-with-output-string (lambda () 'x))) +(err/rt-test (with-output-to-bytes add1)) +(err/rt-test (with-output-to-string add1)) + +;; ---------------------------------------- + ;; pipe and pipe-with-specials commmit tests (define (test-pipe-commit make-pipe) (let-values ([(in out) (make-pipe)]) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 2c0c7a3a4b..0a7bb68e36 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,9 +1,14 @@ +Version 4.1.2.5 +Changed scheme to re-export scheme/port +In scheme/port: added [call-]with-input-from-{string,bytes} and + [call-]with-output-to-{string,bytes} + Version 4.1.2.4 Added call-with-immediate-continuation-mark In scheme/port: added port->string, port->bytes, port->lines port->bytes-lines, and display-list In scheme/file: added file->string, file->bytes, file->lines, - file->value, file->bytes-lines, write-to-file, display-to-file, + file->value, file->bytes-lines, write-to-file, display-to-file, and display-list-to-file Version 4.1.2.3 diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 5757a0394a..4dab675642 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.2.4" +#define MZSCHEME_VERSION "4.1.2.5" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 2 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)