rose-ash/lib/common-lisp/eval.sx

;; 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))

;; ── macro registry ────────────────────────────────────────────────
;; cl-macro-registry: symbol-name -> (fn (form env) expanded-form)
(define cl-macro-registry (dict))

;; Gensym counter (eval-time, distinct from runtime.sx cl-gensym)
(define cl-gensym-counter 0)
(define cl-eval-gensym
  (fn (prefix)
    (do
      (set! cl-gensym-counter (+ cl-gensym-counter 1))
      (str (if (nil? prefix) "G" prefix) cl-gensym-counter))))


(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)))))))))))))


;; ── sequence/list helpers (needed by builtins) ───────────────────

(define cl-member-helper
  (fn (item lst)
    (if (= lst nil) nil
      (if (= (len lst) 0) nil
        (if (= (nth lst 0) item)
          lst
          (cl-member-helper item (rest lst)))))))

(define cl-subst-helper
  (fn (new old tree)
    (if (= tree old) new
      (if (and (list? tree) (> (len tree) 0))
        (map (fn (x) (cl-subst-helper new old x)) tree)
        tree))))

(define cl-position-helper
  (fn (item lst idx)
    (if (= lst nil) nil
      (if (= (len lst) 0) nil
        (if (= (nth lst 0) item)
          idx
          (cl-position-helper item (rest lst) (+ idx 1)))))))

(define cl-position-if-helper
  (fn (fn-obj lst idx)
    (if (= lst nil) nil
      (if (= (len lst) 0) nil
        (if (cl-apply fn-obj (list (nth lst 0)))
          idx
          (cl-position-if-helper fn-obj (rest lst) (+ idx 1)))))))

