giles
55c376f559
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
eval.sx adds the `guard` syntactic operator with R7RS-compliant
clause dispatch: var binds to raised value in a fresh child env;
clauses tried in order; `else` is catch-all; no match re-raises.
Implementation uses a "catch-once-then-handle-outside" pattern to
avoid the handler self-raise loop:
outcome = host-guard {body} ;; tag raise vs success
if outcome was raise:
try clauses → either result or sentinel
if sentinel: re-raise OUTSIDE the host-guard scope
runtime.sx binds R7RS exception primitives:
- raise V
- error MSG IRRITANT... → {:scm-error MSG :irritants LIST}
- error-object?, error-object-message, error-object-irritants
- with-exception-handler HANDLER THUNK
(same outcome-sentinel pattern — handler's own raises propagate
outward instead of re-entering)
12 tests cover: catch on raise, predicate dispatch, else catch-all,
no-error pass-through, first-clause-wins, re-raise-on-no-match,
error-object construction and accessors.
232 total Scheme tests now (62 + 23 + 49 + 78 + 20).
116 lines
4.2 KiB
Plaintext
116 lines
4.2 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")
|
|
|
|
(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}))
|