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

minor improvements

Browse Source 
svn: r12789
This commit is contained in:
Eli Barzilay 2008-12-12 13:43:05 +00:00
parent c76a23ed29
commit 3fcc58c05e
2 changed files with 18 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/scheme/sandbox.ss
View File

@ -223,7 +223,7 @@
;; similar to `call-in-nested-thread', but propagates killing the thread, ;; similar to `call-in-nested-thread', but propagates killing the thread,
;; shutting down the custodian or setting parameters and thread cells; ;; shutting down the custodian or setting parameters and thread cells;
;; optionally with thunks to call for kill/shutdown. ;; optionally with thunks to call for kill/shutdown instead.
(define (call-in-nested-thread* (define (call-in-nested-thread*
thunk thunk
[kill (lambda () (kill-thread (current-thread)))] [kill (lambda () (kill-thread (current-thread)))]
@ -270,8 +270,12 @@
(thread (lambda () (sleep sec) (set! r 'time) (kill-thread t))))) (thread (lambda () (sleep sec) (set! r 'time) (kill-thread t)))))
(set! r (with-handlers ([void (lambda (e) (list raise e))]) (set! r (with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs)))))) (call-with-values thunk (lambda vs (list* values vs))))))
(lambda () (unless r (set! r 'kill))) (lambda ()
(lambda () (unless r (set! r 'shut))))) (unless r (set! r 'kill))
(kill-thread (current-thread)))
(lambda ()
(unless r (set! r 'shut))
(custodian-shutdown-all (current-custodian)))))
(unless (custodian-box-value cust-box) (unless (custodian-box-value cust-box)
(if (memq r '(kill shut)) ; should always be 'shut (if (memq r '(kill shut)) ; should always be 'shut
(set! r 'memory) (set! r 'memory)

14
collects/tests/mzscheme/sandbox.ss
View File

@ -7,8 +7,14 @@
;; test call-in-nested-thread* ;; test call-in-nested-thread*
(let () (let ()
(define (kill) (kill-thread (current-thread)))
(define (shut) (custodian-shutdown-all (current-custodian)))
(define-syntax-rule (nested body ...) (define-syntax-rule (nested body ...)
(call-in-nested-thread* (lambda () body ...))) (call-in-nested-thread* (lambda () body ...)))
(define-syntax-rule (nested* body ...)
(call-in-nested-thread* (lambda () body ...)
(lambda () 'kill)
(lambda () 'shut)))
(test 1 values (nested 1)) (test 1 values (nested 1))
;; propagates parameters ;; propagates parameters
(let ([p (make-parameter #f)]) (let ([p (make-parameter #f)])
@ -19,13 +25,15 @@
;; propagates kill-thread ;; propagates kill-thread
(test (void) thread-wait (test (void) thread-wait
(thread (lambda () (thread (lambda ()
(nested (kill-thread (current-thread))) (nested (kill))
;; never reach here ;; never reach here
(semaphore-wait (make-semaphore 0))))) (semaphore-wait (make-semaphore 0)))))
;; propagates custodian-shutdown-all ;; propagates custodian-shutdown-all
(test (void) values (test (void) values
(parameterize ([current-custodian (make-custodian)]) (parameterize ([current-custodian (make-custodian)]) (nested (shut))))
(nested (custodian-shutdown-all (current-custodian)))))) ;; test handlers parameters
(test 'kill (lambda () (nested* (kill))))
(test 'shut (lambda () (nested* (shut)))))
(let ([ev void]) (let ([ev void])
(define (run thunk) (define (run thunk)