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

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:
2026-05-14 06:36:50 +00:00
parent e3e5d3e888
commit 55c376f559
3 changed files with 169 additions and 0 deletions

View File

@@ -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)))