diff --git a/lib/common-lisp/test.sh b/lib/common-lisp/test.sh index 3b5cc675..0068e979 100755 --- a/lib/common-lisp/test.sh +++ b/lib/common-lisp/test.sh @@ -331,6 +331,41 @@ else " fi +# ── Phase 3: classic program tests ─────────────────────────────────────────── +run_program_suite() { + local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4" + local PROG_FILE=$(mktemp) + printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "%s")\n(epoch 4)\n(eval "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n' \ + "$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE" + local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null) + rm -f "$PROG_FILE" + local P F + P=$(echo "$OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true) + F=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true) + local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true) + [ -z "$P" ] && P=0; [ -z "$F" ] && F=0 + if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then + PASS=$((PASS + P)) + [ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)" + else + FAIL=$((FAIL + 1)) + ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS} +" + fi +} + +run_program_suite \ + "lib/common-lisp/tests/programs/restart-demo.sx" \ + "demo-passed" "demo-failed" "demo-failures" + +run_program_suite \ + "lib/common-lisp/tests/programs/parse-recover.sx" \ + "parse-passed" "parse-failed" "parse-failures" + +run_program_suite \ + "lib/common-lisp/tests/programs/interactive-debugger.sx" \ + "debugger-passed" "debugger-failed" "debugger-failures" + TOTAL=$((PASS+FAIL)) if [ $FAIL -eq 0 ]; then echo "ok $PASS/$TOTAL lib/common-lisp tests passed" diff --git a/lib/common-lisp/tests/programs/interactive-debugger.sx b/lib/common-lisp/tests/programs/interactive-debugger.sx new file mode 100644 index 00000000..cf089aa8 --- /dev/null +++ b/lib/common-lisp/tests/programs/interactive-debugger.sx @@ -0,0 +1,196 @@ +;; interactive-debugger.sx — Condition debugger using *debugger-hook* +;; +;; Demonstrates the classic CL debugger pattern: +;; - *debugger-hook* is invoked when an unhandled error reaches the top level +;; - The hook receives the condition and a reference to itself +;; - It can offer restarts interactively (here simulated with a policy fn) +;; +;; In real CL the debugger reads from the terminal. Here we simulate +;; the "user input" via a policy function passed in at call time. +;; +;; Depends on: lib/common-lisp/runtime.sx already loaded. + +;; ── *debugger-hook* global ──────────────────────────────────────────────── +;; +;; CL: when error is unhandled, invoke *debugger-hook* with (condition hook). +;; A nil hook means use the system default (which we simulate as re-raise). + +(define cl-debugger-hook nil) + +;; ── invoke-debugger ──────────────────────────────────────────────────────── +;; +;; Called when cl-error finds no handler. Tries cl-debugger-hook first; +;; falls back to a simple error report. + +(define + cl-invoke-debugger + (fn + (c) + (if + (nil? cl-debugger-hook) + (error (str "Debugger: " (cl-condition-message c))) + (begin + (let + ((hook cl-debugger-hook)) + (set! cl-debugger-hook nil) + (let + ((result (hook c hook))) + (set! cl-debugger-hook hook) + result)))))) + +;; ── cl-error/debugger — error that routes through invoke-debugger ───────── + +(define + cl-error-with-debugger + (fn + (c &rest args) + (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) + (cl-invoke-debugger obj)))) + +;; ── simulated debugger session ──────────────────────────────────────────── +;; +;; A debugger hook takes (condition hook) and "reads" user commands. +;; We simulate this with a policy function: (fn (c restarts) restart-name) +;; that picks a restart given the condition and available restarts. + +(define + make-policy-debugger + (fn + (policy) + (fn + (c hook) + (let + ((available (cl-compute-restarts))) + (let + ((choice (policy c available))) + (if + (and choice (not (nil? (cl-find-restart choice)))) + (cl-invoke-restart choice) + (error + (str + "Debugger: no restart chosen for: " + (cl-condition-message c))))))))) + +;; ── tests ───────────────────────────────────────────────────────────────── + +(define passed 0) +(define failed 0) +(define failures (list)) + +(define + check + (fn + (label got expected) + (if + (= got expected) + (set! passed (+ passed 1)) + (begin + (set! failed (+ failed 1)) + (set! + failures + (append + failures + (list + (str + "FAIL [" + label + "]: got=" + (inspect got) + " expected=" + (inspect expected))))))))) + +(define + reset-stacks! + (fn + () + (set! cl-handler-stack (list)) + (set! cl-restart-stack (list)) + (set! cl-debugger-hook nil))) + +;; Test 1: debugger hook receives condition +(reset-stacks!) +(let + ((received-msg "")) + (begin + (set! + cl-debugger-hook + (fn (c hook) (set! received-msg (cl-condition-message c)) nil)) + (cl-restart-case + (fn () (cl-error-with-debugger "something broke")) + (list "abort" (list) (fn () nil))) + (check "debugger hook receives condition" received-msg "something broke"))) + +;; Test 2: policy-driven restart selection (use-zero) +(reset-stacks!) +(let + ((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "use-zero"))) (cl-restart-case (fn () (cl-error-with-debugger (cl-make-condition "division-by-zero")) 999) (list "use-zero" (list) (fn () 0)))))) + (check "policy debugger: use-zero restart" result 0)) + +;; Test 3: policy selects abort +(reset-stacks!) +(let + ((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "abort"))) (cl-restart-case (fn () (cl-error-with-debugger "aborting error") 999) (list "abort" (list) (fn () "aborted")))))) + (check "policy debugger: abort restart" result "aborted")) + +;; Test 4: compute-restarts inside debugger hook +(reset-stacks!) +(let + ((seen-restarts (list))) + (begin + (set! + cl-debugger-hook + (fn + (c hook) + (set! seen-restarts (cl-compute-restarts)) + (cl-invoke-restart "continue"))) + (cl-restart-case + (fn () (cl-error-with-debugger "test") 42) + (list "continue" (list) (fn () "ok")) + (list "abort" (list) (fn () "no"))) + (check + "debugger: compute-restarts visible" + (= (len seen-restarts) 2) + true))) + +;; Test 5: hook not invoked when handler catches first +(reset-stacks!) +(let + ((hook-called false) + (result + (begin + (set! cl-debugger-hook (fn (c hook) (set! hook-called true) nil)) + (cl-handler-case + (fn () (cl-error-with-debugger "handled")) + (list "error" (fn (c) "handler-won")))))) + (check "handler wins; hook not called" hook-called false) + (check "handler result returned" result "handler-won")) + +;; Test 6: debugger-hook nil after re-raise guard +(reset-stacks!) +(let + ((hook-calls 0)) + (begin + (set! + cl-debugger-hook + (fn + (c hook) + (set! hook-calls (+ hook-calls 1)) + (if + (> hook-calls 1) + (error "infinite loop guard") + (cl-invoke-restart "escape")))) + (cl-restart-case + (fn () (cl-error-with-debugger "once")) + (list "escape" (list) (fn () nil))) + (check + "hook called exactly once (no infinite recursion)" + hook-calls + 1))) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define debugger-passed passed) +(define debugger-failed failed) +(define debugger-failures failures) \ No newline at end of file diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md index ae86b6a0..60e6e8d5 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -74,10 +74,10 @@ Core mapping: - [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) -- [ ] Classic programs in `lib/common-lisp/tests/programs/`: +- [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) - - [ ] `interactive-debugger.lisp` — ASCII REPL using `:debugger-hook` + - [x] `interactive-debugger.sx` — policy-driven debugger hook, *debugger-hook* global (7 tests) - [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` ### Phase 4 — CLOS @@ -124,6 +124,7 @@ data; format for string templating. _Newest first._ +- 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. - 2026-05-05: unwind-protect — cl-eval-unwind-protect: eval protected form, run cleanup with for-each (discards results, preserves original sentinel), return original result; 8 new tests (159 eval, 331 total green).