29 lines
853 B
Scheme
29 lines
853 B
Scheme
(module label-frame-mred mzscheme
|
|
(require mred
|
|
mzlib/class)
|
|
(provide (all-from-except mred frame%)
|
|
(rename registering-frame% frame%)
|
|
lookup-frame-name)
|
|
|
|
(define (lookup-frame-name frame)
|
|
(semaphore-wait label-sema)
|
|
(begin0
|
|
(hash-table-get label-ht frame (λ () #f))
|
|
(semaphore-post label-sema)))
|
|
|
|
(define label-sema (make-semaphore 1))
|
|
(define label-ht (make-hash-table 'weak))
|
|
|
|
(define registering-frame%
|
|
(class frame%
|
|
(define/override (set-label x)
|
|
(semaphore-wait label-sema)
|
|
(hash-table-put! label-ht this x)
|
|
(semaphore-post label-sema)
|
|
(super set-label x))
|
|
(inherit get-label)
|
|
(super-instantiate ())
|
|
(semaphore-wait label-sema)
|
|
(hash-table-put! label-ht this (get-label))
|
|
(semaphore-post label-sema))))
|