blob: 19a6fa18c61632ed6a2ab778b5c0abcbe9d38de0 (
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
36
37
|
(define-module (vcomponent util control)
:use-module (hnh 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 (car kv))
(val (cadr 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)))
;; TODO what is this even used for?
(define-syntax with-replaced-properties
(syntax-rules ()
[(G_ (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
|
