From d3a494fdeb8634c597cccb6654cdc6aa0da75c23 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 9 Aug 2006 03:28:54 +0000
Subject: [PATCH] fixed break-related bug in drscheme repl

svn: r3993
---
 collects/drscheme/private/rep.ss     | 71 +++++++++-------------------
 collects/tests/drscheme/repl-test.ss | 16 +++----
 2 files changed, 30 insertions(+), 57 deletions(-)

diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index 41b07d7887..74f05eec8f 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -1107,8 +1107,6 @@ TODO
               (custodian-shutdown-all user-custodian))
 	    (set! user-custodian #f))
           
-          (field (user-break-enabled #t))
-          
           (field (eval-thread-thunks null)
                  (eval-thread-state-sema 'not-yet-state-sema)
                  (eval-thread-queue-sema 'not-yet-thread-sema)
@@ -1183,7 +1181,6 @@ TODO
             (set! user-break-parameterization (parameterize-break 
                                                #t 
                                                (current-break-parameterization)))
-            (set! user-break-enabled #t)
             (set! eval-thread-thunks null)
             (set! eval-thread-state-sema (make-semaphore 1))
             (set! eval-thread-queue-sema (make-semaphore 0))
@@ -1372,7 +1369,6 @@ TODO
               (current-error-port (get-err-port))
               (current-value-port (get-value-port))
               (current-input-port (get-in-box-port))
-              (break-enabled #t)
               (let* ([primitive-dispatch-handler (event-dispatch-handler)])
                 (event-dispatch-handler
                  (rec drscheme-event-dispatch-handler ; <= a name for #<...> printout
@@ -1384,51 +1380,28 @@ TODO
                        [(eq? eventspace (get-user-eventspace))
                         ; =User=, =Handler=, =No-Breaks=
                         
-                        (let* ([ub? (eq? user-break-enabled 'user)]
-                               [break-ok? (if ub?
-                                              (break-enabled)
-                                              user-break-enabled)])
-                          (break-enabled #f)
-                          
-                          ; We must distinguish between "top-level" events and
-                          ;  those within `yield' in the user's program.
-                          
-                          (cond
-                            [(not in-evaluation?)
-                             (send context reset-offer-kill)
-                             (send context set-breakables (get-user-thread) (get-user-custodian))
-                             
-                             (protect-user-evaluation
-                              ; Run the dispatch:
-                              (λ () ; =User=, =Handler=, =No-Breaks=
-                                ; This procedure is responsible for adjusting breaks to
-                                ;  match the user's expectations:
-                                (dynamic-wind
-                                 (λ () 
-                                   (break-enabled break-ok?)
-                                   (unless ub?
-                                     (set! user-break-enabled 'user)))
-                                 (λ ()
-                                   (primitive-dispatch-handler eventspace))
-                                 (λ ()
-                                   (unless ub?
-                                     (set! user-break-enabled (break-enabled)))
-                                   (break-enabled #f))))
-                              ; Cleanup after dispatch
-                              (λ ()
-                                ;; in principle, the line below might cause
-                                ;; a "race conditions" in the GUI. That is, there might
-                                ;; be many little events that the user won't quite
-                                ;; be able to break.
-                                (send context set-breakables #f #f)))
-                             
-                             ; Restore break:
-                             (when ub?
-                               (break-enabled break-ok?))]
-                            [else
-                             ; Nested dispatch; don't adjust interface, and restore break:
-                             (break-enabled break-ok?)
-                             (primitive-dispatch-handler eventspace)]))]
+                        ; We must distinguish between "top-level" events and
+                        ;  those within `yield' in the user's program.
+                        (cond
+                          [(not in-evaluation?)
+                           (send context reset-offer-kill)
+                           (send context set-breakables (get-user-thread) (get-user-custodian))
+                           (protect-user-evaluation
+                            ; Run the dispatch:
+                            (λ () ; =User=, =Handler=, =No-Breaks=
+                              (call-with-break-parameterization
+                               user-break-parameterization
+                               (λ () (primitive-dispatch-handler eventspace))))
+                            ; Cleanup after dispatch
+                            (λ ()
+                              ;; in principle, the line below might cause
+                              ;; a "race conditions" in the GUI. That is, there might
+                              ;; be many little events that the user won't quite
+                              ;; be able to break.
+                              (send context set-breakables #f #f)))]
+                          [else
+                           ; Nested dispatch; don't adjust interface
+                           (primitive-dispatch-handler eventspace)])]
                        [else 
                         ; =User=, =Non-Handler=, =No-Breaks=
                         (primitive-dispatch-handler eventspace)])))))))
diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss
index 03deba02e6..a61768a128 100644
--- a/collects/tests/drscheme/repl-test.ss
+++ b/collects/tests/drscheme/repl-test.ss
@@ -98,10 +98,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
                 void)
      
      (make-test "("
-                "{bug09.gif} read: expected a ')'"
-                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a ')'"
-                "read: expected a ')'"
-                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a ')'"
+                "{bug09.gif} read: expected a `)'"
+                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a `)'"
+                "read: expected a `)'"
+                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a `)'"
                 (cons (make-loc 0 0 0) (make-loc 0 1 1))
 		#f
                 void
@@ -399,10 +399,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
      
      ;; error in the middle
      (make-test "1 2 ( 3 4"
-                "1\n2\n{bug09.gif} read: expected a ')'"
-                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a ')'"
-                "1\n2\nread: expected a ')'"
-                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a ')'"
+                "1\n2\n{bug09.gif} read: expected a `)'"
+                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a `)'"
+                "1\n2\nread: expected a `)'"
+                "{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a `)'"
 		(cons (make-loc 0 4 4) (make-loc 0 9 9))
 		#f
                 void