coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

spec: dynamic-wind — after-thunk fires on normal return, raise, and call/cc escape

Browse Source 
- Add make-wind-after-frame / make-wind-return-frame CEK frame types
- Add *winders* global stack tracking active after-thunks
- Add kont-unwind-to-handler (replaces kont-find-handler in raise-eval) — calls
  after-thunks for wind frames encountered while unwinding to handler
- Add wind-escape-to — pops and calls after-thunks down to captured winders-len
- Replace sf-dynamic-wind with step-sf-dynamic-wind (full CEK dispatch)
- Fix "callcc" frame: store winders-len in continuation object
- Fix callcc-continuation? case: call wind-escape-to before escape
- JS platform: extend SxCallccContinuation to store windersLen; add
  callcc-continuation-winders-len accessor
- 8 tests: normal return, raise escape, call/cc escape, nested LIFO, guard ordering
- 1948/2500 (was 1940); zero regressions

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-26 14:19:17 +00:00
parent 0577f245e2
commit a9d5a1082f
4 changed files with 270 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files

108
spec/evaluator.sx
View File

@@ -142,6 +142,16 @@
(define make-callcc-frame (fn (env) {:env env :type "callcc"}))
(define
make-wind-after-frame
(fn (after-thunk winders-len env)
{:type "wind-after" :after-thunk after-thunk :winders-len winders-len :env env}))
(define
make-wind-return-frame
(fn (body-result env)
{:type "wind-return" :body-result body-result :env env}))
;; R7RS exception frames (raise, guard)
(define make-deref-frame (fn (env) {:env env :type "deref"}))
@@ -228,6 +238,44 @@
match))
(kont-find-handler (rest kont) condition))))))
(define
kont-unwind-to-handler
(fn (kont condition)
(if
(empty? kont)
{:handler nil :kont kont}
(let
((frame (first kont)) (rest-k (rest kont)))
(cond
(= (frame-type frame) "handler")
(let
((match (find-matching-handler (get frame "f") condition)))
(if
(nil? match)
(kont-unwind-to-handler rest-k condition)
{:handler match :kont kont}))
(= (frame-type frame) "wind-after")
(do
(when
(> (len *winders*) (get frame "winders-len"))
(set! *winders* (rest *winders*)))
(cek-call (get frame "after-thunk") (list))
(kont-unwind-to-handler rest-k condition))
:else
(kont-unwind-to-handler rest-k condition))))))
(define
wind-escape-to
(fn
(target-len)
(when
(> (len *winders*) target-len)
(let
((after-thunk (first *winders*)))
(set! *winders* (rest *winders*))
(cek-call after-thunk (list))
(wind-escape-to target-len)))))
(define
find-named-restart
(fn
@@ -410,6 +458,8 @@
(define *provide-subscribers* (dict))
(define *winders* (list))
(define *library-registry* (dict))
(define
@@ -1343,14 +1393,24 @@
(make-cek-state (thunk-expr thk) (thunk-env thk) kont))))
(define
sf-dynamic-wind
step-sf-dynamic-wind
(fn
((args :as list) (env :as dict))
(args env kont)
(let
((before (trampoline (eval-expr (first args) env)))
(body (trampoline (eval-expr (nth args 1) env)))
(after (trampoline (eval-expr (nth args 2) env))))
(dynamic-wind-call before body after env))))
(do
(cek-call before (list))
(let
((winders-len (len *winders*)))
(set! *winders* (cons after *winders*))
(continue-with-call
body
(list)
env
(list)
(kont-push (make-wind-after-frame after winders-len env) kont)))))))
;; R7RS records (SRFI-9)
;;
@@ -1788,8 +1848,7 @@
("invoke-restart" (step-sf-invoke-restart args env kont))
("match" (step-sf-match args env kont))
("let-match" (step-sf-let-match args env kont))
("dynamic-wind"
(make-cek-value (sf-dynamic-wind args env) env kont))
("dynamic-wind" (step-sf-dynamic-wind args env kont))
("map" (step-ho-map args env kont))
("map-indexed" (step-ho-map-indexed args env kont))
("filter" (step-ho-filter args env kont))
@@ -4082,16 +4141,36 @@
fenv
(list test-value)
rest-k)))
("wind-after"
(let
((after-thunk (get frame "after-thunk"))
(winders-len (get frame "winders-len"))
(body-result value)
(fenv (get frame "env")))
(do
(when
(> (len *winders*) winders-len)
(set! *winders* (rest *winders*)))
(continue-with-call
after-thunk
(list)
fenv
(list)
(kont-push (make-wind-return-frame body-result fenv) rest-k)))))
("wind-return"
(make-cek-value (get frame "body-result") (get frame "env") rest-k))
("raise-eval"
(let
((condition value)
(fenv (get frame "env"))
(continuable? (get frame "scheme"))
(handler-fn (kont-find-handler rest-k condition)))
(unwind-result (kont-unwind-to-handler rest-k condition))
(handler-fn (get unwind-result "handler"))
(unwound-k (get unwind-result "kont")))
(if
(nil? handler-fn)
(do
(set! *last-error-kont* rest-k)
(set! *last-error-kont* unwound-k)
(host-error
(str "Unhandled exception: " (inspect condition))))
(continue-with-call
@@ -4102,9 +4181,9 @@
(if
continuable?
(kont-push
(make-signal-return-frame fenv rest-k)
rest-k)
(kont-push (make-raise-guard-frame fenv rest-k) rest-k))))))
(make-signal-return-frame fenv unwound-k)
unwound-k)
(kont-push (make-raise-guard-frame fenv unwound-k) unwound-k))))))
("raise-guard"
(do
(set! *last-error-kont* rest-k)
@@ -4132,7 +4211,7 @@
rest-k))))))
("callcc"
(let
((k (make-callcc-continuation rest-k)))
((k (make-callcc-continuation rest-k (len *winders*))))
(continue-with-call
value
(list k)
@@ -4236,8 +4315,11 @@
(callcc-continuation? f)
(let
((arg (if (empty? args) nil (first args)))
(captured (callcc-continuation-data f)))
(make-cek-value arg env captured))
(captured (callcc-continuation-data f))
(w-len (callcc-continuation-winders-len f)))
(do
(wind-escape-to w-len)
(make-cek-value arg env captured)))
(continuation? f)
(let
((arg (if (empty? args) nil (first args)))

113
spec/tests/test-dynamic-wind.sx Normal file
View File

@@ -0,0 +1,113 @@
;; Tests for dynamic-wind: after-thunk fires on normal return,
;; non-local exit via raise/guard, and call/cc escape.
(defsuite
"dynamic-wind-basic"
(deftest
"after fires on normal return"
(let
((log (list)))
(dynamic-wind
(fn () (append! log "before"))
(fn () (append! log "body"))
(fn () (append! log "after")))
(assert= 3 (len log))
(assert= "before" (nth log 0))
(assert= "body" (nth log 1))
(assert= "after" (nth log 2))))
(deftest
"after fires on raise escape"
(let
((log (list)))
(guard
(e (true nil))
(dynamic-wind
(fn () (append! log "before"))
(fn () (append! log "body") (error "boom"))
(fn () (append! log "after"))))
(assert= 3 (len log))
(assert= "before" (nth log 0))
(assert= "body" (nth log 1))
(assert= "after" (nth log 2))))
(deftest
"after fires on call/cc escape"
(let
((log (list)))
(call/cc
(fn
(k)
(dynamic-wind
(fn () (append! log "before"))
(fn () (append! log "body") (k nil))
(fn () (append! log "after")))))
(assert= 3 (len log))
(assert= "before" (nth log 0))
(assert= "body" (nth log 1))
(assert= "after" (nth log 2))))
(deftest
"nested dynamic-wind after-thunks fire LIFO on normal return"
(let
((log (list)))
(dynamic-wind
(fn () (append! log "outer-before"))
(fn
()
(dynamic-wind
(fn () (append! log "inner-before"))
(fn () (append! log "inner-body"))
(fn () (append! log "inner-after"))))
(fn () (append! log "outer-after")))
(assert= 5 (len log))
(assert= "outer-before" (nth log 0))
(assert= "inner-before" (nth log 1))
(assert= "inner-body" (nth log 2))
(assert= "inner-after" (nth log 3))
(assert= "outer-after" (nth log 4))))
(deftest
"nested dynamic-wind after-thunks fire LIFO on raise"
(let
((log (list)))
(guard
(e (true nil))
(dynamic-wind
(fn () (append! log "outer-before"))
(fn
()
(dynamic-wind
(fn () (append! log "inner-before"))
(fn () (append! log "inner-body") (error "boom"))
(fn () (append! log "inner-after"))))
(fn () (append! log "outer-after"))))
(assert= 5 (len log))
(assert= "outer-before" (nth log 0))
(assert= "inner-before" (nth log 1))
(assert= "inner-body" (nth log 2))
(assert= "inner-after" (nth log 3))
(assert= "outer-after" (nth log 4))))
(deftest
"before and after are called"
(let
((count 0))
(dynamic-wind
(fn () (set! count (+ count 1)))
(fn () nil)
(fn () (set! count (+ count 10))))
(assert= 11 count)))
(deftest
"dynamic-wind return value is body result"
(let
((result (dynamic-wind (fn () nil) (fn () 42) (fn () nil))))
(assert= 42 result)))
(deftest
"after fires before guard handler"
(let
((log (list)))
(guard
(e (true (append! log "guard-handler")))
(dynamic-wind
(fn () nil)
(fn () (error "boom"))
(fn () (append! log "after"))))
(assert= 2 (len log))
(assert= "after" (nth log 0))
(assert= "guard-handler" (nth log 1)))))