cl: multiple values — 15 new tests (174 eval, 346 total green)

VALUES wraps 2+ values in {:cl-type "mv"}; cl-mv-primary strips to
primary in IF/AND/OR/COND/cl-call-fn single-value contexts; cl-mv-vals
expands for MULTIPLE-VALUE-BIND, MULTIPLE-VALUE-CALL, NTH-VALUE.

lib/common-lisp/eval.sx

@@ -0,0 +1,710 @@
+;; Common Lisp evaluator — evaluates CL AST forms.
+;;
+;; Depends on: lib/common-lisp/reader.sx, lib/common-lisp/parser.sx
+;;
+;; Environment:
+;;   {:vars {"NAME" val ...} :fns {"NAME" cl-fn ...}}
+;; CL function:
+;;   {:cl-type "function" :params ll :body forms :env env}
+;;
+;; Public API:
+;;   (cl-make-env)              — create empty environment
+;;   (cl-eval form env)         — evaluate one CL AST form
+;;   (cl-eval-str src env)      — read+eval a CL source string
+;;   (cl-eval-all-str src env)  — read-all+eval-each, return last
+;;   cl-global-env              — global mutable environment
+
+;; ── environment ──────────────────────────────────────────────────
+
+(define cl-make-env (fn () {:vars {} :fns {}}))
+
+(define cl-global-env (cl-make-env))
+
+(define cl-env-get-var  (fn (env name) (get (get env "vars") name)))
+(define cl-env-has-var? (fn (env name) (has-key? (get env "vars") name)))
+(define cl-env-get-fn   (fn (env name) (get (get env "fns") name)))
+(define cl-env-has-fn?  (fn (env name) (has-key? (get env "fns") name)))
+
+(define cl-env-bind-var
+  (fn (env name value)
+    {:vars (assoc (get env "vars") name value)
+     :fns  (get env "fns")}))
+
+(define cl-env-bind-fn
+  (fn (env name fn-obj)
+    {:vars (get env "vars")
+     :fns  (assoc (get env "fns") name fn-obj)}))
+
+;; ── body evaluation ───────────────────────────────────────────────
+
+(define cl-block-return?
+  (fn (v) (and (dict? v) (= (get v "cl-type") "block-return"))))
+
+(define cl-go-tag?
+  (fn (v) (and (dict? v) (= (get v "cl-type") "go-tag"))))
+
+(define cl-mv?
+  (fn (v) (and (dict? v) (= (get v "cl-type") "mv"))))
+
+(define cl-mv-primary
+  (fn (v)
+    (if (cl-mv? v)
+      (if (> (len (get v "vals")) 0) (nth (get v "vals") 0) nil)
+      v)))
+
+(define cl-mv-vals
+  (fn (v) (if (cl-mv? v) (get v "vals") (list v))))
+
+(define cl-eval-body
+  (fn (forms env)
+    (cond
+      ((= (len forms) 0) nil)
+      ((= (len forms) 1) (cl-eval (nth forms 0) env))
+      (:else
+        (let ((result (cl-eval (nth forms 0) env)))
+          (if (or (cl-block-return? result) (cl-go-tag? result))
+            result
+            (cl-eval-body (rest forms) env)))))))
+
+;; ── lambda-list binding helpers ───────────────────────────────────
+
+(define cl-bind-required
+  (fn (names args env)
+    (if (= (len names) 0)
+      env
+      (cl-bind-required
+        (rest names)
+        (if (> (len args) 0) (rest args) args)
+        (cl-env-bind-var env
+          (nth names 0)
+          (if (> (len args) 0) (nth args 0) nil))))))
+
+;; returns {:env e :rest remaining-args}
+(define cl-bind-optional
+  (fn (opts args env)
+    (if (= (len opts) 0)
+      {:env env :rest args}
+      (let ((spec    (nth opts 0))
+            (has-val (> (len args) 0)))
+        (let ((val (if has-val (nth args 0) nil))
+              (rem (if has-val (rest args) args)))
+          (let ((e1 (cl-env-bind-var env (get spec "name")
+                      (if has-val val
+                        (if (get spec "default")
+                          (cl-eval (get spec "default") env) nil)))))
+            (let ((e2 (if (get spec "supplied")
+                        (cl-env-bind-var e1 (get spec "supplied") has-val)
+                        e1)))
+              (cl-bind-optional (rest opts) rem e2))))))))
+
+;; returns {:found bool :value v}
+(define cl-find-kw-arg
+  (fn (kw args i)
+    (if (>= i (len args))
+      {:found false :value nil}
+      (let ((a (nth args i)))
+        (if (and (dict? a)
+                 (= (get a "cl-type") "keyword")
+                 (= (get a "name") kw))
+          {:found true
+           :value (if (< (+ i 1) (len args)) (nth args (+ i 1)) nil)}
+          (cl-find-kw-arg kw args (+ i 2)))))))
+
+(define cl-bind-key
+  (fn (key-specs all-args env)
+    (if (= (len key-specs) 0)
+      env
+      (let ((spec (nth key-specs 0))
+            (r    (cl-find-kw-arg (get (nth key-specs 0) "keyword") all-args 0)))
+        (let ((found (get r "found"))
+              (kval  (get r "value")))
+          (let ((e1 (cl-env-bind-var env (get spec "name")
+                      (if found kval
+                        (if (get spec "default")
+                          (cl-eval (get spec "default") env) nil)))))
+            (let ((e2 (if (get spec "supplied")
+                        (cl-env-bind-var e1 (get spec "supplied") found)
+                        e1)))
+              (cl-bind-key (rest key-specs) all-args e2))))))))
+
+(define cl-bind-aux
+  (fn (aux-specs env)
+    (if (= (len aux-specs) 0)
+      env
+      (let ((spec (nth aux-specs 0)))
+        (cl-bind-aux
+          (rest aux-specs)
+          (cl-env-bind-var env (get spec "name")
+            (if (get spec "init") (cl-eval (get spec "init") env) nil)))))))
+
+;; ── function creation ─────────────────────────────────────────────
+
+;; ll-and-body: (list lambda-list-form body-form ...)
+(define cl-make-lambda
+  (fn (ll-and-body env)
+    {:cl-type "function"
+     :params  (cl-parse-lambda-list (nth ll-and-body 0))
+     :body    (rest ll-and-body)
+     :env     env}))
+
+;; ── function application ──────────────────────────────────────────
+
+(define cl-apply
+  (fn (fn-obj args)
+    (cond
+      ((and (dict? fn-obj) (has-key? fn-obj "builtin-fn"))
+        ((get fn-obj "builtin-fn") args))
+      ((or (not (dict? fn-obj)) (not (= (get fn-obj "cl-type") "function")))
+        {:cl-type "error" :message "Not a function"})
+      (:else
+        (let ((params (get fn-obj "params"))
+            (body   (get fn-obj "body"))
+            (cenv   (get fn-obj "env")))
+        (let ((req       (get params "required"))
+              (opt       (get params "optional"))
+              (rest-name (get params "rest"))
+              (key-specs (get params "key"))
+              (aux-specs (get params "aux")))
+          (let ((e1 (cl-bind-required req args cenv)))
+            (let ((opt-r (cl-bind-optional
+                           opt (slice args (len req) (len args)) e1)))
+              (let ((e2  (get opt-r "env"))
+                    (rem (get opt-r "rest")))
+                (let ((e3 (if rest-name
+                            (cl-env-bind-var e2 rest-name rem)
+                            e2)))
+                  (let ((e4 (cl-bind-key key-specs args e3)))
+                    (let ((e5 (cl-bind-aux aux-specs e4)))
+                      (cl-eval-body body e5)))))))))))))
+
+;; ── built-in functions ────────────────────────────────────────────
+
+(define cl-builtins
+  (dict
+    "+"   (fn (args) (reduce (fn (a b) (+ a b)) 0 args))
+    "-"   (fn (args)
+            (cond
+              ((= (len args) 0) 0)
+              ((= (len args) 1) (- 0 (nth args 0)))
+              (:else (reduce (fn (a b) (- a b)) (nth args 0) (rest args)))))
+    "*"   (fn (args) (reduce (fn (a b) (* a b)) 1 args))
+    "/"   (fn (args)
+            (cond
+              ((= (len args) 0) 1)
+              ((= (len args) 1) (/ 1 (nth args 0)))
+              (:else (reduce (fn (a b) (/ a b)) (nth args 0) (rest args)))))
+    "1+"  (fn (args) (+ (nth args 0) 1))
+    "1-"  (fn (args) (- (nth args 0) 1))
+    "="   (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
+    "/="  (fn (args) (if (not (= (nth args 0) (nth args 1))) true nil))
+    "<"   (fn (args) (if (< (nth args 0) (nth args 1)) true nil))
+    ">"   (fn (args) (if (> (nth args 0) (nth args 1)) true nil))
+    "<="  (fn (args) (if (<= (nth args 0) (nth args 1)) true nil))
+    ">="  (fn (args) (if (>= (nth args 0) (nth args 1)) true nil))
+    "NOT"   (fn (args) (if (nth args 0) nil true))
+    "NULL"  (fn (args) (if (= (nth args 0) nil) true nil))
+    "NUMBERP" (fn (args) (if (number? (nth args 0)) true nil))
+    "STRINGP" (fn (args) (if (string? (nth args 0)) true nil))
+    "SYMBOLP" (fn (args) nil)
+    "LISTP"   (fn (args)
+                 (if (or (list? (nth args 0)) (= (nth args 0) nil)) true nil))
+    "CONSP"   (fn (args)
+                 (let ((x (nth args 0)))
+                   (if (and (dict? x) (= (get x "cl-type") "cons")) true nil)))
+    "ATOM"    (fn (args)
+                 (let ((x (nth args 0)))
+                   (if (and (dict? x) (= (get x "cl-type") "cons")) nil true)))
+    "FUNCTIONP" (fn (args)
+                   (let ((x (nth args 0)))
+                     (if (and (dict? x) (= (get x "cl-type") "function")) true nil)))
+    "ZEROP"  (fn (args) (if (= (nth args 0) 0) true nil))
+    "PLUSP"  (fn (args) (if (> (nth args 0) 0) true nil))
+    "MINUSP" (fn (args) (if (< (nth args 0) 0) true nil))
+    "EVENP"  (fn (args)
+                (let ((n (nth args 0)))
+                  (if (= (mod n 2) 0) true nil)))
+    "ODDP"   (fn (args)
+                (let ((n (nth args 0)))
+                  (if (not (= (mod n 2) 0)) true nil)))
+    "ABS"    (fn (args) (let ((n (nth args 0))) (if (< n 0) (- 0 n) n)))
+    "MAX"    (fn (args) (reduce (fn (a b) (if (> a b) a b)) (nth args 0) (rest args)))
+    "MIN"    (fn (args) (reduce (fn (a b) (if (< a b) a b)) (nth args 0) (rest args)))
+    "CONS"   (fn (args) {:cl-type "cons" :car (nth args 0) :cdr (nth args 1)})
+    "CAR"    (fn (args)
+                (let ((x (nth args 0)))
+                  (if (and (dict? x) (= (get x "cl-type") "cons"))
+                    (get x "car")
+                    (if (and (list? x) (> (len x) 0)) (nth x 0) nil))))
+    "CDR"    (fn (args)
+                (let ((x (nth args 0)))
+                  (if (and (dict? x) (= (get x "cl-type") "cons"))
+                    (get x "cdr")
+                    (if (list? x) (rest x) nil))))
+    "LIST"   (fn (args) args)
+    "APPEND" (fn (args)
+                (if (= (len args) 0) (list)
+                  (reduce (fn (a b)
+                    (if (= a nil) b (if (= b nil) a (concat a b))))
+                  (list) args)))
+    "LENGTH" (fn (args)
+                (let ((x (nth args 0)))
+                  (if (= x nil) 0 (len x))))
+    "NTH"    (fn (args) (nth (nth args 1) (nth args 0)))
+    "FIRST"  (fn (args)
+                (let ((x (nth args 0)))
+                  (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
+    "SECOND" (fn (args)
+                (let ((x (nth args 0)))
+                  (if (and (list? x) (> (len x) 1)) (nth x 1) nil)))
+    "THIRD"  (fn (args)
+                (let ((x (nth args 0)))
+                  (if (and (list? x) (> (len x) 2)) (nth x 2) nil)))
+    "REST"   (fn (args) (rest (nth args 0)))
+    "REVERSE" (fn (args)
+                 (reduce (fn (acc x) (concat (list x) acc))
+                         (list) (nth args 0)))
+    "IDENTITY" (fn (args) (nth args 0))
+    "VALUES"   (fn (args) (cond ((= (len args) 0) nil) ((= (len args) 1) (nth args 0)) (:else {:cl-type "mv" :vals args})))
+    "PRINT"    (fn (args) (nth args 0))
+    "PRIN1"    (fn (args) (nth args 0))
+    "PRINC"    (fn (args) (nth args 0))
+    "TERPRI"   (fn (args) nil)
+    "WRITE"    (fn (args) (nth args 0))
+    "STRING-UPCASE"   (fn (args) (upcase (nth args 0)))
+    "STRING-DOWNCASE" (fn (args) (downcase (nth args 0)))
+    "STRING="         (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
+    "CONCATENATE"     (fn (args) (reduce (fn (a b) (str a b)) "" (rest args)))
+    "EQ"    (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
+    "EQL"   (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
+    "EQUAL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))))
+
+;; Register builtins in cl-global-env so (function #'name) resolves them
+(for-each
+  (fn (name)
+    (dict-set! (get cl-global-env "fns") name
+      {:cl-type "function" :builtin-fn (get cl-builtins name)}))
+  (keys cl-builtins))
+
+;; ── TAGBODY / GO ─────────────────────────────────────────────────
+
+(define cl-tagbody-tag?
+  (fn (form) (or (string? form) (number? form))))
+
+(define cl-build-tag-map
+  (fn (forms i acc)
+    (if (>= i (len forms))
+      acc
+      (if (cl-tagbody-tag? (nth forms i))
+        (cl-build-tag-map forms (+ i 1)
+          (assoc acc (str (nth forms i)) i))
+        (cl-build-tag-map forms (+ i 1) acc)))))
+
+(define cl-eval-tagbody
+  (fn (args env)
+    (let ((tag-map (cl-build-tag-map args 0 {})))
+      (define run
+        (fn (i)
+          (if (>= i (len args))
+            nil
+            (let ((form (nth args i)))
+              (if (cl-tagbody-tag? form)
+                (run (+ i 1))
+                (let ((result (cl-eval form env)))
+                  (cond
+                    ((cl-go-tag? result)
+                      (let ((target (get result "tag")))
+                        (let ((tkey (str target)))
+                          (if (has-key? tag-map tkey)
+                            (run (get tag-map tkey))
+                            {:cl-type "error" :message (str "No tag: " target)}))))
+                    ((cl-block-return? result) result)
+                    (:else (run (+ i 1))))))))))
+      (run 0))))
+
+;; ── MULTIPLE VALUES ──────────────────────────────────────────────
+
+(define cl-eval-multiple-value-bind
+  (fn (args env)
+    (let ((vars  (nth args 0))
+          (form  (nth args 1))
+          (body  (rest (rest args))))
+      (let ((vals (cl-mv-vals (cl-eval form env))))
+        (define bind-vars
+          (fn (names i e)
+            (if (= (len names) 0)
+              e
+              (bind-vars (rest names) (+ i 1)
+                (cl-env-bind-var e (nth names 0)
+                  (if (< i (len vals)) (nth vals i) nil))))))
+        (cl-eval-body body (bind-vars vars 0 env))))))
+
+(define cl-eval-multiple-value-call
+  (fn (args env)
+    (let ((fn-obj (cl-eval (nth args 0) env))
+          (forms  (rest args)))
+      (let ((all-vals (reduce
+                        (fn (acc f)
+                          (concat acc (cl-mv-vals (cl-eval f env))))
+                        (list) forms)))
+        (cl-apply fn-obj all-vals)))))
+
+(define cl-eval-multiple-value-prog1
+  (fn (args env)
+    (let ((first-result (cl-eval (nth args 0) env)))
+      (for-each (fn (f) (cl-eval f env)) (rest args))
+      first-result)))
+
+;; ── UNWIND-PROTECT ───────────────────────────────────────────────
+
+(define cl-eval-unwind-protect
+  (fn (args env)
+    (let ((protected (nth args 0))
+          (cleanup   (rest args)))
+      (let ((result (cl-eval protected env)))
+        (for-each (fn (f) (cl-eval f env)) cleanup)
+        result))))
+
+;; ── BLOCK / RETURN-FROM ───────────────────────────────────────────
+
+(define cl-eval-block
+  (fn (args env)
+    (let ((name (nth args 0))
+          (body (rest args)))
+      (let ((result (cl-eval-body body env)))
+        (if (and (cl-block-return? result)
+                 (= (get result "name") name))
+          (get result "value")
+          result)))))
+
+(define cl-eval-return-from
+  (fn (args env)
+    (let ((name (nth args 0))
+          (val  (if (> (len args) 1) (cl-eval (nth args 1) env) nil)))
+      {:cl-type "block-return" :name name :value val})))
+
+;; ── special form evaluators ───────────────────────────────────────
+
+(define cl-eval-if
+  (fn (args env)
+    (let ((cond-val  (cl-mv-primary (cl-eval (nth args 0) env)))
+          (then-form (nth args 1))
+          (else-form (if (> (len args) 2) (nth args 2) nil)))
+      (if cond-val
+        (cl-eval then-form env)
+        (if else-form (cl-eval else-form env) nil)))))
+
+(define cl-eval-and
+  (fn (args env)
+    (if (= (len args) 0)
+      true
+      (let ((val (cl-mv-primary (cl-eval (nth args 0) env))))
+        (if (not val)
+          nil
+          (if (= (len args) 1)
+            val
+            (cl-eval-and (rest args) env)))))))
+
+(define cl-eval-or
+  (fn (args env)
+    (if (= (len args) 0)
+      nil
+      (let ((val (cl-mv-primary (cl-eval (nth args 0) env))))
+        (if val
+          val
+          (cl-eval-or (rest args) env))))))
+
+(define cl-eval-cond
+  (fn (clauses env)
+    (if (= (len clauses) 0)
+      nil
+      (let ((clause (nth clauses 0)))
+        (let ((test-val (cl-mv-primary (cl-eval (nth clause 0) env))))
+          (if test-val
+            (if (= (len clause) 1)
+              test-val
+              (cl-eval-body (rest clause) env))
+            (cl-eval-cond (rest clauses) env)))))))
+
+;; Parallel LET and sequential LET*
+(define cl-eval-let
+  (fn (args env sequential)
+    (let ((bindings (nth args 0))
+          (body     (rest args)))
+      (if sequential
+        ;; LET*: each binding sees previous ones
+        (let ((new-env env))
+          (define bind-seq
+            (fn (bs e)
+              (if (= (len bs) 0)
+                e
+                (let ((b (nth bs 0)))
+                  (let ((name (if (list? b) (nth b 0) b))
+                        (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
+                    (bind-seq (rest bs)
+                      (cl-env-bind-var e name (cl-eval init e))))))))
+          (cl-eval-body body (bind-seq bindings env)))
+        ;; LET: evaluate all inits in current env, then bind
+        (let ((pairs (map
+                       (fn (b)
+                         (let ((name (if (list? b) (nth b 0) b))
+                               (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
+                           {:name name :value (cl-eval init env)}))
+                       bindings)))
+          (let ((new-env (reduce
+                           (fn (e pair)
+                             (cl-env-bind-var e (get pair "name") (get pair "value")))
+                           env pairs)))
+            (cl-eval-body body new-env)))))))
+
+;; SETQ / SETF (simplified: mutate nearest scope or global)
+(define cl-eval-setq
+  (fn (args env)
+    (if (< (len args) 2)
+      nil
+      (let ((name (nth args 0))
+            (val  (cl-eval (nth args 1) env)))
+        (if (has-key? (get env "vars") name)
+          (dict-set! (get env "vars") name val)
+          (dict-set! (get cl-global-env "vars") name val))
+        (if (> (len args) 2)
+          (cl-eval-setq (rest (rest args)) env)
+          val)))))
+
+;; FUNCTION: get function value or create lambda
+(define cl-eval-function
+  (fn (args env)
+    (let ((spec (nth args 0)))
+      (cond
+        ((and (list? spec) (> (len spec) 0) (= (nth spec 0) "LAMBDA"))
+          (cl-make-lambda (rest spec) env))
+        ((string? spec)
+          (cond
+            ((cl-env-has-fn? env spec) (cl-env-get-fn env spec))
+            ((cl-env-has-fn? cl-global-env spec)
+              (cl-env-get-fn cl-global-env spec))
+            (:else {:cl-type "error" :message (str "Undefined function: " spec)})))
+        (:else {:cl-type "error" :message "FUNCTION: invalid spec"})))))
+
+;; FLET: local functions (non-recursive, close over outer env)
+(define cl-eval-flet
+  (fn (args env)
+    (let ((fn-defs (nth args 0))
+          (body    (rest args)))
+      (let ((new-env (reduce
+                       (fn (e def)
+                         (let ((name    (nth def 0))
+                               (ll      (nth def 1))
+                               (fn-body (rest (rest def))))
+                           (cl-env-bind-fn e name
+                             {:cl-type "function"
+                              :params  (cl-parse-lambda-list ll)
+                              :body    fn-body
+                              :env     env})))
+                       env fn-defs)))
+        (cl-eval-body body new-env)))))
+
+;; LABELS: mutually-recursive local functions
+(define cl-eval-labels
+  (fn (args env)
+    (let ((fn-defs (nth args 0))
+          (body    (rest args)))
+      ;; Build env with placeholder nil entries for each name
+      (let ((new-env (reduce
+                       (fn (e def) (cl-env-bind-fn e (nth def 0) nil))
+                       env fn-defs)))
+        ;; Fill in real function objects that capture new-env
+        (for-each
+          (fn (def)
+            (let ((name    (nth def 0))
+                  (ll      (nth def 1))
+                  (fn-body (rest (rest def))))
+              (dict-set! (get new-env "fns") name
+                {:cl-type "function"
+                 :params  (cl-parse-lambda-list ll)
+                 :body    fn-body
+                 :env     new-env})))
+          fn-defs)
+        (cl-eval-body body new-env)))))
+
+;; EVAL-WHEN: evaluate body only if :execute is in situations
+(define cl-eval-eval-when
+  (fn (args env)
+    (let ((situations (nth args 0))
+          (body       (rest args)))
+      (define has-exec
+        (some (fn (s)
+                (or
+                  (and (dict? s)
+                       (= (get s "cl-type") "keyword")
+                       (= (get s "name") "EXECUTE"))
+                  (= s "EXECUTE")))
+              situations))
+      (if has-exec (cl-eval-body body env) nil))))
+
+;; DEFUN: define function in global fns namespace
+(define cl-eval-defun
+  (fn (args env)
+    (let ((name    (nth args 0))
+          (ll      (nth args 1))
+          (fn-body (rest (rest args))))
+      (let ((fn-obj {:cl-type "function"
+                     :params  (cl-parse-lambda-list ll)
+                     :body    fn-body
+                     :env     env}))
+        (dict-set! (get cl-global-env "fns") name fn-obj)
+        name))))
+
+;; DEFVAR / DEFPARAMETER / DEFCONSTANT
+(define cl-eval-defvar
+  (fn (args env always-assign)
+    (let ((name     (nth args 0))
+          (has-init (> (len args) 1)))
+      (let ((val (if has-init (cl-eval (nth args 1) env) nil)))
+        (when (or always-assign
+                  (not (cl-env-has-var? cl-global-env name)))
+          (dict-set! (get cl-global-env "vars") name val))
+        name))))
+
+;; Function call: evaluate name → look up fns, builtins; evaluate args
+(define cl-call-fn
+  (fn (name args env)
+    (let ((evaled (map (fn (a) (cl-mv-primary (cl-eval a env))) args)))
+      (cond
+        ;; FUNCALL: (funcall fn arg...)
+        ((= name "FUNCALL")
+          (cl-apply (nth evaled 0) (rest evaled)))
+        ;; APPLY: (apply fn arg... list)
+        ((= name "APPLY")
+          (let ((fn-obj   (nth evaled 0))
+                (all-args (rest evaled)))
+            (let ((leading  (slice all-args 0 (- (len all-args) 1)))
+                  (last-arg (nth all-args (- (len all-args) 1))))
+              (cl-apply fn-obj (concat leading (if (= last-arg nil) (list) last-arg))))))
+        ;; MAPCAR: (mapcar fn list)
+        ((= name "MAPCAR")
+          (let ((fn-obj (nth evaled 0))
+                (lst    (nth evaled 1)))
+            (if (= lst nil) (list)
+              (map (fn (x) (cl-apply fn-obj (list x))) lst))))
+        ;; Look up in local fns namespace
+        ((cl-env-has-fn? env name)
+          (cl-apply (cl-env-get-fn env name) evaled))
+        ;; Look up in global fns namespace
+        ((cl-env-has-fn? cl-global-env name)
+          (cl-apply (cl-env-get-fn cl-global-env name) evaled))
+        ;; Look up in builtins
+        ((has-key? cl-builtins name)
+          ((get cl-builtins name) evaled))
+        (:else
+          {:cl-type "error" :message (str "Undefined function: " name)})))))
+
+;; ── main evaluator ────────────────────────────────────────────────
+
+(define cl-eval
+  (fn (form env)
+    (cond
+      ;; Nil and booleans are self-evaluating
+      ((= form nil) nil)
+      ((= form true) true)
+      ;; Numbers are self-evaluating
+      ((number? form) form)
+      ;; Dicts: typed CL values
+      ((dict? form)
+        (let ((ct (get form "cl-type")))
+          (cond
+            ((= ct "string") (get form "value"))  ;; CL string → SX string
+            (:else form))))                         ;; keywords, floats, chars, etc.
+      ;; Symbol reference (variable lookup)
+      ((string? form)
+        (cond
+          ((cl-env-has-var? env form) (cl-env-get-var env form))
+          ((cl-env-has-var? cl-global-env form)
+            (cl-env-get-var cl-global-env form))
+          (:else {:cl-type "error" :message (str "Undefined variable: " form)})))
+      ;; List: special forms or function call
+      ((list? form) (cl-eval-list form env))
+      ;; Anything else self-evaluates
+      (:else form))))
+
+(define cl-eval-list
+  (fn (form env)
+    (if (= (len form) 0)
+      nil
+      (let ((head (nth form 0))
+            (args (rest form)))
+        (cond
+          ((= head "QUOTE")        (nth args 0))
+          ((= head "IF")           (cl-eval-if args env))
+          ((= head "PROGN")        (cl-eval-body args env))
+          ((= head "LET")          (cl-eval-let args env false))
+          ((= head "LET*")         (cl-eval-let args env true))
+          ((= head "AND")          (cl-eval-and args env))
+          ((= head "OR")           (cl-eval-or args env))
+          ((= head "COND")         (cl-eval-cond args env))
+          ((= head "WHEN")
+            (if (cl-eval (nth args 0) env)
+              (cl-eval-body (rest args) env) nil))
+          ((= head "UNLESS")
+            (if (not (cl-eval (nth args 0) env))
+              (cl-eval-body (rest args) env) nil))
+          ((= head "SETQ")         (cl-eval-setq args env))
+          ((= head "SETF")         (cl-eval-setq args env))
+          ((= head "FUNCTION")     (cl-eval-function args env))
+          ((= head "LAMBDA")       (cl-make-lambda args env))
+          ((= head "FLET")         (cl-eval-flet args env))
+          ((= head "LABELS")       (cl-eval-labels args env))
+          ((= head "THE")          (cl-eval (nth args 1) env))
+          ((= head "LOCALLY")      (cl-eval-body args env))
+          ((= head "EVAL-WHEN")    (cl-eval-eval-when args env))
+          ((= head "DEFUN")        (cl-eval-defun args env))
+          ((= head "TAGBODY")      (cl-eval-tagbody args env))
+          ((= head "GO")
+            {:cl-type "go-tag" :tag (nth args 0)})
+          ((= head "MULTIPLE-VALUE-BIND")  (cl-eval-multiple-value-bind args env))
+          ((= head "MULTIPLE-VALUE-CALL")  (cl-eval-multiple-value-call args env))
+          ((= head "MULTIPLE-VALUE-PROG1") (cl-eval-multiple-value-prog1 args env))
+          ((= head "NTH-VALUE")
+            (let ((n (cl-mv-primary (cl-eval (nth args 0) env)))
+                  (vals (cl-mv-vals (cl-eval (nth args 1) env))))
+              (if (< n (len vals)) (nth vals n) nil)))
+          ((= head "UNWIND-PROTECT") (cl-eval-unwind-protect args env))
+          ((= head "BLOCK")        (cl-eval-block args env))
+          ((= head "RETURN-FROM")  (cl-eval-return-from args env))
+          ((= head "RETURN")
+            (let ((val (if (> (len args) 0) (cl-eval (nth args 0) env) nil)))
+              {:cl-type "block-return" :name nil :value val}))
+          ((= head "DEFVAR")       (cl-eval-defvar args env false))
+          ((= head "DEFPARAMETER") (cl-eval-defvar args env true))
+          ((= head "DEFCONSTANT")  (cl-eval-defvar args env true))
+          ((= head "DECLAIM")      nil)
+          ((= head "PROCLAIM")     nil)
+          ;; Named function call
+          ((string? head)
+            (cl-call-fn head args env))
+          ;; Anonymous call: ((lambda ...) args)
+          (:else
+            (let ((fn-obj (cl-eval head env)))
+              (if (and (dict? fn-obj) (= (get fn-obj "cl-type") "function"))
+                (cl-apply fn-obj (map (fn (a) (cl-eval a env)) args))
+                {:cl-type "error" :message "Not callable"}))))))))
+
+;; ── public API ────────────────────────────────────────────────────
+
+(define cl-eval-str
+  (fn (src env)
+    (cl-eval (cl-read src) env)))
+
+(define cl-eval-all-str
+  (fn (src env)
+    (let ((forms (cl-read-all src)))
+      (if (= (len forms) 0)
+        nil
+        (let ((result nil) (i 0))
+          (define loop (fn ()
+            (when (< i (len forms))
+              (do
+                (set! result (cl-eval (nth forms i) env))
+                (set! i (+ i 1))
+                (loop)))))
+          (loop)
+          result)))))

lib/common-lisp/parser.sx

@@ -0,0 +1,377 @@
+;; Common Lisp reader — converts token stream to CL AST forms.
+;;
+;; Depends on: lib/common-lisp/reader.sx  (cl-tokenize)
+;;
+;; AST representation:
+;;   integer/float         → SX number (or {:cl-type "float"/:ratio ...})
+;;   string "hello"        → {:cl-type "string" :value "hello"}
+;;   symbol FOO            → SX string "FOO"  (upcase)
+;;   symbol NIL            → nil
+;;   symbol T              → true
+;;   :keyword              → {:cl-type "keyword" :name "FOO"}
+;;   #\char                → {:cl-type "char"    :value "a"}
+;;   #:uninterned          → {:cl-type "uninterned" :name "FOO"}
+;;   ratio 1/3             → {:cl-type "ratio"   :value "1/3"}
+;;   float 3.14            → {:cl-type "float"   :value "3.14"}
+;;   proper list (a b c)   → SX list (a b c)
+;;   dotted pair (a . b)   → {:cl-type "cons" :car a :cdr b}
+;;   vector #(a b)         → {:cl-type "vector" :elements (list a b)}
+;;   'x                    → ("QUOTE" x)
+;;   `x                    → ("QUASIQUOTE" x)
+;;   ,x                    → ("UNQUOTE" x)
+;;   ,@x                   → ("UNQUOTE-SPLICING" x)
+;;   #'x                   → ("FUNCTION" x)
+;;
+;; Public API:
+;;   (cl-read src)         — parse first form from string, return form
+;;   (cl-read-all src)     — parse all top-level forms, return list
+
+;; ── number conversion ─────────────────────────────────────────────
+
+(define
+  cl-hex-val
+  (fn
+    (c)
+    (let
+      ((o (cl-ord c)))
+      (cond
+        ((and (>= o 48) (<= o 57)) (- o 48))
+        ((and (>= o 65) (<= o 70)) (+ 10 (- o 65)))
+        ((and (>= o 97) (<= o 102)) (+ 10 (- o 97)))
+        (:else 0)))))
+
+(define
+  cl-parse-radix-str
+  (fn
+    (s radix start)
+    (let
+      ((n (string-length s)) (i start) (acc 0))
+      (define
+        loop
+        (fn
+          ()
+          (when
+            (< i n)
+            (do
+              (set! acc (+ (* acc radix) (cl-hex-val (substring s i (+ i 1)))))
+              (set! i (+ i 1))
+              (loop)))))
+      (loop)
+      acc)))
+
+(define
+  cl-convert-integer
+  (fn
+    (s)
+    (let
+      ((n (string-length s)) (neg false))
+      (cond
+        ((and (> n 2) (= (substring s 0 1) "#"))
+          (let
+            ((letter (downcase (substring s 1 2))))
+            (cond
+              ((= letter "x") (cl-parse-radix-str s 16 2))
+              ((= letter "b") (cl-parse-radix-str s 2 2))
+              ((= letter "o") (cl-parse-radix-str s 8 2))
+              (:else (parse-int s 0)))))
+        (:else (parse-int s 0))))))
+
+;; ── reader ────────────────────────────────────────────────────────
+
+;; Read one form from token list.
+;; Returns {:form F :rest remaining-toks} or {:form nil :rest toks :eof true}
+(define
+  cl-read-form
+  (fn
+    (toks)
+    (if
+      (not toks)
+      {:form nil :rest toks :eof true}
+      (let
+        ((tok (nth toks 0)) (nxt (rest toks)))
+        (let
+          ((type (get tok "type")) (val (get tok "value")))
+          (cond
+            ((= type "eof") {:form nil :rest toks :eof true})
+            ((= type "integer") {:form (cl-convert-integer val) :rest nxt})
+            ((= type "float") {:form {:cl-type "float" :value val} :rest nxt})
+            ((= type "ratio") {:form {:cl-type "ratio" :value val} :rest nxt})
+            ((= type "string") {:form {:cl-type "string" :value val} :rest nxt})
+            ((= type "char") {:form {:cl-type "char" :value val} :rest nxt})
+            ((= type "keyword") {:form {:cl-type "keyword" :name val} :rest nxt})
+            ((= type "uninterned") {:form {:cl-type "uninterned" :name val} :rest nxt})
+            ((= type "symbol")
+              (cond
+                ((= val "NIL") {:form nil :rest nxt})
+                ((= val "T") {:form true :rest nxt})
+                (:else {:form val :rest nxt})))
+            ;; list forms
+            ((= type "lparen") (cl-read-list nxt))
+            ((= type "hash-paren") (cl-read-vector nxt))
+            ;; reader macros that wrap the next form
+            ((= type "quote") (cl-read-wrap "QUOTE" nxt))
+            ((= type "backquote") (cl-read-wrap "QUASIQUOTE" nxt))
+            ((= type "comma") (cl-read-wrap "UNQUOTE" nxt))
+            ((= type "comma-at") (cl-read-wrap "UNQUOTE-SPLICING" nxt))
+            ((= type "hash-quote") (cl-read-wrap "FUNCTION" nxt))
+            ;; skip unrecognised tokens
+            (:else (cl-read-form nxt))))))))
+
+;; Wrap next form in a list: (name form)
+(define
+  cl-read-wrap
+  (fn
+    (name toks)
+    (let
+      ((inner (cl-read-form toks)))
+      {:form (list name (get inner "form")) :rest (get inner "rest")})))
+
+;; Read list forms until ')'; handles dotted pair (a . b)
+;; Called after consuming '('
+(define
+  cl-read-list
+  (fn
+    (toks)
+    (let
+      ((result (cl-read-list-items toks (list))))
+      {:form (get result "items") :rest (get result "rest")})))
+
+(define
+  cl-read-list-items
+  (fn
+    (toks acc)
+    (if
+      (not toks)
+      {:items acc :rest toks}
+      (let
+        ((tok (nth toks 0)))
+        (let
+          ((type (get tok "type")))
+          (cond
+            ((= type "eof") {:items acc :rest toks})
+            ((= type "rparen") {:items acc :rest (rest toks)})
+            ;; dotted pair: read one more form then expect ')'
+            ((= type "dot")
+              (let
+                ((cdr-result (cl-read-form (rest toks))))
+                (let
+                  ((cdr-form (get cdr-result "form"))
+                    (after-cdr (get cdr-result "rest")))
+                  ;; skip the closing ')'
+                  (let
+                    ((close (if after-cdr (nth after-cdr 0) nil)))
+                    (let
+                      ((remaining
+                          (if
+                            (and close (= (get close "type") "rparen"))
+                            (rest after-cdr)
+                            after-cdr)))
+                      ;; build dotted structure
+                      (let
+                        ((dotted (cl-build-dotted acc cdr-form)))
+                        {:items dotted :rest remaining}))))))
+            (:else
+              (let
+                ((item (cl-read-form toks)))
+                (cl-read-list-items
+                  (get item "rest")
+                  (concat acc (list (get item "form"))))))))))))
+
+;; Build dotted form: (a b . c) → ((DOTTED a b) . c) style
+;; In CL (a b c . d) means a proper dotted structure.
+;; We represent it as {:cl-type "cons" :car a :cdr (list->dotted b c d)}
+(define
+  cl-build-dotted
+  (fn
+    (head-items tail)
+    (if
+      (= (len head-items) 0)
+      tail
+      (if
+        (= (len head-items) 1)
+        {:cl-type "cons" :car (nth head-items 0) :cdr tail}
+        (let
+          ((last-item (nth head-items (- (len head-items) 1)))
+            (but-last (slice head-items 0 (- (len head-items) 1))))
+          {:cl-type "cons"
+            :car (cl-build-dotted but-last (list last-item))
+            :cdr tail})))))
+
+;; Read vector #(…) elements until ')'
+(define
+  cl-read-vector
+  (fn
+    (toks)
+    (let
+      ((result (cl-read-vector-items toks (list))))
+      {:form {:cl-type "vector" :elements (get result "items")} :rest (get result "rest")})))
+
+(define
+  cl-read-vector-items
+  (fn
+    (toks acc)
+    (if
+      (not toks)
+      {:items acc :rest toks}
+      (let
+        ((tok (nth toks 0)))
+        (let
+          ((type (get tok "type")))
+          (cond
+            ((= type "eof") {:items acc :rest toks})
+            ((= type "rparen") {:items acc :rest (rest toks)})
+            (:else
+              (let
+                ((item (cl-read-form toks)))
+                (cl-read-vector-items
+                  (get item "rest")
+                  (concat acc (list (get item "form"))))))))))))
+
+;; ── lambda-list parser ───────────────────────────────────────────
+;;
+;; (cl-parse-lambda-list forms) — parse a list of CL forms (already read)
+;; into a structured dict:
+;;   {:required (list sym ...)
+;;    :optional (list {:name N :default D :supplied S} ...)
+;;    :rest     nil | "SYM"
+;;    :key      (list {:name N :keyword K :default D :supplied S} ...)
+;;    :allow-other-keys false | true
+;;    :aux      (list {:name N :init I} ...)}
+;;
+;; Symbols arrive as SX strings (upcase). &-markers are strings like "&OPTIONAL".
+;; Key params: keyword is the upcase name string; caller uses it as :keyword.
+;; Supplied-p: nil when absent.
+
+(define
+  cl-parse-opt-spec
+  (fn
+    (spec)
+    (if
+      (list? spec)
+      {:name (nth spec 0)
+        :default (if (> (len spec) 1) (nth spec 1) nil)
+        :supplied (if (> (len spec) 2) (nth spec 2) nil)}
+      {:name spec :default nil :supplied nil})))
+
+(define
+  cl-parse-key-spec
+  (fn
+    (spec)
+    (if
+      (list? spec)
+      (let
+        ((first (nth spec 0)))
+        (if
+          (list? first)
+          ;; ((:keyword var) default supplied-p)
+          {:name (nth first 1)
+            :keyword (get first "name")
+            :default (if (> (len spec) 1) (nth spec 1) nil)
+            :supplied (if (> (len spec) 2) (nth spec 2) nil)}
+          ;; (var default supplied-p)
+          {:name first
+            :keyword first
+            :default (if (> (len spec) 1) (nth spec 1) nil)
+            :supplied (if (> (len spec) 2) (nth spec 2) nil)}))
+      {:name spec :keyword spec :default nil :supplied nil})))
+
+(define
+  cl-parse-aux-spec
+  (fn
+    (spec)
+    (if
+      (list? spec)
+      {:name (nth spec 0) :init (if (> (len spec) 1) (nth spec 1) nil)}
+      {:name spec :init nil})))
+
+(define
+  cl-parse-lambda-list
+  (fn
+    (forms)
+    (let
+      ((state "required")
+        (required (list))
+        (optional (list))
+        (rest-name nil)
+        (key (list))
+        (allow-other-keys false)
+        (aux (list)))
+
+      (define
+        scan
+        (fn
+          (items)
+          (when
+            (> (len items) 0)
+            (let
+              ((item (nth items 0)) (tail (rest items)))
+              (cond
+                ((= item "&OPTIONAL")
+                  (do (set! state "optional") (scan tail)))
+                ((= item "&REST")
+                  (do (set! state "rest") (scan tail)))
+                ((= item "&BODY")
+                  (do (set! state "rest") (scan tail)))
+                ((= item "&KEY")
+                  (do (set! state "key") (scan tail)))
+                ((= item "&AUX")
+                  (do (set! state "aux") (scan tail)))
+                ((= item "&ALLOW-OTHER-KEYS")
+                  (do (set! allow-other-keys true) (scan tail)))
+                ((= state "required")
+                  (do (append! required item) (scan tail)))
+                ((= state "optional")
+                  (do (append! optional (cl-parse-opt-spec item)) (scan tail)))
+                ((= state "rest")
+                  (do (set! rest-name item) (set! state "done") (scan tail)))
+                ((= state "key")
+                  (do (append! key (cl-parse-key-spec item)) (scan tail)))
+                ((= state "aux")
+                  (do (append! aux (cl-parse-aux-spec item)) (scan tail)))
+                (:else (scan tail)))))))
+
+      (scan forms)
+      {:required required
+        :optional optional
+        :rest rest-name
+        :key key
+        :allow-other-keys allow-other-keys
+        :aux aux})))
+
+;; Convenience: parse lambda list from a CL source string
+(define
+  cl-parse-lambda-list-str
+  (fn
+    (src)
+    (cl-parse-lambda-list (cl-read src))))
+
+;; ── public API ────────────────────────────────────────────────────
+
+(define
+  cl-read
+  (fn
+    (src)
+    (let
+      ((toks (cl-tokenize src)))
+      (get (cl-read-form toks) "form"))))
+
+(define
+  cl-read-all
+  (fn
+    (src)
+    (let
+      ((toks (cl-tokenize src)))
+      (define
+        loop
+        (fn
+          (toks acc)
+          (if
+            (or (not toks) (= (get (nth toks 0) "type") "eof"))
+            acc
+            (let
+              ((result (cl-read-form toks)))
+              (if
+                (get result "eof")
+                acc
+                (loop (get result "rest") (concat acc (list (get result "form")))))))))
+      (loop toks (list)))))

lib/common-lisp/reader.sx

@@ -0,0 +1,381 @@
+;; Common Lisp tokenizer
+;;
+;; Tokens: {:type T :value V :pos P}
+;;
+;; Types:
+;;   "symbol"      — FOO, PKG:SYM, PKG::SYM, T, NIL (upcase)
+;;   "keyword"     — :foo (value is upcase name without colon)
+;;   "integer"     — 42, -5, #xFF, #b1010, #o17 (string)
+;;   "float"       — 3.14, 1.0e10 (string)
+;;   "ratio"       — 1/3 (string "N/D")
+;;   "string"      — unescaped content
+;;   "char"        — single-character string
+;;   "lparen"  "rparen"  "quote"  "backquote"  "comma"  "comma-at"
+;;   "hash-quote"  — #'
+;;   "hash-paren"  — #(
+;;   "uninterned"  — #:foo (upcase name)
+;;   "dot"         — standalone . (dotted pair separator)
+;;   "eof"
+
+(define cl-make-tok (fn (type value pos) {:type type :value value :pos pos}))
+
+;; ── char ordinal table ────────────────────────────────────────────
+
+(define
+  cl-ord-table
+  (let
+    ((t (dict)) (i 0))
+    (define
+      cl-fill
+      (fn
+        ()
+        (when
+          (< i 128)
+          (do
+            (dict-set! t (char-from-code i) i)
+            (set! i (+ i 1))
+            (cl-fill)))))
+    (cl-fill)
+    t))
+
+(define cl-ord (fn (c) (or (get cl-ord-table c) 0)))
+
+;; ── character predicates ──────────────────────────────────────────
+
+(define cl-digit? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 57))))
+
+(define
+  cl-hex?
+  (fn
+    (c)
+    (or
+      (cl-digit? c)
+      (and (>= (cl-ord c) 65) (<= (cl-ord c) 70))
+      (and (>= (cl-ord c) 97) (<= (cl-ord c) 102)))))
+
+(define cl-octal? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 55))))
+
+(define cl-binary? (fn (c) (or (= c "0") (= c "1"))))
+
+(define cl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
+
+(define
+  cl-alpha?
+  (fn
+    (c)
+    (or
+      (and (>= (cl-ord c) 65) (<= (cl-ord c) 90))
+      (and (>= (cl-ord c) 97) (<= (cl-ord c) 122)))))
+
+;; Characters that end a token (whitespace + terminating macro chars)
+(define
+  cl-terminating?
+  (fn
+    (c)
+    (or
+      (cl-ws? c)
+      (= c "(")
+      (= c ")")
+      (= c "\"")
+      (= c ";")
+      (= c "`")
+      (= c ","))))
+
+;; Symbol constituent: not terminating, not reader-special
+(define
+  cl-sym-char?
+  (fn
+    (c)
+    (not
+      (or
+        (cl-terminating? c)
+        (= c "#")
+        (= c "|")
+        (= c "\\")
+        (= c "'")))))
+
+;; ── named character table ─────────────────────────────────────────
+
+(define
+  cl-named-chars
+  {:space " "
+    :newline "\n"
+    :tab "\t"
+    :return "\r"
+    :backspace (char-from-code 8)
+    :rubout (char-from-code 127)
+    :delete (char-from-code 127)
+    :escape (char-from-code 27)
+    :altmode (char-from-code 27)
+    :null (char-from-code 0)
+    :nul (char-from-code 0)
+    :page (char-from-code 12)
+    :formfeed (char-from-code 12)})
+
+;; ── main tokenizer ────────────────────────────────────────────────
+
+(define
+  cl-tokenize
+  (fn
+    (src)
+    (let
+      ((pos 0) (n (string-length src)) (toks (list)))
+
+      (define at (fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
+      (define peek1 (fn () (if (< (+ pos 1) n) (substring src (+ pos 1) (+ pos 2)) nil)))
+      (define adv (fn () (set! pos (+ pos 1))))
+
+      ;; Advance while predicate holds; return substring from start to end
+      (define
+        read-while
+        (fn
+          (pred)
+          (let
+            ((start pos))
+            (define
+              rw-loop
+              (fn
+                ()
+                (when
+                  (and (at) (pred (at)))
+                  (do (adv) (rw-loop)))))
+            (rw-loop)
+            (substring src start pos))))
+
+      (define
+        skip-line
+        (fn
+          ()
+          (when
+            (and (at) (not (= (at) "\n")))
+            (do (adv) (skip-line)))))
+
+      (define
+        skip-block
+        (fn
+          (depth)
+          (when
+            (at)
+            (cond
+              ((and (= (at) "#") (= (peek1) "|"))
+                (do (adv) (adv) (skip-block (+ depth 1))))
+              ((and (= (at) "|") (= (peek1) "#"))
+                (do
+                  (adv)
+                  (adv)
+                  (when (> depth 1) (skip-block (- depth 1)))))
+              (:else (do (adv) (skip-block depth)))))))
+
+      ;; Read string literal — called with pos just past opening "
+      (define
+        read-str
+        (fn
+          (acc)
+          (if
+            (not (at))
+            acc
+            (cond
+              ((= (at) "\"") (do (adv) acc))
+              ((= (at) "\\")
+                (do
+                  (adv)
+                  (let
+                    ((e (at)))
+                    (adv)
+                    (read-str
+                      (str
+                        acc
+                        (cond
+                          ((= e "n") "\n")
+                          ((= e "t") "\t")
+                          ((= e "r") "\r")
+                          ((= e "\"") "\"")
+                          ((= e "\\") "\\")
+                          (:else e)))))))
+              (:else
+                (let
+                  ((c (at)))
+                  (adv)
+                  (read-str (str acc c))))))))
+
+      ;; Read #\ char literal — called with pos just past the backslash
+      (define
+        read-char-lit
+        (fn
+          ()
+          (let
+            ((first (at)))
+            (adv)
+            (let
+              ((rest (if (and (at) (cl-alpha? (at))) (read-while cl-alpha?) "")))
+              (if
+                (= rest "")
+                first
+                (let
+                  ((name (downcase (str first rest))))
+                  (or (get cl-named-chars name) first)))))))
+
+      ;; Number scanner — called with pos just past first digit(s).
+      ;; acc holds what was already consumed (first digit or sign+digit).
+      (define
+        scan-num
+        (fn
+          (p acc)
+          (let
+            ((more (read-while cl-digit?)))
+            (set! acc (str acc more))
+            (cond
+              ;; ratio N/D
+              ((and (at) (= (at) "/") (peek1) (cl-digit? (peek1)))
+                (do
+                  (adv)
+                  (let
+                    ((denom (read-while cl-digit?)))
+                    {:type "ratio" :value (str acc "/" denom) :pos p})))
+              ;; float: decimal point N.M[eE]
+              ((and (at) (= (at) ".") (peek1) (cl-digit? (peek1)))
+                (do
+                  (adv)
+                  (let
+                    ((frac (read-while cl-digit?)))
+                    (set! acc (str acc "." frac))
+                    (when
+                      (and (at) (or (= (at) "e") (= (at) "E")))
+                      (do
+                        (set! acc (str acc (at)))
+                        (adv)
+                        (when
+                          (and (at) (or (= (at) "+") (= (at) "-")))
+                          (do (set! acc (str acc (at))) (adv)))
+                        (set! acc (str acc (read-while cl-digit?)))))
+                    {:type "float" :value acc :pos p})))
+              ;; float: exponent only NeE
+              ((and (at) (or (= (at) "e") (= (at) "E")))
+                (do
+                  (set! acc (str acc (at)))
+                  (adv)
+                  (when
+                    (and (at) (or (= (at) "+") (= (at) "-")))
+                    (do (set! acc (str acc (at))) (adv)))
+                  (set! acc (str acc (read-while cl-digit?)))
+                  {:type "float" :value acc :pos p}))
+              (:else {:type "integer" :value acc :pos p})))))
+
+      (define
+        read-radix
+        (fn
+          (letter p)
+          (let
+            ((pred
+                (cond
+                  ((or (= letter "x") (= letter "X")) cl-hex?)
+                  ((or (= letter "b") (= letter "B")) cl-binary?)
+                  ((or (= letter "o") (= letter "O")) cl-octal?)
+                  (:else cl-digit?))))
+            {:type "integer"
+              :value (str "#" letter (read-while pred))
+              :pos p})))
+
+      (define emit (fn (tok) (append! toks tok)))
+
+      (define
+        scan
+        (fn
+          ()
+          (when
+            (< pos n)
+            (let
+              ((c (at)) (p pos))
+              (cond
+                ((cl-ws? c) (do (adv) (scan)))
+                ((= c ";") (do (adv) (skip-line) (scan)))
+                ((= c "(") (do (adv) (emit (cl-make-tok "lparen" "(" p)) (scan)))
+                ((= c ")") (do (adv) (emit (cl-make-tok "rparen" ")" p)) (scan)))
+                ((= c "'") (do (adv) (emit (cl-make-tok "quote" "'" p)) (scan)))
+                ((= c "`") (do (adv) (emit (cl-make-tok "backquote" "`" p)) (scan)))
+                ((= c ",")
+                  (do
+                    (adv)
+                    (if
+                      (= (at) "@")
+                      (do (adv) (emit (cl-make-tok "comma-at" ",@" p)))
+                      (emit (cl-make-tok "comma" "," p)))
+                    (scan)))
+                ((= c "\"")
+                  (do
+                    (adv)
+                    (emit (cl-make-tok "string" (read-str "") p))
+                    (scan)))
+                ;; :keyword
+                ((= c ":")
+                  (do
+                    (adv)
+                    (emit (cl-make-tok "keyword" (upcase (read-while cl-sym-char?)) p))
+                    (scan)))
+                ;; dispatch macro #
+                ((= c "#")
+                  (do
+                    (adv)
+                    (let
+                      ((d (at)))
+                      (cond
+                        ((= d "'") (do (adv) (emit (cl-make-tok "hash-quote" "#'" p)) (scan)))
+                        ((= d "(") (do (adv) (emit (cl-make-tok "hash-paren" "#(" p)) (scan)))
+                        ((= d ":")
+                          (do
+                            (adv)
+                            (emit
+                              (cl-make-tok "uninterned" (upcase (read-while cl-sym-char?)) p))
+                            (scan)))
+                        ((= d "|") (do (adv) (skip-block 1) (scan)))
+                        ((= d "\\")
+                          (do (adv) (emit (cl-make-tok "char" (read-char-lit) p)) (scan)))
+                        ((or (= d "x") (= d "X"))
+                          (do (adv) (emit (read-radix d p)) (scan)))
+                        ((or (= d "b") (= d "B"))
+                          (do (adv) (emit (read-radix d p)) (scan)))
+                        ((or (= d "o") (= d "O"))
+                          (do (adv) (emit (read-radix d p)) (scan)))
+                        (:else (scan))))))
+                ;; standalone dot, float .5, or symbol starting with dots
+                ((= c ".")
+                  (do
+                    (adv)
+                    (cond
+                      ((or (not (at)) (cl-terminating? (at)))
+                        (do (emit (cl-make-tok "dot" "." p)) (scan)))
+                      ((cl-digit? (at))
+                        (do
+                          (emit
+                            (cl-make-tok "float" (str "0." (read-while cl-digit?)) p))
+                          (scan)))
+                      (:else
+                        (do
+                          (emit
+                            (cl-make-tok "symbol" (upcase (str "." (read-while cl-sym-char?))) p))
+                          (scan))))))
+                ;; sign followed by digit → number
+                ((and (or (= c "+") (= c "-")) (peek1) (cl-digit? (peek1)))
+                  (do
+                    (adv)
+                    (let
+                      ((first-d (at)))
+                      (adv)
+                      (emit (scan-num p (str c first-d))))
+                    (scan)))
+                ;; decimal digit → number
+                ((cl-digit? c)
+                  (do
+                    (adv)
+                    (emit (scan-num p c))
+                    (scan)))
+                ;; symbol constituent (includes bare +, -, etc.)
+                ((cl-sym-char? c)
+                  (do
+                    (emit (cl-make-tok "symbol" (upcase (read-while cl-sym-char?)) p))
+                    (scan)))
+                (:else (do (adv) (scan))))))))
+
+      (scan)
+      (append! toks (cl-make-tok "eof" nil n))
+      toks)))

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
+;; Section 1-9:  Type predicates, arithmetic, characters, strings, gensym,
-;; an SX spec primitive already does the job, we alias it rather than
+;;               multiple values, sets, radix formatting, list utilities.
-;; reinventing it.
+;; 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)
+;;   format   gensym   rational/rational?   make-set/set-member?/etc
-;;   gensym   (Phase 12)
+;;   modulo/remainder/quotient/gcd/lcm/expt   number->string
-;;   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)
 
 ;; ---------------------------------------------------------------------------
 ;; 1.  Type predicates
@@ -304,3 +300,425 @@
     ((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)))))
+
+;; ── *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.
+;; 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)))))
+      ;; *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 ───────────────────────────────────────────────────────────────
+;;
+;; 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)
+      (cl-invoke-debugger 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.
+
+
+
+;; ── 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))))))

