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/fixnum
racket/flonum racket/flonum
racket/vector racket/vector
"../mzlib/private/streams.rkt" mzlib/private/streams
(for-syntax racket/base (for-syntax racket/base
racket/syntax)) racket/syntax))
@ -148,27 +148,56 @@
[else (void)])) [else (void)]))
(define (dynamic-place module-path function) (define (dynamic-place module-path function)
(define-values (p i o e) (dynamic-place* module-path (start-place 'dynamic-place module-path function
function #f (current-output-port) (current-error-port)))
#:in #f
#:out (current-output-port) (define (dynamic-place* module-path
#:err (current-error-port))) 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) (close-output-port i)
p) p)
(define (dynamic-place* module-path (define (start-place* who module-path function in out err)
function ;; Duplicate checks in that are in the primitive `pl-dynamic-place',
#:in [in #f] ;; unfortunately, but we want these checks before we start making
#:out [out (current-output-port)] ;; stream-pumping threads, etc.
#:err [err (current-error-port)]) (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 (cond
[(pl-place-enabled?) [(pl-place-enabled?)
(define-values (p pin pout perr) (define-values (p pin pout perr)
(pl-dynamic-place module-path (pl-dynamic-place module-path
function function
(if-stream-in 'dynamic-place in) (if-stream-in who in)
(if-stream-out 'dynamic-place out) (if-stream-out who out)
(if-stream-out 'dynamic-place err))) (if-stream-out who err)))
(pump-place p pin pout perr in out err) (pump-place p pin pout perr in out err)
(values p (values p
@ -189,53 +218,49 @@
(and (not out) outr) (and (not out) outr)
(and (not err) errr)))])) (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 () (syntax-case stx ()
[(_ ch body1 body ...) [(who ch body1 body ...)
(begin (if (eq? (syntax-local-context) 'module-begin)
(unless (syntax-transforming-module-expression?) ;; when a `place' form is the only thing in a module mody:
(raise-syntax-error #f "can only be used in a module" stx)) #`(begin #,stx)
(unless (identifier? #'ch) ;; normal case:
(raise-syntax-error #f "expected an identifier" stx #'ch)) (begin
(with-syntax ([internal-def-name (unless (syntax-transforming-module-expression?)
(syntax-local-lift-expression #'(lambda (ch) body1 body ...))] (raise-syntax-error #f "can only be used in a module" stx))
[func-name (generate-temporary #'place/anon)] (unless (identifier? #'ch)
[in _in] (raise-syntax-error #f "expected an identifier" stx #'ch))
[out _out] (with-syntax ([internal-def-name
[err _err] (syntax-local-lift-expression #'(lambda (ch) body1 body ...))]
[dynamic-place-func _dynamic-place-func]) [func-name (generate-temporary #'place/anon)]
(syntax-local-lift-provide #'(rename internal-def-name func-name)) [in _in]
#'(place/proc (#%variable-reference) 'func-name dynamic-place-func #:in in #:out out #:err err)))] [out _out]
[(_ ch) [err _err]
(raise-syntax-error #f "expected at least one body expression" stx)])) [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) (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) (define-syntax (place* stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:in in #:out out #:err err ch body ...) (place-form #'in #'out #'err #'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)]
[(_ #:in in #:out out ch body ...) (place-form #'in #'out #'#f #'dynamic-place* #'('place* ch body ...))] [(pf #:in in #:out out ch body ...) (place-form #'in #'out #'#f #'start-place* #'(pf ch body ...) stx)]
[(_ #:out out #:err err ch body ...) (place-form #'#f #'out #'err #'dynamic-place* #'('place* ch body ...))] [(pf #:out out #:err err ch body ...) (place-form #'#f #'out #'err #'start-place* #'(pf ch body ...) stx)]
[(_ #:in in #:err err ch body ...) (place-form #'in #'#f #'err #'dynamic-place* #'('place* ch body ...))] [(pf #:in in #:err err ch body ...) (place-form #'in #'#f #'err #'start-place* #'(pf ch body ...) stx)]
[(_ #:in in ch body ...) (place-form #'in #'#f #'#f #'dynamic-place* #'('place* ch body ...))] [(pf #:in in ch body ...) (place-form #'in #'#f #'#f #'start-place* #'(pf ch body ...) stx)]
[(_ #:out out ch body ...) (place-form #'#f #'out #'#f #'dynamic-place* #'('place* ch body ...))] [(pf #:out out ch body ...) (place-form #'#f #'out #'#f #'start-place* #'(pf ch body ...) stx)]
[(_ #:err err ch body ...) (place-form #'#f #'#f #'err #'dynamic-place* #'('place* ch body ...))] [(pf #:err err ch body ...) (place-form #'#f #'#f #'err #'start-place* #'(pf ch body ...) stx)]
[(_ ch body ...) (place-form #'#f #'#f #'#f #'dynamic-place* #'('place* ch body ...))] [(pf ch body ...) (place-form #'#f #'#f #'#f #'start-place* #'(pf ch body ...) stx)]))
))
(define (place/proc vr (define (place/proc vr func-name who start-place-func in out err)
func-name
[dynamic-place-func dynamic-place]
#:in [in #f]
#:out [out (current-output-port)]
#:err [err (current-error-port)])
(define name (define name
(resolved-module-path-name (resolved-module-path-name
(variable-reference->resolved-module-path (variable-reference->resolved-module-path
vr))) vr)))
(when (symbol? name) (when (symbol? name)
(error 'place "the current module-path-name is not a file path")) (error who "the current module-path-name is not a file path"))
(if (eq? dynamic-place-func dynamic-place) (start-place-func who name func-name in out err))
(dynamic-place-func name func-name)
(dynamic-place-func name func-name #:in in #:out out #:err 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?]) [start-proc symbol?])
place?]{ place?]{
@ -133,16 +133,17 @@ are simulated using @racket[thread].}
@racket[start-proc] returns, then the place terminates with the @racket[start-proc] returns, then the place terminates with the
@tech{completion value} @racket[0]. @tech{completion value} @racket[0].
In the created place, the values of the @racket[current-input-port], In the created place, the @racket[current-input-port] parameter
@racket[current-output-port], and @racket[current-error-port] 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 parameters are connected to the current ports in the creating
place. If the ports are @tech{file-stream ports}, then the connected place. If the output ports are @tech{file-stream ports}, then the
ports in the places share the underlying stream, otherwise a connected ports in the places share the underlying stream, otherwise
@tech{thread} in the creating place pumps bytes to and from the a @tech{thread} in the creating place pumps bytes to the current
current ports in the creating place.} 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?] [start-proc symbol?]
[#:in in (or/c input-port? #f) #f] [#:in in (or/c input-port? #f) #f]
[#:out out (or/c output-port? #f) (current-output-port)] [#: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)))) (equal? #f (port-closed? (current-error-port))))
(error "sub-place port-close test failed")) (error "sub-place port-close test failed"))
;; Closing only stdin should lead to closed stdin in ;; Closing only stdin shouldn't matter; the new place
;; a sub-place: ;; gets a finished stdin:
(close-input-port (current-input-port)) (close-input-port (current-input-port))
(define p (place ch (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) (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))