diff --git a/lib/common-lisp/tests/programs/parse-recover.sx b/lib/common-lisp/tests/programs/parse-recover.sx new file mode 100644 index 00000000..9d980cc6 --- /dev/null +++ b/lib/common-lisp/tests/programs/parse-recover.sx @@ -0,0 +1,163 @@ +;; parse-recover.sx — Parser with skipped-token restart +;; +;; Classic CL pattern: a simple token parser that signals a condition +;; when it encounters an unexpected token. The :skip-token restart +;; allows the parser to continue past the offending token. +;; +;; Depends on: lib/common-lisp/runtime.sx already loaded. + +;; ── condition type ───────────────────────────────────────────────────────── + +(cl-define-condition "parse-error" (list "error") (list "token" "position")) + +;; ── simple token parser ──────────────────────────────────────────────────── +;; +;; parse-numbers: given a list of tokens (strings), parse integers. +;; Non-integer tokens signal parse-error with two restarts: +;; skip-token — skip the bad token and continue +;; use-zero — use 0 in place of the bad token + +(define + parse-numbers + (fn + (tokens) + (define result (list)) + (define + process + (fn + (toks) + (if + (empty? toks) + result + (let + ((tok (first toks)) (rest-toks (rest toks))) + (let + ((n (string->number tok 10))) + (if + n + (begin + (set! result (append result (list n))) + (process rest-toks)) + (cl-restart-case + (fn + () + (cl-signal + (cl-make-condition + "parse-error" + "token" + tok + "position" + (len result))) + (set! result (append result (list 0))) + (process rest-toks)) + (list "skip-token" (list) (fn () (process rest-toks))) + (list + "use-zero" + (list) + (fn + () + (begin + (set! result (append result (list 0))) + (process rest-toks))))))))))) + (process tokens) + result)) + +;; ── 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)))) + +;; All valid tokens +(reset-stacks!) +(check + "all valid: 1 2 3" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token")))) + (fn () (parse-numbers (list "1" "2" "3")))) + (list 1 2 3)) + +;; Skip bad token +(reset-stacks!) +(check + "skip bad token: 1 x 3 -> (1 3)" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token")))) + (fn () (parse-numbers (list "1" "x" "3")))) + (list 1 3)) + +;; Use zero for bad token +(reset-stacks!) +(check + "use-zero for bad: 1 x 3 -> (1 0 3)" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "use-zero")))) + (fn () (parse-numbers (list "1" "x" "3")))) + (list 1 0 3)) + +;; Multiple bad tokens, all skipped +(reset-stacks!) +(check + "skip multiple bad: a 2 b 4 -> (2 4)" + (cl-handler-bind + (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token")))) + (fn () (parse-numbers (list "a" "2" "b" "4")))) + (list 2 4)) + +;; handler-case: abort on first bad token +(reset-stacks!) +(check + "handler-case: abort on first bad" + (cl-handler-case + (fn () (parse-numbers (list "1" "bad" "3"))) + (list + "parse-error" + (fn + (c) + (str + "parse error at position " + (cl-condition-slot c "position") + ": " + (cl-condition-slot c "token"))))) + "parse error at position 1: bad") + +;; Verify condition type hierarchy +(reset-stacks!) +(check + "parse-error isa error" + (cl-condition-of-type? + (cl-make-condition "parse-error" "token" "x" "position" 0) + "error") + true) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define parse-passed passed) +(define parse-failed failed) +(define parse-failures failures) \ No newline at end of file diff --git a/lib/common-lisp/tests/programs/restart-demo.sx b/lib/common-lisp/tests/programs/restart-demo.sx new file mode 100644 index 00000000..db615135 --- /dev/null +++ b/lib/common-lisp/tests/programs/restart-demo.sx @@ -0,0 +1,141 @@ +;; restart-demo.sx — Classic CL condition system demo +;; +;; Demonstrates resumable exceptions via restarts. +;; The `safe-divide` function signals a division-by-zero condition +;; and offers two restarts: +;; :use-zero — return 0 as the result +;; :retry — call safe-divide again with a corrected divisor +;; +;; Depends on: lib/common-lisp/runtime.sx already loaded. + +;; ── safe-divide ──────────────────────────────────────────────────────────── +;; +;; Divides numerator by denominator. +;; When denominator is 0, signals division-by-zero with two restarts. + +(define + safe-divide + (fn + (n d) + (if + (= d 0) + (cl-restart-case + (fn + () + (cl-signal + (cl-make-condition + "division-by-zero" + "operation" + "/" + "operands" + (list n d))) + (error "division by zero — no restart invoked")) + (list "use-zero" (list) (fn () 0)) + (list "retry" (list "d") (fn (d2) (safe-divide n d2)))) + (/ n d)))) + +;; ── 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)))) + +;; Normal division +(reset-stacks!) +(check "10 / 2 = 5" (safe-divide 10 2) 5) + +;; Invoke use-zero restart +(reset-stacks!) +(check + "10 / 0 -> use-zero" + (cl-handler-bind + (list + (list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero")))) + (fn () (safe-divide 10 0))) + 0) + +;; Invoke retry restart with a corrected denominator +(reset-stacks!) +(check + "10 / 0 -> retry with 2" + (cl-handler-bind + (list + (list + "division-by-zero" + (fn (c) (cl-invoke-restart "retry" 2)))) + (fn () (safe-divide 10 0))) + 5) + +;; Nested calls: outer handles the inner divide-by-zero +(reset-stacks!) +(check + "nested: 20 / (0->4) = 5" + (cl-handler-bind + (list + (list + "division-by-zero" + (fn (c) (cl-invoke-restart "retry" 4)))) + (fn () (let ((r1 (safe-divide 20 0))) r1))) + 5) + +;; handler-case — unwinding version +(reset-stacks!) +(check + "handler-case: catches division-by-zero" + (cl-handler-case + (fn () (safe-divide 9 0)) + (list "division-by-zero" (fn (c) "caught!"))) + "caught!") + +;; Verify use-zero is idempotent (two uses) +(reset-stacks!) +(check + "two use-zero invocations" + (cl-handler-bind + (list + (list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero")))) + (fn + () + (+ + (safe-divide 10 0) + (safe-divide 3 0)))) + 0) + +;; No restart needed for normal division +(reset-stacks!) +(check + "no restart needed for 8/4" + (safe-divide 8 4) + 2) + +;; ── summary ──────────────────────────────────────────────────────────────── + +(define demo-passed passed) +(define demo-failed failed) +(define demo-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 b989c16a..ae86b6a0 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -75,8 +75,8 @@ Core mapping: - [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/`: - - [ ] `restart-demo.lisp` — division with `:use-zero` and `:retry` restarts - - [ ] `parse-recover.lisp` — parser with skipped-token restart + - [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` - [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` @@ -124,6 +124,7 @@ data; format for string templating. _Newest first._ +- 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). - 2026-05-05: tagbody + go — cl-go-tag? sentinel; cl-eval-tagbody runs body with tag-index map (keys str-normalised for integer tags); go-tag propagation in cl-eval-body alongside block-return; 11 new tests (151 eval, 323 total green).