Add with-replaced-attrs.

1 files changed, 39 insertions, 0 deletions

diff --git a/vcalendar/control.scm b/vcalendar/control.scm
new file mode 100644
index 00000000..a38d678f
--- /dev/null
+++ b/vcalendar/control.scm
@@ -0,0 +1,39 @@
+(define-module (vcalendar control)
+  #:use-module (util)
+  #:use-module (vcalendar)
+  #:export (with-replaced-attrs))
+
+
+(eval-when (expand load)                ; No idea why I must have load here.
+  (define href (make-procedure-with-setter hashq-ref hashq-set!))
+
+  (define (set-temp-values! table component kvs)
+    (for-each (lambda (kv)
+                (let* (((key val) kv))
+                  (when (attr component key)
+                    (set! (href table key) (attr component key))
+                    (set! (attr component key) val))))
+              kvs))
+
+  (define (restore-values! table component keys)
+    (for-each (lambda (key)
+                (and=> (href table key)
+                       (lambda (val)
+                         (set! (attr component key) val))))
+              keys)))
+
+;;; TODO with-added-attributes
+
+(define-syntax with-replaced-attrs
+  (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
+
+;;; TODO test that restore works, at all
+;;; Test that non-local exit and return works