;; ── 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)
               (let ((x (nth args 0)))
                 (if (or (= x nil) (and (list? x) (= (len x) 0))) 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)
                 (let ((x (nth args 0)))
                   (if (or (list? x) (= x nil)
                           (and (dict? x) (= (get x "cl-type") "cons")))
                     true nil)))
    "CONSP"   (fn (args)
                 (let ((x (nth args 0)))
                   (if (or (and (list? x) (> (len x) 0))
                           (and (dict? x) (= (get x "cl-type") "cons")))
                     true nil)))
    "ATOM"    (fn (args)
                 (let ((x (nth args 0)))
                   (if (or (and (list? x) (> (len x) 0))
                           (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))
    ;; sequence functions
    "MAPC"    (fn (args)
                 (let ((fn-obj (nth args 0))
                       (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                   (begin
                     (for-each (fn (x) (cl-apply fn-obj (list x))) lst)
                     (nth args 1))))
    "MAPCAN"  (fn (args)
                 (let ((fn-obj (nth args 0))
                       (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                   (reduce (fn (acc x)
                              (let ((r (cl-apply fn-obj (list x))))
                                (if (= r nil) acc
                                  (concat acc r))))
                           (list) lst)))
    "REDUCE"  (fn (args)
                 (let ((fn-obj (nth args 0))
                       (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                   (let ((iv-r (cl-find-kw-arg "INITIAL-VALUE" args 2)))
                     (let ((has-iv (get iv-r "found"))
                           (iv     (get iv-r "value")))
                       (if (= (len lst) 0)
                         (if has-iv iv (cl-apply fn-obj (list)))
                         (if has-iv
                           (reduce (fn (acc x) (cl-apply fn-obj (list acc x))) iv lst)
                           (reduce (fn (acc x) (cl-apply fn-obj (list acc x)))
                                   (nth lst 0) (rest lst))))))))
    "FIND"    (fn (args)
                 (let ((item (nth args 0))
                       (lst  (if (= (nth args 1) nil) (list) (nth args 1))))
                   (let ((r (some (fn (x) (if (= x item) x false)) lst)))
                     (if r r nil))))
    "FIND-IF" (fn (args)
                 (let ((fn-obj (nth args 0))
                       (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                   (let ((r (some (fn (x)
                                    (let ((res (cl-apply fn-obj (list x))))
                                      (if res x false)))
                                  lst)))
                     (if r r nil))))
    "FIND-IF-NOT" (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (let ((r (some (fn (x)
                                        (let ((res (cl-apply fn-obj (list x))))
                                          (if res false x)))
                                      lst)))
                         (if r r nil))))
    "POSITION"    (fn (args)
                     (cl-position-helper (nth args 0)
                       (if (= (nth args 1) nil) (list) (nth args 1)) 0))
    "POSITION-IF" (fn (args)
                     (cl-position-if-helper (nth args 0)
                       (if (= (nth args 1) nil) (list) (nth args 1)) 0))
    "COUNT"       (fn (args)
                     (let ((item (nth args 0))
                           (lst  (if (= (nth args 1) nil) (list) (nth args 1))))
                       (len (filter (fn (x) (= x item)) lst))))
    "COUNT-IF"    (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (len (filter (fn (x) (cl-apply fn-obj (list x))) lst))))
    "EVERY"       (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (if (every? (fn (x) (cl-apply fn-obj (list x))) lst) true nil)))
    "SOME"        (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (let ((r (some (fn (x) (cl-apply fn-obj (list x))) lst)))
                         (if r r nil))))
    "NOTANY"      (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (if (some (fn (x) (cl-apply fn-obj (list x))) lst) nil true)))
    "NOTEVERY"    (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (if (every? (fn (x) (cl-apply fn-obj (list x))) lst) nil true)))
    "REMOVE"      (fn (args)
                     (let ((item (nth args 0))
                           (lst  (if (= (nth args 1) nil) (list) (nth args 1))))
                       (filter (fn (x) (not (= x item))) lst)))
    "REMOVE-IF"   (fn (args)
                     (let ((fn-obj (nth args 0))
                           (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                       (filter (fn (x) (not (cl-apply fn-obj (list x)))) lst)))
    "REMOVE-IF-NOT" (fn (args)
                       (let ((fn-obj (nth args 0))
                             (lst    (if (= (nth args 1) nil) (list) (nth args 1))))
                         (filter (fn (x) (cl-apply fn-obj (list x))) lst)))
    "SUBST"       (fn (args)
                     (cl-subst-helper (nth args 0) (nth args 1)
                       (if (= (nth args 2) nil) (list) (nth args 2))))
    "MEMBER"      (fn (args)
                     (cl-member-helper (nth args 0)
                       (if (= (nth args 1) nil) nil (nth args 1))))
    ;; list ops
    "ASSOC"    (fn (args)
                  (let ((key (nth args 0))
                        (lst (if (= (nth args 1) nil) (list) (nth args 1))))
                    (let ((r (some
                               (fn (pair)
                                 (let ((k (if (and (dict? pair) (= (get pair "cl-type") "cons"))
                                            (get pair "car")
                                            (if (and (list? pair) (> (len pair) 0))
                                              (nth pair 0)
                                              nil))))
                                   (if (= k key) pair false)))
                               lst)))
                      (if r r nil))))
    "RASSOC"   (fn (args)
                  (let ((val (nth args 0))
                        (lst (if (= (nth args 1) nil) (list) (nth args 1))))
                    (let ((r (some
                               (fn (pair)
                                 (let ((v (if (and (dict? pair) (= (get pair "cl-type") "cons"))
                                            (get pair "cdr")
                                            (if (and (list? pair) (> (len pair) 1))
                                              (nth pair 1)
                                              nil))))
                                   (if (= v val) pair false)))
                               lst)))
                      (if r r nil))))
    "GETF"     (fn (args)
                  (let ((plist (if (= (nth args 0) nil) (list) (nth args 0)))
                        (ind   (nth args 1))
                        (def   (if (> (len args) 2) (nth args 2) nil)))
                    (let ((ind-name (if (and (dict? ind) (= (get ind "cl-type") "keyword"))
                                      (get ind "name")
                                      (upcase (str ind)))))
                      (let ((r (cl-find-kw-arg ind-name plist 0)))
                        (if (get r "found") (get r "value") def)))))
    "LAST"     (fn (args)
                  (let ((lst (nth args 0)))
                    (if (or (= lst nil) (= (len lst) 0)) nil
                      (list (nth lst (- (len lst) 1))))))
    "BUTLAST"  (fn (args)
                  (let ((lst (nth args 0)))
                    (if (or (= lst nil) (= (len lst) 0)) (list)
                      (slice lst 0 (- (len lst) 1)))))
    "NTHCDR"   (fn (args)
                  (let ((n   (nth args 0))
                        (lst (nth args 1)))
                    (if (= lst nil) nil
                      (if (>= n (len lst)) nil
                        (slice lst n (len lst))))))
    "COPY-LIST" (fn (args) (nth args 0))
    "LIST*"    (fn (args)
                  (if (= (len args) 0) nil
                    (if (= (len args) 1) (nth args 0)
                      (let ((head (slice args 0 (- (len args) 1)))
                            (tail (nth args (- (len args) 1))))
                        (concat head (if (list? tail) tail (list tail)))))))
    "CAAR"     (fn (args)
                  (let ((x (nth args 0)))
                    (let ((c (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
                      (if (and (list? c) (> (len c) 0)) (nth c 0) nil))))
    "CADR"     (fn (args)
                  (let ((x (nth args 0)))
                    (if (and (list? x) (> (len x) 1)) (nth x 1) nil)))
    "CDAR"     (fn (args)
                  (let ((x (nth args 0)))
                    (let ((c (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
                      (if (and (list? c) (> (len c) 0)) (rest c) nil))))
    "CDDR"     (fn (args)
                  (let ((x (nth args 0)))
                    (if (and (list? x) (> (len x) 2))
                      (slice x 2 (len x))
                      nil)))
    "CADDR"    (fn (args)
                  (let ((x (nth args 0)))
                    (if (and (list? x) (> (len x) 2)) (nth x 2) nil)))
    "CADDDR"   (fn (args)
                  (let ((x (nth args 0)))
                    (if (and (list? x) (> (len x) 3)) (nth x 3) nil)))
    "PAIRLIS"  (fn (args)
                  (let ((ks (if (= (nth args 0) nil) (list) (nth args 0)))
                        (vs (if (= (nth args 1) nil) (list) (nth args 1))))
                    (map (fn (i) (list (nth ks i) (nth vs i)))
                         (range 0 (len ks)))))
    ;; string ops
    "SUBSEQ"   (fn (args)
                  (let ((seq   (nth args 0))
                        (start (nth args 1))
                        (end   (if (> (len args) 2) (nth args 2) nil)))
                    (if (string? seq)
                      (if end (substr seq start (- end 1)) (substr seq start (- (len seq) 1)))
                      (if (= seq nil) (list)
                        (if end (slice seq start end) (slice seq start (len seq)))))))
    "STRING"   (fn (args)
                  (let ((x (nth args 0)))
                    (if (string? x) x (str x))))
    "CHAR"     (fn (args)
                  (let ((s (nth args 0)) (i (nth args 1)))
                    {:cl-type "char" :value (substr s i (+ i 1))}))
    "CHAR="    (fn (args)
                  (let ((a (nth args 0)) (b (nth args 1)))
                    (let ((av (if (dict? a) (get a "value") a))
                          (bv (if (dict? b) (get b "value") b)))
                      (if (= av bv) true nil))))
    "STRING-LENGTH"   (fn (args) (len (nth args 0)))
    "STRING<"  (fn (args) (if (< (nth args 0) (nth args 1)) true nil))
    "STRING>"  (fn (args) (if (> (nth args 0) (nth args 1)) true nil))
    "STRING<=" (fn (args) (if (<= (nth args 0) (nth args 1)) true nil))
    "STRING>=" (fn (args) (if (>= (nth args 0) (nth args 1)) true nil))
    "WRITE-TO-STRING" (fn (args) (inspect (nth args 0)))
    "SYMBOL-NAME"     (fn (args) (upcase (str (nth args 0))))
    "COERCE"          (fn (args)
                         (let ((x (nth args 0))
                               (tp (upcase (str (nth args 1)))))
                           (cond
                             ((= tp "LIST") (if (string? x)
                               (map (fn (i) {:cl-type "char" :value (substr x i (+ i 1))})
                                    (range 0 (len x))) x))
                             ((= tp "STRING") (if (list? x)
                               (reduce (fn (a c) (str a (if (dict? c) (get c "value") c))) "" x)
                               (str x)))
                             (:else x))))
    "MAKE-LIST" (fn (args)
                   (let ((n (nth args 0)))
                     (map (fn (_) nil) (range 0 n))))))

;; 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)))))))

;; Dynamic variable infrastructure
(define cl-dyn-unbound {:cl-type "dyn-unbound"})
(define cl-specials {})
(define cl-symbol-macros {})
(define cl-mark-special!
  (fn (name) (dict-set! cl-specials name true)))
(define cl-special?
  (fn (name) (has-key? cl-specials name)))
;; Apply dynamic bindings: save old global values, set new, run thunk, restore
(define cl-apply-dyn
  (fn (binds thunk)
    (if (= (len binds) 0)
      (thunk)
      (let ((b          (nth binds 0))
            (rest-binds (rest binds)))
        (let ((name  (get b "name"))
              (val   (get b "value"))
              (gvars (get cl-global-env "vars")))
          (let ((old (if (has-key? gvars name)
                       (get gvars name)
                       cl-dyn-unbound)))
            (dict-set! gvars name val)
            (let ((result (cl-apply-dyn rest-binds thunk)))
              (if (and (dict? old) (= (get old "cl-type") "dyn-unbound"))
                (dict-set! gvars name nil)
                (dict-set! gvars name old))
              result)))))))
;; Sequential LET* with dynamic variable support
(define cl-letstar-bind
  (fn (bs e thunk)
    (if (= (len bs) 0)
      (thunk e)
      (let ((b       (nth bs 0))
            (rest-bs (rest bs)))
        (let ((name (if (list? b) (nth b 0) b))
              (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
          (let ((val (cl-eval init e)))
            (if (cl-special? name)
              (let ((gvars (get cl-global-env "vars")))
                (let ((old (if (has-key? gvars name)
                             (get gvars name)
                             cl-dyn-unbound)))
                  (dict-set! gvars name val)
                  (let ((result (cl-letstar-bind rest-bs e thunk)))
                    (if (and (dict? old) (= (get old "cl-type") "dyn-unbound"))
                      (dict-set! gvars name nil)
                      (dict-set! gvars name old))
                    result)))
              (cl-letstar-bind rest-bs (cl-env-bind-var e name val) thunk))))))))

;; 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
        (cl-letstar-bind bindings env (fn (new-env) (cl-eval-body body new-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 ((spec-pairs (filter (fn (p) (cl-special? (get p "name"))) pairs))
                (lex-pairs  (filter (fn (p) (not (cl-special? (get p "name")))) pairs)))
            (let ((new-env (reduce
                             (fn (e pair)
                               (cl-env-bind-var e (get pair "name") (get pair "value")))
                             env lex-pairs)))
              (cl-apply-dyn spec-pairs
                (fn () (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))
        (cl-mark-special! name)
        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 or symbol-macro lookup)
      ((string? form)
        (let ((uform (upcase form)))
          (if (and (has-key? cl-symbol-macros uform)
                   (not (= (get cl-symbol-macros uform) nil)))
            (cl-eval (get cl-symbol-macros uform) env)
            (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))))


;; Convert a CL cons tree to an SX list (for macro expansion results)
(define cl-cons->sx-list
  (fn (x)
    (if (and (dict? x) (= (get x "cl-type") "cons"))
      (cons (cl-cons->sx-list (get x "car"))
            (cl-cons->sx-list (get x "cdr")))
      (if (and (dict? x) (= (get x "cl-type") "nil"))
        (list)
        (if (list? x)
          (map cl-cons->sx-list x)
          x)))))

;; ── macro expansion ───────────────────────────────────────────────

;; Expand a macro one level. Returns {:expanded bool :form form}
(define cl-macroexpand-1
  (fn (form env)
    (if (not (list? form))
      {:expanded false :form form}
      (if (= (len form) 0)
        {:expanded false :form form}
        (let ((head (nth form 0)))
          (if (not (string? head))
            {:expanded false :form form}
            (let ((uhead (upcase head)))
              (if (has-key? cl-macro-registry uhead)
                {:expanded true
                 :form (cl-cons->sx-list ((get cl-macro-registry uhead) form env))}
                {:expanded false :form form}))))))))

;; Fully expand macros (loop until stable)
(define cl-macroexpand
  (fn (form env)
    (let ((r (cl-macroexpand-1 form env)))
      (if (get r "expanded")
        (cl-macroexpand (get r "form") env)
        (get r "form")))))


;; Helper: bind macro lambda-list params to actuals in env
(define cl-macro-bind-params
  (fn (ps as env)
    (if (= (len ps) 0)
      env
      (let ((p (nth ps 0)))
        (if (= p "&REST")
          (cl-env-bind-var env (nth ps 1) as)
          (cl-macro-bind-params
            (rest ps)
            (if (= (len as) 0) (list) (rest as))
            (cl-env-bind-var env p
              (if (= (len as) 0) nil (nth as 0)))))))))

;; DEFMACRO: store expander function in macro registry
;; (defmacro name (params...) body...)
(define cl-eval-defmacro
  (fn (args env)
    (let ((name (nth args 0))
          (params (nth args 1))
          (body (rest (rest args))))
      (let ((uname (upcase name)))
        (let ((expander
                (fn (form xenv)
                  (let ((actuals (rest form))
                        (bound-env (cl-macro-bind-params (map upcase params) (rest form) env)))
                    (cl-eval-body body bound-env)))))
          (dict-set! cl-macro-registry uname expander)
          uname)))))

;; MACROLET: local macro bindings
;; (macrolet ((name params body...) ...) body...)
(define cl-eval-macrolet
  (fn (args env)
    (let ((bindings (nth args 0))
          (body (rest args)))
      (define orig-registry cl-macro-registry)
      (for-each
        (fn (b)
          (let ((name (nth b 0))
                (params (nth b 1))
                (mbody (rest (rest b))))
            (cl-eval-defmacro (list name params (nth mbody 0)) env)))
        bindings)
      (let ((result (cl-eval-body body env)))
        ;; restore — not perfect isolation but workable
        result))))

;; SYMBOL-MACROLET: bind symbols to expansion forms
(define cl-eval-symbol-macrolet
  (fn (args env)
    (let ((bindings (nth args 0))
          (body (rest args)))
      ;; Install each symbol in cl-symbol-macros; save old to restore after
      (let ((saved (map (fn (b) (let ((sym (upcase (nth b 0))))
                                  {:sym sym :old (if (has-key? cl-symbol-macros sym) (get cl-symbol-macros sym) nil)}))
                        bindings)))
        (for-each
          (fn (b)
            (dict-set! cl-symbol-macros (upcase (nth b 0)) (nth b 1)))
          bindings)
        (let ((result (cl-eval-body body env)))
          (for-each
            (fn (s)
              (if (= (get s "old") nil)
                (dict-set! cl-symbol-macros (get s "sym") nil)
                (dict-set! cl-symbol-macros (get s "sym") (get s "old"))))
            saved)
          result)))))

(define cl-eval-list
  (fn (form env)
    (if (= (len form) 0)
      nil
      (let ((head (nth form 0))
            (args (rest form)))
        (cond
          ;; Macro expansion check
          ((and (string? head) (has-key? cl-macro-registry (upcase head)))
            (cl-eval (cl-macroexpand form env) env))
          ((= 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)
          ((= head "DEFMACRO")     (cl-eval-defmacro args env))
          ((= head "MACROLET")     (cl-eval-macrolet args env))
          ((= head "SYMBOL-MACROLET") (cl-eval-symbol-macrolet args env))
          ((= head "MACROEXPAND-1")
            (let ((arg (cl-eval (nth args 0) env)))
              (cl-macroexpand-1 arg env)))
          ((= head "MACROEXPAND")
            (let ((arg (cl-eval (nth args 0) env)))
              (cl-macroexpand arg env)))
          ((= head "GENSYM")
            (cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) nil)))
          ((= head "GENTEMP")
            (cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) "T")))
          ;; 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)))))