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}))