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

;; --- Dynamic variables ---
(cl-test "defvar marks special"
  (do (ev "(defvar *dv* 10)")
    (cl-special? "*DV*"))
  true)
(cl-test "defvar: let rebinds dynamically"
  (ev "(progn (defvar *x* 1) (defun get-x () *x*) (let ((*x* 99)) (get-x)))")
  99)
(cl-test "defvar: binding restores after let"
  (ev "(progn (defvar *yrst* 5) (let ((*yrst* 42)) *yrst*) *yrst*)")
  5)
(cl-test "defparameter marks special"
  (do (ev "(defparameter *dp* 0)")
    (cl-special? "*DP*"))
  true)
(cl-test "defparameter: let rebinds dynamically"
  (ev "(progn (defparameter *z* 10) (defun get-z () *z*) (let ((*z* 77)) (get-z)))")
  77)
(cl-test "defparameter: always assigns"
  (ev "(progn (defparameter *p* 1) (defparameter *p* 2) *p*)")
  2)
(cl-test "dynamic binding: nested lets"
  (ev "(progn (defvar *n* 0) (let ((*n* 1)) (let ((*n* 2)) *n*)))")
  2)
(cl-test "dynamic binding: restores across nesting"
  (ev "(progn (defvar *m* 10) (let ((*m* 20)) (let ((*m* 30)) nil)) *m*)")
  10)
