cl: Phase 3 conditions + restarts — handler-bind, handler-case, restart-case, 55 tests (123 total runtime)

define-condition with 15-type ANSI hierarchy (condition/error/warning/
simple-error/simple-warning/type-error/arithmetic-error/division-by-zero/
cell-error/unbound-variable/undefined-function/program-error/storage-condition).

cl-condition-of-type? walks the hierarchy; cl-make-condition builds tagged
dicts {:cl-type "cl-condition" :class name :slots {...}}. cl-signal-obj
walks cl-handler-stack for non-unwinding dispatch. cl-handler-case and
cl-restart-case use call/cc escape continuations for unwinding. All stacks
are mutable SX globals (the built-in handler-bind/restart-case only accept
literal AST specs — not computed lists). Key fix: cl-condition-of-type?
captures cl-condition-classes at define-time via let-closure to avoid
free-variable failure through env_merge parent chain.

55 tests in lib/common-lisp/tests/conditions.sx, wired into test.sh.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

lib/common-lisp/runtime.sx

@@ -1,18 +1,14 @@
-;; lib/common-lisp/runtime.sx — CL built-ins using SX spec primitives
+;; lib/common-lisp/runtime.sx — CL built-ins + condition system on SX
 ;;
-;; Provides CL-specific wrappers and helpers. Deliberately thin: wherever
-;; an SX spec primitive already does the job, we alias it rather than
-;; reinventing it.
+;; Section 1-9:  Type predicates, arithmetic, characters, strings, gensym,
+;;               multiple values, sets, radix formatting, list utilities.
+;; Section 10:   Condition system (define-condition, signal/error/warn,
+;;               handler-bind, handler-case, restart-case, invoke-restart).
 ;;
 ;; Primitives used from spec:
 ;;   char/char->integer/integer->char/char-upcase/char-downcase
-;;   format   (Phase 21 — must be loaded before this file)
-;;   gensym   (Phase 12)
-;;   rational/rational?  (Phase 16)
-;;   make-set/set-member?/set-union/etc  (Phase 18)
-;;   open-input-string/read-char/etc  (Phase 14)
-;;   modulo/remainder/quotient/gcd/lcm/expt  (Phase 2 / Phase 15)
-;;   number->string with radix  (Phase 15)
+;;   format   gensym   rational/rational?   make-set/set-member?/etc
+;;   modulo/remainder/quotient/gcd/lcm/expt   number->string
 
 ;; ---------------------------------------------------------------------------
 ;; 1.  Type predicates
@@ -304,3 +300,372 @@
     ((or (cl-empty? plist) (cl-empty? (rest plist))) nil)
     ((equal? (first plist) key) (first (rest plist)))
     (else (cl-getf (rest (rest plist)) key))))
