blob: add48c2862b8ef816350c094626fe304a8ecb98e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
(define-module (vcomponent control)
#:use-module (calp util)
#:use-module (vcomponent)
#:export (with-replaced-properties))
(eval-when (expand load) ; No idea why I must have load here.
(define href (make-procedure-with-setter hash-ref hash-set!))
(define (set-temp-values! table component kvs)
(for-each (lambda (kv)
(let* (((key val) kv))
(when (prop component key)
(set! (href table key) (prop component key))
(set! (prop component key) val))))
kvs))
(define (restore-values! table component keys)
(for-each (lambda (key)
(and=> (href table key)
(lambda (val)
(set! (prop component key) val))))
keys)))
(define-syntax with-replaced-properties
(syntax-rules ()
[(_ (component (key val) ...)
body ...)
(let ((htable (make-hash-table 10)))
(dynamic-wind
(lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard
(lambda () body ...)
(lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard
|
