From a90f56e3f34d004e7bd8024217224b9e536316f7 Mon Sep 17 00:00:00 2001
From: giles <giles.bradshaw@rose-ash.com>
Date: Thu, 14 May 2026 06:37:51 +0000
Subject: [PATCH] =?UTF-8?q?scheme:=20Phase=205c=20=E2=80=94=20dynamic-wind?=
 =?UTF-8?q?=20(basic,=20no=20call/cc=20tracking)=20+=205=20tests?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

(dynamic-wind BEFORE THUNK AFTER)
  - Calls BEFORE; runs THUNK; calls AFTER; returns THUNK's value.
  - If THUNK raises, AFTER still runs before the raise propagates.
  - Implementation: outcome-sentinel pattern (same trick as guard
    and with-exception-handler) — catch THUNK's raise inside a
    host guard, run AFTER unconditionally, then either return the
    value or re-raise outside the catch.

Not implemented: call/cc-escape tracking. R7RS specifies that
dynamic-wind's BEFORE and AFTER thunks should re-run when control
re-enters or exits the dynamic extent via continuations. That
requires explicit dynamic-extent stack tracking, deferred until
a consumer needs it (probably never needed for pure-eval Scheme
programs; matters for first-class-continuation-heavy code).

5 tests: success ordering, return value, after-on-raise,
raise propagation, nested wind.

237 total Scheme tests now (62 + 23 + 49 + 78 + 25).
---
 lib/scheme/runtime.sx       | 26 ++++++++++++++++++
 lib/scheme/tests/control.sx | 53 +++++++++++++++++++++++++++++++++++++
 2 files changed, 79 insertions(+)

diff --git a/lib/scheme/runtime.sx b/lib/scheme/runtime.sx
index 6dfeae46..f2a869ca 100644
--- a/lib/scheme/runtime.sx
+++ b/lib/scheme/runtime.sx
@@ -586,4 +586,30 @@
                     ((and (dict? outcome) (get outcome :scm-weh-raised))
                       (scheme-apply handler (list (get outcome :value))))
                     (:else outcome))))))))
+      ;; dynamic-wind BEFORE THUNK AFTER — runs BEFORE, then THUNK,
+      ;; then AFTER. If THUNK raises, AFTER still runs before the
+      ;; raise propagates. This is the basic-correctness version;
+      ;; proper call/cc-escape interaction would need dynamic-extent
+      ;; tracking, deferred until needed.
+      (scheme-env-bind! env "dynamic-wind"
+        (fn (args)
+          (cond
+            ((not (= (length args) 3))
+              (error "dynamic-wind: expects (before thunk after)"))
+            (:else
+              (let ((before-thunk (first args))
+                    (mid-thunk (nth args 1))
+                    (after-thunk (nth args 2)))
+                (begin
+                  (scheme-apply before-thunk (list))
+                  (let ((outcome
+                          (guard
+                            (e (true {:scm-dw-raised true :value e}))
+                            (scheme-apply mid-thunk (list)))))
+                    (begin
+                      (scheme-apply after-thunk (list))
+                      (cond
+                        ((and (dict? outcome) (get outcome :scm-dw-raised))
+                          (raise (get outcome :value)))
+                        (:else outcome))))))))))
       env)))
diff --git a/lib/scheme/tests/control.sx b/lib/scheme/tests/control.sx
index 4134110a..f4675668 100644
--- a/lib/scheme/tests/control.sx
+++ b/lib/scheme/tests/control.sx
@@ -112,4 +112,57 @@
       "(guard (e ((error-object? e) (error-object-message e))) (error \"the-msg\"))"))
   "the-msg")
 
+;; ── dynamic-wind ────────────────────────────────────────────────
+;; Basic version: runs before/thunk/after on success; before/after
+;; on raise (with the raise still propagating after the after-thunk).
+;; call/cc escape-out interaction is NOT yet tracked — deferred.
+
+(scm-ctl-test "dynamic-wind: ordering on success"
+  (scm-ctl-all
+    "(define log '())
+     (define (note x) (set! log (cons x log)))
+     (dynamic-wind
+       (lambda () (note 'before))
+       (lambda () (note 'thunk) 42)
+       (lambda () (note 'after)))
+     (reverse log)")
+  (list "before" "thunk" "after"))
+(scm-ctl-test "dynamic-wind: returns thunk value"
+  (scm-ctl
+    "(dynamic-wind (lambda () 'b) (lambda () 42) (lambda () 'a))") 42)
+(scm-ctl-test "dynamic-wind: after runs on raise"
+  (scm-ctl-all
+    "(define log '())
+     (define (note x) (set! log (cons x log)))
+     (guard (e (else 'caught))
+       (dynamic-wind
+         (lambda () (note 'before))
+         (lambda () (raise 'boom))
+         (lambda () (note 'after))))
+     (reverse log)")
+  (list "before" "after"))
+(scm-ctl-test "dynamic-wind: raise propagates after after-thunk"
+  (scm-ctl-all
+    "(guard (e (else e))
+       (dynamic-wind
+         (lambda () 'b)
+         (lambda () (raise 'the-raised))
+         (lambda () 'a)))")
+  "the-raised")
+(scm-ctl-test "dynamic-wind: nested"
+  (scm-ctl-all
+    "(define log '())
+     (define (note x) (set! log (cons x log)))
+     (dynamic-wind
+       (lambda () (note 'outer-before))
+       (lambda ()
+         (dynamic-wind
+           (lambda () (note 'inner-before))
+           (lambda () (note 'inner-thunk))
+           (lambda () (note 'inner-after))))
+       (lambda () (note 'outer-after)))
+     (reverse log)")
+  (list "outer-before" "inner-before" "inner-thunk"
+        "inner-after" "outer-after"))
+
 (define scm-ctl-tests-run! (fn () {:total (+ scm-ctl-pass scm-ctl-fail) :passed scm-ctl-pass :failed scm-ctl-fail :fails scm-ctl-fails}))