+
+;; ---------------------------------------------------------------------------
+;; 10.  Condition system (Phase 3)
+;;
+;; Condition objects:
+;;   {:cl-type "cl-condition" :class "NAME" :slots {slot-name val ...}}
+;;
+;; The built-in handler-bind / restart-case expect LITERAL handler specs in
+;; source (they operate on the raw AST), so we implement our own handler and
+;; restart stacks as mutable SX globals.
+;; ---------------------------------------------------------------------------
+
+;; ── condition class registry ───────────────────────────────────────────────
+;;
+;; Populated at load time with all ANSI standard condition types.
+;; Also mutated by cl-define-condition.
+
+(define
+  cl-condition-classes
+  (dict
+    "condition"
+    {:parents (list) :slots (list) :name "condition"}
+    "serious-condition"
+    {:parents (list "condition") :slots (list) :name "serious-condition"}
+    "error"
+    {:parents (list "serious-condition") :slots (list) :name "error"}
+    "warning"
+    {:parents (list "condition") :slots (list) :name "warning"}
+    "simple-condition"
+    {:parents (list "condition") :slots (list "format-control" "format-arguments") :name "simple-condition"}
+    "simple-error"
+    {:parents (list "error" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-error"}
+    "simple-warning"
+    {:parents (list "warning" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-warning"}
+    "type-error"
+    {:parents (list "error") :slots (list "datum" "expected-type") :name "type-error"}
+    "arithmetic-error"
+    {:parents (list "error") :slots (list "operation" "operands") :name "arithmetic-error"}
+    "division-by-zero"
+    {:parents (list "arithmetic-error") :slots (list) :name "division-by-zero"}
+    "cell-error"
+    {:parents (list "error") :slots (list "name") :name "cell-error"}
+    "unbound-variable"
+    {:parents (list "cell-error") :slots (list) :name "unbound-variable"}
+    "undefined-function"
+    {:parents (list "cell-error") :slots (list) :name "undefined-function"}
+    "program-error"
+    {:parents (list "error") :slots (list) :name "program-error"}
+    "storage-condition"
+    {:parents (list "serious-condition") :slots (list) :name "storage-condition"}))
+
+;; ── condition predicates ───────────────────────────────────────────────────
+
+(define
+  cl-condition?
+  (fn (x) (and (dict? x) (= (get x "cl-type") "cl-condition"))))
+
+;; cl-condition-of-type? walks the class hierarchy.
+;; We capture cl-condition-classes at define time via let to avoid
+;; free-variable scoping issues at call time.
+
+(define
+  cl-condition-of-type?
+  (let
+    ((classes cl-condition-classes))
+    (fn
+      (c type-name)
+      (if
+        (not (cl-condition? c))
+        false
+        (let
+          ((class-name (get c "class")))
+          (define
+            check
+            (fn
+              (n)
+              (if
+                (= n type-name)
+                true
+                (let
+                  ((entry (get classes n)))
+                  (if
+                    (nil? entry)
+                    false
+                    (some (fn (p) (check p)) (get entry "parents")))))))
+          (check class-name))))))
+
+;; ── condition constructors ─────────────────────────────────────────────────
+
+;; cl-define-condition registers a new condition class.
+;; name:       string (condition class name)
+;; parents:    list of strings (parent class names)
+;; slot-names: list of strings
+
+(define
+  cl-define-condition
+  (fn
+    (name parents slot-names)
+    (begin (dict-set! cl-condition-classes name {:parents parents :slots slot-names :name name}) name)))
+
+;; cl-make-condition constructs a condition object.
+;; Keyword args (alternating slot-name/value pairs) populate the slots dict.
+
+(define
+  cl-make-condition
+  (fn
+    (name &rest kw-args)
+    (let
+      ((slots (dict)))
+      (define
+        fill
+        (fn
+          (args)
+          (when
+            (>= (len args) 2)
+            (begin
+              (dict-set! slots (first args) (first (rest args)))
+              (fill (rest (rest args)))))))
+      (fill kw-args)
+      {:cl-type "cl-condition" :slots slots :class name})))
+
+;; ── condition accessors ────────────────────────────────────────────────────
+
+(define
+  cl-condition-slot
+  (fn
+    (c slot-name)
+    (if (cl-condition? c) (get (get c "slots") slot-name) nil)))
+
+(define
+  cl-condition-message
+  (fn
+    (c)
+    (if
+      (not (cl-condition? c))
+      (str c)
+      (let
+        ((slots (get c "slots")))
+        (or
+          (get slots "message")
+          (get slots "format-control")
+          (str "Condition: " (get c "class")))))))
+
+(define
+  cl-simple-condition-format-control
+  (fn (c) (cl-condition-slot c "format-control")))
+
+(define
+  cl-simple-condition-format-arguments
+  (fn (c) (cl-condition-slot c "format-arguments")))
+
+(define cl-type-error-datum (fn (c) (cl-condition-slot c "datum")))
+
+(define
+  cl-type-error-expected-type
+  (fn (c) (cl-condition-slot c "expected-type")))
+
+(define
+  cl-arithmetic-error-operation
+  (fn (c) (cl-condition-slot c "operation")))
+
+(define
+  cl-arithmetic-error-operands
+  (fn (c) (cl-condition-slot c "operands")))
+
+;; ── mutable handler + restart stacks ──────────────────────────────────────
+;;
+;; Handler entry: {:type "type-name" :fn (fn (condition) result)}
+;; Restart entry: {:name "restart-name" :fn (fn (&optional arg) result) :escape k}
+;;
+;; New handlers are prepended (checked first = most recent handler wins).
+
+(define cl-handler-stack (list))
+(define cl-restart-stack (list))
+
+(define
+  cl-push-handlers
+  (fn (entries) (set! cl-handler-stack (append entries cl-handler-stack))))
+
+(define
+  cl-pop-handlers
+  (fn
+    (n)
+    (set! cl-handler-stack (slice cl-handler-stack n (len cl-handler-stack)))))
+
+(define
+  cl-push-restarts
+  (fn (entries) (set! cl-restart-stack (append entries cl-restart-stack))))
+
+(define
+  cl-pop-restarts
+  (fn
+    (n)
+    (set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack)))))
+
+;; ── cl-signal (non-unwinding) ─────────────────────────────────────────────
+;;
+;; Walks cl-handler-stack; for each matching entry, calls the handler fn.
+;; Handlers return normally — signal continues to the next matching handler.
+
+(define
+  cl-signal-obj
+  (fn
+    (obj stack)
+    (if
+      (empty? stack)
+      nil
+      (let
+        ((entry (first stack)))
+        (if
+          (cl-condition-of-type? obj (get entry "type"))
+          (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)))))
+      (cl-signal-obj obj cl-handler-stack))))
+
+;; ── cl-error ───────────────────────────────────────────────────────────────
+;;
+;; Signals an error. If no handler catches it, raises a host-level error.
+
+(define
+  cl-error
+  (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)
+      (error (str "Unhandled CL error: " (cl-condition-message obj))))))
+
+;; ── cl-warn ────────────────────────────────────────────────────────────────
+
+(define
+  cl-warn
+  (fn
+    (c &rest args)
+    (let
+      ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-warning" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-warning" "format-control" (str c))))))
+      (cl-signal-obj obj cl-handler-stack))))
+
+;; ── cl-handler-bind (non-unwinding) ───────────────────────────────────────
+;;
+;; bindings: list of (type-name handler-fn) pairs
+;; thunk:    (fn () body)
+
+(define
+  cl-handler-bind
+  (fn
+    (bindings thunk)
+    (let
+      ((entries (map (fn (b) {:fn (first (rest b)) :type (first b)}) bindings)))
+      (begin
+        (cl-push-handlers entries)
+        (let
+          ((result (thunk)))
+          (begin (cl-pop-handlers (len entries)) result))))))
+
+;; ── cl-handler-case (unwinding) ───────────────────────────────────────────
+;;
+;; thunk: (fn () body)
+;; cases: list of (type-name handler-fn) pairs
+;;
+;; Uses call/cc for the escape continuation.
+
+(define
+  cl-handler-case
+  (fn
+    (thunk &rest cases)
+    (call/cc
+      (fn
+        (escape)
+        (let
+          ((entries (map (fn (c) {:fn (fn (x) (escape ((first (rest c)) x))) :type (first c)}) cases)))
+          (begin
+            (cl-push-handlers entries)
+            (let
+              ((result (thunk)))
+              (begin (cl-pop-handlers (len entries)) result))))))))
+
+;; ── cl-restart-case ────────────────────────────────────────────────────────
+;;
+;; thunk:    (fn () body)
+;; restarts: list of (name params body-fn) triples
+;;   body-fn is (fn () val) or (fn (arg) val)
+
+(define
+  cl-restart-case
+  (fn
+    (thunk &rest restarts)
+    (call/cc
+      (fn
+        (escape)
+        (let
+          ((entries (map (fn (r) {:fn (first (rest (rest r))) :escape escape :name (first r)}) restarts)))
+          (begin
+            (cl-push-restarts entries)
+            (let
+              ((result (thunk)))
+              (begin (cl-pop-restarts (len entries)) result))))))))
+
+;; ── cl-with-simple-restart ─────────────────────────────────────────────────
+
+(define
+  cl-with-simple-restart
+  (fn
+    (name description thunk)
+    (cl-restart-case thunk (list name (list) (fn () nil)))))
+
+;; ── find-restart / invoke-restart / compute-restarts ──────────────────────
+
+(define
+  cl-find-restart-entry
+  (fn
+    (name stack)
+    (if
+      (empty? stack)
+      nil
+      (let
+        ((entry (first stack)))
+        (if
+          (= (get entry "name") name)
+          entry
+          (cl-find-restart-entry name (rest stack)))))))
+
+(define
+  cl-find-restart
+  (fn (name) (cl-find-restart-entry name cl-restart-stack)))
+
+(define
+  cl-invoke-restart
+  (fn
+    (name &rest args)
+    (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
+            (if (empty? args) (restart-fn) (restart-fn (first args)))))))))
+
+(define
+  cl-compute-restarts
+  (fn () (map (fn (e) (get e "name")) cl-restart-stack)))
+
+;; ── with-condition-restarts (stub — association is advisory) ──────────────
+
+(define cl-with-condition-restarts (fn (c restarts thunk) (thunk)))
+
+;; ── 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))))))