fix for PR 8496

svn: r5438
This commit is contained in:
Robby Findler 2007-01-23 20:02:05 +00:00
parent 69a6c8a5cb
commit 9bcd4aafe7
2 changed files with 89 additions and 85 deletions

View File

@ -1148,7 +1148,7 @@ TODO
(break-enabled #f)
(set! user-thread-box (make-weak-box (current-thread)))
(initialize-parameters snip-classes))))
;; disable breaks until an evaluation actually occurs
(send context set-breakables #f #f)
@ -1187,6 +1187,10 @@ TODO
(set! in-evaluation? #f)
(update-running #f)
(send context set-breakables #f #f)
;; after this returns, future event dispatches
;; will use the user's break parameterization
(initialize-dispatch-handler)
;; let init-thread procedure return,
;; now that parameters are set
@ -1290,71 +1294,72 @@ TODO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; initialize-paramters : (listof snip-class%) -> void
(define/private initialize-parameters ; =User=
(λ (snip-classes)
(current-language-settings user-language-settings)
(error-value->string-handler drscheme-error-value->string-handler)
(error-print-source-location #f)
(error-display-handler drscheme-error-display-handler)
(current-load-relative-directory #f)
(current-custodian user-custodian)
(current-load text-editor-load-handler)
(drscheme:eval:set-basic-parameters snip-classes)
(current-rep this)
(let ([dir (or (send context get-directory)
(define/private (initialize-parameters snip-classes) ; =User=
(current-language-settings user-language-settings)
(error-value->string-handler drscheme-error-value->string-handler)
(error-print-source-location #f)
(error-display-handler drscheme-error-display-handler)
(current-load-relative-directory #f)
(current-custodian user-custodian)
(current-load text-editor-load-handler)
(drscheme:eval:set-basic-parameters snip-classes)
(current-rep this)
(let ([dir (or (send context get-directory)
drscheme:init:first-dir)])
(current-directory dir)
(current-load-relative-directory dir))
(set! user-namespace-box (make-weak-box (current-namespace)))
(current-output-port (get-out-port))
(current-error-port (get-err-port))
(current-value-port (get-value-port))
(current-input-port (get-in-box-port))
(let* ([primitive-dispatch-handler (event-dispatch-handler)])
(event-dispatch-handler
(rec drscheme-event-dispatch-handler ; <= a name for #<...> printout
(λ (eventspace) ; =User=, =Handler=
; Breaking is enabled if the user turned on breaks and
; is in a `yield'. If we get a break, that's ok, because
; the kernel never queues an event in the user's eventspace.
(cond
[(eq? eventspace (get-user-eventspace))
; =User=, =Handler=
; We must distinguish between "top-level" events and
; those within `yield' in the user's program.
(cond
[(not in-evaluation?)
;; at this point, we must not be in a nested dispatch, so we can
;; just disable breaks and rely on call-with-break-parameterization
;; to restore them to the user's setting.
(call-with-break-parameterization
no-breaks-break-parameterization
(λ ()
; =No-Breaks=
(send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian))
(call-with-continuation-prompt
(λ () ; =User=, =Handler=, =No-Breaks=
(call-with-break-parameterization
user-break-parameterization
(λ () (primitive-dispatch-handler eventspace)))))
;; in principle, the line below might cause
;; "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)])))))))
(current-directory dir)
(current-load-relative-directory dir))
(set! user-namespace-box (make-weak-box (current-namespace)))
(current-output-port (get-out-port))
(current-error-port (get-err-port))
(current-value-port (get-value-port))
(current-input-port (get-in-box-port)))
(define/private (initialize-dispatch-handler) ;;; =User=
(let* ([primitive-dispatch-handler (event-dispatch-handler)])
(event-dispatch-handler
(rec drscheme-event-dispatch-handler ; <= a name for #<...> printout
(λ (eventspace) ; =User=, =Handler=
; Breaking is enabled if the user turned on breaks and
; is in a `yield'. If we get a break, that's ok, because
; the kernel never queues an event in the user's eventspace.
(cond
[(eq? eventspace (get-user-eventspace))
; =User=, =Handler=
; We must distinguish between "top-level" events and
; those within `yield' in the user's program.
(cond
[(not in-evaluation?)
;; at this point, we must not be in a nested dispatch, so we can
;; just disable breaks and rely on call-with-break-parameterization
;; to restore them to the user's setting.
(call-with-break-parameterization
no-breaks-break-parameterization
(λ ()
; =No-Breaks=
(send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian))
(call-with-continuation-prompt
(λ () ; =User=, =Handler=, =No-Breaks=
(call-with-break-parameterization
user-break-parameterization
(λ () (primitive-dispatch-handler eventspace)))))
;; in principle, the line below might cause
;; "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)]))))))
(define/public (new-empty-console)
(queue-user/wait
@ -1451,7 +1456,7 @@ TODO
(λ () ; =User=, =No-Breaks=
(send (drscheme:language-configuration:language-settings-language user-language-settings)
first-opened)))
(insert-prompt)
(send context enable-evaluation)
(end-edit-sequence)

View File

@ -960,25 +960,24 @@ module browser threading seems wrong.
;; break-callback : -> void
(define/public (break-callback)
(cond
[(or (not (weak-box-value thread-to-break-box))
(not (weak-box-value custodian-to-kill-box)))
(bell)]
[offer-kill?
(if (user-wants-kill?)
(let ([thd (weak-box-value thread-to-break-box)])
(when thd
(break-thread thd)))
(let ([cust (weak-box-value custodian-to-kill-box)])
(when cust
(custodian-shutdown-all cust))))]
[else
(let ([thd (weak-box-value thread-to-break-box)])
(when thd
(break-thread thd)))
;; only offer a kill the next time if
;; something got broken.
(set! offer-kill? #t)]))
(let ([thread-to-break (weak-box-value thread-to-break-box)]
[custodian-to-kill (weak-box-value custodian-to-kill-box)])
(cond
[(or (not thread-to-break)
(not custodian-to-kill))
(bell)]
[offer-kill?
(if (user-wants-kill?)
(when thread-to-break
(break-thread thread-to-break))
(when custodian-to-kill
(custodian-shutdown-all custodian-to-kill)))]
[else
(when thread-to-break
(break-thread thread-to-break))
;; only offer a kill the next time if
;; something got broken.
(set! offer-kill? #t)])))
;; user-wants-kill? : -> boolean
;; handles events, so be sure to check state