giles
4504b8ae5e
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 33s
lib/guest/test-runner.sx — per-suite mutable state {:pass :fail :fails}
+ refl-test recorder + refl-test-report. Replaces the identical
4-define harness that appears in 142+ test files across the codebase.
Each migrated file goes from:
(define X-test-pass 0)
(define X-test-fail 0)
(define X-test-fails (list))
(define X-test (fn (name actual expected) (if (= actual expected)
(set! X-test-pass (+ X-test-pass 1)) (begin ...))))
;; ... tests ...
(define X-tests-run! (fn () {:total ... :passed ... :failed ... :fails ...}))
to:
(define X-suite (refl-make-test-suite))
(define X-test (fn (n a e) (refl-test X-suite n a e)))
;; ... tests ...
(define X-tests-run! (fn () (refl-test-report X-suite)))
All 322 Kernel tests pass unchanged (parse 62, eval 36, vau 38,
standard 127, encap 19, hygiene 26, metacircular 14). 84 LoC removed.
Migration is mechanical (the prefix is the only difference between
suites); /tmp/migrate_harness.py drives the regex. Other guests
(Tcl, Smalltalk, APL, CL, Erlang, Haskell, etc.) migrated in
subsequent commits.
259 lines
7.2 KiB
Plaintext
259 lines
7.2 KiB
Plaintext
;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
|
|
;;
|
|
;; Phase 2 covers literal evaluation, symbol lookup, and combiner
|
|
;; dispatch (operative vs applicative). Standard-environment operatives
|
|
;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
|
|
;; minimal env on the fly and verify the dispatch contract directly.
|
|
|
|
(define ke-suite (refl-make-test-suite))
|
|
(define ke-test (fn (n a e) (refl-test ke-suite n a e)))
|
|
|
|
;; ── helpers ──────────────────────────────────────────────────────
|
|
|
|
(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
|
|
|
|
(define
|
|
ke-make-test-env
|
|
(fn
|
|
()
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind!
|
|
env
|
|
"+"
|
|
(kernel-make-primitive-applicative
|
|
(fn (args) (+ (first args) (nth args 1)))))
|
|
(kernel-env-bind!
|
|
env
|
|
"list"
|
|
(kernel-make-primitive-applicative (fn (args) args)))
|
|
(kernel-env-bind!
|
|
env
|
|
"$quote"
|
|
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
|
(kernel-env-bind!
|
|
env
|
|
"$if"
|
|
(kernel-make-primitive-operative
|
|
(fn
|
|
(args dyn-env)
|
|
(if
|
|
(kernel-eval (first args) dyn-env)
|
|
(kernel-eval (nth args 1) dyn-env)
|
|
(kernel-eval (nth args 2) dyn-env)))))
|
|
env)))
|
|
|
|
;; ── literal evaluation ───────────────────────────────────────────
|
|
(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
|
|
(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
|
|
(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
|
|
(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
|
|
(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
|
|
(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
|
|
(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
|
|
|
|
;; ── symbol lookup ────────────────────────────────────────────────
|
|
(ke-test
|
|
"sym: bound to number"
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind! env "x" 100)
|
|
(ke-eval-src "x" env))
|
|
100)
|
|
|
|
(ke-test
|
|
"sym: bound to string"
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind! env "name" "kernel")
|
|
(ke-eval-src "name" env))
|
|
"kernel")
|
|
|
|
(ke-test
|
|
"sym: parent-chain lookup"
|
|
(let
|
|
((p (kernel-make-env)))
|
|
(kernel-env-bind! p "outer" 1)
|
|
(let
|
|
((c (kernel-extend-env p)))
|
|
(kernel-env-bind! c "inner" 2)
|
|
(+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
|
|
3)
|
|
|
|
(ke-test
|
|
"sym: child shadows parent"
|
|
(let
|
|
((p (kernel-make-env)))
|
|
(kernel-env-bind! p "x" 1)
|
|
(let
|
|
((c (kernel-extend-env p)))
|
|
(kernel-env-bind! c "x" 2)
|
|
(ke-eval-src "x" c)))
|
|
2)
|
|
|
|
(ke-test
|
|
"env-has?: present"
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind! env "x" 1)
|
|
(kernel-env-has? env "x"))
|
|
true)
|
|
|
|
(ke-test
|
|
"env-has?: missing"
|
|
(kernel-env-has? (kernel-make-env) "nope")
|
|
false)
|
|
|
|
;; ── tagged-value predicates ─────────────────────────────────────
|
|
(ke-test
|
|
"tag: operative?"
|
|
(kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
|
|
true)
|
|
|
|
(ke-test
|
|
"tag: applicative?"
|
|
(kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
|
|
true)
|
|
|
|
(ke-test
|
|
"tag: combiner? operative"
|
|
(kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
|
|
true)
|
|
|
|
(ke-test
|
|
"tag: combiner? applicative"
|
|
(kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
|
|
true)
|
|
|
|
(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
|
|
|
|
(ke-test "tag: number is not operative" (kernel-operative? 42) false)
|
|
|
|
;; ── wrap / unwrap ────────────────────────────────────────────────
|
|
(ke-test
|
|
"wrap+unwrap roundtrip"
|
|
(let
|
|
((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
|
|
(= (kernel-unwrap (kernel-wrap op)) op))
|
|
true)
|
|
|
|
(ke-test
|
|
"wrap produces applicative"
|
|
(kernel-applicative?
|
|
(kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
|
|
true)
|
|
|
|
(ke-test
|
|
"unwrap of primitive-applicative is operative"
|
|
(kernel-operative?
|
|
(kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
|
|
true)
|
|
|
|
;; ── combiner dispatch — applicatives evaluate their args ─────────
|
|
(ke-test
|
|
"applicative: simple call"
|
|
(ke-eval-src "(+ 2 3)" (ke-make-test-env))
|
|
5)
|
|
|
|
(ke-test
|
|
"applicative: nested"
|
|
(ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
|
|
10)
|
|
|
|
(ke-test
|
|
"applicative: receives evaluated args"
|
|
(let
|
|
((env (ke-make-test-env)))
|
|
(kernel-env-bind! env "x" 10)
|
|
(kernel-env-bind! env "y" 20)
|
|
(ke-eval-src "(+ x y)" env))
|
|
30)
|
|
|
|
(ke-test
|
|
"applicative: list builds an SX list of values"
|
|
(let
|
|
((env (ke-make-test-env)))
|
|
(kernel-env-bind! env "a" 1)
|
|
(kernel-env-bind! env "b" 2)
|
|
(ke-eval-src "(list a b 99)" env))
|
|
(list 1 2 99))
|
|
|
|
;; ── combiner dispatch — operatives DO NOT evaluate their args ───
|
|
(ke-test
|
|
"operative: $quote returns symbol unevaluated"
|
|
(ke-eval-src "($quote foo)" (ke-make-test-env))
|
|
"foo")
|
|
|
|
(ke-test
|
|
"operative: $quote returns list unevaluated"
|
|
(ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
|
|
(list "+" 1 2))
|
|
|
|
(ke-test
|
|
"operative: $if true branch"
|
|
(ke-eval-src "($if #t 1 2)" (ke-make-test-env))
|
|
1)
|
|
|
|
(ke-test
|
|
"operative: $if false branch"
|
|
(ke-eval-src "($if #f 1 2)" (ke-make-test-env))
|
|
2)
|
|
|
|
(ke-test
|
|
"operative: $if doesn't eval untaken branch"
|
|
(ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
|
|
99)
|
|
|
|
(ke-test
|
|
"operative: $if takes dynamic env for branches"
|
|
(let
|
|
((env (ke-make-test-env)))
|
|
(kernel-env-bind! env "x" 7)
|
|
(ke-eval-src "($if #t x 0)" env))
|
|
7)
|
|
|
|
;; ── operative built ON-THE-FLY can inspect raw expressions ──────
|
|
(ke-test
|
|
"operative: sees raw symbol head"
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind!
|
|
env
|
|
"head"
|
|
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
|
(ke-eval-src "(head (+ 1 2))" env))
|
|
(list "+" 1 2))
|
|
|
|
(ke-test
|
|
"operative: sees dynamic env"
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind! env "x" 999)
|
|
(kernel-env-bind!
|
|
env
|
|
"$probe"
|
|
(kernel-make-primitive-operative
|
|
(fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
|
|
(ke-eval-src "($probe ignored)" env))
|
|
999)
|
|
|
|
;; ── error cases ──────────────────────────────────────────────────
|
|
(ke-test
|
|
"error: unbound symbol"
|
|
(guard
|
|
(e (true :raised))
|
|
(kernel-eval (kernel-parse "nope") (kernel-make-env)))
|
|
:raised)
|
|
|
|
(ke-test
|
|
"error: combine non-combiner"
|
|
(guard
|
|
(e (true :raised))
|
|
(let
|
|
((env (kernel-make-env)))
|
|
(kernel-env-bind! env "x" 42)
|
|
(kernel-eval (kernel-parse "(x 1)") env)))
|
|
:raised)
|
|
|
|
(define ke-tests-run! (fn () (refl-test-report ke-suite)))
|