Changeset 39080 in project

Timestamp:

10/29/20 17:56:53 (5 months ago)

Author:

Moritz Heidkamp

Message:

vandusen: Work around the fact taht dynamic-wind's after thunk is not invoked when the main thunk is exited via an error

Location:

release/4/vandusen/trunk

Files:

• vandusen-db.scm (modified) (2 diffs)
• vandusen-remote.scm (modified) (1 diff)
• vandusen.scm (modified) (3 diffs)

release/4/vandusen/trunk/vandusen-db.scm

@@ -4 +4 @@
 
 (import chicken scheme)
-(use (prefix sql-de-lite sql:) srfi-18 srfi-13)
+(use (prefix sql-de-lite sql:) srfi-18 srfi-13 vandusen)
 (reexport (except sql-de-lite exec query sql))
 
@@ -18 +18 @@
   (let ((mx (make-mutex)))
     (lambda (thunk)
-      (dynamic-wind
+      (dynamic-wind+
           (lambda ()
             (mutex-lock! mx))

release/4/vandusen/trunk/vandusen-remote.scm

@@ -21 +21 @@
                                      (receive (in out) (tcp-accept listener)
                                               (thread-start! (lambda ()
-                                                               (dynamic-wind
+                                                               (dynamic-wind+
                                                                    void
                                                                    (lambda ()

release/4/vandusen/trunk/vandusen.scm

@@ -14 +14 @@
  add-finalizer
  set-nick!
- after-connect)
+ after-connect
+ dynamic-wind+)
 
 (import chicken scheme srfi-1 extras data-structures)
@@ -54 +55 @@
     (print "debug: " message)))
 
+(define (dynamic-wind+ before thunk after)
+  (let ((exn #f))
+    (dynamic-wind
+        before
+        (lambda ()
+          (handle-exceptions e
+            (set! exn (list e))
+            (thunk)))
+        (lambda ()
+          (after)
+          (when exn
+            (signal (car exn)))))))
+
 (define connection #f)
 (define connection-mutex (make-mutex))
@@ -62 +76 @@
 
 (define (call-with-connection proc)
-  (dynamic-wind
+  (dynamic-wind+
       (lambda ()
-        (mutex-lock! connection-mutex))
+        (mutex-lock! connection-mutex))
       (cut proc connection)
       (lambda ()
-        (mutex-unlock! connection-mutex))))
+        (mutex-unlock! connection-mutex))))
 
 (define (start config-file)