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

fix the use of impersonator-ephemerons in the framework preferences library

Browse Source
This commit is contained in:
Robby Findler 2013-02-20 15:02:33 -06:00
parent a25a073bc3
commit 5eddac7482
2 changed files with 87 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/framework/preferences.rkt
View File

@ -191,7 +191,7 @@ the state transitions / contracts are:
(define preferences:add-callback
(lambda (p callback [weak? #f])
(let ([new-cb (make-pref-callback (if weak?
(make-weak-box (impersonator-ephemeron callback))
(impersonator-ephemeron callback)
callback))])
(hash-set! callbacks
p
@ -215,27 +215,28 @@ the state transitions / contracts are:
;; check-callbacks : sym val -> void
(define (check-callbacks p value)
(let ([new-callbacks
(let loop ([callbacks (hash-ref callbacks p '())])
(cond
[(null? callbacks) null]
[else
(let* ([callback (car callbacks)]
[cb (pref-callback-cb callback)])
(cond
[(weak-box? cb)
(let ([v (weak-box-value cb)])
(if v
(begin
(v p value)
(cons callback (loop (cdr callbacks))))
(loop (cdr callbacks))))]
[else
(cb p value)
(cons callback (loop (cdr callbacks)))]))]))])
(if (null? new-callbacks)
(hash-remove! callbacks p)
(hash-set! callbacks p new-callbacks))))
(define new-callbacks
(let loop ([callbacks (hash-ref callbacks p '())])
(cond
[(null? callbacks) null]
[else
(define callback (car callbacks))
(define cb (pref-callback-cb callback))
(cond
[(ephemeron? cb)
(define v (ephemeron-value cb))
(cond
[v
(v p value)
(cons callback (loop (cdr callbacks)))]
[else
(loop (cdr callbacks))])]
[else
(cb p value)
(cons callback (loop (cdr callbacks)))])])))
(if (null? new-callbacks)
(hash-remove! callbacks p)
(hash-set! callbacks p new-callbacks)))
(define (preferences:set-un/marshall p marshall unmarshall)
(cond

75
collects/tests/framework/prefs.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require "test-suite-utils.rkt")
(define ((check-eq? x) y) (eq? x y))
(define ((check-equal? x) y) (equal? x y))
(define pref-sym 'plt:not-a-real-preference)
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
(define default-test-sym 'plt:not-a-real-preference-default-test)
@ -10,22 +10,22 @@
(test
'preference-unbound
(check-eq? 'passed)
(check-equal? 'passed)
`(with-handlers ([exn:unknown-preference?
(lambda (x)
'passed)])
(preferences:get ',pref-sym)))
(test 'preference-set-default/get
(check-eq? 'passed)
(check-equal? 'passed)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
(test 'preference-set/get
(check-eq? 'new-pref)
(check-equal? 'new-pref)
`(begin (preferences:set ',pref-sym 'new-pref)
(preferences:get ',pref-sym)))
(test 'preference-marshalling
(check-eq? 'the-answer)
(check-equal? 'the-answer)
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
(preferences:set-un/marshall ',marshalling-pref-sym
(lambda (f) (f))
@ -34,7 +34,7 @@
(preferences:set ',marshalling-pref-sym (lambda () 2)))))
(shutdown-mred)
(test 'preference-marshalling
(check-eq? 2)
(check-equal? 2)
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
(preferences:set-un/marshall ',marshalling-pref-sym
(lambda (f) (f))
@ -52,27 +52,80 @@
(yield (make-semaphore 0)))))
(test 'preference-get-after-restart
(check-eq? 'new-pref)
(check-equal? 'new-pref)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
(test 'preference-no-set-default-stage1
(check-eq? 'stage1)
(check-equal? 'stage1)
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:set ',default-test-sym 'new-value)
'stage1))
(shutdown-mred)
(test 'preference-no-set-default-stage2
(check-eq? 'stage2)
(check-equal? 'stage2)
`(begin 'stage2))
(shutdown-mred)
(test 'preference-no-set-default-stage3
(check-eq? 'new-value)
(check-equal? 'new-value)
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:get ',default-test-sym)))
(test 'preference-add-callback
(check-equal? 2)
`(begin
(let ([x 1])
(define remove-it (preferences:add-callback ',default-test-sym (λ (a b) (set! x (+ x 1)))))
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
x)))
(test 'preference-add-weak-callback
(check-equal? 2)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
x)))
(test 'preference-add-weak-callback2
(check-equal? 3)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(unless (zero? (random 1)) (set! f 'not-a-proc)) ;; try to stop inlining
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(collect-garbage) (collect-garbage) (collect-garbage)
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
(f 'a 'b) ;; make sure safe-for-space doesn't free 'f' earlier
x)))
(test 'preference-weak-callback-is-weak
(check-equal? #t)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define wb (make-weak-box f))
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(set! f #f)
(begin0
(let loop ([n 10])
(cond
[(not (weak-box-value wb)) #t]
[(zero? n) 'f-still-alive]
[else
(collect-garbage)
(loop (- n 1))]))
(remove-it)))))
(test 'dialog-appears
(lambda (x) (eq? 'passed x))
(check-equal? 'passed)
(lambda ()
(queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
(preferences:show-dialog)))