From 4f8054f125e7c0bf83d43fb5b3a5fdede5707730 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 5 Dec 2005 15:45:26 +0000
Subject: [PATCH] fixed a bug in IO where port-next-location went into a busy
 loop before any io had happened

svn: r1526
---
 collects/framework/private/text.ss | 10 ++++++----
 collects/framework/test.ss         |  4 +++-
 collects/tests/drscheme/io.ss      | 27 +++++++++++++++++++++++----
 3 files changed, 32 insertions(+), 9 deletions(-)

diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index 12b9400ea1..82094f949b 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -1655,9 +1655,7 @@ WARNING: printf is rebound in the body of the unit to always
                            [resp-chan (cdr pr)])
                        (set! positioners (cons pr positioners))
                        (loop))))
-                  (if position
-                      (apply choice-evt (map service-positioner positioners))
-                      never-evt)
+                  (apply choice-evt (map service-positioner positioners))
                   (handle-evt
                    read-chan
                    (λ (ent)
@@ -1748,7 +1746,11 @@ WARNING: printf is rebound in the body of the unit to always
                      [resp-evt (cdr pr)])
                  (handle-evt
                   (choice-evt nack-evt 
-                              (channel-put-evt resp-evt position))
+                              (channel-put-evt resp-evt (or position 
+                                                            
+                                                            ;; a bogus position for when 
+                                                            ;; nothing has happened yet.
+                                                            (list 1 0 1))))
                   (let ([sent-position position])
                     (λ (_)
                       (set! positioners (remq pr positioners))
diff --git a/collects/framework/test.ss b/collects/framework/test.ss
index 8c564e3531..ea47ed507e 100644
--- a/collects/framework/test.ss
+++ b/collects/framework/test.ss
@@ -905,7 +905,9 @@
 	   (if (method-in-interface? 'on-event (object-interface window))
 	       (send window on-event event)
 	       (error mouse-tag "focused window does not have on-event"))]
-	  [(send (car l) on-subwindow-event window event)  #f]
+	  [(and (is-a? (car l) window<%>)
+                (send (car l) on-subwindow-event window event))
+           #f]
 	  [else  (loop (cdr l))]))))
   
   ;;
diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss
index dadddcd7ac..998cbf0cd7 100644
--- a/collects/tests/drscheme/io.ss
+++ b/collects/tests/drscheme/io.ss
@@ -29,8 +29,7 @@ add this test:
         (clear-definitions drs-frame)
         (type-in-definitions drs-frame expression)
         (do-execute drs-frame)
-        (let* ([text (send drs-frame get-interactions-text)]
-               [got (get-string/style-desc text (send text paragraph-start-position 2))])
+        (let* ([got (get-annotated-output)])
           (unless (andmap (λ (exp got)
                             (and (string=? (car exp) (car got))
                                  (or (equal? (cadr exp) (cadr got))
@@ -38,13 +37,33 @@ add this test:
                                           ((cadr exp) (cadr got))))))
                           expected 
                           got)
-            (error 'io.ss "expected ~s, got ~s for ~s" expected got expression)))))
+            (fprintf (current-error-port)
+                     "expected ~s, got ~s for ~s\n\n"
+                     expected
+                     got
+                     expression)))))
+    
+    (define (get-annotated-output)
+      (let ([chan (make-channel)])
+        (queue-callback
+         (λ ()
+           (let ([text (send drs-frame get-interactions-text)])
+             (channel-put chan 
+                          (get-string/style-desc text
+                                                 (send text paragraph-start-position 2))))))
+        (channel-get chan)))
     
     (define (output-style x) (equal? (list-ref x 9) '(150 0 150)))
     (define (error-style x) (equal? (list-ref x 9) '(255 0 0)))
     
     (define prompt '("\n> " default-color))
     
+    ;; this test has to be first to test an uninitialized state of the port
+    ;; NOTE: missing a name for the "value" style ... so this test appears to fail (altho it actually passes)
+    (check-output "(port-next-location (current-input-port))" 
+                  (list '("1\n0\n1\n" value-style)
+                        prompt))
+    
     (check-output "(display 1)" (list (list "1" output-style) prompt))
     (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt))
     
@@ -166,7 +185,7 @@ add this test:
   (set-language-level! (list "PLT" (regexp "Textual")))
   
   (define (run-test)
+    (output-err-port-checking) ;; must come first
     ;(long-io/execute-test)
-    ;(output-err-port-checking)
     (reading-test)
     ))