srfi125 find-update add thunk indirection to enforce tail position

2 files changed, 54 insertions, 15 deletions

diff --git a/srfi-225-test.scm b/srfi-225-test.scm
index 1ef4231..d4d601b 100644
--- a/srfi-225-test.scm
+++ b/srfi-225-test.scm
@@ -635,15 +635,49 @@
 
   (test-group
    "dict-fold"
-   (define value
-     (dict-fold dto
-                (lambda (key value acc)
-                  (append acc (list key value)))
-                '()
-                (alist->dict '((a . b) (c . d)))))
-   (test-assert
-       (or (equal? '(a b c d) value)
-           (equal? '(c d a b) value))))
+   
+   ;; simple case
+   (let ()
+    (define value
+      (dict-fold dto
+                 (lambda (key value acc)
+                   (append acc (list key value)))
+                 '()
+                 (alist->dict '((a . b) (c . d)))))
+    (test-assert
+      (or (equal? '(a b c d) value)
+          (equal? '(c d a b) value))))
+   
+   (let ()
+
+     ;; continuation captured in a middle of fold
+    (define k #f)
+    (define pass 0)
+
+    (define value
+      (dict-fold dto
+                 (lambda (key value acc)
+                   ;; check fold only starts once -- further passes enter in a middle
+                   (test-assert (not (and k
+                                          (null? acc))))
+                   ;; capture continuation on second fold iteration
+                   (when (and (not k)
+                              (not (null? acc)))
+                     (test-assert
+                       (or (equal? '(a b) acc)
+                           (equal? '(c d) acc)))
+                     (call/cc (lambda (cont) (set! k cont))))
+                   (append acc (list key value)))
+                 '()
+                 (alist->dict '((a . b) (c . d)))))
+
+    (test-assert
+      (or (equal? '(a b c d) value)
+          (equal? '(c d a b) value)))
+
+    (when (< pass 3)
+      (set! pass (+ 1 pass))
+      (k #t))))
 
   (test-group
    "dict-map->list"
diff --git a/srfi/srfi-125-impl.scm b/srfi/srfi-125-impl.scm
index 1d5cf8e..bbc5543 100644
--- a/srfi/srfi-125-impl.scm
+++ b/srfi/srfi-125-impl.scm
@@ -72,7 +72,10 @@
         table))
 
     (define (t125-hash-table-find-update* dto table key fail success)
-      (define (handle-success value)
+      ;; instead of running immediately,
+      ;; add an indirection through thunk
+      ;; to guarantee call in tail position
+      (define (make-success-thunk value)
         (define (update new-key new-value)
           (guard-immutable table
             (unless (eq? new-key key)
@@ -83,18 +86,20 @@
           (guard-immutable table
             (t125-hash-table-delete! table key)
             table))
-        (success key value update remove))
-      (define (handle-fail)
+        (lambda ()
+          (success key value update remove) ))
+      (define (make-failure-thunk)
         (define (ignore)
           table)
         (define (insert value)
           (guard-immutable table
             (t125-hash-table-set! table key value)
             table))
-        (fail insert ignore))
+        (lambda ()
+          (fail insert ignore)))
 
-      (define default (cons #f #f))
-      (t125-hash-table-ref table key handle-fail handle-success))
+      (define thunk (t125-hash-table-ref table key make-failure-thunk make-success-thunk))
+      (thunk))
 
     (define (t125-hash-table-comparator* dto table)
       (make-comparator (lambda args #t)