130 lines
3.7 KiB
Racket
130 lines
3.7 KiB
Racket
|
|
(load-relative "loadtest.rktl")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Yield Tests ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define s (make-semaphore))
|
|
(define v 4)
|
|
(queue-callback (lambda () (set! v 5)))
|
|
(yield)
|
|
(test v 'yield-run 5)
|
|
(queue-callback (lambda () (set! v 6)))
|
|
|
|
(semaphore-post s)
|
|
(yield s)
|
|
(test v 'yield-wait 5)
|
|
(yield)
|
|
(test v 'yield-run 6)
|
|
|
|
(queue-callback (lambda () (set! v 7) (semaphore-post s)))
|
|
(yield s)
|
|
(test v 'yield-run-post 7)
|
|
|
|
(queue-callback (lambda ()
|
|
(set! v 8)
|
|
(semaphore-post s)
|
|
(queue-callback
|
|
(lambda () (set! v 9)))))
|
|
(yield s)
|
|
(test v 'yield-wait-post 8)
|
|
(yield)
|
|
(test v 'yield-run 9)
|
|
|
|
(define d (make-object dialog% "hello"))
|
|
(thread (lambda ()
|
|
(sync (system-idle-evt))
|
|
(queue-callback (lambda () (set! v 11)))
|
|
(send d show #f)))
|
|
(queue-callback (lambda () (set! v 10)))
|
|
(send d show #t)
|
|
(test v 'dialog-wait 10)
|
|
(yield)
|
|
(test v 'dialog-run 11)
|
|
|
|
(define d (make-object dialog% "Hello"))
|
|
(let ([t (thread (lambda ()
|
|
(send d show #t)))])
|
|
(let loop () (unless (send d is-shown?) (loop)))
|
|
(st #t d is-shown?)
|
|
(thread-suspend t)
|
|
(stv d show #f)
|
|
(st #f d is-shown?)
|
|
(thread-resume t)
|
|
(thread-wait t)
|
|
(st #f d is-shown?)
|
|
|
|
(let ([t (thread (lambda ()
|
|
(send d show #t)))])
|
|
(let loop () (unless (send d is-shown?) (sleep) (loop)))
|
|
(st #t d is-shown?)
|
|
(thread-suspend t)
|
|
(stv d show #f)
|
|
(st #f d is-shown?)
|
|
(let ([t2 (thread (lambda () (send d show #t)))])
|
|
(yield (system-idle-evt))
|
|
(st #t d is-shown?)
|
|
(thread-resume t)
|
|
(yield (system-idle-evt))
|
|
(st #t d is-shown?)
|
|
(test #t 'thread2 (thread-running? t2))
|
|
(stv d show #f)
|
|
(thread-wait t)
|
|
(thread-wait t2)
|
|
(st #f d is-shown?))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Parameterization Tests ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Killing an eventspace
|
|
(define c (make-custodian))
|
|
(define e (parameterize ([current-custodian c]) (make-eventspace)))
|
|
(define tmr (parameterize ([current-eventspace e])
|
|
(new timer% [notify-callback void])))
|
|
(parameterize ([current-eventspace e]) (send (make-object frame% "x" #f 50 50) show #t))
|
|
(test #f 'shutdown? (eventspace-shutdown? e))
|
|
(custodian-shutdown-all c)
|
|
(test #t 'shutdown? (eventspace-shutdown? e))
|
|
(define (try-use-es t)
|
|
(test
|
|
'error
|
|
'shutdown-eventspace
|
|
(with-handlers ([(lambda (x)
|
|
(and (exn:fail? x)
|
|
(regexp-match "shutdown" (exn-message x))))
|
|
(lambda (x)
|
|
(printf "got expected error: ~a\n" (exn-message x))
|
|
'error)])
|
|
(parameterize ([current-eventspace e])
|
|
(t)))))
|
|
(try-use-es (lambda () (make-object frame% "x" #f 50 50)))
|
|
(try-use-es (lambda () (make-object dialog% "x" #f 50 50)))
|
|
(try-use-es (lambda () (make-object timer%)))
|
|
(try-use-es (lambda () (queue-callback void)))
|
|
(try-use-es (lambda () (send tmr start 100 #t)))
|
|
|
|
;; ----------------------------------------
|
|
;; Check that breaking an eventspace thread doesn't kill it:
|
|
|
|
(let ()
|
|
(define o (open-output-bytes))
|
|
(define evtsp (parameterize ([current-error-port o])
|
|
(make-eventspace)))
|
|
(define evtth (eventspace-handler-thread evtsp))
|
|
|
|
(sleep 0.1)
|
|
(break-thread evtth)
|
|
|
|
(define done (make-semaphore))
|
|
(parameterize ((current-eventspace evtsp))
|
|
(queue-callback (lambda () (semaphore-post done))))
|
|
|
|
(unless (sync/timeout 3 done)
|
|
(error "broken thread is really broken")))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(report-errs)
|