giles
4da91bb9b4
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 12s
lib/common-lisp/eval.sx: cl-eval-ast implementing 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, string ops, funcall/apply/mapcar. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
286 lines
13 KiB
Plaintext
286 lines
13 KiB
Plaintext
;; 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))
|