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

fix polling of text% input port

Browse Source 
svn: r1453

original commit: 23347d028a835083f409a611190bc955340ec912
This commit is contained in:
Matthew Flatt 2005-12-01 03:46:57 +00:00
parent 76f52c0442
commit 2743c5e451
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)
(poll-guard-evt
(lambda (polling?)
(if polling?
(let ([answer
(sync
(nack-guard-evt
(λ (nack)
(let ([chan (make-channel)])
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #t))
chan))))])
(wrap-evt always-evt (λ (_) answer)))
(nack-guard-evt
(λ (nack)
(let ([chan (make-channel)])
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #f))
chan)))))))
(let ([evt
(nack-guard-evt
(λ (nack)
(let ([chan (make-channel)])
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack polling?))
chan)))])
(if polling?
(let ([v (sync evt)])
(if (eq? v 0)
;; Don't return 0, because that means something is
;; probably ready. We want to indicate that nothing is
;; ready.
never-evt
;; 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)
(sync