From 55c376f559aac409b502a50d5a1a04d27171e73c Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 14 May 2026 06:36:50 +0000 Subject: [PATCH] =?UTF-8?q?scheme:=20Phase=205b=20=E2=80=94=20R7RS=20excep?= =?UTF-8?q?tions=20(raise/guard/with-exception-handler)=20+=2012=20tests?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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). --- lib/scheme/eval.sx | 71 +++++++++++++++++++++++++++++++++++++ lib/scheme/runtime.sx | 55 ++++++++++++++++++++++++++++ lib/scheme/tests/control.sx | 43 ++++++++++++++++++++++ 3 files changed, 169 insertions(+) diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx index 739fa41c..dfb92c88 100644 --- a/lib/scheme/eval.sx +++ b/lib/scheme/eval.sx @@ -334,6 +334,77 @@ (scheme-define-op! "or" (fn (args env) (scm-or-step args env))) +;; ── guard (R7RS exception clause-dispatch syntactic form) ──────── +;; (guard (var (test1 body1) (test2 body2) ... [else body]) body...) +;; +;; Evaluates body in an exception-protected scope. If an exception is +;; raised, var is bound to the raised value in a fresh child env, the +;; cond-like clauses are tried in order, and the first matching clause's +;; body is returned. If no clause matches (and no else), the exception +;; re-raises. The bare `else` symbol is the catch-all per R7RS. + +;; Sentinel that means "no clause matched; re-raise outside the guard". +(define scm-guard-no-match-marker {:scm-guard-no-match true}) + +(define scm-guard-try-clauses + (fn (clauses env raised) + (cond + ((or (nil? clauses) (= (length clauses) 0)) + scm-guard-no-match-marker) + (:else + (let ((clause (first clauses))) + (cond + ((not (list? clause)) scm-guard-no-match-marker) + ((and (string? (first clause)) (= (first clause) "else")) + (scheme-eval-body (rest clause) env)) + (:else + (let ((test-val (scheme-eval (first clause) env))) + (cond + ((not (= test-val false)) + (cond + ((= (length clause) 1) test-val) + (:else (scheme-eval-body (rest clause) env)))) + (:else + (scm-guard-try-clauses (rest clauses) env raised))))))))))) + +(define scm-guard-handle + (fn (raised-val var-name clauses env) + (let ((local (scheme-extend-env env))) + (begin + (scheme-env-bind! local var-name raised-val) + (scm-guard-try-clauses clauses local raised-val))))) + +(scheme-define-op! "guard" + (fn (args env) + (cond + ((< (length args) 1) + (error "guard: expects ((var clauses...) body...)")) + ((not (list? (first args))) + (error "guard: first form must be (var clauses...)")) + ((= (length (first args)) 0) + (error "guard: clause list needs a var name")) + (:else + (let ((var-name (first (first args))) + (clauses (rest (first args))) + (body (rest args))) + ;; Catch once; if no clause matches, the sentinel is returned + ;; and we re-raise OUTSIDE the guard scope (so the re-raise + ;; doesn't itself get caught). + (let ((outcome + (guard + (e (true {:scm-guard-raised true :value e})) + (scheme-eval-body body env)))) + (cond + ((and (dict? outcome) (get outcome :scm-guard-raised)) + (let ((result (scm-guard-handle (get outcome :value) + var-name clauses env))) + (cond + ((and (dict? result) + (get result :scm-guard-no-match)) + (raise (get outcome :value))) + (:else result)))) + (:else outcome)))))))) + ;; ── eval-args helper ───────────────────────────────────────────── (define diff --git a/lib/scheme/runtime.sx b/lib/scheme/runtime.sx index df62a23f..6dfeae46 100644 --- a/lib/scheme/runtime.sx +++ b/lib/scheme/runtime.sx @@ -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))) diff --git a/lib/scheme/tests/control.sx b/lib/scheme/tests/control.sx index c897a7ac..4134110a 100644 --- a/lib/scheme/tests/control.sx +++ b/lib/scheme/tests/control.sx @@ -69,4 +69,47 @@ (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}))