From 733b1ebefaa3c3b682b8609e304b6f8702d77fe6 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 5 May 2026 11:21:52 +0000 Subject: [PATCH] =?UTF-8?q?cl:=20Phase=203=20complete=20=E2=80=94=20*debug?= =?UTF-8?q?ger-hook*,=20*break-on-signals*,=20invoke-restart-interactively?= =?UTF-8?q?=20(147=20tests)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/common-lisp/runtime.sx | 79 ++++++++++++++++++++++++----- lib/common-lisp/tests/conditions.sx | 66 ++++++++++++++++++++++++ plans/common-lisp-on-sx.md | 3 +- 3 files changed, 134 insertions(+), 14 deletions(-) diff --git a/lib/common-lisp/runtime.sx b/lib/common-lisp/runtime.sx index 469b9d94..73dac5b0 100644 --- a/lib/common-lisp/runtime.sx +++ b/lib/common-lisp/runtime.sx @@ -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)))))) \ No newline at end of file diff --git a/lib/common-lisp/tests/conditions.sx b/lib/common-lisp/tests/conditions.sx index 6422263e..2745c1e8 100644 --- a/lib/common-lisp/tests/conditions.sx +++ b/lib/common-lisp/tests/conditions.sx @@ -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 diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md index 60e6e8d5..63c0dd76 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -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.