giles
a90f56e3f3
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).
169 lines
6.1 KiB
Plaintext
169 lines
6.1 KiB
Plaintext
;; lib/scheme/tests/control.sx — call/cc, dynamic-wind, exceptions.
|
|
|
|
(define scm-ctl-pass 0)
|
|
(define scm-ctl-fail 0)
|
|
(define scm-ctl-fails (list))
|
|
|
|
(define
|
|
scm-ctl-test
|
|
(fn
|
|
(name actual expected)
|
|
(if
|
|
(= actual expected)
|
|
(set! scm-ctl-pass (+ scm-ctl-pass 1))
|
|
(begin
|
|
(set! scm-ctl-fail (+ scm-ctl-fail 1))
|
|
(append! scm-ctl-fails {:name name :actual actual :expected expected})))))
|
|
|
|
(define
|
|
scm-ctl
|
|
(fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))
|
|
|
|
(define
|
|
scm-ctl-all
|
|
(fn
|
|
(src)
|
|
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
|
|
|
|
;; ── call/cc — escape continuations ──────────────────────────────
|
|
;; Single-shot only: when k is invoked, control jumps out of the
|
|
;; surrounding call/cc and the result of the entire call/cc form is
|
|
;; whatever was passed to k.
|
|
|
|
(scm-ctl-test
|
|
"call/cc: no escape"
|
|
(scm-ctl "(call/cc (lambda (k) 42))")
|
|
42)
|
|
(scm-ctl-test
|
|
"call/cc: simple escape"
|
|
(scm-ctl "(call/cc (lambda (k) (+ 1 (k 42))))")
|
|
42)
|
|
(scm-ctl-test
|
|
"call/cc: escape past *"
|
|
(scm-ctl "(+ 10 (call/cc (lambda (k) (* 2 (k 5)))))")
|
|
15)
|
|
(scm-ctl-test
|
|
"call/cc: alias call-with-current-continuation"
|
|
(scm-ctl "(call-with-current-continuation (lambda (k) (k 99)))")
|
|
99)
|
|
(scm-ctl-test
|
|
"call/cc: doesn't escape if k unused"
|
|
(scm-ctl "(+ 1 (call/cc (lambda (k) (* 100 1))))")
|
|
101)
|
|
|
|
;; ── call/cc as early-exit for list search ───────────────────────
|
|
(scm-ctl-test
|
|
"call/cc: detect-via-escape"
|
|
(scm-ctl-all
|
|
"(define (detect pred xs)\n (call/cc\n (lambda (return)\n (for-each\n (lambda (x) (if (pred x) (return x) #f))\n xs)\n #f)))\n (detect (lambda (x) (> x 10)) '(1 5 7 12 20))")
|
|
12)
|
|
(scm-ctl-test
|
|
"call/cc: detect returns #f when no match"
|
|
(scm-ctl-all
|
|
"(define (detect pred xs)\n (call/cc\n (lambda (return)\n (for-each\n (lambda (x) (if (pred x) (return x) #f))\n xs)\n #f)))\n (detect (lambda (x) (> x 100)) '(1 5 7))")
|
|
false)
|
|
|
|
;; ── call/cc producing the captured k value ──────────────────────
|
|
(scm-ctl-test
|
|
"call/cc: k is a procedure"
|
|
(scm-ctl "(procedure? (call/cc (lambda (k) k)))")
|
|
true)
|
|
|
|
;; ── Exceptions: raise / guard / with-exception-handler / error ──
|
|
(scm-ctl-test "raise + guard caught"
|
|
(scm-ctl "(guard (e (else 'caught)) (raise 'boom))") "caught")
|
|
(scm-ctl-test "guard: number? matches"
|
|
(scm-ctl "(guard (e ((number? e) e) (else 'other)) (raise 42))") 42)
|
|
(scm-ctl-test "guard: number? mismatches → else"
|
|
(scm-ctl "(guard (e ((number? e) e) (else 'other)) (raise 'sym))")
|
|
"other")
|
|
(scm-ctl-test "guard: no error → body value"
|
|
(scm-ctl "(guard (e (else 'never)) 42)") 42)
|
|
(scm-ctl-test "guard: first matching clause wins"
|
|
(scm-ctl
|
|
"(guard (e ((number? e) 'num) ((symbol? e) 'sym) (else 'other)) (raise 'foo))")
|
|
"sym")
|
|
(scm-ctl-test "guard: re-raises when no clause matches"
|
|
(scm-ctl
|
|
"(guard (e (else 'outer)) (guard (e ((number? e) 'inner)) (raise 'not-a-number)))")
|
|
"outer")
|
|
(scm-ctl-test "guard: var bound in clause body"
|
|
(scm-ctl "(guard (e ((symbol? e) e)) (raise 'the-symbol))")
|
|
"the-symbol")
|
|
(scm-ctl-test "with-exception-handler: caught"
|
|
(scm-ctl
|
|
"(with-exception-handler (lambda (e) 'caught) (lambda () (raise 'oops)))")
|
|
"caught")
|
|
(scm-ctl-test "with-exception-handler: no raise"
|
|
(scm-ctl
|
|
"(with-exception-handler (lambda (e) 99) (lambda () 42))")
|
|
42)
|
|
(scm-ctl-test "with-exception-handler: handler sees the value"
|
|
(scm-ctl
|
|
"(with-exception-handler (lambda (e) (+ e 1)) (lambda () (raise 41)))")
|
|
42)
|
|
(scm-ctl-test "error: irritants accessible"
|
|
(scm-ctl
|
|
"(guard (e ((error-object? e) (error-object-irritants e))) (error \"msg\" 1 2 3))")
|
|
(list 1 2 3))
|
|
(scm-ctl-test "error: message accessible"
|
|
(scheme-string-value
|
|
(scm-ctl
|
|
"(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}))
|