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:
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user