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

fixed break-related bug in drscheme repl

Browse Source 
svn: r3993
This commit is contained in:
Robby Findler 2006-08-09 03:28:54 +00:00
parent 22b6119e74
commit d3a494fdeb
2 changed files with 30 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
collects/drscheme/private/rep.ss
View File

@ -1107,8 +1107,6 @@ TODO
(custodian-shutdown-all user-custodian)) (custodian-shutdown-all user-custodian))
(set! user-custodian #f)) (set! user-custodian #f))
(field (user-break-enabled #t))
(field (eval-thread-thunks null) (field (eval-thread-thunks null)
(eval-thread-state-sema 'not-yet-state-sema) (eval-thread-state-sema 'not-yet-state-sema)
(eval-thread-queue-sema 'not-yet-thread-sema) (eval-thread-queue-sema 'not-yet-thread-sema)
@ -1183,7 +1181,6 @@ TODO
(set! user-break-parameterization (parameterize-break (set! user-break-parameterization (parameterize-break
#t #t
(current-break-parameterization))) (current-break-parameterization)))
(set! user-break-enabled #t)
(set! eval-thread-thunks null) (set! eval-thread-thunks null)
(set! eval-thread-state-sema (make-semaphore 1)) (set! eval-thread-state-sema (make-semaphore 1))
(set! eval-thread-queue-sema (make-semaphore 0)) (set! eval-thread-queue-sema (make-semaphore 0))
@ -1372,7 +1369,6 @@ TODO
(current-error-port (get-err-port)) (current-error-port (get-err-port))
(current-value-port (get-value-port)) (current-value-port (get-value-port))
(current-input-port (get-in-box-port)) (current-input-port (get-in-box-port))
(break-enabled #t)
(let* ([primitive-dispatch-handler (event-dispatch-handler)]) (let* ([primitive-dispatch-handler (event-dispatch-handler)])
(event-dispatch-handler (event-dispatch-handler
(rec drscheme-event-dispatch-handler ; <= a name for #<...> printout (rec drscheme-event-dispatch-handler ; <= a name for #<...> printout
@ -1384,51 +1380,28 @@ TODO
[(eq? eventspace (get-user-eventspace)) [(eq? eventspace (get-user-eventspace))
; =User=, =Handler=, =No-Breaks= ; =User=, =Handler=, =No-Breaks=
(let* ([ub? (eq? user-break-enabled 'user)] ; We must distinguish between "top-level" events and
[break-ok? (if ub? ; those within `yield' in the user's program.
(break-enabled) (cond
user-break-enabled)]) [(not in-evaluation?)
(break-enabled #f) (send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian))
; We must distinguish between "top-level" events and (protect-user-evaluation
; those within `yield' in the user's program. ; Run the dispatch:
(λ () ; =User=, =Handler=, =No-Breaks=
(cond (call-with-break-parameterization
[(not in-evaluation?) user-break-parameterization
(send context reset-offer-kill) (λ () (primitive-dispatch-handler eventspace))))
(send context set-breakables (get-user-thread) (get-user-custodian)) ; Cleanup after dispatch
(λ ()
(protect-user-evaluation ;; in principle, the line below might cause
; Run the dispatch: ;; a "race conditions" in the GUI. That is, there might
(λ () ; =User=, =Handler=, =No-Breaks= ;; be many little events that the user won't quite
; This procedure is responsible for adjusting breaks to ;; be able to break.
; match the user's expectations: (send context set-breakables #f #f)))]
(dynamic-wind [else
(λ () ; Nested dispatch; don't adjust interface
(break-enabled break-ok?) (primitive-dispatch-handler eventspace)])]
(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)]))]
[else [else
; =User=, =Non-Handler=, =No-Breaks= ; =User=, =Non-Handler=, =No-Breaks=
(primitive-dispatch-handler eventspace)]))))))) (primitive-dispatch-handler eventspace)])))))))

16
collects/tests/drscheme/repl-test.ss
View File

@ -98,10 +98,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
void) void)
(make-test "(" (make-test "("
"{bug09.gif} read: expected a ')'" "{bug09.gif} read: expected a `)'"
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a ')'" "{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a `)'"
"read: expected a ')'" "read: expected a `)'"
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: 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)) (cons (make-loc 0 0 0) (make-loc 0 1 1))
#f #f
void 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 ;; error in the middle
(make-test "1 2 ( 3 4" (make-test "1 2 ( 3 4"
"1\n2\n{bug09.gif} read: expected a ')'" "1\n2\n{bug09.gif} read: expected a `)'"
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a ')'" "{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a `)'"
"1\n2\nread: expected a ')'" "1\n2\nread: expected a `)'"
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: 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)) (cons (make-loc 0 4 4) (make-loc 0 9 9))
#f #f
void void