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

fix polling of text% input port

Browse Source 
svn: r1453
This commit is contained in:
Matthew Flatt 2005-12-01 03:46:57 +00:00
parent 7124e7f063
commit 23347d028a
1 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/framework/private/text.ss
View File

@ -1857,20 +1857,23 @@ WARNING: printf is rebound in the body of the unit to always
(define (peek-proc bstr skip-count progress-evt) (define (peek-proc bstr skip-count progress-evt)
(poll-guard-evt (poll-guard-evt
(lambda (polling?) (lambda (polling?)
(if polling? (let ([evt
(let ([answer (nack-guard-evt
(sync (λ (nack)
(nack-guard-evt (let ([chan (make-channel)])
(λ (nack) (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack polling?))
(let ([chan (make-channel)]) chan)))])
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #t)) (if polling?
chan))))]) (let ([v (sync evt)])
(wrap-evt always-evt (λ (_) answer))) (if (eq? v 0)
(nack-guard-evt ;; Don't return 0, because that means something is
(λ (nack) ;; probably ready. We want to indicate that nothing is
(let ([chan (make-channel)]) ;; ready.
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #f)) never-evt
chan))))))) ;; Even on success, package it as an event, because
;; `read-bytes-proc' expects an event
(wrap-evt always-evt (lambda (_) v))))
evt)))))
(define (progress-evt-proc) (define (progress-evt-proc)
(sync (sync