From 2743c5e451054dfb30618b13bd3e0a7627bed4b8 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 1 Dec 2005 03:46:57 +0000
Subject: [PATCH] fix polling of text% input port

svn: r1453

original commit: 23347d028a835083f409a611190bc955340ec912
---
 collects/framework/private/text.ss | 31 ++++++++++++++++--------------
 1 file changed, 17 insertions(+), 14 deletions(-)

diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index d200bfb6..12b9400e 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -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