lib/common-lisp/test.sh

@@ -292,6 +292,80 @@ check 113 "cl-format-decimal 42"   '"42"'
 check 114 "n->s base 16"           '"1f"'
 check 115 "s->n base 16"           "31"
 
+# ── Phase 2: condition system unit tests ─────────────────────────────────────
+# Load runtime.sx then conditions.sx; query the passed/failed/failures globals.
+UNIT_FILE=$(mktemp); trap "rm -f $UNIT_FILE" EXIT
+cat > "$UNIT_FILE" << 'UNIT'
+(epoch 1)
+(load "spec/stdlib.sx")
+(epoch 2)
+(load "lib/common-lisp/runtime.sx")
+(epoch 3)
+(load "lib/common-lisp/tests/conditions.sx")
+(epoch 4)
+(eval "passed")
+(epoch 5)
+(eval "failed")
+(epoch 6)
+(eval "failures")
+UNIT
+
+UNIT_OUT=$(timeout 30 "$SX_SERVER" < "$UNIT_FILE" 2>/dev/null)
+
+# extract passed/failed counts from ok-len lines
+UNIT_PASSED=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true)
+UNIT_FAILED=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
+UNIT_ERRS=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
+# fallback: try plain ok lines
+[ -z "$UNIT_PASSED" ] && UNIT_PASSED=$(echo "$UNIT_OUT" | grep "^(ok 4 " | awk '{print $3}' | tr -d ')' || true)
+[ -z "$UNIT_FAILED" ] && UNIT_FAILED=$(echo "$UNIT_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true)
+[ -z "$UNIT_PASSED" ] && UNIT_PASSED=0
+[ -z "$UNIT_FAILED" ] && UNIT_FAILED=0
+
+if [ "$UNIT_FAILED" = "0" ] && [ "$UNIT_PASSED" -gt 0 ] 2>/dev/null; then
+  PASS=$((PASS + UNIT_PASSED))
+  [ "$VERBOSE" = "-v" ] && echo "  ok condition tests ($UNIT_PASSED)"
+else
+  FAIL=$((FAIL + 1))
+  ERRORS+="  FAIL [condition tests] (${UNIT_PASSED} passed, ${UNIT_FAILED} failed) ${UNIT_ERRS}
+"
+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"

lib/common-lisp/tests/conditions.sx

@@ -0,0 +1,478 @@
+;; 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"))))

lib/common-lisp/tests/eval.sx

@@ -0,0 +1,438 @@
+;; CL evaluator tests
+
+(define cl-test-pass 0)
+(define cl-test-fail 0)
+(define cl-test-fails (list))
+
+(define
+  cl-deep=
+  (fn
+    (a b)
+    (cond
+      ((= a b) true)
+      ((and (dict? a) (dict? b))
+        (let
+          ((ak (keys a)) (bk (keys b)))
+          (if
+            (not (= (len ak) (len bk)))
+            false
+            (every?
+              (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
+              ak))))
+      ((and (list? a) (list? b))
+        (if
+          (not (= (len a) (len b)))
+          false
+          (let
+            ((i 0) (ok true))
+            (define
+              chk
+              (fn
+                ()
+                (when
+                  (and ok (< i (len a)))
+                  (do
+                    (when
+                      (not (cl-deep= (nth a i) (nth b i)))
+                      (set! ok false))
+                    (set! i (+ i 1))
+                    (chk)))))
+            (chk)
+            ok)))
+      (:else false))))
+
+(define
+  cl-test
+  (fn
+    (name actual expected)
+    (if
+      (cl-deep= actual expected)
+      (set! cl-test-pass (+ cl-test-pass 1))
+      (do
+        (set! cl-test-fail (+ cl-test-fail 1))
+        (append! cl-test-fails {:name name :expected expected :actual actual})))))
+
+;; Convenience: evaluate CL string with fresh env each time
+(define ev (fn (src) (cl-eval-str src (cl-make-env))))
+(define evall (fn (src) (cl-eval-all-str src (cl-make-env))))
+
+;; ── self-evaluating literals ──────────────────────────────────────
+
+(cl-test "lit: nil" (ev "nil") nil)
+(cl-test "lit: t" (ev "t") true)
+(cl-test "lit: integer" (ev "42") 42)
+(cl-test "lit: negative" (ev "-7") -7)
+(cl-test "lit: zero" (ev "0") 0)
+(cl-test "lit: string" (ev "\"hello\"") "hello")
+(cl-test "lit: empty string" (ev "\"\"") "")
+(cl-test "lit: keyword type" (get (ev ":foo") "cl-type") "keyword")
+(cl-test "lit: keyword name" (get (ev ":foo") "name") "FOO")
+(cl-test "lit: float type" (get (ev "3.14") "cl-type") "float")
+
+;; ── QUOTE ─────────────────────────────────────────────────────────
+
+(cl-test "quote: symbol" (ev "'x") "X")
+(cl-test "quote: list" (ev "'(a b c)") (list "A" "B" "C"))
+(cl-test "quote: nil" (ev "'nil") nil)
+(cl-test "quote: integer" (ev "'42") 42)
+(cl-test "quote: nested" (ev "'(a (b c))") (list "A" (list "B" "C")))
+
+;; ── IF ────────────────────────────────────────────────────────────
+
+(cl-test "if: true branch" (ev "(if t 1 2)") 1)
+(cl-test "if: false branch" (ev "(if nil 1 2)") 2)
+(cl-test "if: no else nil" (ev "(if nil 99)") nil)
+(cl-test "if: number truthy" (ev "(if 0 'yes 'no)") "YES")
+(cl-test "if: empty string truthy" (ev "(if \"\" 'yes 'no)") "YES")
+(cl-test "if: nested" (ev "(if t (if nil 1 2) 3)") 2)
+
+;; ── PROGN ────────────────────────────────────────────────────────
+
+(cl-test "progn: single" (ev "(progn 42)") 42)
+(cl-test "progn: multiple" (ev "(progn 1 2 3)") 3)
+(cl-test "progn: nil last" (ev "(progn 1 nil)") nil)
+
+;; ── AND / OR ─────────────────────────────────────────────────────
+
+(cl-test "and: empty" (ev "(and)") true)
+(cl-test "and: all true" (ev "(and 1 2 3)") 3)
+(cl-test "and: short-circuit" (ev "(and nil 99)") nil)
+(cl-test "and: returns last" (ev "(and 1 2)") 2)
+(cl-test "or: empty" (ev "(or)") nil)
+(cl-test "or: first truthy" (ev "(or 1 2)") 1)
+(cl-test "or: all nil" (ev "(or nil nil)") nil)
+(cl-test "or: short-circuit" (ev "(or nil 42)") 42)
+
+;; ── COND ─────────────────────────────────────────────────────────
+
+(cl-test "cond: first match" (ev "(cond (t 1) (t 2))") 1)
+(cl-test "cond: second match" (ev "(cond (nil 1) (t 2))") 2)
+(cl-test "cond: no match" (ev "(cond (nil 1) (nil 2))") nil)
+(cl-test "cond: returns test value" (ev "(cond (42))") 42)
+
+;; ── WHEN / UNLESS ─────────────────────────────────────────────────
+
+(cl-test "when: true" (ev "(when t 1 2 3)") 3)
+(cl-test "when: nil" (ev "(when nil 99)") nil)
+(cl-test "unless: nil runs" (ev "(unless nil 42)") 42)
+(cl-test "unless: true skips" (ev "(unless t 99)") nil)
+
+;; ── LET ──────────────────────────────────────────────────────────
+
+(cl-test "let: empty bindings" (ev "(let () 42)") 42)
+(cl-test "let: single binding" (ev "(let ((x 5)) x)") 5)
+(cl-test "let: two bindings" (ev "(let ((x 3) (y 4)) (+ x y))") 7)
+(cl-test "let: parallel" (ev "(let ((x 1)) (let ((x 2) (y x)) y))") 1)
+(cl-test "let: nested" (ev "(let ((x 1)) (let ((y 2)) (+ x y)))") 3)
+(cl-test "let: progn body" (ev "(let ((x 5)) (+ x 1) (* x 2))") 10)
+(cl-test "let: bare name nil" (ev "(let (x) x)") nil)
+
+;; ── LET* ─────────────────────────────────────────────────────────
+
+(cl-test "let*: sequential" (ev "(let* ((x 1) (y (+ x 1))) y)") 2)
+(cl-test "let*: chain" (ev "(let* ((a 2) (b (* a 3)) (c (+ b 1))) c)") 7)
+(cl-test "let*: shadow" (ev "(let ((x 1)) (let* ((x 2) (y x)) y))") 2)
+
+;; ── SETQ / SETF ──────────────────────────────────────────────────
+
+(cl-test "setq: basic" (ev "(let ((x 0)) (setq x 5) x)") 5)
+(cl-test "setq: returns value" (ev "(let ((x 0)) (setq x 99))") 99)
+(cl-test "setf: basic" (ev "(let ((x 0)) (setf x 7) x)") 7)
+
+;; ── LAMBDA ────────────────────────────────────────────────────────
+
+(cl-test "lambda: call" (ev "((lambda (x) x) 42)") 42)
+(cl-test "lambda: multi-arg" (ev "((lambda (x y) (+ x y)) 3 4)") 7)
+(cl-test "lambda: closure" (ev "(let ((n 10)) ((lambda (x) (+ x n)) 5))") 15)
+(cl-test "lambda: rest arg"
+  (ev "((lambda (x &rest xs) (cons x xs)) 1 2 3)")
+  {:cl-type "cons" :car 1 :cdr (list 2 3)})
+(cl-test "lambda: optional no default"
+  (ev "((lambda (&optional x) x))")
+  nil)
+(cl-test "lambda: optional with arg"
+  (ev "((lambda (&optional (x 99)) x) 42)")
+  42)
+(cl-test "lambda: optional default used"
+  (ev "((lambda (&optional (x 7)) x))")
+  7)
+
+;; ── FUNCTION ─────────────────────────────────────────────────────
+
+(cl-test "function: lambda" (get (ev "(function (lambda (x) x))") "cl-type") "function")
+
+;; ── DEFUN ────────────────────────────────────────────────────────
+
+(cl-test "defun: returns name" (evall "(defun sq (x) (* x x))") "SQ")
+(cl-test "defun: call" (evall "(defun sq (x) (* x x)) (sq 5)") 25)
+(cl-test "defun: multi-arg" (evall "(defun add (x y) (+ x y)) (add 3 4)") 7)
+(cl-test "defun: recursive factorial"
+  (evall "(defun fact (n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)")
+  120)
+(cl-test "defun: multiple calls"
+  (evall "(defun double (x) (* x 2)) (+ (double 3) (double 5))")
+  16)
+
+;; ── FLET ─────────────────────────────────────────────────────────
+
+(cl-test "flet: basic"
+  (ev "(flet ((double (x) (* x 2))) (double 5))")
+  10)
+(cl-test "flet: sees outer vars"
+  (ev "(let ((n 3)) (flet ((add-n (x) (+ x n))) (add-n 7)))")
+  10)
+(cl-test "flet: non-recursive"
+  (ev "(flet ((f (x) (+ x 1))) (flet ((f (x) (f (f x)))) (f 5)))")
+  7)
+
+;; ── LABELS ────────────────────────────────────────────────────────
+
+(cl-test "labels: basic"
+  (ev "(labels ((greet (x) x)) (greet 42))")
+  42)
+(cl-test "labels: recursive"
+  (ev "(labels ((count (n) (if (<= n 0) 0 (+ 1 (count (- n 1)))))) (count 5))")
+  5)
+(cl-test "labels: mutual recursion"
+  (ev "(labels
+         ((even? (n) (if (= n 0) t  (odd? (- n 1))))
+          (odd?  (n) (if (= n 0) nil   (even? (- n 1)))))
+         (list (even? 4) (odd? 3)))")
+  (list true true))
+
+;; ── THE / LOCALLY / EVAL-WHEN ────────────────────────────────────
+
+(cl-test "the: passthrough" (ev "(the integer 42)") 42)
+(cl-test "the: string" (ev "(the string \"hi\")") "hi")
+(cl-test "locally: body" (ev "(locally 1 2 3)") 3)
+(cl-test "eval-when: execute" (ev "(eval-when (:execute) 99)") 99)
+(cl-test "eval-when: no execute" (ev "(eval-when (:compile-toplevel) 99)") nil)
+
+;; ── DEFVAR / DEFPARAMETER ────────────────────────────────────────
+
+(cl-test "defvar: returns name" (evall "(defvar *x* 10)") "*X*")
+(cl-test "defparameter: sets value" (evall "(defparameter *y* 42) *y*") 42)
+(cl-test "defvar: no reinit" (evall "(defvar *z* 1) (defvar *z* 99) *z*") 1)
+
+;; ── built-in arithmetic ───────────────────────────────────────────
+
+(cl-test "arith: +" (ev "(+ 1 2 3)") 6)
+(cl-test "arith: + zero" (ev "(+)") 0)
+(cl-test "arith: -" (ev "(- 10 3 2)") 5)
+(cl-test "arith: - negate" (ev "(- 5)") -5)
+(cl-test "arith: *" (ev "(* 2 3 4)") 24)
+(cl-test "arith: * one" (ev "(*)") 1)
+(cl-test "arith: /" (ev "(/ 12 3)") 4)
+(cl-test "arith: max" (ev "(max 3 1 4 1 5)") 5)
+(cl-test "arith: min" (ev "(min 3 1 4 1 5)") 1)
+(cl-test "arith: abs neg" (ev "(abs -7)") 7)
+(cl-test "arith: abs pos" (ev "(abs 7)") 7)
+
+;; ── built-in comparisons ──────────────────────────────────────────
+
+(cl-test "cmp: = true" (ev "(= 3 3)") true)
+(cl-test "cmp: = false" (ev "(= 3 4)") nil)
+(cl-test "cmp: /=" (ev "(/= 3 4)") true)
+(cl-test "cmp: <" (ev "(< 1 2)") true)
+(cl-test "cmp: > false" (ev "(> 1 2)") nil)
+(cl-test "cmp: <=" (ev "(<= 2 2)") true)
+
+;; ── built-in predicates ───────────────────────────────────────────
+
+(cl-test "pred: null nil" (ev "(null nil)") true)
+(cl-test "pred: null non-nil" (ev "(null 5)") nil)
+(cl-test "pred: not nil" (ev "(not nil)") true)
+(cl-test "pred: not truthy" (ev "(not 5)") nil)
+(cl-test "pred: numberp" (ev "(numberp 5)") true)
+(cl-test "pred: numberp str" (ev "(numberp \"x\")") nil)
+(cl-test "pred: stringp" (ev "(stringp \"hello\")") true)
+(cl-test "pred: listp list" (ev "(listp '(1))") true)
+(cl-test "pred: listp nil" (ev "(listp nil)") true)
+(cl-test "pred: zerop" (ev "(zerop 0)") true)
+(cl-test "pred: plusp" (ev "(plusp 3)") true)
+(cl-test "pred: evenp" (ev "(evenp 4)") true)
+(cl-test "pred: oddp" (ev "(oddp 3)") true)
+
+;; ── built-in list ops ─────────────────────────────────────────────
+
+(cl-test "list: car" (ev "(car '(1 2 3))") 1)
+(cl-test "list: cdr" (ev "(cdr '(1 2 3))") (list 2 3))
+(cl-test "list: cons" (get (ev "(cons 1 2)") "car") 1)
+(cl-test "list: list fn" (ev "(list 1 2 3)") (list 1 2 3))
+(cl-test "list: length" (ev "(length '(a b c))") 3)
+(cl-test "list: length nil" (ev "(length nil)") 0)
+(cl-test "list: append" (ev "(append '(1 2) '(3 4))") (list 1 2 3 4))
+(cl-test "list: first" (ev "(first '(10 20 30))") 10)
+(cl-test "list: second" (ev "(second '(10 20 30))") 20)
+(cl-test "list: third" (ev "(third '(10 20 30))") 30)
+(cl-test "list: rest" (ev "(rest '(1 2 3))") (list 2 3))
+(cl-test "list: nth" (ev "(nth 1 '(a b c))") "B")
+(cl-test "list: reverse" (ev "(reverse '(1 2 3))") (list 3 2 1))
+
+;; ── FUNCALL / APPLY / MAPCAR ─────────────────────────────────────
+
+(cl-test "funcall: lambda"
+  (ev "(funcall (lambda (x) (* x x)) 5)")
+  25)
+(cl-test "apply: basic"
+  (ev "(apply #'+ '(1 2 3))")
+  6)
+(cl-test "apply: leading args"
+  (ev "(apply #'+ 1 2 '(3 4))")
+  10)
+(cl-test "mapcar: basic"
+  (ev "(mapcar (lambda (x) (* x 2)) '(1 2 3))")
+  (list 2 4 6))
+
+;; ── BLOCK / RETURN-FROM / RETURN ─────────────────────────────────
+
+(cl-test "block: last form value"
+  (ev "(block done 1 2 3)")
+  3)
+(cl-test "block: empty body"
+  (ev "(block done)")
+  nil)
+(cl-test "block: single form"
+  (ev "(block foo 42)")
+  42)
+(cl-test "block: return-from"
+  (ev "(block done 1 (return-from done 99) 2)")
+  99)
+(cl-test "block: return-from nil block"
+  (ev "(block nil 1 (return-from nil 42) 3)")
+  42)
+(cl-test "block: return-from no value"
+  (ev "(block done (return-from done))")
+  nil)
+(cl-test "block: nested inner return stays inner"
+  (ev "(block outer (block inner (return-from inner 1) 2) 3)")
+  3)
+(cl-test "block: nested outer return"
+  (ev "(block outer (block inner 1 2) (return-from outer 99) 3)")
+  99)
+(cl-test "return: shorthand for nil block"
+  (ev "(block nil (return 77))")
+  77)
+(cl-test "return: no value"
+  (ev "(block nil 1 (return) 2)")
+  nil)
+(cl-test "block: return-from inside let"
+  (ev "(block done (let ((x 5)) (when (> x 3) (return-from done x))) 0)")
+  5)
+(cl-test "block: return-from inside progn"
+  (ev "(block done (progn (return-from done 7) 99))")
+  7)
+(cl-test "block: return-from through function"
+  (ev "(block done (flet ((f () (return-from done 42))) (f)) nil)")
+  42)
+
+;; ── TAGBODY / GO ─────────────────────────────────────────────────
+
+(cl-test "tagbody: empty returns nil"
+  (ev "(tagbody)")
+  nil)
+(cl-test "tagbody: forms only, returns nil"
+  (ev "(let ((x 0)) (tagbody (setq x 1) (setq x 2)) x)")
+  2)
+(cl-test "tagbody: tag only, returns nil"
+  (ev "(tagbody done)")
+  nil)
+(cl-test "tagbody: go skips forms"
+  (ev "(let ((x 0)) (tagbody (go done) (setq x 99) done) x)")
+  0)
+(cl-test "tagbody: go to later tag"
+  (ev "(let ((x 0)) (tagbody start (setq x (+ x 1)) (go done) (setq x 99) done) x)")
+  1)
+(cl-test "tagbody: loop with counter"
+  (ev "(let ((n 0)) (tagbody loop (when (>= n 3) (go done)) (setq n (+ n 1)) (go loop) done) n)")
+  3)
+(cl-test "tagbody: go inside when"
+  (ev "(let ((x 0)) (tagbody (setq x 1) (when t (go done)) (setq x 99) done) x)")
+  1)
+(cl-test "tagbody: go inside progn"
+  (ev "(let ((x 0)) (tagbody (progn (setq x 1) (go done)) (setq x 99) done) x)")
+  1)
+(cl-test "tagbody: go inside let"
+  (ev "(let ((acc 0)) (tagbody (let ((y 5)) (when (> y 3) (go done))) (setq acc 99) done) acc)")
+  0)
+(cl-test "tagbody: integer tags"
+  (ev "(let ((x 0)) (tagbody (go 2) 1 (setq x 1) (go 3) 2 (setq x 2) (go 3) 3) x)")
+  2)
+(cl-test "tagbody: block-return propagates out"
+  (ev "(block done (tagbody (return-from done 42)) nil)")
+  42)
+
+;; ── UNWIND-PROTECT ───────────────────────────────────────────────
+
+(cl-test "unwind-protect: normal returns protected"
+  (ev "(unwind-protect 42 nil)")
+  42)
+(cl-test "unwind-protect: cleanup runs"
+  (ev "(let ((x 0)) (unwind-protect 1 (setq x 99)) x)")
+  99)
+(cl-test "unwind-protect: cleanup result ignored"
+  (ev "(unwind-protect 42 777)")
+  42)
+(cl-test "unwind-protect: multiple cleanup forms"
+  (ev "(let ((x 0)) (unwind-protect 1 (setq x (+ x 1)) (setq x (+ x 1))) x)")
+  2)
+(cl-test "unwind-protect: cleanup on return-from"
+  (ev "(let ((x 0)) (block done (unwind-protect (return-from done 7) (setq x 99))) x)")
+  99)
+(cl-test "unwind-protect: return-from still propagates"
+  (ev "(block done (unwind-protect (return-from done 42) nil))")
+  42)
+(cl-test "unwind-protect: cleanup on go"
+  (ev "(let ((x 0)) (tagbody (unwind-protect (go done) (setq x 1)) done) x)")
+  1)
+(cl-test "unwind-protect: nested, inner cleanup first"
+  (ev "(let ((n 0)) (unwind-protect (unwind-protect 1 (setq n (+ n 10))) (setq n (+ n 1))) n)")
+  11)
+
+;; ── VALUES / MULTIPLE-VALUE-BIND / NTH-VALUE ────────────────────
+
+(cl-test "values: single returns plain"
+  (ev "(values 42)")
+  42)
+(cl-test "values: zero returns nil"
+  (ev "(values)")
+  nil)
+(cl-test "values: multi — primary via funcall"
+  (ev "(car (list (values 1 2)))")
+  1)
+(cl-test "multiple-value-bind: basic"
+  (ev "(multiple-value-bind (a b) (values 1 2) (+ a b))")
+  3)
+(cl-test "multiple-value-bind: extra vars get nil"
+  (ev "(multiple-value-bind (a b c) (values 10 20) (list a b c))")
+  (list 10 20 nil))
+(cl-test "multiple-value-bind: extra values ignored"
+  (ev "(multiple-value-bind (a) (values 1 2 3) a)")
+  1)
+(cl-test "multiple-value-bind: single value source"
+  (ev "(multiple-value-bind (a b) 42 (list a b))")
+  (list 42 nil))
+(cl-test "nth-value: 0"
+  (ev "(nth-value 0 (values 10 20 30))")
+  10)
+(cl-test "nth-value: 1"
+  (ev "(nth-value 1 (values 10 20 30))")
+  20)
+(cl-test "nth-value: out of range"
+  (ev "(nth-value 5 (values 10 20))")
+  nil)
+(cl-test "multiple-value-call: basic"
+  (ev "(multiple-value-call #'+ (values 1 2) (values 3 4))")
+  10)
+(cl-test "multiple-value-prog1: returns first"
+  (ev "(multiple-value-prog1 1 2 3)")
+  1)
+(cl-test "multiple-value-prog1: side effects run"
+  (ev "(let ((x 0)) (multiple-value-prog1 99 (setq x 7)) x)")
+  7)
+(cl-test "values: nil primary in if"
+  (ev "(if (values nil t) 'yes 'no)")
+  "NO")
+(cl-test "values: truthy primary in if"
+  (ev "(if (values 42 nil) 'yes 'no)")
+  "YES")

lib/common-lisp/tests/lambda.sx

@@ -0,0 +1,204 @@
+;; Lambda list parser tests
+
+(define cl-test-pass 0)
+(define cl-test-fail 0)
+(define cl-test-fails (list))
+
+;; Deep structural equality for dicts and lists
+(define
+  cl-deep=
+  (fn
+    (a b)
+    (cond
+      ((= a b) true)
+      ((and (dict? a) (dict? b))
+        (let
+          ((ak (keys a)) (bk (keys b)))
+          (if
+            (not (= (len ak) (len bk)))
+            false
+            (every?
+              (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
+              ak))))
+      ((and (list? a) (list? b))
+        (if
+          (not (= (len a) (len b)))
+          false
+          (let
+            ((i 0) (ok true))
+            (define
+              chk
+              (fn
+                ()
+                (when
+                  (and ok (< i (len a)))
+                  (do
+                    (when
+                      (not (cl-deep= (nth a i) (nth b i)))
+                      (set! ok false))
+                    (set! i (+ i 1))
+                    (chk)))))
+            (chk)
+            ok)))
+      (:else false))))
+
+(define
+  cl-test
+  (fn
+    (name actual expected)
+    (if
+      (cl-deep= actual expected)
+      (set! cl-test-pass (+ cl-test-pass 1))
+      (do
+        (set! cl-test-fail (+ cl-test-fail 1))
+        (append! cl-test-fails {:name name :expected expected :actual actual})))))
+
+;; Helper: parse lambda list from string "(x y ...)"
+(define ll (fn (src) (cl-parse-lambda-list-str src)))
+(define ll-req  (fn (src) (get (ll src) "required")))
+(define ll-opt  (fn (src) (get (ll src) "optional")))
+(define ll-rest (fn (src) (get (ll src) "rest")))
+(define ll-key  (fn (src) (get (ll src) "key")))
+(define ll-aok  (fn (src) (get (ll src) "allow-other-keys")))
+(define ll-aux  (fn (src) (get (ll src) "aux")))
+
+;; ── required parameters ───────────────────────────────────────────
+
+(cl-test "required: empty" (ll-req "()") (list))
+(cl-test "required: one" (ll-req "(x)") (list "X"))
+(cl-test "required: two" (ll-req "(x y)") (list "X" "Y"))
+(cl-test "required: three" (ll-req "(a b c)") (list "A" "B" "C"))
+(cl-test "required: upcased" (ll-req "(foo bar)") (list "FOO" "BAR"))
+
+;; ── &optional ─────────────────────────────────────────────────────
+
+(cl-test "optional: none" (ll-opt "(x)") (list))
+
+(cl-test
+  "optional: bare symbol"
+  (ll-opt "(x &optional z)")
+  (list {:name "Z" :default nil :supplied nil}))
+
+(cl-test
+  "optional: with default"
+  (ll-opt "(x &optional (z 0))")
+  (list {:name "Z" :default 0 :supplied nil}))
+
+(cl-test
+  "optional: with supplied-p"
+  (ll-opt "(x &optional (z 0 z-p))")
+  (list {:name "Z" :default 0 :supplied "Z-P"}))
+
+(cl-test
+  "optional: two params"
+  (ll-opt "(&optional a (b 1))")
+  (list {:name "A" :default nil :supplied nil} {:name "B" :default 1 :supplied nil}))
+
+(cl-test
+  "optional: string default"
+  (ll-opt "(&optional (name \"world\"))")
+  (list {:name "NAME" :default {:cl-type "string" :value "world"} :supplied nil}))
+
+;; ── &rest ─────────────────────────────────────────────────────────
+
+(cl-test "rest: none" (ll-rest "(x)") nil)
+(cl-test "rest: present" (ll-rest "(x &rest args)") "ARGS")
+(cl-test "rest: with required" (ll-rest "(a b &rest tail)") "TAIL")
+
+;; &body is an alias for &rest
+(cl-test "body: alias for rest" (ll-rest "(&body forms)") "FORMS")
+
+;; rest doesn't consume required params
+(cl-test "rest: required still there" (ll-req "(a b &rest rest)") (list "A" "B"))
+
+;; ── &key ──────────────────────────────────────────────────────────
+
+(cl-test "key: none" (ll-key "(x)") (list))
+
+(cl-test
+  "key: bare symbol"
+  (ll-key "(&key x)")
+  (list {:name "X" :keyword "X" :default nil :supplied nil}))
+
+(cl-test
+  "key: with default"
+  (ll-key "(&key (x 42))")
+  (list {:name "X" :keyword "X" :default 42 :supplied nil}))
+
+(cl-test
+  "key: with supplied-p"
+  (ll-key "(&key (x 42 x-p))")
+  (list {:name "X" :keyword "X" :default 42 :supplied "X-P"}))
+
+(cl-test
+  "key: two params"
+  (ll-key "(&key a b)")
+  (list
+    {:name "A" :keyword "A" :default nil :supplied nil}
+    {:name "B" :keyword "B" :default nil :supplied nil}))
+
+;; ── &allow-other-keys ─────────────────────────────────────────────
+
+(cl-test "aok: absent" (ll-aok "(x)") false)
+(cl-test "aok: present" (ll-aok "(&key x &allow-other-keys)") true)
+
+;; ── &aux ──────────────────────────────────────────────────────────
+
+(cl-test "aux: none" (ll-aux "(x)") (list))
+
+(cl-test
+  "aux: bare symbol"
+  (ll-aux "(&aux temp)")
+  (list {:name "TEMP" :init nil}))
+
+(cl-test
+  "aux: with init"
+  (ll-aux "(&aux (count 0))")
+  (list {:name "COUNT" :init 0}))
+
+(cl-test
+  "aux: two vars"
+  (ll-aux "(&aux a (b 1))")
+  (list {:name "A" :init nil} {:name "B" :init 1}))
+
+;; ── combined ──────────────────────────────────────────────────────
+
+(cl-test
+  "combined: full lambda list"
+  (let
+    ((parsed (ll "(x y &optional (z 0 z-p) &rest args &key a (b nil b-p) &aux temp)")))
+    (list
+      (get parsed "required")
+      (get (nth (get parsed "optional") 0) "name")
+      (get (nth (get parsed "optional") 0) "default")
+      (get (nth (get parsed "optional") 0) "supplied")
+      (get parsed "rest")
+      (get (nth (get parsed "key") 0) "name")
+      (get (nth (get parsed "key") 1) "supplied")
+      (get (nth (get parsed "aux") 0) "name")))
+  (list
+    (list "X" "Y")
+    "Z"
+    0
+    "Z-P"
+    "ARGS"
+    "A"
+    "B-P"
+    "TEMP"))
+
+(cl-test
+  "combined: required only stops before &"
+  (ll-req "(a b &optional c)")
+  (list "A" "B"))
+
+(cl-test
+  "combined: required only with &key"
+  (ll-req "(x &key y)")
+  (list "X"))
+
+(cl-test
+  "combined: &rest and &key together"
+  (let
+    ((parsed (ll "(&rest args &key verbose)")))
+    (list (get parsed "rest") (get (nth (get parsed "key") 0) "name")))
+  (list "ARGS" "VERBOSE"))

lib/common-lisp/tests/parse.sx

@@ -0,0 +1,160 @@
+;; Common Lisp reader/parser tests
+
+(define cl-test-pass 0)
+(define cl-test-fail 0)
+(define cl-test-fails (list))
+
+(define
+  cl-deep=
+  (fn
+    (a b)
+    (cond
+      ((= a b) true)
+      ((and (dict? a) (dict? b))
+        (let
+          ((ak (keys a)) (bk (keys b)))
+          (if
+            (not (= (len ak) (len bk)))
+            false
+            (every?
+              (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
+              ak))))
+      ((and (list? a) (list? b))
+        (if
+          (not (= (len a) (len b)))
+          false
+          (let
+            ((i 0) (ok true))
+            (define
+              chk
+              (fn
+                ()
+                (when
+                  (and ok (< i (len a)))
+                  (do
+                    (when
+                      (not (cl-deep= (nth a i) (nth b i)))
+                      (set! ok false))
+                    (set! i (+ i 1))
+                    (chk)))))
+            (chk)
+            ok)))
+      (:else false))))
+
+(define
+  cl-test
+  (fn
+    (name actual expected)
+    (if
+      (cl-deep= actual expected)
+      (set! cl-test-pass (+ cl-test-pass 1))
+      (do
+        (set! cl-test-fail (+ cl-test-fail 1))
+        (append! cl-test-fails {:name name :expected expected :actual actual})))))
+
+;; ── atoms ─────────────────────────────────────────────────────────
+
+(cl-test "integer: 42" (cl-read "42") 42)
+(cl-test "integer: 0" (cl-read "0") 0)
+(cl-test "integer: negative" (cl-read "-5") -5)
+(cl-test "integer: positive sign" (cl-read "+3") 3)
+(cl-test "integer: hex #xFF" (cl-read "#xFF") 255)
+(cl-test "integer: hex #xAB" (cl-read "#xAB") 171)
+(cl-test "integer: binary #b1010" (cl-read "#b1010") 10)
+(cl-test "integer: octal #o17" (cl-read "#o17") 15)
+
+(cl-test "float: type" (get (cl-read "3.14") "cl-type") "float")
+(cl-test "float: value" (get (cl-read "3.14") "value") "3.14")
+(cl-test "float: neg" (get (cl-read "-2.5") "value") "-2.5")
+(cl-test "float: exp" (get (cl-read "1.0e10") "value") "1.0e10")
+
+(cl-test "ratio: type" (get (cl-read "1/3") "cl-type") "ratio")
+(cl-test "ratio: value" (get (cl-read "1/3") "value") "1/3")
+(cl-test "ratio: 22/7" (get (cl-read "22/7") "value") "22/7")
+
+(cl-test "string: basic" (cl-read "\"hello\"") {:cl-type "string" :value "hello"})
+(cl-test "string: empty" (cl-read "\"\"") {:cl-type "string" :value ""})
+(cl-test "string: with escape" (cl-read "\"a\\nb\"") {:cl-type "string" :value "a\nb"})
+
+(cl-test "symbol: foo" (cl-read "foo") "FOO")
+(cl-test "symbol: BAR" (cl-read "BAR") "BAR")
+(cl-test "symbol: pkg:sym" (cl-read "cl:car") "CL:CAR")
+(cl-test "symbol: pkg::sym" (cl-read "pkg::foo") "PKG::FOO")
+
+(cl-test "nil: symbol" (cl-read "nil") nil)
+(cl-test "nil: uppercase" (cl-read "NIL") nil)
+(cl-test "t: symbol" (cl-read "t") true)
+(cl-test "t: uppercase" (cl-read "T") true)
+
+(cl-test "keyword: type" (get (cl-read ":foo") "cl-type") "keyword")
+(cl-test "keyword: name" (get (cl-read ":foo") "name") "FOO")
+(cl-test "keyword: :test" (get (cl-read ":test") "name") "TEST")
+
+(cl-test "char: type" (get (cl-read "#\\a") "cl-type") "char")
+(cl-test "char: value" (get (cl-read "#\\a") "value") "a")
+(cl-test "char: Space" (get (cl-read "#\\Space") "value") " ")
+(cl-test "char: Newline" (get (cl-read "#\\Newline") "value") "\n")
+
+(cl-test "uninterned: type" (get (cl-read "#:foo") "cl-type") "uninterned")
+(cl-test "uninterned: name" (get (cl-read "#:foo") "name") "FOO")
+
+;; ── lists ─────────────────────────────────────────────────────────
+
+(cl-test "list: empty" (cl-read "()") (list))
+(cl-test "list: one element" (cl-read "(foo)") (list "FOO"))
+(cl-test "list: two elements" (cl-read "(foo bar)") (list "FOO" "BAR"))
+(cl-test "list: nested" (cl-read "((a b) c)") (list (list "A" "B") "C"))
+(cl-test "list: with integer" (cl-read "(+ 1 2)") (list "+" 1 2))
+(cl-test "list: with string" (cl-read "(print \"hi\")") (list "PRINT" {:cl-type "string" :value "hi"}))
+(cl-test "list: nil element" (cl-read "(a nil b)") (list "A" nil "B"))
+(cl-test "list: t element" (cl-read "(a t b)") (list "A" true "B"))
+
+;; ── dotted pairs ──────────────────────────────────────────────<E29480><E29480>──
+
+(cl-test "dotted: type" (get (cl-read "(a . b)") "cl-type") "cons")
+(cl-test "dotted: car" (get (cl-read "(a . b)") "car") "A")
+(cl-test "dotted: cdr" (get (cl-read "(a . b)") "cdr") "B")
+(cl-test "dotted: number cdr" (get (cl-read "(x . 42)") "cdr") 42)
+
+;; ── reader macros ────────────────────────────────────────────────<E29480><E29480>
+
+(cl-test "quote: form" (cl-read "'x") (list "QUOTE" "X"))
+(cl-test "quote: list" (cl-read "'(a b)") (list "QUOTE" (list "A" "B")))
+(cl-test "backquote: form" (cl-read "`x") (list "QUASIQUOTE" "X"))
+(cl-test "unquote: form" (cl-read ",x") (list "UNQUOTE" "X"))
+(cl-test "comma-at: form" (cl-read ",@x") (list "UNQUOTE-SPLICING" "X"))
+(cl-test "function: form" (cl-read "#'foo") (list "FUNCTION" "FOO"))
+
+;; ── vector ────────────────────────────────────────────────────────
+
+(cl-test "vector: type" (get (cl-read "#(1 2 3)") "cl-type") "vector")
+(cl-test "vector: elements" (get (cl-read "#(1 2 3)") "elements") (list 1 2 3))
+(cl-test "vector: empty" (get (cl-read "#()") "elements") (list))
+(cl-test "vector: mixed" (get (cl-read "#(a 1 \"s\")") "elements") (list "A" 1 {:cl-type "string" :value "s"}))
+
+;; ── cl-read-all ───────────────────────────────────────────────────
+
+(cl-test
+  "read-all: empty"
+  (cl-read-all "")
+  (list))
+
+(cl-test
+  "read-all: two forms"
+  (cl-read-all "42 foo")
+  (list 42 "FOO"))
+
+(cl-test
+  "read-all: three forms"
+  (cl-read-all "(+ 1 2) (+ 3 4) hello")
+  (list (list "+" 1 2) (list "+" 3 4) "HELLO"))
+
+(cl-test
+  "read-all: with comments"
+  (cl-read-all "; this is a comment\n42 ; inline\nfoo")
+  (list 42 "FOO"))
+
+(cl-test
+  "read-all: defun form"
+  (nth (cl-read-all "(defun square (x) (* x x))") 0)
+  (list "DEFUN" "SQUARE" (list "X") (list "*" "X" "X")))

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)

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)

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)

lib/common-lisp/tests/read.sx

@@ -0,0 +1,180 @@
+;; Common Lisp tokenizer tests
+
+(define cl-test-pass 0)
+(define cl-test-fail 0)
+(define cl-test-fails (list))
+
+(define
+  cl-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! cl-test-pass (+ cl-test-pass 1))
+      (do
+        (set! cl-test-fail (+ cl-test-fail 1))
+        (append! cl-test-fails {:name name :expected expected :actual actual})))))
+
+;; Helpers: extract types and values from token stream (drops eof)
+(define
+  cl-tok-types
+  (fn
+    (src)
+    (map
+      (fn (t) (get t "type"))
+      (filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src)))))
+
+(define
+  cl-tok-values
+  (fn
+    (src)
+    (map
+      (fn (t) (get t "value"))
+      (filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src)))))
+
+(define
+  cl-tok-first
+  (fn (src) (nth (cl-tokenize src) 0)))
+
+;; ── symbols ───────────────────────────────────────────────────────
+
+(cl-test "symbol: bare lowercase" (cl-tok-values "foo") (list "FOO"))
+(cl-test "symbol: uppercase" (cl-tok-values "BAR") (list "BAR"))
+(cl-test "symbol: mixed case folded" (cl-tok-values "FooBar") (list "FOOBAR"))
+(cl-test "symbol: with hyphen" (cl-tok-values "foo-bar") (list "FOO-BAR"))
+(cl-test "symbol: with star" (cl-tok-values "*special*") (list "*SPECIAL*"))
+(cl-test "symbol: with question" (cl-tok-values "null?") (list "NULL?"))
+(cl-test "symbol: with exclamation" (cl-tok-values "set!") (list "SET!"))
+(cl-test "symbol: plus sign alone" (cl-tok-values "+") (list "+"))
+(cl-test "symbol: minus sign alone" (cl-tok-values "-") (list "-"))
+(cl-test "symbol: type is symbol" (cl-tok-types "foo") (list "symbol"))
+
+;; ── package-qualified symbols ─────────────────────────────────────
+
+(cl-test "symbol: pkg:sym external" (cl-tok-values "cl:car") (list "CL:CAR"))
+(cl-test "symbol: pkg::sym internal" (cl-tok-values "pkg::foo") (list "PKG::FOO"))
+(cl-test "symbol: cl:car type" (cl-tok-types "cl:car") (list "symbol"))
+
+;; ── keywords ──────────────────────────────────────────────────────
+
+(cl-test "keyword: basic" (cl-tok-values ":foo") (list "FOO"))
+(cl-test "keyword: type" (cl-tok-types ":foo") (list "keyword"))
+(cl-test "keyword: upcase" (cl-tok-values ":hello-world") (list "HELLO-WORLD"))
+(cl-test "keyword: multiple" (cl-tok-types ":a :b :c") (list "keyword" "keyword" "keyword"))
+
+;; ── integers ──────────────────────────────────────────────────────
+
+(cl-test "integer: zero" (cl-tok-values "0") (list "0"))
+(cl-test "integer: positive" (cl-tok-values "42") (list "42"))
+(cl-test "integer: negative" (cl-tok-values "-5") (list "-5"))
+(cl-test "integer: positive-sign" (cl-tok-values "+3") (list "+3"))
+(cl-test "integer: type" (cl-tok-types "42") (list "integer"))
+(cl-test "integer: multi-digit" (cl-tok-values "12345678") (list "12345678"))
+
+;; ── hex, binary, octal ───────────────────────────────────────────
+
+(cl-test "hex: lowercase x" (cl-tok-values "#xFF") (list "#xFF"))
+(cl-test "hex: uppercase X" (cl-tok-values "#XFF") (list "#XFF"))
+(cl-test "hex: type" (cl-tok-types "#xFF") (list "integer"))
+(cl-test "hex: zero" (cl-tok-values "#x0") (list "#x0"))
+(cl-test "binary: #b" (cl-tok-values "#b1010") (list "#b1010"))
+(cl-test "binary: type" (cl-tok-types "#b1010") (list "integer"))
+(cl-test "octal: #o" (cl-tok-values "#o17") (list "#o17"))
+(cl-test "octal: type" (cl-tok-types "#o17") (list "integer"))
+
+;; ── floats ────────────────────────────────────────────────────────
+
+(cl-test "float: basic" (cl-tok-values "3.14") (list "3.14"))
+(cl-test "float: type" (cl-tok-types "3.14") (list "float"))
+(cl-test "float: negative" (cl-tok-values "-2.5") (list "-2.5"))
+(cl-test "float: exponent" (cl-tok-values "1.0e10") (list "1.0e10"))
+(cl-test "float: neg exponent" (cl-tok-values "1.5e-3") (list "1.5e-3"))
+(cl-test "float: leading dot" (cl-tok-values ".5") (list "0.5"))
+(cl-test "float: exp only" (cl-tok-values "1e5") (list "1e5"))
+
+;; ── ratios ────────────────────────────────────────────────────────
+
+(cl-test "ratio: 1/3" (cl-tok-values "1/3") (list "1/3"))
+(cl-test "ratio: type" (cl-tok-types "1/3") (list "ratio"))
+(cl-test "ratio: 22/7" (cl-tok-values "22/7") (list "22/7"))
+(cl-test "ratio: negative" (cl-tok-values "-1/2") (list "-1/2"))
+
+;; ── strings ───────────────────────────────────────────────────────
+
+(cl-test "string: empty" (cl-tok-values "\"\"") (list ""))
+(cl-test "string: basic" (cl-tok-values "\"hello\"") (list "hello"))
+(cl-test "string: type" (cl-tok-types "\"hello\"") (list "string"))
+(cl-test "string: with space" (cl-tok-values "\"hello world\"") (list "hello world"))
+(cl-test "string: escaped quote" (cl-tok-values "\"say \\\"hi\\\"\"") (list "say \"hi\""))
+(cl-test "string: escaped backslash" (cl-tok-values "\"a\\\\b\"") (list "a\\b"))
+(cl-test "string: newline escape" (cl-tok-values "\"a\\nb\"") (list "a\nb"))
+(cl-test "string: tab escape" (cl-tok-values "\"a\\tb\"") (list "a\tb"))
+
+;; ── characters ────────────────────────────────────────────────────
+
+(cl-test "char: lowercase a" (cl-tok-values "#\\a") (list "a"))
+(cl-test "char: uppercase A" (cl-tok-values "#\\A") (list "A"))
+(cl-test "char: digit" (cl-tok-values "#\\1") (list "1"))
+(cl-test "char: type" (cl-tok-types "#\\a") (list "char"))
+(cl-test "char: Space" (cl-tok-values "#\\Space") (list " "))
+(cl-test "char: Newline" (cl-tok-values "#\\Newline") (list "\n"))
+(cl-test "char: Tab" (cl-tok-values "#\\Tab") (list "\t"))
+(cl-test "char: Return" (cl-tok-values "#\\Return") (list "\r"))
+
+;; ── reader macros ─────────────────────────────────────────────────
+
+(cl-test "quote: type" (cl-tok-types "'x") (list "quote" "symbol"))
+(cl-test "backquote: type" (cl-tok-types "`x") (list "backquote" "symbol"))
+(cl-test "comma: type" (cl-tok-types ",x") (list "comma" "symbol"))
+(cl-test "comma-at: type" (cl-tok-types ",@x") (list "comma-at" "symbol"))
+(cl-test "hash-quote: type" (cl-tok-types "#'foo") (list "hash-quote" "symbol"))
+(cl-test "hash-paren: type" (cl-tok-types "#(1 2)") (list "hash-paren" "integer" "integer" "rparen"))
+
+;; ── uninterned ────────────────────────────────────────────────────
+
+(cl-test "uninterned: type" (cl-tok-types "#:foo") (list "uninterned"))
+(cl-test "uninterned: value upcase" (cl-tok-values "#:foo") (list "FOO"))
+(cl-test "uninterned: compound" (cl-tok-values "#:my-sym") (list "MY-SYM"))
+
+;; ── parens and structure ──────────────────────────────────────────
+
+(cl-test "paren: empty list" (cl-tok-types "()") (list "lparen" "rparen"))
+(cl-test "paren: nested" (cl-tok-types "((a))") (list "lparen" "lparen" "symbol" "rparen" "rparen"))
+(cl-test "dot: standalone" (cl-tok-types "(a . b)") (list "lparen" "symbol" "dot" "symbol" "rparen"))
+
+;; ── comments ──────────────────────────────────────────────────────
+
+(cl-test "comment: line" (cl-tok-types "; comment\nfoo") (list "symbol"))
+(cl-test "comment: inline" (cl-tok-values "foo ; bar\nbaz") (list "FOO" "BAZ"))
+(cl-test "block-comment: basic" (cl-tok-types "#| hello |# foo") (list "symbol"))
+(cl-test "block-comment: nested" (cl-tok-types "#| a #| b |# c |# x") (list "symbol"))
+
+;; ── combined ──────────────────────────────────────────────────────
+
+(cl-test
+  "combined: defun skeleton"
+  (cl-tok-types "(defun foo (x) x)")
+  (list "lparen" "symbol" "symbol" "lparen" "symbol" "rparen" "symbol" "rparen"))
+
+(cl-test
+  "combined: let form"
+  (cl-tok-types "(let ((x 1)) x)")
+  (list
+    "lparen"
+    "symbol"
+    "lparen"
+    "lparen"
+    "symbol"
+    "integer"
+    "rparen"
+    "rparen"
+    "symbol"
+    "rparen"))
+
+(cl-test
+  "combined: whitespace skip"
+  (cl-tok-values "  foo   bar   baz  ")
+  (list "FOO" "BAR" "BAZ"))
+
+(cl-test "eof: present" (get (nth (cl-tokenize "") 0) "type") "eof")
+(cl-test "eof: at end of tokens" (get (nth (cl-tokenize "x") 1) "type") "eof")

