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

Revise with-logging-to-port to avoid the extra dummy log entry.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-05-31 18:48:31 -04:00
parent a2afe2c285
commit 47f48c08ad
1 changed files with 24 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/tests/typed-scheme/optimizer/run.rkt
View File

@ -6,18 +6,32 @@
test-opt test-missed-optimization) test-opt test-missed-optimization)
(define (with-logging-to-port port level proc) (define (with-logging-to-port port level proc)
(let* ([logger (current-logger)] (let* ([logger (make-logger #f (current-logger))]
[receiver (make-log-receiver logger level)] [receiver (make-log-receiver logger level)]
[stop-key (gensym)] [stop-chan (make-channel)]
[t (thread (lambda () [t (thread (lambda ()
(let loop () (define (output-event l)
(let ([l (sync receiver)])
(unless (eq? (vector-ref l 2) stop-key)
(displayln (vector-ref l 1) ; actual message (displayln (vector-ref l 1) ; actual message
port) port))
(loop))))))]) (define (clear-events)
(begin0 (proc) (let ([l (sync/timeout 0 receiver)])
(log-message logger level "" stop-key) ; stop the receiver thread (when l ; still something to read
(output-event l)
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
(cond [(eq? l 'stop)
;; we received all the events we were supposed
;; to get, read them all (w/o waiting), then
;; stop
(clear-events)]
[else ; keep going
(output-event l)
(loop)])))))])
(begin0
(parameterize ([current-logger logger])
(proc))
(channel-put stop-chan 'stop) ; stop the receiver thread
(thread-wait t)))) (thread-wait t))))
;; TODO put in unstable somewhere ;; TODO put in unstable somewhere