giles
733b1ebefa
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>
478 lines
16 KiB
Plaintext
478 lines
16 KiB
Plaintext
;; lib/common-lisp/tests/conditions.sx — Phase 3 condition system tests
|
|
;;
|
|
;; Loaded by lib/common-lisp/test.sh after:
|
|
;; (load "spec/stdlib.sx")
|
|
;; (load "lib/common-lisp/runtime.sx")
|
|
;;
|
|
;; Each test resets the handler/restart stacks to ensure isolation.
|
|
|
|
(define
|
|
reset-stacks!
|
|
(fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))
|
|
|
|
;; ── helpers ────────────────────────────────────────────────────────────────
|
|
|
|
(define passed 0)
|
|
(define failed 0)
|
|
(define failures (list))
|
|
|
|
(define
|
|
assert-equal
|
|
(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
|
|
assert-true
|
|
(fn
|
|
(label got)
|
|
(if
|
|
got
|
|
(set! passed (+ passed 1))
|
|
(begin
|
|
(set! failed (+ failed 1))
|
|
(set!
|
|
failures
|
|
(append
|
|
failures
|
|
(list
|
|
(str "FAIL [" label "]: expected true, got " (inspect got)))))))))
|
|
|
|
(define
|
|
assert-nil
|
|
(fn
|
|
(label got)
|
|
(if
|
|
(nil? got)
|
|
(set! passed (+ passed 1))
|
|
(begin
|
|
(set! failed (+ failed 1))
|
|
(set!
|
|
failures
|
|
(append
|
|
failures
|
|
(list (str "FAIL [" label "]: expected nil, got " (inspect got)))))))))
|
|
|
|
;; ── 1. condition predicates ────────────────────────────────────────────────
|
|
|
|
(reset-stacks!)
|
|
|
|
(let
|
|
((c (cl-make-condition "simple-error" "format-control" "oops")))
|
|
(begin
|
|
(assert-true "cl-condition? on condition" (cl-condition? c))
|
|
(assert-equal "cl-condition? on string" (cl-condition? "hello") false)
|
|
(assert-equal "cl-condition? on number" (cl-condition? 42) false)
|
|
(assert-equal "cl-condition? on nil" (cl-condition? nil) false)))
|
|
|
|
;; ── 2. cl-make-condition + slot access ────────────────────────────────────
|
|
|
|
(reset-stacks!)
|
|
|
|
(let
|
|
((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2))))
|
|
(begin
|
|
(assert-equal "class field" (get c "class") "simple-error")
|
|
(assert-equal "cl-type field" (get c "cl-type") "cl-condition")
|
|
(assert-equal
|
|
"format-control slot"
|
|
(cl-condition-slot c "format-control")
|
|
"msg")
|
|
(assert-equal
|
|
"format-arguments slot"
|
|
(cl-condition-slot c "format-arguments")
|
|
(list 1 2))
|
|
(assert-nil "missing slot is nil" (cl-condition-slot c "no-such-slot"))
|
|
(assert-equal "condition-message" (cl-condition-message c) "msg")))
|
|
|
|
;; ── 3. cl-condition-of-type? — hierarchy walking ─────────────────────────
|
|
|
|
(reset-stacks!)
|
|
|
|
(let
|
|
((se (cl-make-condition "simple-error" "format-control" "x"))
|
|
(w (cl-make-condition "simple-warning" "format-control" "y"))
|
|
(te
|
|
(cl-make-condition
|
|
"type-error"
|
|
"datum"
|
|
5
|
|
"expected-type"
|
|
"string"))
|
|
(dz (cl-make-condition "division-by-zero")))
|
|
(begin
|
|
(assert-true
|
|
"se isa simple-error"
|
|
(cl-condition-of-type? se "simple-error"))
|
|
(assert-true "se isa error" (cl-condition-of-type? se "error"))
|
|
(assert-true
|
|
"se isa serious-condition"
|
|
(cl-condition-of-type? se "serious-condition"))
|
|
(assert-true "se isa condition" (cl-condition-of-type? se "condition"))
|
|
(assert-equal
|
|
"se not isa warning"
|
|
(cl-condition-of-type? se "warning")
|
|
false)
|
|
(assert-true
|
|
"w isa simple-warning"
|
|
(cl-condition-of-type? w "simple-warning"))
|
|
(assert-true "w isa warning" (cl-condition-of-type? w "warning"))
|
|
(assert-true "w isa condition" (cl-condition-of-type? w "condition"))
|
|
(assert-equal "w not isa error" (cl-condition-of-type? w "error") false)
|
|
(assert-true "te isa type-error" (cl-condition-of-type? te "type-error"))
|
|
(assert-true "te isa error" (cl-condition-of-type? te "error"))
|
|
(assert-true
|
|
"dz isa division-by-zero"
|
|
(cl-condition-of-type? dz "division-by-zero"))
|
|
(assert-true
|
|
"dz isa arithmetic-error"
|
|
(cl-condition-of-type? dz "arithmetic-error"))
|
|
(assert-true "dz isa error" (cl-condition-of-type? dz "error"))
|
|
(assert-equal
|
|
"non-condition not isa anything"
|
|
(cl-condition-of-type? 42 "error")
|
|
false)))
|
|
|
|
;; ── 4. cl-define-condition ────────────────────────────────────────────────
|
|
|
|
(reset-stacks!)
|
|
|
|
(begin
|
|
(cl-define-condition "my-app-error" (list "error") (list "code" "detail"))
|
|
(let
|
|
((c (cl-make-condition "my-app-error" "code" 404 "detail" "not found")))
|
|
(begin
|
|
(assert-true "user condition: cl-condition?" (cl-condition? c))
|
|
(assert-true
|
|
"user condition isa my-app-error"
|
|
(cl-condition-of-type? c "my-app-error"))
|
|
(assert-true
|
|
"user condition isa error"
|
|
(cl-condition-of-type? c "error"))
|
|
(assert-true
|
|
"user condition isa condition"
|
|
(cl-condition-of-type? c "condition"))
|
|
(assert-equal
|
|
"user condition slot code"
|
|
(cl-condition-slot c "code")
|
|
404)
|
|
(assert-equal
|
|
"user condition slot detail"
|
|
(cl-condition-slot c "detail")
|
|
"not found"))))
|
|
|
|
;; ── 5. cl-handler-bind (non-unwinding) ───────────────────────────────────
|
|
|
|
(reset-stacks!)
|
|
|
|
(let
|
|
((log (list)))
|
|
(begin
|
|
(cl-handler-bind
|
|
(list
|
|
(list
|
|
"error"
|
|
(fn (c) (set! log (append log (list (cl-condition-message c)))))))
|
|
(fn
|
|
()
|
|
(cl-signal (cl-make-condition "simple-error" "format-control" "oops"))))
|
|
(assert-equal "handler-bind: handler fired" log (list "oops"))))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Non-unwinding: body continues after signal
|
|
(let
|
|
((body-ran false))
|
|
(begin
|
|
(cl-handler-bind
|
|
(list (list "error" (fn (c) nil)))
|
|
(fn
|
|
()
|
|
(cl-signal (cl-make-condition "simple-error" "format-control" "x"))
|
|
(set! body-ran true)))
|
|
(assert-true "handler-bind: body continues after signal" body-ran)))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Type filtering: warning handler does not fire for error
|
|
(let
|
|
((w-fired false))
|
|
(begin
|
|
(cl-handler-bind
|
|
(list (list "warning" (fn (c) (set! w-fired true))))
|
|
(fn
|
|
()
|
|
(cl-signal (cl-make-condition "simple-error" "format-control" "e"))))
|
|
(assert-equal
|
|
"handler-bind: type filter (warning ignores error)"
|
|
w-fired
|
|
false)))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Multiple handlers: both matching handlers fire
|
|
(let
|
|
((log (list)))
|
|
(begin
|
|
(cl-handler-bind
|
|
(list
|
|
(list "error" (fn (c) (set! log (append log (list "e1")))))
|
|
(list "condition" (fn (c) (set! log (append log (list "e2"))))))
|
|
(fn
|
|
()
|
|
(cl-signal (cl-make-condition "simple-error" "format-control" "x"))))
|
|
(assert-equal "handler-bind: both handlers fire" log (list "e1" "e2"))))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 6. cl-handler-case (unwinding) ───────────────────────────────────────
|
|
|
|
;; Catches error, returns handler result
|
|
(let
|
|
((result (cl-handler-case (fn () (cl-error "boom") 99) (list "error" (fn (c) (str "caught: " (cl-condition-message c)))))))
|
|
(assert-equal "handler-case: catches error" result "caught: boom"))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Returns body result when no signal
|
|
(let
|
|
((result (cl-handler-case (fn () 42) (list "error" (fn (c) -1)))))
|
|
(assert-equal "handler-case: body result" result 42))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Only first matching handler runs (unwinding)
|
|
(let
|
|
((result (cl-handler-case (fn () (cl-error "x")) (list "simple-error" (fn (c) "simple")) (list "error" (fn (c) "error")))))
|
|
(assert-equal "handler-case: most specific wins" result "simple"))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 7. cl-warn ────────────────────────────────────────────────────────────
|
|
|
|
(let
|
|
((warned false))
|
|
(begin
|
|
(cl-handler-bind
|
|
(list (list "warning" (fn (c) (set! warned true))))
|
|
(fn () (cl-warn "be careful")))
|
|
(assert-true "cl-warn: fires warning handler" warned)))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Warn with condition object
|
|
(let
|
|
((msg ""))
|
|
(begin
|
|
(cl-handler-bind
|
|
(list (list "warning" (fn (c) (set! msg (cl-condition-message c)))))
|
|
(fn
|
|
()
|
|
(cl-warn
|
|
(cl-make-condition "simple-warning" "format-control" "take care"))))
|
|
(assert-equal "cl-warn: condition object" msg "take care")))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 8. cl-restart-case + cl-invoke-restart ───────────────────────────────
|
|
|
|
;; Basic restart invocation
|
|
(let
|
|
((result (cl-restart-case (fn () (cl-invoke-restart "use-zero")) (list "use-zero" (list) (fn () 0)))))
|
|
(assert-equal "restart-case: invoke-restart use-zero" result 0))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Restart with argument
|
|
(let
|
|
((result (cl-restart-case (fn () (cl-invoke-restart "use-value" 77)) (list "use-value" (list "v") (fn (v) v)))))
|
|
(assert-equal "restart-case: invoke-restart with arg" result 77))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; Body returns normally when restart not invoked
|
|
(let
|
|
((result (cl-restart-case (fn () 42) (list "never-used" (list) (fn () -1)))))
|
|
(assert-equal "restart-case: body result" result 42))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 9. cl-with-simple-restart ─────────────────────────────────────────────
|
|
|
|
(let
|
|
((result (cl-with-simple-restart "skip" "Skip this step" (fn () (cl-invoke-restart "skip") 99))))
|
|
(assert-nil "with-simple-restart: invoke returns nil" result))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 10. cl-find-restart ───────────────────────────────────────────────────
|
|
|
|
(let
|
|
((found (cl-restart-case (fn () (cl-find-restart "retry")) (list "retry" (list) (fn () nil)))))
|
|
(assert-true "find-restart: finds active restart" (not (nil? found))))
|
|
|
|
(reset-stacks!)
|
|
|
|
(let
|
|
((not-found (cl-restart-case (fn () (cl-find-restart "nonexistent")) (list "retry" (list) (fn () nil)))))
|
|
(assert-nil "find-restart: nil for inactive restart" not-found))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 11. cl-compute-restarts ───────────────────────────────────────────────
|
|
|
|
(let
|
|
((names (cl-restart-case (fn () (cl-restart-case (fn () (cl-compute-restarts)) (list "inner" (list) (fn () nil)))) (list "outer" (list) (fn () nil)))))
|
|
(assert-equal
|
|
"compute-restarts: both restarts"
|
|
names
|
|
(list "inner" "outer")))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 12. handler-bind + restart-case interop ───────────────────────────────
|
|
|
|
;; Classic CL pattern: error handler invokes a restart
|
|
(let
|
|
((result (cl-restart-case (fn () (cl-handler-bind (list (list "error" (fn (c) (cl-invoke-restart "use-zero")))) (fn () (cl-error "divide by zero")))) (list "use-zero" (list) (fn () 0)))))
|
|
(assert-equal "interop: handler invokes restart" result 0))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 13. cl-cerror ─────────────────────────────────────────────────────────
|
|
|
|
;; When "continue" restart is invoked, cerror returns nil
|
|
(let
|
|
((result (cl-restart-case (fn () (cl-cerror "continue anyway" "something bad") 42) (list "continue" (list) (fn () "resumed")))))
|
|
(assert-true
|
|
"cerror: returns"
|
|
(or (nil? result) (= result 42) (= result "resumed"))))
|
|
|
|
(reset-stacks!)
|
|
|
|
;; ── 14. slot accessor helpers ─────────────────────────────────────────────
|
|
|
|
(let
|
|
((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2))))
|
|
(begin
|
|
(assert-equal
|
|
"simple-condition-format-control"
|
|
(cl-simple-condition-format-control c)
|
|
"msg")
|
|
(assert-equal
|
|
"simple-condition-format-arguments"
|
|
(cl-simple-condition-format-arguments c)
|
|
(list 1 2))))
|
|
|
|
(let
|
|
((c (cl-make-condition "type-error" "datum" 42 "expected-type" "string")))
|
|
(begin
|
|
(assert-equal "type-error-datum" (cl-type-error-datum c) 42)
|
|
(assert-equal
|
|
"type-error-expected-type"
|
|
(cl-type-error-expected-type c)
|
|
"string")))
|
|
|
|
(let
|
|
((c (cl-make-condition "arithmetic-error" "operation" "/" "operands" (list 1 0))))
|
|
(begin
|
|
(assert-equal
|
|
"arithmetic-error-operation"
|
|
(cl-arithmetic-error-operation c)
|
|
"/")
|
|
(assert-equal
|
|
"arithmetic-error-operands"
|
|
(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
|
|
(= failed 0)
|
|
(print (str "ok " passed "/" (+ passed failed) " condition tests passed"))
|
|
(begin
|
|
(for-each (fn (f) (print f)) failures)
|
|
(print
|
|
(str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed")))) |