suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

places: doc repair, refine error checking, fix a test

Browse Source
This commit is contained in:
Matthew Flatt 2011-09-17 07:17:09 -06:00
parent 48fdcdd65d
commit f280fb14b4
3 changed files with 110 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
collects/racket/place.rkt
View File

@ -7,7 +7,7 @@
racket/fixnum
racket/flonum
racket/vector
"../mzlib/private/streams.rkt"
mzlib/private/streams
(for-syntax racket/base
racket/syntax))
@ -148,27 +148,56 @@
[else (void)]))
(define (dynamic-place module-path function)
(define-values (p i o e) (dynamic-place* module-path
function
#:in #f
#:out (current-output-port)
#:err (current-error-port)))
(start-place 'dynamic-place module-path function
#f (current-output-port) (current-error-port)))
(define (dynamic-place* module-path
function
#:in [in #f]
#:out [out (current-output-port)]
#:err [err (current-error-port)])
(start-place* 'dynamic-place* module-path function in out err))
(define (start-place who module-path function in out err)
(define-values (p i o e) (start-place* who
module-path
function
in
out
err))
(close-output-port i)
p)
(define (dynamic-place* module-path
function
#:in [in #f]
#:out [out (current-output-port)]
#:err [err (current-error-port)])
(define (start-place* who module-path function in out err)
;; Duplicate checks in that are in the primitive `pl-dynamic-place',
;; unfortunately, but we want these checks before we start making
;; stream-pumping threads, etc.
(unless (or (module-path? module-path) (path? module-path))
(raise-type-error who "module-path or path" module-path))
(unless (symbol? function)
(raise-type-error who "symbol" module-path))
(unless (or (not in) (input-port? in))
(raise-type-error who "input-port or #f" in))
(unless (or (not out) (output-port? out))
(raise-type-error who "output-port or #f" out))
(unless (or (not err) (output-port? err) (eq? err 'stdout))
(raise-type-error who "output-port, #f, or 'stdout" err))
(when (and (pair? module-path) (eq? (car module-path) 'quote))
(raise-mismatch-error who "not a filesystem module-path: " module-path))
(when (and (input-port? in) (port-closed? in))
(raise-mismatch-error who "input port is closed: " in))
(when (and (output-port? out) (port-closed? out))
(raise-mismatch-error who "output port is closed: " out))
(when (and (output-port? err) (port-closed? err))
(raise-mismatch-error who "error port is closed: " err))
(cond
[(pl-place-enabled?)
(define-values (p pin pout perr)
(pl-dynamic-place module-path
function
(if-stream-in 'dynamic-place in)
(if-stream-out 'dynamic-place out)
(if-stream-out 'dynamic-place err)))
(if-stream-in who in)
(if-stream-out who out)
(if-stream-out who err)))
(pump-place p pin pout perr in out err)
(values p
@ -189,53 +218,49 @@
(and (not out) outr)
(and (not err) errr)))]))
(define-for-syntax (place-form _in _out _err _dynamic-place-func stx)
(define-for-syntax (place-form _in _out _err _start-place-func stx orig-stx)
(syntax-case stx ()
[(_ ch body1 body ...)
(begin
(unless (syntax-transforming-module-expression?)
(raise-syntax-error #f "can only be used in a module" stx))
(unless (identifier? #'ch)
(raise-syntax-error #f "expected an identifier" stx #'ch))
(with-syntax ([internal-def-name
(syntax-local-lift-expression #'(lambda (ch) body1 body ...))]
[func-name (generate-temporary #'place/anon)]
[in _in]
[out _out]
[err _err]
[dynamic-place-func _dynamic-place-func])
(syntax-local-lift-provide #'(rename internal-def-name func-name))
#'(place/proc (#%variable-reference) 'func-name dynamic-place-func #:in in #:out out #:err err)))]
[(_ ch)
(raise-syntax-error #f "expected at least one body expression" stx)]))
[(who ch body1 body ...)
(if (eq? (syntax-local-context) 'module-begin)
;; when a `place' form is the only thing in a module mody:
#`(begin #,stx)
;; normal case:
(begin
(unless (syntax-transforming-module-expression?)
(raise-syntax-error #f "can only be used in a module" stx))
(unless (identifier? #'ch)
(raise-syntax-error #f "expected an identifier" stx #'ch))
(with-syntax ([internal-def-name
(syntax-local-lift-expression #'(lambda (ch) body1 body ...))]
[func-name (generate-temporary #'place/anon)]
[in _in]
[out _out]
[err _err]
[start-place-func _start-place-func])
(syntax-local-lift-provide #'(rename internal-def-name func-name))
#'(place/proc (#%variable-reference) 'func-name 'who start-place-func in out err))))]
[(_ ch)
(raise-syntax-error #f "expected at least one body expression" orig-stx)]))
(define-syntax (place stx)
(place-form #'#f #'(current-output-port) #'(current-error-port) #'dynamic-place stx))
(place-form #'#f #'(current-output-port) #'(current-error-port) #'start-place stx stx))
(define-syntax (place* stx)
(syntax-case stx ()
[(_ #:in in #:out out #:err err ch body ...) (place-form #'in #'out #'err #'dynamic-place* #'('place* ch body ...))]
[(_ #:in in #:out out ch body ...) (place-form #'in #'out #'#f #'dynamic-place* #'('place* ch body ...))]
[(_ #:out out #:err err ch body ...) (place-form #'#f #'out #'err #'dynamic-place* #'('place* ch body ...))]
[(_ #:in in #:err err ch body ...) (place-form #'in #'#f #'err #'dynamic-place* #'('place* ch body ...))]
[(_ #:in in ch body ...) (place-form #'in #'#f #'#f #'dynamic-place* #'('place* ch body ...))]
[(_ #:out out ch body ...) (place-form #'#f #'out #'#f #'dynamic-place* #'('place* ch body ...))]
[(_ #:err err ch body ...) (place-form #'#f #'#f #'err #'dynamic-place* #'('place* ch body ...))]
[(_ ch body ...) (place-form #'#f #'#f #'#f #'dynamic-place* #'('place* ch body ...))]
))
[(pf #:in in #:out out #:err err ch body ...) (place-form #'in #'out #'err #'start-place* #'(pf ch body ...) stx)]
[(pf #:in in #:out out ch body ...) (place-form #'in #'out #'#f #'start-place* #'(pf ch body ...) stx)]
[(pf #:out out #:err err ch body ...) (place-form #'#f #'out #'err #'start-place* #'(pf ch body ...) stx)]
[(pf #:in in #:err err ch body ...) (place-form #'in #'#f #'err #'start-place* #'(pf ch body ...) stx)]
[(pf #:in in ch body ...) (place-form #'in #'#f #'#f #'start-place* #'(pf ch body ...) stx)]
[(pf #:out out ch body ...) (place-form #'#f #'out #'#f #'start-place* #'(pf ch body ...) stx)]
[(pf #:err err ch body ...) (place-form #'#f #'#f #'err #'start-place* #'(pf ch body ...) stx)]
[(pf ch body ...) (place-form #'#f #'#f #'#f #'start-place* #'(pf ch body ...) stx)]))
(define (place/proc vr
func-name
[dynamic-place-func dynamic-place]
#:in [in #f]
#:out [out (current-output-port)]
#:err [err (current-error-port)])
(define (place/proc vr func-name who start-place-func in out err)
(define name
(resolved-module-path-name
(variable-reference->resolved-module-path
vr)))
(when (symbol? name)
(error 'place "the current module-path-name is not a file path"))
(if (eq? dynamic-place-func dynamic-place)
(dynamic-place-func name func-name)
(dynamic-place-func name func-name #:in in #:out out #:err err)))
(error who "the current module-path-name is not a file path"))
(start-place-func who name func-name in out err))

17
collects/scribblings/reference/places.scrbl
View File

@ -104,7 +104,7 @@ are simulated using @racket[thread].}
}
@defproc[(dynamic-place [module-path module-path?]
@defproc[(dynamic-place [module-path (or/c module-path? path?)]
[start-proc symbol?])
place?]{
@ -133,16 +133,17 @@ are simulated using @racket[thread].}
@racket[start-proc] returns, then the place terminates with the
@tech{completion value} @racket[0].
In the created place, the values of the @racket[current-input-port],
@racket[current-output-port], and @racket[current-error-port]
In the created place, the @racket[current-input-port] parameter
is set to an empty input port, while the values of the
@racket[current-output-port] and @racket[current-error-port]
parameters are connected to the current ports in the creating
place. If the ports are @tech{file-stream ports}, then the connected
ports in the places share the underlying stream, otherwise a
@tech{thread} in the creating place pumps bytes to and from the
current ports in the creating place.}
place. If the output ports are @tech{file-stream ports}, then the
connected ports in the places share the underlying stream, otherwise
a @tech{thread} in the creating place pumps bytes to the current
ports in the creating place.}
@defproc[(dynamic-place* [module-path module-path?]
@defproc[(dynamic-place* [module-path (or/c module-path? path?)]
[start-proc symbol?]
[#:in in (or/c input-port? #f) #f]
[#:out out (or/c output-port? #f) (current-output-port)]

28
collects/tests/racket/place-stdio.rkt
View File

@ -14,11 +14,31 @@
(equal? #f (port-closed? (current-error-port))))
(error "sub-place port-close test failed"))
;; Closing only stdin should lead to closed stdin in
;; a sub-place:
;; Closing only stdin shouldn't matter; the new place
;; gets a finished stdin:
(close-input-port (current-input-port))
(define p (place ch
(place-channel-put ch (port-closed? (current-input-port)))))
(place-channel-put ch (eof-object? (read-byte (current-input-port))))))
(unless (equal? (place-channel-get p) #t)
(error "closed-stdin test failed")))
(error "closed-stdin test failed"))
;; Cosed current output port => fail creating place
(define (try-closed mk)
(with-handlers ([exn:fail:contract? (lambda (exn)
(unless (regexp-match? #rx"port is closed"
(exn-message exn))
(raise exn)))])
(let ([p (mk)])
(close-output-port p)
(parameterize ([current-output-port p])
(place ch (void)))
(error (format "closed-stdout test failed on ~e" mk)))))
(let ([f (make-temporary-file)])
(dynamic-wind
void
(lambda ()
(try-closed (lambda () (open-output-file f #:exists 'truncate))))
(lambda ()
(delete-file f))))
(try-closed open-output-bytes))