From bc703eef01c912962a502fa676560b2c200d90ca Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 20 Dec 2021 23:06:02 +0100
Subject: let-env now handles non-local exits correctly.

---
 module/calp/util.scm | 28 ++++++++++++++++------------
 tests/let-env.scm    | 22 ++++++++++++++++++++++
 2 files changed, 38 insertions(+), 12 deletions(-)
 create mode 100644 tests/let-env.scm

diff --git a/module/calp/util.scm b/module/calp/util.scm
index 6cee1b0f..70091b2e 100644
--- a/module/calp/util.scm
+++ b/module/calp/util.scm
@@ -554,23 +554,27 @@
 
 
 
-;;; TODO shouldn't this use dynamic-wind? To handle non-local exits?
+
 (define-syntax let-env
   (syntax-rules ()
     [(_ ((name value) ...)
         body ...)
 
-     (let ((env-pairs
-            (map (lambda (n new-value)
-                   (list n new-value (getenv n)))
-                 (list (symbol->string (quote name)) ...)
-                 (list value ...))))
-       (for-each (lambda (pair) (setenv (car pair) (cadr pair)))
-                 env-pairs)
-       (let ((return (begin body ...)))
-        (for-each (lambda (pair) (setenv (car pair) (caddr pair)))
-                  env-pairs)
-        return))]))
+     (let ((env-pairs #f))
+       (dynamic-wind
+         (lambda ()
+           (set! env-pairs
+             (map (lambda (n new-value)
+                    (list n new-value (getenv n)))
+                  (list (symbol->string (quote name)) ...)
+                  (list value ...)))
+           (for-each (lambda (pair) (setenv (car pair) (cadr pair)))
+                     env-pairs))
+         (lambda () body ...)
+         (lambda ()
+           (for-each (lambda (pair) (setenv (car pair) (caddr pair)))
+                     env-pairs))))]))
+
 
 (define-public (uuidgen)
   ((@ (rnrs io ports) call-with-port)
diff --git a/tests/let-env.scm b/tests/let-env.scm
new file mode 100644
index 00000000..0fe77539
--- /dev/null
+++ b/tests/let-env.scm
@@ -0,0 +1,22 @@
+(((guile) setenv getenv)
+ ((calp util) let-env))
+
+(setenv "CALP_TEST_ENV" "1")
+(test-equal "Ensure we have set value beforehand"
+  "1" (getenv "CALP_TEST_ENV"))
+(let-env ((CALP_TEST_ENV "2"))
+         (test-equal "Test our local override"
+           "2" (getenv "CALP_TEST_ENV")))
+(test-equal "Test that we have returned"
+  "1" (getenv "CALP_TEST_ENV"))
+
+(catch 'test-error
+  (lambda ()
+   (let-env ((CALP_TEST_ENV "2"))
+            (test-equal "Test our local override again"
+              "2" (getenv "CALP_TEST_ENV"))
+            (throw 'test-error)))
+  list)
+
+(test-equal "Test restoration after non-local exit"
+  "1" (getenv "CALP_TEST_ENV"))
-- 
cgit v1.2.3