diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-21 16:17:28 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-22 22:58:30 +0100 |
commit | d00fea566004e67161ee45246b239fff5d416b0e (patch) | |
tree | 5641c0c0d0e78b046b6045ed2440512f12259560 /module/vcomponent/util/control.scm | |
parent | Complete rewrite of use2dot (diff) | |
download | calp-d00fea566004e67161ee45246b239fff5d416b0e.tar.gz calp-d00fea566004e67161ee45246b239fff5d416b0e.tar.xz |
Cleanup modules.
Primarly this moves all vcompenent input and output code to clearly
labeled modules, instead of being spread out. At the same time it also
removes a handfull of unused procedures.
Diffstat (limited to 'module/vcomponent/util/control.scm')
-rw-r--r-- | module/vcomponent/util/control.scm | 36 |
1 files changed, 36 insertions, 0 deletions
diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm new file mode 100644 index 00000000..4cb6c708 --- /dev/null +++ b/module/vcomponent/util/control.scm @@ -0,0 +1,36 @@ +(define-module (vcomponent util 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))) + +;; TODO what is this even used for? +(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 + |