scheme: Phase 5b — R7RS exceptions (raise/guard/with-exception-handler) + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
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).
This commit is contained in:
@@ -531,4 +531,59 @@
|
||||
(scheme-apply (first args) (list scheme-k)))))))))
|
||||
(scheme-env-bind! env "call-with-current-continuation"
|
||||
(refl-env-lookup env "call/cc"))
|
||||
;; ── R7RS exception primitives ──────────────────────────
|
||||
;; raise V — raises V as exception (host SX raise).
|
||||
(scheme-env-bind! env "raise"
|
||||
(fn (args)
|
||||
(cond
|
||||
((not (= (length args) 1))
|
||||
(error "raise: expects 1 argument"))
|
||||
(:else (raise (first args))))))
|
||||
;; error MSG IRRITANTS... — convention: raise an error-object
|
||||
;; that's a dict {:scm-error MSG :irritants LIST}. The print
|
||||
;; surface (error-object-message / error-object-irritants)
|
||||
;; can pull these apart.
|
||||
(scheme-env-bind! env "error"
|
||||
(fn (args)
|
||||
(cond
|
||||
((= (length args) 0) (error "error: expects (message [irritant...])"))
|
||||
(:else
|
||||
(raise {:scm-error (cond
|
||||
((scheme-string? (first args))
|
||||
(scheme-string-value (first args)))
|
||||
(:else (first args)))
|
||||
:irritants (rest args)})))))
|
||||
(scheme-env-bind! env "error-object?"
|
||||
(scm-unary "error-object?"
|
||||
(fn (v) (and (dict? v) (string? (get v :scm-error))))))
|
||||
(scheme-env-bind! env "error-object-message"
|
||||
(scm-unary "error-object-message"
|
||||
(fn (v) (scheme-string-make (get v :scm-error)))))
|
||||
(scheme-env-bind! env "error-object-irritants"
|
||||
(scm-unary "error-object-irritants"
|
||||
(fn (v) (get v :irritants))))
|
||||
;; with-exception-handler HANDLER THUNK — runs THUNK; if it
|
||||
;; raises, calls HANDLER with the raised value (handler can
|
||||
;; itself raise or return a value). Implemented via host guard.
|
||||
;; with-exception-handler — catch THUNK's raise; if caught,
|
||||
;; call HANDLER. If HANDLER itself raises, propagate that to
|
||||
;; the outer scope (don't re-catch in this same guard, which
|
||||
;; would loop). The two-step outcome-sentinel pattern mirrors
|
||||
;; the `guard` special form's escape.
|
||||
(scheme-env-bind! env "with-exception-handler"
|
||||
(fn (args)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "with-exception-handler: expects 2 arguments"))
|
||||
(:else
|
||||
(let ((handler (first args))
|
||||
(thunk (nth args 1)))
|
||||
(let ((outcome
|
||||
(guard
|
||||
(e (true {:scm-weh-raised true :value e}))
|
||||
(scheme-apply thunk (list)))))
|
||||
(cond
|
||||
((and (dict? outcome) (get outcome :scm-weh-raised))
|
||||
(scheme-apply handler (list (get outcome :value))))
|
||||
(:else outcome))))))))
|
||||
env)))
|
||||
|
||||
Reference in New Issue
Block a user