312 lines
11 KiB
Plaintext
312 lines
11 KiB
Plaintext
// lisp_test — in-process test driver for the tiny Lisp.
|
|
//
|
|
// Drives eval_str on a sequence of source snippets and
|
|
// inspects the returned `*value` (kind + payload). `ww test
|
|
// lisp_test.ww` builds + execs this; exit 0 means every probe
|
|
// passed, non-zero means at least one failed (with `FAIL <name>`
|
|
// on stderr).
|
|
//
|
|
// We exercise the same wwstage cgen edges as lisp.ww itself, so a
|
|
// regression in cross-module type / field access shows up here:
|
|
// - `*value` field reads (.kind / .ival / .fval / .sid)
|
|
// - `(*value | rterror)` returns crossing the
|
|
// use-boundary
|
|
// - module-qualified enum constants (`valkind.INT`) in
|
|
// `==` comparisons and `case let _: rterror =>` arms.
|
|
|
|
use os;
|
|
use fmt;
|
|
use strconv;
|
|
use lispcore;
|
|
|
|
let nfail: i32 = 0;
|
|
let ntotal: i32 = 0;
|
|
|
|
// ---- result printers --------------------------------------------------
|
|
|
|
fn pname(name: str) void = {
|
|
os.write(1, name.ptr, name.len: u64);
|
|
};
|
|
|
|
fn ok(name: str) void = {
|
|
os.write(1, "ok ".ptr, 5u64);
|
|
pname(name);
|
|
os.write(1, "\n".ptr, 1u64);
|
|
};
|
|
|
|
fn fail(name: str, why: str) void = {
|
|
os.write(2, "FAIL ".ptr, 5u64);
|
|
os.write(2, name.ptr, name.len: u64);
|
|
os.write(2, ": ".ptr, 2u64);
|
|
os.write(2, why.ptr, why.len: u64);
|
|
os.write(2, "\n".ptr, 1u64);
|
|
nfail += 1;
|
|
};
|
|
|
|
fn faili(name: str, why: str, got: i64) void = {
|
|
os.write(2, "FAIL ".ptr, 5u64);
|
|
os.write(2, name.ptr, name.len: u64);
|
|
os.write(2, ": ".ptr, 2u64);
|
|
os.write(2, why.ptr, why.len: u64);
|
|
os.write(2, " got=".ptr, 5u64);
|
|
let buf: [32]u8;
|
|
let n: i32 = strconv.i64tos(buf[0:32], got);
|
|
os.write(2, buf.ptr, n: u64);
|
|
os.write(2, "\n".ptr, 1u64);
|
|
nfail += 1;
|
|
};
|
|
|
|
// ---- assertion helpers ------------------------------------------------
|
|
//
|
|
// Each `check_*` evaluates `input` against the supplied env, then
|
|
// verifies the result. We always bind the result to a local *value
|
|
// before doing field access — the wwstage cgen drops the trailing
|
|
// field load on chained `xs[0].kind`-style reads.
|
|
|
|
fn check_int(name: str, input: str, expected: i64, ep: **env) void = {
|
|
ntotal += 1;
|
|
let r = eval_str(input, ep);
|
|
match (r) {
|
|
case let v: *value => {
|
|
let p: *value = v;
|
|
if (p.kind != valkind.INT) {
|
|
fail(name, "kind != INT");
|
|
return;
|
|
};
|
|
if (p.ival != expected) {
|
|
faili(name, "wrong i64", p.ival);
|
|
return;
|
|
};
|
|
ok(name);
|
|
};
|
|
case let _e: rterror => fail(name, "rterror");
|
|
};
|
|
};
|
|
|
|
fn check_bool(name: str, input: str, expected: bool, ep: **env) void = {
|
|
ntotal += 1;
|
|
let r = eval_str(input, ep);
|
|
match (r) {
|
|
case let v: *value => {
|
|
let p: *value = v;
|
|
if (p.kind != valkind.BOOL) {
|
|
fail(name, "kind != BOOL");
|
|
return;
|
|
};
|
|
let want: i32 = 0;
|
|
if (expected) { want = 1; };
|
|
if (p.bval != want) {
|
|
faili(name, "wrong bool", p.bval: i64);
|
|
return;
|
|
};
|
|
ok(name);
|
|
};
|
|
case let _e: rterror => fail(name, "rterror");
|
|
};
|
|
};
|
|
|
|
fn check_kind(name: str, input: str, want: valkind, ep: **env) void = {
|
|
ntotal += 1;
|
|
let r = eval_str(input, ep);
|
|
match (r) {
|
|
case let v: *value => {
|
|
let p: *value = v;
|
|
if (p.kind != want) {
|
|
faili(name, "wrong kind", p.kind as i32: i64);
|
|
return;
|
|
};
|
|
ok(name);
|
|
};
|
|
case let _e: rterror => fail(name, "rterror");
|
|
};
|
|
};
|
|
|
|
// Float — bit-equal comparison through the `fbuf` route lispcore uses
|
|
// elsewhere. f64 hand-routing avoids the cgen's mis-lowering of f64
|
|
// reads from struct fields.
|
|
let chkfbuf: f64 = 0.0;
|
|
|
|
fn fapprox(a: f64, b: f64) bool = {
|
|
// Tolerance 1e-6 — enough for "is the answer right?" without
|
|
// pulling in a real float compare.
|
|
let d: f64 = a - b;
|
|
if (d < 0.0) { d = -d; };
|
|
return d < 0.000001;
|
|
};
|
|
|
|
fn check_float(name: str, input: str, expected: f64, ep: **env) void = {
|
|
ntotal += 1;
|
|
let r = eval_str(input, ep);
|
|
match (r) {
|
|
case let v: *value => {
|
|
let p: *value = v;
|
|
if (p.kind != valkind.FLOAT) {
|
|
fail(name, "kind != FLOAT");
|
|
return;
|
|
};
|
|
// Cross-module *f64-via-pointer-deref read of v.fval.
|
|
let raw: *u8 = p: *u8;
|
|
let fp: *f64 = (raw + 16u64): *f64;
|
|
let got: f64 = *fp;
|
|
if (!fapprox(got, expected)) {
|
|
fail(name, "wrong float");
|
|
return;
|
|
};
|
|
ok(name);
|
|
};
|
|
case let _e: rterror => fail(name, "rterror");
|
|
};
|
|
};
|
|
|
|
fn check_err(name: str, input: str, ep: **env) void = {
|
|
ntotal += 1;
|
|
let r = eval_str(input, ep);
|
|
match (r) {
|
|
case let _v: *value => fail(name, "expected rterror, got value");
|
|
case let _e: rterror => ok(name);
|
|
};
|
|
};
|
|
|
|
// run an expression for its effect (e.g. `(define ...)`); ignore the
|
|
// returned nil. Test passes iff there's no runtime error.
|
|
fn run(name: str, input: str, ep: **env) void = {
|
|
ntotal += 1;
|
|
let r = eval_str(input, ep);
|
|
match (r) {
|
|
case let _v: *value => ok(name);
|
|
case let _e: rterror => fail(name, "rterror during run");
|
|
};
|
|
};
|
|
|
|
// ---- entry ------------------------------------------------------------
|
|
|
|
export fn main() i32 = {
|
|
// Shared env across the whole suite. `define`s leak between
|
|
// probes so later tests can reference `fact`, `square`, etc.
|
|
let e: *env = nil;
|
|
let ep: **env = &e;
|
|
initsyms();
|
|
bind_builtins(ep);
|
|
|
|
// ---- atoms + simple arithmetic ----
|
|
check_int ("int-literal", "42", 42i64, ep);
|
|
check_int ("add", "(+ 1 2 3 4 5)", 15i64, ep);
|
|
check_int ("sub", "(- 100 25 25)", 50i64, ep);
|
|
check_int ("mul", "(* 6 7)", 42i64, ep);
|
|
check_int ("div", "(/ 100 5)", 20i64, ep);
|
|
check_int ("div-3way", "(/ 1000 10 5)", 20i64, ep);
|
|
check_int ("mod", "(mod 17 5)", 2i64, ep);
|
|
check_int ("neg", "(- 7)", -7i64, ep);
|
|
check_int ("nested", "(+ (* 2 3) (* 4 5))", 26i64, ep);
|
|
|
|
// ---- comparisons ----
|
|
check_bool ("eq-true", "(= 5 5)", true, ep);
|
|
check_bool ("eq-false", "(= 5 6)", false, ep);
|
|
check_bool ("lt-chained", "(< 1 2 3 4)", true, ep);
|
|
check_bool ("lt-fail", "(< 1 2 2)", false, ep);
|
|
check_bool ("gt", "(> 5 3 1)", true, ep);
|
|
check_bool ("le", "(<= 3 3 4)", true, ep);
|
|
|
|
// ---- conditionals + truthy ----
|
|
check_int ("if-then", "(if #t 1 2)", 1i64, ep);
|
|
check_int ("if-else", "(if #f 1 2)", 2i64, ep);
|
|
check_int ("if-truthy-int", "(if 0 1 2)", 1i64, ep);
|
|
check_bool ("not-false", "(not #f)", true, ep);
|
|
|
|
// ---- lists ----
|
|
check_kind ("quote-list-cons", "'(1 2 3)", valkind.CONS, ep);
|
|
check_kind ("empty-list-nil", "'()", valkind.NIL, ep);
|
|
check_kind ("cons-cell", "(cons 1 2)", valkind.CONS, ep);
|
|
check_int ("car", "(car '(11 22 33))", 11i64, ep);
|
|
check_int ("car-of-list", "(car (list 7 8))", 7i64, ep);
|
|
check_int ("len-cdr", "(car (cdr '(1 2 3)))",2i64, ep);
|
|
check_bool ("null?-empty", "(null? '())", true, ep);
|
|
check_bool ("null?-pair", "(null? '(1))", false, ep);
|
|
check_bool ("pair?-cons", "(pair? '(a))", true, ep);
|
|
check_bool ("pair?-atom", "(pair? 'a)", false, ep);
|
|
|
|
// ---- predicates ----
|
|
check_bool ("number?-int", "(number? 42)", true, ep);
|
|
check_bool ("number?-float", "(number? 3.14)", true, ep);
|
|
check_bool ("number?-sym", "(number? 'foo)", false, ep);
|
|
check_bool ("symbol?-sym", "(symbol? 'foo)", true, ep);
|
|
check_bool ("symbol?-int", "(symbol? 1)", false, ep);
|
|
check_bool ("eq?-sym", "(eq? 'a 'a)", true, ep);
|
|
check_bool ("eq?-int", "(eq? 7 7)", true, ep);
|
|
check_bool ("eq?-mixed", "(eq? 'a 1)", false, ep);
|
|
|
|
// ---- define + lookup + set! ----
|
|
run ("def-x", "(define x 100)", ep);
|
|
check_int ("ref-x", "x", 100i64, ep);
|
|
run ("set-x", "(set! x 7)", ep);
|
|
check_int ("ref-x-set", "x", 7i64, ep);
|
|
|
|
// ---- lambdas + recursion ----
|
|
run ("def-sq", "(define sq (lambda (n) (* n n)))", ep);
|
|
check_int ("call-sq", "(sq 9)", 81i64, ep);
|
|
run ("def-fact", "(define fact (lambda (n) (if (<= n 1) 1 (* n (fact (- n 1))))))", ep);
|
|
check_int ("fact-5", "(fact 5)", 120i64, ep);
|
|
check_int ("fact-10", "(fact 10)", 3628800i64, ep);
|
|
run ("def-fib", "(define fib (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))", ep);
|
|
check_int ("fib-10", "(fib 10)", 55i64, ep);
|
|
check_int ("fib-15", "(fib 15)", 610i64, ep);
|
|
run ("def-gcd", "(define gcd (lambda (a b) (if (= b 0) a (gcd b (mod a b)))))", ep);
|
|
check_int ("gcd", "(gcd 60 48)", 12i64, ep);
|
|
|
|
// ---- higher-order ----
|
|
run ("def-map", "(define mp (lambda (f l) (if (null? l) '() (cons (f (car l)) (mp f (cdr l))))))", ep);
|
|
run ("def-inc", "(define inc (lambda (n) (+ n 1)))", ep);
|
|
check_kind ("map-yields-list", "(mp inc '(1 2 3))", valkind.CONS, ep);
|
|
check_int ("map-car", "(car (mp inc '(1 2 3)))", 2i64, ep);
|
|
|
|
// ---- let + begin ----
|
|
check_int ("let-product", "(let ((a 3) (b 4)) (* a b))", 12i64, ep);
|
|
check_int ("begin-last", "(begin 1 2 (+ 10 20))", 30i64, ep);
|
|
|
|
// ---- tail-call optimization ----
|
|
// 30k iterations is well past the pre-TCO segfault threshold
|
|
// (~25k) but still completes inside the test budget. Each probe
|
|
// exercises a different tail position: lambda body via if,
|
|
// lambda body via begin, and lambda body via let.
|
|
run ("def-spin", "(define spin (lambda (n a) (if (= n 0) a (spin (- n 1) (+ a 1)))))", ep);
|
|
check_int ("tco-if", "(spin 30000 0)", 30000i64, ep);
|
|
run ("def-bspin", "(define bspin (lambda (n a) (if (= n 0) a (begin a (bspin (- n 1) (+ a 1))))))", ep);
|
|
check_int ("tco-begin", "(bspin 30000 0)", 30000i64, ep);
|
|
run ("def-lspin", "(define lspin (lambda (n a) (if (= n 0) a (let ((m (- n 1))) (lspin m (+ a 1))))))", ep);
|
|
check_int ("tco-let", "(lspin 30000 0)", 30000i64, ep);
|
|
|
|
// ---- floats ----
|
|
check_float("float-add", "(+ 1.5 2.5)", 4.0, ep);
|
|
check_float("float-mul", "(* 0.5 0.5)", 0.25, ep);
|
|
check_float("float-div", "(/ 22.0 7.0)", 3.142857, ep);
|
|
check_float("float-promote", "(+ 1 2.5)", 3.5, ep);
|
|
check_bool ("float-cmp", "(< 1.0 2.0)", true, ep);
|
|
|
|
// ---- runtime errors ----
|
|
check_err ("err-unbound", "this-symbol-isnt-bound", ep);
|
|
check_err ("err-car-not-pair", "(car 1)", ep);
|
|
check_err ("err-div-zero", "(/ 5 0)", ep);
|
|
check_err ("err-bad-arg", "(+ 'a 'b)", ep);
|
|
|
|
// ---- summary ----
|
|
let buf: [32]u8;
|
|
let n: i32 = 0;
|
|
if (nfail == 0) {
|
|
os.write(1, "\nlisp_test: ".ptr, 12u64);
|
|
n = strconv.i64tos(buf[0:32], ntotal: i64);
|
|
os.write(1, buf.ptr, n: u64);
|
|
os.write(1, "/".ptr, 1u64);
|
|
os.write(1, buf.ptr, n: u64);
|
|
os.write(1, " pass\n".ptr, 6u64);
|
|
return 0;
|
|
};
|
|
os.write(2, "\nlisp_test: ".ptr, 12u64);
|
|
n = strconv.i64tos(buf[0:32], nfail: i64);
|
|
os.write(2, buf.ptr, n: u64);
|
|
os.write(2, " of ".ptr, 4u64);
|
|
n = strconv.i64tos(buf[0:32], ntotal: i64);
|
|
os.write(2, buf.ptr, n: u64);
|
|
os.write(2, " failed\n".ptr, 8u64);
|
|
return 1;
|
|
};
|