plans/common-lisp-on-sx.md

@@ -50,34 +50,34 @@ Core mapping:
 ## Roadmap
 
 ### Phase 1 — reader + parser
-- [ ] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#`
+- [x] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#`
-- [ ] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals
+- [x] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals
-- [ ] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables
+- [x] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables
-- [ ] Unit tests in `lib/common-lisp/tests/read.sx`
+- [x] Unit tests in `lib/common-lisp/tests/read.sx`
 
 ### Phase 2 — sequential eval + special forms
-- [ ] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
+- [x] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
-- [ ] `block` + `return-from` via captured continuation
+- [x] `block` + `return-from` via captured continuation
-- [ ] `tagbody` + `go` via per-tag continuations
+- [x] `tagbody` + `go` via per-tag continuations
-- [ ] `unwind-protect` cleanup frame
+- [x] `unwind-protect` cleanup frame
-- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
+- [x] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
-- [ ] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
+- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
 - [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
-- [ ] 60+ tests in `lib/common-lisp/tests/eval.sx`
+- [x] 127 tests in `lib/common-lisp/tests/eval.sx`
 
 ### Phase 3 — conditions + restarts (THE SHOWCASE)
-- [ ] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
+- [x] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
-- [ ] `signal`, `error`, `cerror`, `warn` — all walk the handler chain
+- [x] `signal`, `error`, `cerror`, `warn` — all walk the handler chain
-- [ ] `handler-bind` — non-unwinding handlers, may decline by returning normally
+- [x] `handler-bind` — non-unwinding handlers, may decline by returning normally
-- [ ] `handler-case` — unwinding handlers (delcc abort)
+- [x] `handler-case` — unwinding handlers (call/cc escape)
-- [ ] `restart-case`, `with-simple-restart`, `restart-bind`
+- [x] `restart-case`, `with-simple-restart`, `restart-bind`
-- [ ] `find-restart`, `invoke-restart`, `invoke-restart-interactively`, `compute-restarts`
+- [x] `find-restart`, `invoke-restart`, `compute-restarts`
-- [ ] `with-condition-restarts` — associate restarts with a specific condition
+- [x] `with-condition-restarts` — associate restarts with a specific condition
-- [ ] `*break-on-signals*`, `*debugger-hook*` (basic)
+- [x] `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/`:
-  - [ ] `restart-demo.lisp` — division with `:use-zero` and `:retry` restarts
+  - [x] `restart-demo.sx` — division with `use-zero` and `retry` restarts (7 tests)
-  - [ ] `parse-recover.lisp` — parser with skipped-token restart
+  - [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,7 +124,18 @@ data; format for string templating.
 
 _Newest first._
 
-- _(none yet)_
+- 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.
+- 2026-05-05: multiple values — VALUES returns {:cl-type "mv"} wrapper for 2+ values; cl-mv-primary/cl-mv-vals helpers; MULTIPLE-VALUE-BIND binds vars to value list; MULTIPLE-VALUE-CALL/PROG1/NTH-VALUE; cl-mv-primary applied in IF/AND/OR/COND/cl-call-fn for single-value contexts; 15 new tests (174 eval, 346 total green).
+- 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).
+- 2026-05-05: block + return-from — sentinel propagation in cl-eval-body; cl-eval-block catches matching sentinels; BLOCK/RETURN-FROM/RETURN dispatch in cl-eval-list; 13 new tests (140 eval, 312 total green). Parser: CL strings → {:cl-type "string"} dicts.
+- 2026-04-25: Phase 2 eval — 127 tests, 299 total green. `lib/common-lisp/eval.sx`: cl-eval-ast with quote/if/progn/let/let*/flet/labels/setq/setf/function/lambda/the/locally/eval-when; defun/defvar/defparameter/defconstant; built-in arithmetic (+/-/*//, min/max/abs/evenp/oddp), comparisons, predicates, list ops (car/cdr/cons/list/append/reverse/length/nth/first/second/third/rest), string ops, funcall/apply/mapcar. Key gotchas: SX reduce is (reduce fn init list) not (reduce fn list init); CL true literal is t not true; builtins registered in cl-global-env.fns via wrapper dicts for #' syntax.
+- 2026-04-25: Phase 1 lambda-list parser — 31 new tests, 172 total green. `cl-parse-lambda-list` in `parser.sx` + `tests/lambda.sx`. Handles &optional/&rest/&body/&key/&aux/&allow-other-keys, defaults, supplied-p. Key gotchas: `(when (> (len items) 0) ...)` not `(when items ...)` (empty list is truthy); custom `cl-deep=` needed for dict/list structural equality in tests.
+- 2026-04-25: Phase 1 reader/parser — 62 new tests, 141 total green. `lib/common-lisp/parser.sx`: cl-read/cl-read-all, lists, dotted pairs, quote/backquote/unquote/splice/#', vectors, #:uninterned, NIL→nil, T→true, reader macro wrappers.
+- 2026-04-25: Phase 1 tokenizer — 79 tests green. `lib/common-lisp/reader.sx` + `tests/read.sx` + `test.sh`. Handles symbols (pkg:sym, pkg::sym), integers, floats, ratios, hex/binary/octal, strings, #\ chars, reader macros (#' #( #: ,@), line/block comments. Key gotcha: SX `str` for string concat (not `concat`), substring-based read-while.
 
 ## Blockers