scheme: Phase 5c — dynamic-wind (basic, no call/cc tracking) + 5 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
(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).
This commit is contained in:
@@ -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)))
|
||||
|
||||
@@ -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}))
|
||||
|
||||
Reference in New Issue
Block a user