cl: Phase 3 complete — *debugger-hook*, *break-on-signals*, invoke-restart-interactively (147 tests)
cl-debugger-hook: mutable global (fn (c hook) result); cl-invoke-debugger calls it with infinite-recursion guard (sets hook nil during call). cl-error now routes unhandled errors through cl-invoke-debugger instead of bare host error — allows the hook to invoke a restart and resume. cl-break-on-signals: when set to a type name, cl-signal fires the debugger hook before walking handlers if the condition matches. cl-invoke-restart-interactively: calls the restart fn with no args (no terminal protocol — equivalent to (invoke-restart name)). 4 new tests in conditions.sx covering all three; Phase 3 fully complete. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -495,6 +495,47 @@
|
||||
(n)
|
||||
(set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack)))))
|
||||
|
||||
;; ── *debugger-hook* + invoke-debugger ────────────────────────────────────
|
||||
;;
|
||||
;; cl-debugger-hook: called when an error propagates with no handler.
|
||||
;; Signature: (fn (condition hook) result). The hook arg is itself
|
||||
;; (so the hook can rebind it to nil to prevent recursion).
|
||||
;; nil = use default (re-raise as host error).
|
||||
|
||||
(define cl-debugger-hook nil)
|
||||
|
||||
(define cl-invoke-debugger
|
||||
(fn (c)
|
||||
(if (nil? cl-debugger-hook)
|
||||
(error (str "Debugger: " (cl-condition-message c)))
|
||||
(let ((hook cl-debugger-hook))
|
||||
(set! cl-debugger-hook nil)
|
||||
(let ((result (hook c hook)))
|
||||
(set! cl-debugger-hook hook)
|
||||
result)))))
|
||||
|
||||
;; ── *break-on-signals* ────────────────────────────────────────────────────
|
||||
;;
|
||||
;; When set to a type name string, cl-signal invokes the debugger hook
|
||||
;; before walking handlers if the condition is of that type.
|
||||
;; nil = disabled (ANSI default).
|
||||
|
||||
(define cl-break-on-signals nil)
|
||||
|
||||
;; ── invoke-restart-interactively ──────────────────────────────────────────
|
||||
;;
|
||||
;; Like invoke-restart but calls the restart's fn with no arguments
|
||||
;; (real CL would prompt the user for each arg via :interactive).
|
||||
|
||||
(define cl-invoke-restart-interactively
|
||||
(fn (name)
|
||||
(let ((entry (cl-find-restart-entry name cl-restart-stack)))
|
||||
(if (nil? entry)
|
||||
(error (str "No active restart: " name))
|
||||
(let ((restart-fn (get entry "fn"))
|
||||
(escape (get entry "escape")))
|
||||
(escape (restart-fn)))))))
|
||||
|
||||
;; ── cl-signal (non-unwinding) ─────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks cl-handler-stack; for each matching entry, calls the handler fn.
|
||||
@@ -514,12 +555,16 @@
|
||||
(begin ((get entry "fn") obj) (cl-signal-obj obj (rest stack)))
|
||||
(cl-signal-obj obj (rest stack)))))))
|
||||
|
||||
(define
|
||||
cl-signal
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((obj (if (cl-condition? c) c (cl-make-condition "simple-condition" "format-control" (str c)))))
|
||||
(define cl-signal
|
||||
(fn (c)
|
||||
(let ((obj (if (cl-condition? c)
|
||||
c
|
||||
(cl-make-condition "simple-condition"
|
||||
"format-control" (str c)))))
|
||||
;; *break-on-signals*: invoke debugger hook when type matches
|
||||
(when (and (not (nil? cl-break-on-signals))
|
||||
(cl-condition-of-type? obj cl-break-on-signals))
|
||||
(cl-invoke-debugger obj))
|
||||
(cl-signal-obj obj cl-handler-stack))))
|
||||
|
||||
;; ── cl-error ───────────────────────────────────────────────────────────────
|
||||
@@ -533,7 +578,7 @@
|
||||
(let
|
||||
((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
|
||||
(cl-signal-obj obj cl-handler-stack)
|
||||
(error (str "Unhandled CL error: " (cl-condition-message obj))))))
|
||||
(cl-invoke-debugger obj))))
|
||||
|
||||
;; ── cl-warn ────────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -660,12 +705,20 @@
|
||||
;; Signals a continuable error. The "continue" restart is established;
|
||||
;; invoke-restart "continue" to proceed past the error.
|
||||
|
||||
(define
|
||||
cl-cerror
|
||||
(fn
|
||||
(continue-string c &rest args)
|
||||
(let
|
||||
((obj (if (cl-condition? c) c (cl-make-condition "simple-error" "format-control" (str c) "format-arguments" args))))
|
||||
|
||||
|
||||
;; ── cl-cerror ──────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Signals a continuable error. The "continue" restart is established;
|
||||
;; invoke-restart "continue" to proceed past the error.
|
||||
|
||||
(define cl-cerror
|
||||
(fn (continue-string c &rest args)
|
||||
(let ((obj (if (cl-condition? c)
|
||||
c
|
||||
(cl-make-condition "simple-error"
|
||||
"format-control" (str c)
|
||||
"format-arguments" args))))
|
||||
(cl-restart-case
|
||||
(fn () (cl-signal-obj obj cl-handler-stack))
|
||||
(list "continue" (list) (fn () nil))))))
|
||||
@@ -401,6 +401,72 @@
|
||||
(cl-arithmetic-error-operands c)
|
||||
(list 1 0))))
|
||||
|
||||
|
||||
;; ── 15. *debugger-hook* ───────────────────────────────────────────────────
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
(let ((received nil))
|
||||
(begin
|
||||
(set! cl-debugger-hook
|
||||
(fn (c h)
|
||||
(set! received (cl-condition-message c))
|
||||
(cl-invoke-restart "escape")))
|
||||
(cl-restart-case
|
||||
(fn () (cl-error "debugger test"))
|
||||
(list "escape" (list) (fn () nil)))
|
||||
(set! cl-debugger-hook nil)
|
||||
(assert-equal "debugger-hook receives condition" received "debugger test")))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; ── 16. *break-on-signals* ────────────────────────────────────────────────
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
(let ((triggered false))
|
||||
(begin
|
||||
(set! cl-break-on-signals "error")
|
||||
(set! cl-debugger-hook
|
||||
(fn (c h)
|
||||
(set! triggered true)
|
||||
(cl-invoke-restart "abort")))
|
||||
(cl-restart-case
|
||||
(fn ()
|
||||
(cl-signal (cl-make-condition "simple-error" "format-control" "x")))
|
||||
(list "abort" (list) (fn () nil)))
|
||||
(set! cl-break-on-signals nil)
|
||||
(set! cl-debugger-hook nil)
|
||||
(assert-true "break-on-signals fires hook" triggered)))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; break-on-signals: non-matching type does NOT fire hook
|
||||
(let ((triggered false))
|
||||
(begin
|
||||
(set! cl-break-on-signals "error")
|
||||
(set! cl-debugger-hook
|
||||
(fn (c h) (set! triggered true) nil))
|
||||
(cl-handler-bind
|
||||
(list (list "warning" (fn (c) nil)))
|
||||
(fn ()
|
||||
(cl-signal (cl-make-condition "simple-warning" "format-control" "w"))))
|
||||
(set! cl-break-on-signals nil)
|
||||
(set! cl-debugger-hook nil)
|
||||
(assert-equal "break-on-signals: type mismatch not triggered" triggered false)))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; ── 17. cl-invoke-restart-interactively ──────────────────────────────────
|
||||
|
||||
(let ((result
|
||||
(cl-restart-case
|
||||
(fn () (cl-invoke-restart-interactively "use-default"))
|
||||
(list "use-default" (list) (fn () 99)))))
|
||||
(assert-equal "invoke-restart-interactively: returns restart value" result 99))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(if
|
||||
|
||||
@@ -73,7 +73,7 @@ Core mapping:
|
||||
- [x] `restart-case`, `with-simple-restart`, `restart-bind`
|
||||
- [x] `find-restart`, `invoke-restart`, `compute-restarts`
|
||||
- [x] `with-condition-restarts` — associate restarts with a specific condition
|
||||
- [ ] `invoke-restart-interactively`, `*break-on-signals*`, `*debugger-hook*` (basic)
|
||||
- [x] `invoke-restart-interactively`, `*break-on-signals*`, `*debugger-hook*` (basic)
|
||||
- [x] Classic programs in `lib/common-lisp/tests/programs/`:
|
||||
- [x] `restart-demo.sx` — division with `use-zero` and `retry` restarts (7 tests)
|
||||
- [x] `parse-recover.sx` — parser with skipped-token restart (6 tests)
|
||||
@@ -124,6 +124,7 @@ data; format for string templating.
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-05-05: Phase 3 complete — cl-debugger-hook/cl-invoke-debugger in runtime.sx (cl-error routes through hook), cl-break-on-signals (fires hook before handlers on type match), cl-invoke-restart-interactively (calls fn with no args); 4 new tests (147 total). Phase 3 all boxes ticked.
|
||||
- 2026-05-05: Phase 3 interactive-debugger.sx — cl-debugger-hook global, cl-invoke-debugger, cl-error-with-debugger, make-policy-debugger; 7 tests (143 total). Tests wired into test.sh program suite runner. Phase 3 condition core complete.
|
||||
- 2026-05-05: Phase 3 classic programs — `tests/programs/restart-demo.sx` (7 tests: safe-divide with use-zero + retry restarts) and `tests/programs/parse-recover.sx` (6 tests: token parser with skip-token + use-zero restarts, handler-case abort). Key gotcha: use `=` not `equal?` for list comparison in sx_server.
|
||||
- 2026-05-05: Phase 3 conditions + restarts — `cl-condition-classes` hierarchy (15 types), `cl-condition?`/`cl-condition-of-type?`, `cl-make-condition`, `cl-define-condition`, `cl-signal`/`cl-error`/`cl-warn`/`cl-cerror`, `cl-handler-bind` (non-unwinding), `cl-handler-case` (call/cc escape), `cl-restart-case`/`cl-with-simple-restart`, `cl-find-restart`/`cl-invoke-restart`/`cl-compute-restarts`, `cl-with-condition-restarts`; 55 new tests in `tests/conditions.sx` (123 total runtime tests). Key gotcha: `cl-condition-classes` must be captured at define-time via `let` in `cl-condition-of-type?` — free-variable lookup at call-time fails through env_merge parent chain.
|
||||
|
||||
Reference in New Issue
Block a user