From ca3272bd45941ac77e8bfb45bb4741a8076b371b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 25 Jul 2012 21:37:58 -0600
Subject: [PATCH] racket/port: fix `make-limited-input-port' handling of
 progress evts

Merge to v5.3
---
 collects/racket/port.rkt           |  5 +-
 collects/tests/racket/portlib.rktl | 74 ++++++++++++++++--------------
 2 files changed, 43 insertions(+), 36 deletions(-)

diff --git a/collects/racket/port.rkt b/collects/racket/port.rkt
index 6b50ac0c99..8e5b6ab1b7 100644
--- a/collects/racket/port.rkt
+++ b/collects/racket/port.rkt
@@ -1000,7 +1000,10 @@
       (define (do-peek str skip progress-evt)
         (let ([count (max 0 (min (- limit got skip) (bytes-length str)))])
           (if (zero? count)
-              eof
+              (if (and progress-evt
+                       (sync/timeout 0 progress-evt))
+                  #f
+                  eof)
               (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)])
                 (if (eq? n 0)
                     (wrap-evt port (lambda (x) 0))
diff --git a/collects/tests/racket/portlib.rktl b/collects/tests/racket/portlib.rktl
index c5078319ab..7f0e3548ff 100644
--- a/collects/tests/racket/portlib.rktl
+++ b/collects/tests/racket/portlib.rktl
@@ -840,42 +840,46 @@
     
 ;; --------------------------------------------------
 
-;; check that commit-based reading counts against a port limit:
-(let* ([p (make-limited-input-port
-           (open-input-string "A\nB\nC\nD\n") 
-           4)]
-       [N 6]
-       [chs (for/list ([i N])
-              (let ([ch (make-channel)])
-                (thread
-                 (lambda ()
-                   (channel-put ch (list (sync (read-bytes-line-evt p))
-                                         (file-position p)))))
-                ch))]
-       [r (for/list ([ch chs])
-            (channel-get ch))])
-  r)
+;; check that commit-based reading counts against a port limit;
+;; this test also checks an interaction of `make-limited-input-port'
+;; and progress evts, so run it several times
+(for ([i 100])
+  (let* ([p (make-limited-input-port
+             (open-input-string "A\nB\nC\nD\n") 
+             4)]
+         [N 6]
+         [chs (for/list ([i N])
+                (let ([ch (make-channel)])
+                  (thread
+                   (lambda ()
+                     (channel-put ch (list (sync (read-bytes-line-evt p))
+                                           (file-position p)))))
+                  ch))]
+         [r (for/list ([ch chs])
+              (channel-get ch))])
+    (test #t list? r)))
 
-;; check proper locking for concurrent access:    
-(let* ([p (make-limited-input-port
-           (open-input-string "A\nB\nC\nD\n") 
-           4)]
-       [N 6]
-       [chs (for/list ([i N])
-              (let ([ch (make-channel)])
-                (thread
-                 (lambda ()
-                   (when (even? i) (sleep))
-                   (channel-put ch (list (sync (read-bytes-line-evt p))
-                                         (file-position p)))))
-                ch))]
-       [rs (for/list ([ch chs])
-             (channel-get ch))])
-  (test 2 apply + (for/list ([r rs]) (if (bytes? (car r)) 1 0)))
-  (test #t values (for/and ([r rs]) 
-                    (if (eof-object? (car r))
-                        (eq? (cadr r) 4)
-                        (memq (cadr r) '(2 4))))))
+;; check proper locking for concurrent access:
+(for ([i 100])
+  (let* ([p (make-limited-input-port
+             (open-input-string "A\nB\nC\nD\n") 
+             4)]
+         [N 6]
+         [chs (for/list ([i N])
+                (let ([ch (make-channel)])
+                  (thread
+                   (lambda ()
+                     (when (even? i) (sleep))
+                     (channel-put ch (list (sync (read-bytes-line-evt p))
+                                           (file-position p)))))
+                  ch))]
+         [rs (for/list ([ch chs])
+               (channel-get ch))])
+    (test 2 apply + (for/list ([r rs]) (if (bytes? (car r)) 1 0)))
+    (test #t values (for/and ([r rs]) 
+                      (if (eof-object? (car r))
+                          (eq? (cadr r) 4)
+                          (and (memq (cadr r) '(2 4)) #t))))))
 
 
 (let-values ([(in out) (make-pipe-with-specials)])