diff --git a/.gitignore b/.gitignore index 8c01ef63..59e3938f 100644 --- a/.gitignore +++ b/.gitignore @@ -29,6 +29,9 @@ examples/**/*.o examples/**/*.s examples/**/*.combined.ww examples/mandelbrot/mandelbrot +examples/cmatrix/cmatrix +examples/lisp/lisp +examples/lisp/lisp_test # Stage-0 binaries under bootstrap//. Untracked by default — # committing them is the v1.0 lock per PLAN.md (the new trust diff --git a/examples/lisp/CLAUDE.md b/examples/lisp/CLAUDE.md new file mode 100644 index 00000000..bbed7565 --- /dev/null +++ b/examples/lisp/CLAUDE.md @@ -0,0 +1,154 @@ +examples/lisp — tiny Lisp interpreter in pure ww. Demo program; not a +production interpreter. Treat the files below as a worked example of +"what does and doesn't lower cleanly through the wwstage cgen today", +not as a reference Lisp implementation. + +## Layout + +- `lispcore.ww` interpreter module: types, lexer, parser, env, + eval, apply, printer, REPL. Everything the entry + point and the test driver consume is `export`-ed. +- `lisp.ww` entry point; `use lispcore;` + `main()`. +- `lisp_test.ww` in-process test driver (66 probes). Built as a + standalone binary, exec'd directly — `ww test` + drops `-I` in single-file mode, so the Makefile + runs the binary itself. +- `test_*.lisp` demo source files (`cat test_X.lisp | ./lisp`). + +The lispcore.ww + lisp.ww split exists so the tests can `use` the +interpreter functions. Both files combine under the same module name +(the directory's basename, `lisp`), because `ww`'s module resolver +takes the *containing-directory* basename when finding a sibling. +Cross-module type prefixes like `lispcore.value` don't resolve in the +test — use the bare names. + +## wwstage cgen workarounds at play + +Every workaround below is documented inline at its use site. The +shape of the bug is what matters, not the specific symptom — the +same bug class shows up in any new code that hits the same pattern. + +1. **Top-level `[N]T` arrays mis-address inside functions.** + `globalarr[i] = …` lowers to `LEAQ (BP), BX` instead of + `LEAQ globalarr(SB), BX` — the global address gets treated as a + stack frame, corrupting both. Heap-allocate via `os.alloc` into a + `*T` and alias to a local at the top of each function before + indexing. See `sym_off` / `sym_blob` / `obuf`. + +2. **`global_ptr[i]` mis-addresses too.** Even after switching to a + pointer global, `MOVQ global_ptr(SB), BX` is replaced with + `MOVQ (BP), BX`. Alias `let p = global_ptr;` at function entry, + then `p[i]`. See every helper that touches the symbol interner. + +3. **Two-level field write through a non-pointer sub-struct.** + `L.cur.kind = k` or `L.src.ptr = buf.ptr` (where `cur`/`src` is a + non-pointer struct field of a struct reached through a pointer) is + silently dropped — the function body emits no store. Either + flatten the sub-struct (see `lexer.curkind`/`curival`/…) or build + the whole sub-struct as a local and do a single whole-struct + assign (`let s: str = …; L.src = s;`). + +4. **f64 through every boundary is unreliable.** The cgen routes f64 + stores via integer registers; in most paths AX gets stored where + X0 should have been written. + - `alloc(value{ fval = v })`: writes the kind enum (AX still + holds it) instead of the f64. + - `p.fval = v` through a `*T`: same — stores AX. + - `*p = v` for `*f64`: stores AX. + - `func(f64_arg)` where the source is a struct field: cgen does + `MOVQ off(BX), AX` (integer load) and never puts the bits in X0. + + What does work: `MOVSD X0, global(SB)` (a top-level f64 global) + and `MOVSD X0, off(BP)` (a local f64 slot). The interpreter + threads f64 through a scratch global (`fbuf`) and byte-copies + 8 bytes wherever a `*f64` would normally suffice. See `vfloat`, + `to_f64`, `copybytes`. + +5. **`alloc(value{ text = s })` writes only `s.ptr`.** The cgen sets + up `s.ptr` in AX, sets the new-pointer in BX, then needs `s.len` + in another reg — but the same BX gets clobbered by the new-pointer + reload, so the `.len` store never happens. Manual init via + `p.text = s` writes both halves correctly. + +6. **`(slice | E)` tagged-union returns drop `slice.len`.** The + wwstage return convention is AX=tag, DX=payload1, CX=payload2. A + slice header is 24 bytes (ptr/len/cap); only ptr and cap come + through in DX/CX. The intermediate `BX = s.len` is loaded but + never moved into a return register. Inline the slice-building + loop into the caller instead of factoring it into a helper. See + `eval`'s argument-eval inline. + +7. **`xs[i].kind` drops the trailing field load.** Field access on a + slice element gives back only the bytes at `&xs[i]` — the cgen + doesn't chain the dereference. Bind to a local first: + `let p = xs[i]; if (p.kind …)`. See every builtin. + +8. **f64 compound assigns are mis-lowered to `acc = d` (no OP).** + `acc += f` / `acc /= f` etc. on f64 locals drop the operator. + Write the explicit form: `acc = acc + f` / `acc = acc / f`. + Integer compound assigns work fine, so `acc += i` on `i64` + stays as-is. + +If a new function "should work but acts weird", the bug is almost +always one of the above and shows up under valgrind/gdb the same +way it did the first time: silently dropped store, missing field +read, garbage payload after a tagged-union return. + +## Interpreter limitations (design, not bug) + +- **No GC.** Every cons / value / env frame is `mmap`'d via + `rt_alloc` and never reclaimed. A long REPL session leaks until + the process exits. The test_huge demo peaks at ~595 MB under + `--pages-as-heap=yes`. Per-top-level-form arena reset would cut + this by ~100× — see the closing note in `repl()` for the hook + point. +- **No tail-call optimization.** Recursion grows the C-side stack + one frame per Lisp call. `(spin 100000 0)` will eventually stack- + overflow even though it's tail-recursive in source. +- **No bigints.** `i64` wraps silently on overflow. `(fact 21)` + rolls over. +- **Float printing is fixed `%.6f`.** `1.0` prints as `1.000000`. + Strconv has no `ftos` yet. +- **String escapes are accepted but not translated.** `"\n"` in + source lands as the two bytes `\\` + `n`, not a newline. +- **No `(load)` / file I/O builtins.** Programs come in via stdin. + +## Latent issues — not observed, but the surface to watch + +- Other i64 compound assigns in the cgen aren't audited site-by-site. + Workaround #8 covers f64; if you add new arithmetic on integers + inside a hot loop, scan the asm. +- The interactive REPL's `shift_buf(L.curstart)` assumes `parse_expr` + always primes exactly one token of lookahead after returning success. + A future parser change that skips that prime silently eats input. +- The `define` tie-back prepends a self-binding frame onto + `bv.envp`. It assumes constructors always initialize `envp`. They + do today. +- Cross-module type names (`lispcore.value`) don't resolve; we + side-step by using bare names. If `ww`'s module resolver starts + honoring the qualified form, the tests still work — but if it + starts *rejecting* unqualified cross-module references, both + files break. + +## Build / test / profile + +``` +make # build ./lisp +make test # build + run lisp_test (66 in-process probes) +make demo # cat each test_*.lisp through ./lisp +make clean +``` + +Demo files are pipe-driven: `cat test_arith.lisp | ./lisp`. + +Valgrind: + +``` +valgrind --error-exitcode=2 ./lisp < test_huge.lisp +valgrind --tool=massif --pages-as-heap=yes ./lisp < test_huge.lisp +``` + +The memcheck leak counter reads "0 allocs / 0 frees" because +`rt_alloc` is `mmap`, not `malloc`. Memcheck still catches uninit +reads, bad accesses, and stack issues. For real heap-shape analysis +use massif with `--pages-as-heap=yes`. diff --git a/examples/lisp/Makefile b/examples/lisp/Makefile new file mode 100644 index 00000000..c4dfb4ae --- /dev/null +++ b/examples/lisp/Makefile @@ -0,0 +1,48 @@ +# examples/lisp — tiny Lisp interpreter, built with the ww toolchain. +# No FFI: the program lives entirely on lib/* and libwwrt.a. +# +# Layout +# lisp.ww entry point. `use lispcore;` + `main()` = repl(). +# lispcore.ww interpreter module. Types/functions are `export`-ed +# so both lisp.ww and lisp_test.ww consume them via +# the same `use lispcore;`. +# lisp_test.ww in-process test driver, executed by `make test` +# (which invokes `ww test`). +# +# `ww`'s module resolver uses the *directory's basename* as the module +# name when finding `lispcore.ww` through `-I `. Passing the +# absolute path of the current directory keeps that name stable +# (otherwise `-I.` collapses to ".", and the cgen mangles symbols as +# `..helper`, which then breaks the assembler). + +WW := $(shell cd ../..; pwd)/out/bin/ww +HERE := $(shell pwd) + +lisp: lisp.ww lispcore.ww + $(WW) build lisp.ww -I $(HERE) + +# `ww test ` in single-file mode discards extra args, so we +# can't pass `-I` through it. Build the test as a normal binary and +# exec it directly — exit 0 means all probes passed. +test: lisp_test lisp + ./lisp_test + +lisp_test: lisp_test.ww lispcore.ww + $(WW) build lisp_test.ww -I $(HERE) + +# Demo programs in tree. `make demo` runs every test_*.lisp through +# the REPL; each prints its results to stdout (errors go to stderr +# and don't break the run). Useful as a smoke check after edits. +DEMOS := test_arith.lisp test_list.lisp test_lambda.lisp test_error.lisp + +demo: lisp + @for f in $(DEMOS); do \ + echo "==> $$f"; \ + ./lisp < $$f; \ + done + +clean: + rm -f lisp lisp.o lisp.s lisp.combined.ww \ + lisp_test lisp_test.o lisp_test.s lisp_test.combined.ww + +.PHONY: clean test demo diff --git a/examples/lisp/lisp.ww b/examples/lisp/lisp.ww new file mode 100644 index 00000000..7d68ca65 --- /dev/null +++ b/examples/lisp/lisp.ww @@ -0,0 +1,10 @@ +// lisp — entry point. The interpreter lives in `lispcore.ww`; this +// file only wires it to `main()` so `ww build lisp.ww` produces the +// REPL binary. The matching tests live in `lisp_test.ww` and pull +// the same module via `use lispcore;`. + +use lispcore; + +export fn main() i32 = { + return lispcore.repl(); +}; diff --git a/examples/lisp/lisp_test.ww b/examples/lisp/lisp_test.ww new file mode 100644 index 00000000..68aa95b5 --- /dev/null +++ b/examples/lisp/lisp_test.ww @@ -0,0 +1,299 @@ +// 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 ` +// 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); + + // ---- 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; +}; diff --git a/examples/lisp/lispcore.ww b/examples/lisp/lispcore.ww new file mode 100644 index 00000000..72e8a39e --- /dev/null +++ b/examples/lisp/lispcore.ww @@ -0,0 +1,1469 @@ +// lispcore — tiny Lisp interpreter module. The public surface that +// lisp.ww (the REPL entry point) and lisp_test.ww (the in-process +// test driver) consume. Pure-stdlib: no @symbol FFI of its own +// (every system call routes through lib/os, lib/fmt, lib/ascii, +// lib/strconv, lib/strings). +// +// What this exercises across the ww language: +// - tagged-union returns with many variants: +// (*value | rterror) from eval / apply +// (*value | parserr | eof) from the parser +// - `match` with `yield` so the REPL dispatch is one expression +// - `?` to propagate the error variant up the call chain +// - struct types + struct literals + the `alloc(structlit{...})` +// constructor sugar (subject to the f64/str traps below) +// - enum types (valkind, sform, btin, tkind) + `switch` dispatch +// - tagged-union-typed function parameters + bool-return helpers +// - `[]*value` slices with `append(s, v)` growth +// - `for (let x .. xs)` byte/element range loop +// - classic `for (cond)` + `break` +// - `defer` to release the slurp buffer on every exit edge +// - runes ('a'), str literals, f64 arithmetic, mixed i64/f64 promo +// - module imports (use os/fmt/ascii/strconv/strings) +// +// Build: make +// Run: ./lisp — REPL on stdin +// echo '(+ 1 2)' | ./lisp +// +// Surface: +// atoms nil, #t, #f, integers, floats, "strings", symbols +// special quote if define lambda let begin set! +// builtins + - * / mod = < > <= >= cons car cdr list +// null? pair? number? symbol? eq? not print println +// +// wwstage cgen workarounds in this file (search for "wwstage" or the +// trap name for context at each site): +// +// - top-level `[N]T` arrays are mis-addressed inside functions +// (LEAQ from BP, not from the SB symbol). Heap-allocate via +// os.alloc into a `*T` and alias to a local before indexing. +// - `global_ptr[i]` is mis-addressed too — alias `global` into a +// local `*T` at function entry; `local_ptr[i]` then works. +// - two-level field stores `L.cur.kind = k` (with `cur` a non- +// pointer sub-struct) silently drop. Flatten the inner fields. +// - `alloc(value{ fval = ... })` and `p.fval = …` store an integer +// reg at the f64 offset. Same for `*p = v` when p is *f64. +// Routing through a top-level f64 global + byte copy is reliable. +// - `alloc(value{ text = s })` writes only s.ptr, not s.len. +// Manual init via `p.text = s` writes both halves. +// - `(slice | E)` tagged-union returns drop the slice's `len`. +// Inline the slice builder; don't return it through tagged-union. +// - `xs[i].kind` reads only the slice index, drops the trailing +// field load. Bind `let p = xs[i];` first. +// - `acc /= d` / `acc += f` on f64 locals lower to `acc = d` (drop +// the OP). Write the explicit form `acc = acc OP d`. + +use os; +use fmt; +use ascii; +use strconv; +use strings; + +// ---- value representation --------------------------------------------- +// +// One heap-allocated `value` per atom or cons cell. ww doesn't have +// C-style unions, so every variant carries the full payload set; the +// `kind` tag tells us which fields are live. ~72 bytes is acceptable +// for a demo — every cons cell allocates one. + +export type valkind = enum i32 { + NIL = 0, + BOOL = 1, + INT = 2, + FLOAT = 3, + SYM = 4, + STR = 5, + CONS = 6, + BUILTIN = 7, + LAMBDA = 8, +}; + +export type value = struct { + kind: valkind, + bval: i32, // BOOL: 0/1 + ival: i64, // INT, BUILTIN id, LAMBDA arity + fval: f64, // FLOAT + sid: i32, // SYM — interner id + text: str, // STR + car: *value, // CONS car / LAMBDA params head + cdr: *value, // CONS cdr / LAMBDA body head + envp: *env, // LAMBDA captured env +}; + +// 4+4+8+8+4+pad+16+8+8+8 = 72 with natural alignment. Round up to 96 +// so any future field growth (or alignment surprise from the wwstage +// cgen) doesn't corrupt the next heap cell. +def VALUE_SZ: u64 = 96u64; + +// env — single linked list of (sym → value) bindings. Adding a new +// scope is just a prepend; lookup walks the chain head→tail. +export type env = struct { + sid: i32, + val: *value, + next: *env, +}; +def ENV_SZ: u64 = 32u64; + +// ---- error variants --------------------------------------------------- + +export type rterror = !str; // runtime: division by zero, unbound symbol, … +export type parserr = !str; // parse: bad token, unterminated string, … +export type eof = !void; // parser: end of input — distinct from a parse error + +// ---- value constructors ---------------------------------------------- +// +// alloc(structlit{...}) sugar: cgen rewrites this to rt_alloc(VALUE_SZ) +// + per-field stores, returning a freshly-init'd *value. Mirrors the +// `new T(...)` ergonomics other languages have without ww needing +// constructors or generics. + +export fn vnil() *value = { + return alloc(value{ kind = valkind.NIL }); +}; + +export fn vbool(b: bool) *value = { + let n: i32 = 0; + if (b) { n = 1; }; + return alloc(value{ kind = valkind.BOOL, bval = n }); +}; + +export fn vint(v: i64) *value = { + return alloc(value{ kind = valkind.INT, ival = v }); +}; + +// f64 → struct-field via a *T pointer is mis-lowered (stores AX instead +// of MOVSD from X0). MOVSD into a top-level f64 global works, so route +// the bits through a scratch global and copy them as bytes. +def FVAL_OFF: u64 = 16u64; +let fbuf: f64 = 0.0; + +fn vfloat(v: f64) *value = { + fbuf = v; + let p: *value = os.alloc(VALUE_SZ): *value; + p.kind = valkind.FLOAT; + let raw: *u8 = p: *u8; + let dst: *u8 = raw + FVAL_OFF; + let srcp: *f64 = &fbuf; + let src: *u8 = srcp: *u8; + let i: u64 = 0u64; + for (i < 8u64) { dst[i] = src[i]; i += 1u64; }; + return p; +}; + +export fn vsym(id: i32) *value = { + return alloc(value{ kind = valkind.SYM, sid = id }); +}; + +// alloc(value{ text = s }) writes only s.ptr — the BX register holding +// s.len is clobbered by the new-ptr reload before the .len store. +// Manual init writes both halves correctly. +fn vstr(s: str) *value = { + let p: *value = os.alloc(VALUE_SZ): *value; + p.kind = valkind.STR; + p.text = s; + return p; +}; + +export fn vcons(a: *value, d: *value) *value = { + return alloc(value{ kind = valkind.CONS, car = a, cdr = d }); +}; + +fn vbuiltin(id: i32) *value = { + return alloc(value{ kind = valkind.BUILTIN, ival = id: i64 }); +}; + +fn vlambda(params: *value, body: *value, e: *env) *value = { + return alloc(value{ + kind = valkind.LAMBDA, + car = params, + cdr = body, + envp = e, + }); +}; + +// ---- symbol interner -------------------------------------------------- +// +// Parallel arrays. The `def NAME: [N]T` form keeps everything in .bss +// — no heap, no init. The wwstage cgen treats `[N]` arrays +// as primitive-sized for indexing, which is the trap cmatrix's comment +// warns about; we hold every per-symbol field as its own array. + +def SYM_CAP: i32 = 256; +def SYM_BLOBSZ: i32 = 8192; + +// Backing storage is heap-allocated by main() rather than declared as +// a top-level `[N]T` global, because the wwstage cgen still mis-lowers +// `globalarr[i] = …` (variable index) to `LEAQ (BP), BX` — it treats +// the global address as if it were on the stack. Pointers indexed +// through `[i]` go through the cmatrix path (LEAQ from rt_alloc result) +// which works. +let sym_off: *i32 = nil; +let sym_len: *i32 = nil; +let sym_blob: *u8 = nil; +let sym_count: i32 = 0; +let sym_blobuse: i32 = 0; + +// Pre-interned ids for the special-form / builtin tables. Computed in +// initsyms(); the consts below are filled at runtime, not at compile +// time, so we keep them as plain mutable globals. +let SID_QUOTE: i32 = 0; +let SID_IF: i32 = 0; +let SID_DEFINE: i32 = 0; +let SID_LAMBDA: i32 = 0; +let SID_LET: i32 = 0; +let SID_BEGIN: i32 = 0; +let SID_SETBANG: i32 = 0; + +// streqid / intern / symname all alias the global *T pointers into +// locals before indexing. The wwstage cgen mis-lowers `global[i]` when +// `global` is a pointer-typed top-level let: it reads BP+0 instead of +// `LEAQ global(SB)`. Through a local the address path is correct. + +fn streqid(a: str, off: i32, len: i32) bool = { + if (a.len != len) { return false; }; + let blob: *u8 = sym_blob; + let i: i32 = 0; + for (i < len) { + if (a[i] != blob[off + i]) { return false; }; + i += 1; + }; + return true; +}; + +export fn intern(s: str) i32 = { + let offt: *i32 = sym_off; + let lent: *i32 = sym_len; + let blob: *u8 = sym_blob; + let i: i32 = 0; + for (i < sym_count) { + if (streqid(s, offt[i], lent[i])) { return i; }; + i += 1; + }; + os.assert(sym_count < SYM_CAP, "sym table full"); + os.assert(sym_blobuse + s.len <= SYM_BLOBSZ, "sym blob full"); + let off: i32 = sym_blobuse; + let j: i32 = 0; + for (j < s.len) { + blob[off + j] = s[j]; + j += 1; + }; + offt[sym_count] = off; + lent[sym_count] = s.len; + let id: i32 = sym_count; + sym_count += 1; + sym_blobuse += s.len; + return id; +}; + +fn symname(id: i32) str = { + let offt: *i32 = sym_off; + let lent: *i32 = sym_len; + let r: str; + r.ptr = sym_blob + offt[id]; + r.len = lent[id]; + return r; +}; + +// ---- builtin / special-form ids -------------------------------------- + +type sform = enum i32 { + NONE = 0, + QUOTE = 1, + IF = 2, + DEFINE = 3, + LAMBDA = 4, + LET = 5, + BEGIN = 6, + SETBANG = 7, +}; + +type btin = enum i32 { + ADD = 0, + SUB = 1, + MUL = 2, + DIV = 3, + MOD = 4, + EQ = 5, + LT = 6, + GT = 7, + LE = 8, + GE = 9, + CONS = 10, + CAR = 11, + CDR = 12, + LIST = 13, + NULLP = 14, + PAIRP = 15, + NUMP = 16, + SYMP = 17, + EQP = 18, + NOT = 19, + PRINT = 20, + PRINTLN = 21, +}; + +// classify_sform — special-forms are recognised by the *symbol id* of +// the operator, so the lexer doesn't need to know about them. Symbol +// ids for SID_QUOTE etc. are filled in by initsyms(). +fn classify_sform(id: i32) sform = { + if (id == SID_QUOTE) { return sform.QUOTE; }; + if (id == SID_IF) { return sform.IF; }; + if (id == SID_DEFINE) { return sform.DEFINE; }; + if (id == SID_LAMBDA) { return sform.LAMBDA; }; + if (id == SID_LET) { return sform.LET; }; + if (id == SID_BEGIN) { return sform.BEGIN; }; + if (id == SID_SETBANG) { return sform.SETBANG; }; + return sform.NONE; +}; + +// ---- lexer ------------------------------------------------------------ +// +// Token-by-token over a borrowed []u8 source. `(`, `)`, `'` are single +// chars; integers/floats/strings/symbols all need a small state body. + +type tkind = enum i32 { + END = 0, // out of input + LPAREN = 1, + RPAREN = 2, + QUOTE = 3, // ' + INT = 4, + FLOAT = 5, + STR = 6, + SYM = 7, + TRUE = 8, + FALSE = 9, +}; + +// Current-token fields are flattened into `lexer`. ww's wwstage cgen +// drops two-level field stores like `L.curkind = k` (with cur a +// non-pointer sub-struct) — emits an empty function body. Single- +// level stores through *lexer work fine. + +type lexer = struct { + src: str, + pos: i32, + curstart: i32, // byte offset where L.curkind's source starts — + // the parser's one-token lookahead means L.pos has + // already advanced past the lookahead's bytes; the + // interactive REPL needs this to know how many of + // `buf` are safely consumed. + curkind: tkind, + curival: i64, + curfval: f64, + cursid: i32, + curtext: str, +}; + +fn isdelim(c: u8) bool = { + if (ascii.isspace(c: rune)) { return true; }; + if (c == '(': u8) { return true; }; + if (c == ')': u8) { return true; }; + if (c == '\'': u8) { return true; }; + if (c == ';': u8) { return true; }; + return false; +}; + +fn skipws(L: *lexer) void = { + for (L.pos < L.src.len) { + let c: u8 = L.src[L.pos]; + if (ascii.isspace(c: rune)) { + L.pos += 1; + continue; + }; + // `;` to end of line — Scheme-style line comment. + if (c == ';': u8) { + for (L.pos < L.src.len) { + if (L.src[L.pos] == 10u8) { + L.pos += 1; + break; + }; + L.pos += 1; + }; + continue; + }; + break; + }; +}; + +fn readatom(L: *lexer) str = { + let start: i32 = L.pos; + for (L.pos < L.src.len) { + if (isdelim(L.src[L.pos])) { break; }; + L.pos += 1; + }; + let r: str; + r.ptr = L.src.ptr + start; + r.len = L.pos - start; + return r; +}; + +// allnum — true iff `s` is a (possibly-signed) sequence of digits. +fn allnum(s: str) bool = { + if (s.len == 0) { return false; }; + let i: i32 = 0; + if (s[0] == '-': u8) { + if (s.len == 1) { return false; }; + i = 1; + }; + for (i < s.len) { + if (!ascii.isdigit(s[i]: rune)) { return false; }; + i += 1; + }; + return true; +}; + +// allfloat — like allnum but allows exactly one '.'. Lets us pick +// floats out of the atom stream before falling through to symbol. +fn allfloat(s: str) bool = { + if (s.len == 0) { return false; }; + let i: i32 = 0; + let dots: i32 = 0; + let digits: i32 = 0; + if (s[0] == '-': u8) { + if (s.len == 1) { return false; }; + i = 1; + }; + for (i < s.len) { + let c: u8 = s[i]; + if (c == '.': u8) { + dots += 1; + if (dots > 1) { return false; }; + } else if (ascii.isdigit(c: rune)) { + digits += 1; + } else { + return false; + }; + i += 1; + }; + return digits > 0 && dots == 1; +}; + +// parsef — tiny decimal float scanner. Not IEEE-perfect, but adequate +// for the demo. Mirrors strconv.stoi64's shape. +fn parsef(s: str) f64 = { + let i: i32 = 0; + let neg: bool = false; + if (s[0] == '-': u8) { neg = true; i = 1; }; + let intp: f64 = 0.0; + for (i < s.len) { + let c: u8 = s[i]; + if (c == '.': u8) { i += 1; break; }; + intp = intp * 10.0 + ((c: i64 - 48): f64); + i += 1; + }; + let frac: f64 = 0.0; + let scale: f64 = 1.0; + for (i < s.len) { + let c: u8 = s[i]; + frac = frac * 10.0 + ((c: i64 - 48): f64); + scale = scale * 10.0; + i += 1; + }; + let v: f64 = intp + frac / scale; + if (neg) { v = -v; }; + return v; +}; + +// readstr — consume "..." from the input. Caller has already eaten +// the opening quote. Returns the inner text as a borrowed str, or +// parserr on unterminated input. Escape handling is intentionally +// thin: \n \t \" \\ — anything else passes through as the trailing +// byte. +fn readstr(L: *lexer, out: *str) (i32 | parserr) = { + let start: i32 = L.pos; + for (L.pos < L.src.len) { + let c: u8 = L.src[L.pos]; + if (c == '"': u8) { + let r: str; + r.ptr = L.src.ptr + start; + r.len = L.pos - start; + L.pos += 1; // past closing quote + *out = r; + return 0; + }; + if (c == '\\': u8 && L.pos + 1 < L.src.len) { + L.pos += 2; + continue; + }; + L.pos += 1; + }; + return "unterminated string": parserr; +}; + +// next — advance L.cur to the next token. Three-variant return so the +// caller can distinguish "got token", "ran out cleanly", and "broken +// input" without re-checking flags. +fn next(L: *lexer) (i32 | parserr | eof) = { + skipws(L); + L.curstart = L.pos; // start-of-current-token (or end-of-input) + if (L.pos >= L.src.len) { + L.curkind = tkind.END; + return eof{}; + }; + let c: u8 = L.src[L.pos]; + if (c == '(': u8) { L.curkind = tkind.LPAREN; L.pos += 1; return 0; }; + if (c == ')': u8) { L.curkind = tkind.RPAREN; L.pos += 1; return 0; }; + if (c == '\'': u8) { L.curkind = tkind.QUOTE; L.pos += 1; return 0; }; + if (c == '"': u8) { + L.pos += 1; + let s: str; + readstr(L, &s)?; + L.curkind = tkind.STR; + L.curtext = s; + return 0; + }; + let a: str = readatom(L); + if (a.len == 0) { return "empty token": parserr; }; + if (strings.compare(a, "#t") == 0) { L.curkind = tkind.TRUE; return 0; }; + if (strings.compare(a, "#f") == 0) { L.curkind = tkind.FALSE; return 0; }; + if (allnum(a)) { + let r = strconv.stoi64(a); + match (r) { + case let v: i64 => { + L.curkind = tkind.INT; + L.curival = v; + return 0; + }; + case let e: strconv.invalid => { return "bad integer": parserr; }; + case let e: strconv.overflow => { return "integer overflow": parserr; }; + }; + }; + if (allfloat(a)) { + L.curkind = tkind.FLOAT; + L.curfval = parsef(a); + return 0; + }; + L.curkind = tkind.SYM; + L.cursid = intern(a); + return 0; +}; + +// ---- parser ----------------------------------------------------------- +// +// Read one s-expression. After a successful parse, L.cur holds the +// next un-consumed token (parser is eager-lookahead). + +fn parse_expr(L: *lexer) (*value | parserr | eof) = { + let k: tkind = L.curkind; + if (k == tkind.END) { return eof{}; }; + if (k == tkind.RPAREN) { return "unexpected ')'": parserr; }; + + if (k == tkind.LPAREN) { + // Advance past '('. + let r = next(L); + match (r) { + case let _ok: i32 => { }; + case let e: parserr => return e; + case eof => return "unterminated list": parserr; + }; + // Empty list `()`. + if (L.curkind == tkind.RPAREN) { + let r2 = next(L); + // Discard the eof shape — empty input after ')' is fine. + match (r2) { + case let _ok: i32 => { }; + case let e: parserr => return e; + case eof => { }; + }; + return vnil(); + }; + let head: *value = vnil(); + let tail: *value = nil; + for (true) { + if (L.curkind == tkind.RPAREN) { break; }; + if (L.curkind == tkind.END) { + return "unterminated list": parserr; + }; + let v = parse_expr(L)?; + let cell: *value = vcons(v, vnil()); + if (tail == nil) { head = cell; } + else { tail.cdr = cell; }; + tail = cell; + if (L.curkind == tkind.RPAREN) { break; }; + }; + // Advance past ')'. + let r3 = next(L); + match (r3) { + case let _ok: i32 => { }; + case let e: parserr => return e; + case eof => { }; + }; + return head; + }; + + if (k == tkind.QUOTE) { + // Advance past '. + let r = next(L); + match (r) { + case let _ok: i32 => { }; + case let e: parserr => return e; + case eof => return "EOF after quote": parserr; + }; + let inner = parse_expr(L)?; + // 'expr ⇒ (quote expr) + return vcons(vsym(SID_QUOTE), vcons(inner, vnil())); + }; + + // Self-evaluating atom — read the token, then advance. + let v: *value = vnil(); + if (k == tkind.INT) { v = vint(L.curival); } + else if (k == tkind.FLOAT) { v = vfloat(L.curfval); } + else if (k == tkind.STR) { v = vstr(L.curtext); } + else if (k == tkind.SYM) { v = vsym(L.cursid); } + else if (k == tkind.TRUE) { v = vbool(true); } + else if (k == tkind.FALSE) { v = vbool(false); } + else { return "unexpected token": parserr; }; + + let r4 = next(L); + match (r4) { + case let _ok: i32 => { }; + case let e: parserr => return e; + case eof => { }; + }; + return v; +}; + +// ---- env -------------------------------------------------------------- + +fn env_define(e: **env, sid: i32, v: *value) void = { + let f: *env = alloc(env{ sid = sid, val = v, next = *e }); + *e = f; +}; + +fn env_lookup(e: *env, sid: i32) (*value | rterror) = { + let cur: *env = e; + for (cur != nil) { + if (cur.sid == sid) { return cur.val; }; + cur = cur.next; + }; + return "unbound symbol": rterror; +}; + +fn env_set(e: *env, sid: i32, v: *value) (i32 | rterror) = { + let cur: *env = e; + for (cur != nil) { + if (cur.sid == sid) { cur.val = v; return 0; }; + cur = cur.next; + }; + return "set!: unbound symbol": rterror; +}; + +// ---- helpers on values ------------------------------------------------ + +fn truthy(v: *value) bool = { + // Only #f is false. nil/0/"" are truthy, classic Lisp. + if (v.kind == valkind.BOOL && v.bval == 0) { return false; }; + return true; +}; + +fn list_len(v: *value) i32 = { + let n: i32 = 0; + let cur: *value = v; + for (cur.kind == valkind.CONS) { + n += 1; + cur = cur.cdr; + }; + return n; +}; + +// args_to_slice — flatten a Lisp list of already-evaluated values into +// a ww `[]*value`. Exercises `append(s, v)`. The caller releases the +// slice via os.free. +fn args_to_slice(args: *value) []*value = { + let s: []*value; + s.ptr = nil; + s.len = 0; + s.cap = 0; + let cur: *value = args; + for (cur.kind == valkind.CONS) { + append(s, cur.car); + cur = cur.cdr; + }; + return s; +}; + +// ---- arithmetic helpers ---------------------------------------------- +// +// Numeric ops are int-when-all-ints / float-otherwise. We scan once +// to decide, then run the right loop. + +fn any_float(xs: []*value) bool = { + for (let x .. xs) { + if (x.kind == valkind.FLOAT) { return true; }; + }; + return false; +}; + +// to_f64 / to_i64 take an out-pointer rather than `(T | rterror)`: +// the wwstage tagged-union return convention doesn't put a returned +// f64 in X0 (it pushes the bits into DX), but the unwrap path reads +// X0 — so the caller sees garbage. An out-pointer sidesteps the +// boundary entirely. + +// f64 movement through the wwstage cgen is fragile: only MOVSD into a +// top-level global emits the right MOVSD. Field-of-pointer stores, +// struct-literal stores, and function-arg passing for f64 all run +// through integer registers and lose the value. We treat every +// "f64 stored at address A" as a byte-copy from a known-good source. +// +// copybytes(d, s) — pure 8-byte memcpy. +// to_f64 — INT branch routes through `fbuf` (global f64 store works +// for the CVTSI2SD-produced X0), then byte-copies; FLOAT +// branch is a direct bit-copy from `v.fval`. + +fn copybytes(d: *u8, s: *u8) void = { + let i: u64 = 0u64; + for (i < 8u64) { d[i] = s[i]; i += 1u64; }; +}; + +fn to_f64(v: *value, out: *f64) bool = { + let dst: *u8 = out: *u8; + if (v.kind == valkind.INT) { + fbuf = v.ival: f64; + let sp: *f64 = &fbuf; + copybytes(dst, sp: *u8); + return true; + }; + if (v.kind == valkind.FLOAT) { + let raw: *u8 = v: *u8; + copybytes(dst, raw + FVAL_OFF); + return true; + }; + return false; +}; + +fn to_i64(v: *value, out: *i64) bool = { + if (v.kind == valkind.INT) { *out = v.ival; return true; }; + if (v.kind == valkind.FLOAT) { *out = v.fval: i64; return true; }; + return false; +}; + +// ---- builtins --------------------------------------------------------- + +// Helper: pull a single i64 out of xs[i], or error. +fn arg_i64(x: *value) (i64 | rterror) = { + if (x.kind == valkind.INT) { return x.ival; }; + if (x.kind == valkind.FLOAT) { return x.fval: i64; }; + return "expected number": rterror; +}; + +// f64 compound assigns (+=, -=, *=, /=) get mis-lowered to `acc = f` +// (drop the OP) in the wwstage cgen — write `acc = acc OP f`. +// Integer compound assigns work fine. + +fn b_add(xs: []*value) (*value | rterror) = { + if (any_float(xs)) { + let acc: f64 = 0.0; + let f: f64 = 0.0; + for (let x .. xs) { + if (!to_f64(x, &f)) { return "expected number": rterror; }; + acc = acc + f; + }; + return vfloat(acc); + }; + let acc: i64 = 0; + for (let x .. xs) { acc += arg_i64(x)?; }; + return vint(acc); +}; + +fn b_sub(xs: []*value) (*value | rterror) = { + if (xs.len == 0) { return "(-): need at least 1 arg": rterror; }; + if (any_float(xs)) { + let acc: f64 = 0.0; + let f: f64 = 0.0; + if (!to_f64(xs[0], &acc)) { return "expected number": rterror; }; + if (xs.len == 1) { return vfloat(-acc); }; + let i: i32 = 1; + for (i < xs.len) { + if (!to_f64(xs[i], &f)) { return "expected number": rterror; }; + acc = acc - f; + i += 1; + }; + return vfloat(acc); + }; + let acc: i64 = arg_i64(xs[0])?; + if (xs.len == 1) { return vint(-acc); }; + let i: i32 = 1; + for (i < xs.len) { acc -= arg_i64(xs[i])?; i += 1; }; + return vint(acc); +}; + +fn b_mul(xs: []*value) (*value | rterror) = { + if (any_float(xs)) { + let acc: f64 = 1.0; + let f: f64 = 0.0; + for (let x .. xs) { + if (!to_f64(x, &f)) { return "expected number": rterror; }; + acc = acc * f; + }; + return vfloat(acc); + }; + let acc: i64 = 1; + for (let x .. xs) { acc *= arg_i64(x)?; }; + return vint(acc); +}; + +// Compound `acc /= d` is mis-lowered (store-without-divide) in the +// wwstage cgen — explicit `acc = acc / d` works. + +fn b_div(xs: []*value) (*value | rterror) = { + if (xs.len < 2) { return "(/): need at least 2 args": rterror; }; + if (any_float(xs)) { + let acc: f64 = 0.0; + let d: f64 = 0.0; + if (!to_f64(xs[0], &acc)) { return "expected number": rterror; }; + let i: i32 = 1; + for (i < xs.len) { + if (!to_f64(xs[i], &d)) { return "expected number": rterror; }; + if (d == 0.0) { return "divide by zero": rterror; }; + acc = acc / d; + i += 1; + }; + return vfloat(acc); + }; + let acc: i64 = arg_i64(xs[0])?; + let i: i32 = 1; + for (i < xs.len) { + let d: i64 = arg_i64(xs[i])?; + if (d == 0) { return "divide by zero": rterror; }; + acc = acc / d; + i += 1; + }; + return vint(acc); +}; + +fn b_mod(xs: []*value) (*value | rterror) = { + if (xs.len != 2) { return "(mod): need 2 args": rterror; }; + let a: i64 = arg_i64(xs[0])?; + let b: i64 = arg_i64(xs[1])?; + if (b == 0) { return "mod by zero": rterror; }; + let q: i64 = a / b; + return vint(a - q * b); +}; + +fn cmp2(xs: []*value, want: i32) (*value | rterror) = { + if (xs.len < 2) { return "comparison: need >=2 args": rterror; }; + let i: i32 = 0; + let af: f64 = 0.0; + let bf: f64 = 0.0; + for (i < xs.len - 1) { + if (!to_f64(xs[i], &af)) { return "expected number": rterror; }; + if (!to_f64(xs[i + 1], &bf)) { return "expected number": rterror; }; + let ok: bool = false; + if (want == 0) { ok = (af == bf); } + else if (want == 1) { ok = (af < bf); } + else if (want == 2) { ok = (af > bf); } + else if (want == 3) { ok = (af <= bf); } + else { ok = (af >= bf); }; + if (!ok) { return vbool(false); }; + i += 1; + }; + return vbool(true); +}; + +fn b_cons(xs: []*value) (*value | rterror) = { + if (xs.len != 2) { return "cons: need 2 args": rterror; }; + return vcons(xs[0], xs[1]); +}; + +// Field access on a slice element (xs[i].kind) is mis-lowered by the +// wwstage cgen: it emits only the slice index, drops the trailing +// field load. Workaround: bind xs[i] to a local *value first. + +fn b_car(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "car: need 1 arg": rterror; }; + let p: *value = xs[0]; + if (p.kind != valkind.CONS) { return "car: not a pair": rterror; }; + return p.car; +}; + +fn b_cdr(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "cdr: need 1 arg": rterror; }; + let p: *value = xs[0]; + if (p.kind != valkind.CONS) { return "cdr: not a pair": rterror; }; + return p.cdr; +}; + +fn b_list(xs: []*value) (*value | rterror) = { + let head: *value = vnil(); + let i: i32 = xs.len - 1; + for (i >= 0) { + head = vcons(xs[i], head); + i -= 1; + }; + return head; +}; + +fn b_nullp(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "null?: need 1 arg": rterror; }; + let p: *value = xs[0]; + return vbool(p.kind == valkind.NIL); +}; + +fn b_pairp(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "pair?: need 1 arg": rterror; }; + let p: *value = xs[0]; + return vbool(p.kind == valkind.CONS); +}; + +fn b_nump(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "number?: need 1 arg": rterror; }; + let p: *value = xs[0]; + let k: valkind = p.kind; + return vbool(k == valkind.INT || k == valkind.FLOAT); +}; + +fn b_symp(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "symbol?: need 1 arg": rterror; }; + let p: *value = xs[0]; + return vbool(p.kind == valkind.SYM); +}; + +fn b_eqp(xs: []*value) (*value | rterror) = { + if (xs.len != 2) { return "eq?: need 2 args": rterror; }; + let a: *value = xs[0]; + let b: *value = xs[1]; + if (a.kind != b.kind) { return vbool(false); }; + if (a.kind == valkind.NIL) { return vbool(true); }; + if (a.kind == valkind.BOOL) { return vbool(a.bval == b.bval); }; + if (a.kind == valkind.INT) { return vbool(a.ival == b.ival); }; + if (a.kind == valkind.SYM) { return vbool(a.sid == b.sid); }; + // Reference equality for everything else — matches eq? semantics + // in classic Lisps. + return vbool(a == b); +}; + +fn b_not(xs: []*value) (*value | rterror) = { + if (xs.len != 1) { return "not: need 1 arg": rterror; }; + let p: *value = xs[0]; + return vbool(!truthy(p)); +}; + +fn b_print(xs: []*value) (*value | rterror) = { + for (let x .. xs) { print_value(x, false); }; + return vnil(); +}; + +fn b_println(xs: []*value) (*value | rterror) = { + for (let x .. xs) { print_value(x, false); }; + fmt.println(""); + return vnil(); +}; + +// apply_builtin — switch over the builtin id (an i32 stashed in the +// BUILTIN value's ival slot). Switch case labels reject the `:` cast +// form, so the id and the btin enum must agree on i32. +fn apply_builtin(id: i32, xs: []*value) (*value | rterror) = { + switch (id) { + case btin.ADD: return b_add(xs); + case btin.SUB: return b_sub(xs); + case btin.MUL: return b_mul(xs); + case btin.DIV: return b_div(xs); + case btin.MOD: return b_mod(xs); + case btin.EQ: return cmp2(xs, 0); + case btin.LT: return cmp2(xs, 1); + case btin.GT: return cmp2(xs, 2); + case btin.LE: return cmp2(xs, 3); + case btin.GE: return cmp2(xs, 4); + case btin.CONS: return b_cons(xs); + case btin.CAR: return b_car(xs); + case btin.CDR: return b_cdr(xs); + case btin.LIST: return b_list(xs); + case btin.NULLP: return b_nullp(xs); + case btin.PAIRP: return b_pairp(xs); + case btin.NUMP: return b_nump(xs); + case btin.SYMP: return b_symp(xs); + case btin.EQP: return b_eqp(xs); + case btin.NOT: return b_not(xs); + case btin.PRINT: return b_print(xs); + case btin.PRINTLN: return b_println(xs); + }; + return "unknown builtin": rterror; +}; + +// ---- eval ------------------------------------------------------------- + +export fn eval(v: *value, e: **env) (*value | rterror) = { + // Self-evaluating atoms — every variant of `valkind` that isn't + // SYM (lookup) or CONS (application). + if (v.kind == valkind.NIL) { return v; }; + if (v.kind == valkind.BOOL) { return v; }; + if (v.kind == valkind.INT) { return v; }; + if (v.kind == valkind.FLOAT) { return v; }; + if (v.kind == valkind.STR) { return v; }; + if (v.kind == valkind.BUILTIN) { return v; }; + if (v.kind == valkind.LAMBDA) { return v; }; + + if (v.kind == valkind.SYM) { + return env_lookup(*e, v.sid)?; + }; + + // CONS — application. The head selects a special form (via symbol + // id) or evaluates to a callable. + let head: *value = v.car; + let rest: *value = v.cdr; + + if (head.kind == valkind.SYM) { + let sf: sform = classify_sform(head.sid); + if (sf != sform.NONE) { + return eval_sform(sf, rest, e)?; + }; + }; + + let callee: *value = eval(head, e)?; + + // Inline the args walk: a separate `(slice | rterror)` return loses + // xs.len through the wwstage cgen's 3-reg tagged-union convention + // (AX=tag, DX=ptr, CX=cap — len is computed into BX and dropped). + // Keeping the slice strictly local sidesteps that. + let xs: []*value; + xs.ptr = nil; + xs.len = 0; + xs.cap = 0; + let cur: *value = rest; + for (cur.kind == valkind.CONS) { + let av = eval(cur.car, e)?; + append(xs, av); + cur = cur.cdr; + }; + + return apply(callee, xs, e)?; +}; + +// eval_sform — dispatch on the special-form tag. Each arm consumes a +// specific shape of the rest-list and updates `e` if it must. +fn eval_sform(sf: sform, rest: *value, e: **env) (*value | rterror) = { + let tag: sform = sf; + switch (tag) { + case sform.QUOTE: { + if (rest.kind != valkind.CONS) { return "quote: missing arg": rterror; }; + return rest.car; + }; + case sform.IF: { + if (list_len(rest) < 2) { return "if: need cond + then": rterror; }; + let cnd: *value = rest.car; + let thn: *value = rest.cdr.car; + let cv = eval(cnd, e)?; + if (truthy(cv)) { return eval(thn, e)?; }; + let elsep: *value = rest.cdr.cdr; + if (elsep.kind == valkind.CONS) { + return eval(elsep.car, e)?; + }; + return vnil(); + }; + case sform.DEFINE: { + if (list_len(rest) != 2) { return "define: (define name expr)": rterror; }; + let nameval: *value = rest.car; + if (nameval.kind != valkind.SYM) { return "define: name must be symbol": rterror; }; + let body: *value = rest.cdr.car; + let bv = eval(body, e)?; + env_define(e, nameval.sid, bv); + // Recursive-lambda tie-back: prepend a self-binding frame + // to the captured env so `(fact …)` inside fact's body + // resolves. Earlier versions clobbered `bv.envp` with `*e`, + // which wiped out any non-global env that closures (e.g. + // `(adder 5)` returning `(lambda (x) (+ x k))`) had captured. + if (bv.kind == valkind.LAMBDA) { + let frame: *env = alloc(env{ + sid = nameval.sid, + val = bv, + next = bv.envp, + }); + bv.envp = frame; + }; + return vnil(); + }; + case sform.SETBANG: { + if (list_len(rest) != 2) { return "set!: (set! name expr)": rterror; }; + let nameval: *value = rest.car; + if (nameval.kind != valkind.SYM) { return "set!: name must be symbol": rterror; }; + let body: *value = rest.cdr.car; + let bv = eval(body, e)?; + env_set(*e, nameval.sid, bv)?; + return bv; + }; + case sform.LAMBDA: { + if (list_len(rest) < 2) { return "lambda: (lambda (params) body...)": rterror; }; + let params: *value = rest.car; + let body: *value = rest.cdr; + return vlambda(params, body, *e); + }; + case sform.LET: { + // (let ((x v) (y w) ...) body...) + if (list_len(rest) < 2) { return "let: (let ((b ...)) body)": rterror; }; + let binds: *value = rest.car; + let body: *value = rest.cdr; + let inner: *env = *e; + let cur: *value = binds; + for (cur.kind == valkind.CONS) { + let pair: *value = cur.car; + if (list_len(pair) != 2) { return "let: bad binding": rterror; }; + let nm: *value = pair.car; + if (nm.kind != valkind.SYM) { return "let: name must be sym": rterror; }; + let val = eval(pair.cdr.car, e)?; + let f: *env = alloc(env{ sid = nm.sid, val = val, next = inner }); + inner = f; + cur = cur.cdr; + }; + let inscope: *env = inner; + let pe: *env = inscope; + return run_body(body, &pe)?; + }; + case sform.BEGIN: { + return run_body(rest, e)?; + }; + }; + return "bad sform": rterror; +}; + +// run_body — evaluate a sequence of forms, returning the last value. +fn run_body(forms: *value, e: **env) (*value | rterror) = { + let result: *value = vnil(); + let cur: *value = forms; + for (cur.kind == valkind.CONS) { + result = eval(cur.car, e)?; + cur = cur.cdr; + }; + return result; +}; + +// apply — call a BUILTIN or LAMBDA with already-evaluated args. +fn apply(callee: *value, xs: []*value, e: **env) (*value | rterror) = { + if (callee.kind == valkind.BUILTIN) { + return apply_builtin(callee.ival: i32, xs)?; + }; + if (callee.kind == valkind.LAMBDA) { + // Extend the lambda's captured env with one frame per param. + let inner: *env = callee.envp; + let p: *value = callee.car; + let i: i32 = 0; + for (p.kind == valkind.CONS) { + if (i >= xs.len) { return "lambda: too few args": rterror; }; + let nm: *value = p.car; + if (nm.kind != valkind.SYM) { return "lambda: bad param": rterror; }; + let f: *env = alloc(env{ sid = nm.sid, val = xs[i], next = inner }); + inner = f; + p = p.cdr; + i += 1; + }; + if (i != xs.len) { return "lambda: too many args": rterror; }; + let pe: *env = inner; + return run_body(callee.cdr, &pe)?; + }; + return "not callable": rterror; +}; + +// ---- printer --------------------------------------------------------- + +// Use a fixed-size scratch buffer so we don't bounce through fmt for +// every glyph. fmt.print already buffers per-write into write(2), but +// we'd like one syscall per top-level value. + +let obuf: *u8 = nil; +let obufuse: i32 = 0; +def OBUF_SZ: i32 = 4096; + +fn obuf_putc(c: u8) void = { + let buf: *u8 = obuf; + if (obufuse >= OBUF_SZ) { + os.write(1, buf, obufuse: u64); + obufuse = 0; + }; + buf[obufuse] = c; + obufuse += 1; +}; + +fn obuf_puts(s: str) void = { + let i: i32 = 0; + for (i < s.len) { obuf_putc(s[i]); i += 1; }; +}; + +fn obuf_putint(v: i64) void = { + let tmp: [32]u8; + let n: i32 = strconv.i64tos(tmp[0:32], v); + let i: i32 = 0; + for (i < n) { obuf_putc(tmp[i]); i += 1; }; +}; + +fn obuf_putfloat(v: f64) void = { + // One decimal place is fine for the demo — full-fidelity printing + // is a strconv.ftos away. + let neg: bool = false; + let f: f64 = v; + if (f < 0.0) { neg = true; f = -f; }; + let ip: i64 = f: i64; + let frac: f64 = (f - (ip: f64)) * 1000000.0; + let fp: i64 = frac: i64; + if (neg) { obuf_putc('-': u8); }; + obuf_putint(ip); + obuf_putc('.': u8); + // Pad to 6 digits. + let pad: [16]u8; + let n: i32 = strconv.i64tos(pad[0:16], fp); + let z: i32 = 6 - n; + for (z > 0) { obuf_putc('0': u8); z -= 1; }; + let i: i32 = 0; + for (i < n) { obuf_putc(pad[i]); i += 1; }; +}; + +fn obuf_flush() void = { + if (obufuse > 0) { + os.write(1, obuf, obufuse: u64); + obufuse = 0; + }; +}; + +export fn print_value(v: *value, nl: bool) void = { + let k: valkind = v.kind; + switch (k) { + case valkind.NIL: obuf_puts("()"); + case valkind.BOOL: { + if (v.bval == 0) { obuf_puts("#f"); } else { obuf_puts("#t"); }; + }; + case valkind.INT: obuf_putint(v.ival); + case valkind.FLOAT: obuf_putfloat(v.fval); + case valkind.SYM: obuf_puts(symname(v.sid)); + case valkind.STR: { + obuf_putc('"': u8); + obuf_puts(v.text); + obuf_putc('"': u8); + }; + case valkind.BUILTIN: obuf_puts("#"); + case valkind.LAMBDA: obuf_puts("#"); + case valkind.CONS: { + obuf_putc('(': u8); + let cur: *value = v; + let first: bool = true; + for (cur.kind == valkind.CONS) { + if (!first) { obuf_putc(' ': u8); }; + first = false; + print_value(cur.car, false); + cur = cur.cdr; + }; + if (cur.kind != valkind.NIL) { + obuf_puts(" . "); + print_value(cur, false); + }; + obuf_putc(')': u8); + }; + }; + if (nl) { obuf_putc(10u8); }; + obuf_flush(); +}; + +// ---- builtin binding -------------------------------------------------- + +fn bind_one(e: **env, name: str, id: i32) void = { + let sid: i32 = intern(name); + env_define(e, sid, vbuiltin(id)); +}; + +export fn initsyms() void = { + sym_off = os.alloc((SYM_CAP: u64) * 4u64): *i32; + sym_len = os.alloc((SYM_CAP: u64) * 4u64): *i32; + sym_blob = os.alloc(SYM_BLOBSZ: u64): *u8; + obuf = os.alloc(OBUF_SZ: u64): *u8; + + // Stash the special-form ids so classify_sform sees them. + SID_QUOTE = intern("quote"); + SID_IF = intern("if"); + SID_DEFINE = intern("define"); + SID_LAMBDA = intern("lambda"); + SID_LET = intern("let"); + SID_BEGIN = intern("begin"); + SID_SETBANG = intern("set!"); +}; + +export fn bind_builtins(e: **env) void = { + bind_one(e, "+", btin.ADD as i32); + bind_one(e, "-", btin.SUB as i32); + bind_one(e, "*", btin.MUL as i32); + bind_one(e, "/", btin.DIV as i32); + bind_one(e, "mod", btin.MOD as i32); + bind_one(e, "=", btin.EQ as i32); + bind_one(e, "<", btin.LT as i32); + bind_one(e, ">", btin.GT as i32); + bind_one(e, "<=", btin.LE as i32); + bind_one(e, ">=", btin.GE as i32); + bind_one(e, "cons", btin.CONS as i32); + bind_one(e, "car", btin.CAR as i32); + bind_one(e, "cdr", btin.CDR as i32); + bind_one(e, "list", btin.LIST as i32); + bind_one(e, "null?", btin.NULLP as i32); + bind_one(e, "pair?", btin.PAIRP as i32); + bind_one(e, "number?", btin.NUMP as i32); + bind_one(e, "symbol?", btin.SYMP as i32); + bind_one(e, "eq?", btin.EQP as i32); + bind_one(e, "not", btin.NOT as i32); + bind_one(e, "print", btin.PRINT as i32); + bind_one(e, "println", btin.PRINTLN as i32); +}; + +// ---- REPL ------------------------------------------------------------- + +// Slurp every byte from `fd` until EOF into a fresh buffer. The caller +// owns the buffer. Mirrors Hare's io::drain. +// eval_str — parse a single top-level form from `s` and evaluate it. +// Folds parse failures and EOF into the rterror variant so callers +// only need to dispatch over `(*value | rterror)`. This is the one +// the test driver in `lisp_test.ww` consumes. +export fn eval_str(s: str, ep: **env) (*value | rterror) = { + let L: lexer; + L.src = s; + L.pos = 0; + match (next(&L)) { + case let _ok: i32 => { }; + case let e: parserr => return e: str: rterror; + case eof => return "empty input": rterror; + }; + let r = parse_expr(&L); + let v: *value = match (r) { + case let v: *value => yield v; + case let e: parserr => return e: str: rterror; + case eof => return "empty input": rterror; + }; + return eval(v, ep)?; +}; + +fn print_err(prefix: str, msg: str) void = { + os.write(2, prefix.ptr, prefix.len: u64); + os.write(2, msg.ptr, msg.len: u64); + os.write(2, "\n".ptr, 1u64); +}; + +// is_unterminated — parserr-text test for "we ran out of input mid- +// form, please read more". Two specific texts qualify; everything +// else is a hard syntax error. +fn is_unterminated(er: str) bool = { + if (strings.compare(er, "unterminated list") == 0) { return true; }; + if (strings.compare(er, "unterminated string") == 0) { return true; }; + return false; +}; + +// repl — interactive read-eval-print loop. Earlier versions slurped +// stdin to EOF first; this one reads a chunk, tries to parse a top- +// level form, and either evaluates it or asks for more input. +// +// Prompts go to stderr (fd 2) so `./lisp | downstream` doesn't see +// "> " on stdout. The banner does too. +// +// State machine: +// `buf` accumulates raw bytes. `cont` switches between "> " (start +// of a fresh form) and " " (continuing an incomplete form). After +// a successful parse we shift `L.pos` bytes off the front of `buf` +// and reuse whatever's behind them as the next form's source. +export fn repl() i32 = { + let e: *env = nil; + let ep: **env = &e; + initsyms(); + bind_builtins(ep); + + os.write(2, "ww-lisp — Ctrl-D to exit.\n".ptr, 28u64); + + let buf: []u8; + buf.ptr = nil; + buf.len = 0; + buf.cap = 0; + let at_eof: bool = false; + let cont: bool = false; // true = print " " instead of "> " + let chunk: [4096]u8; + + for (true) { + // 1. If we have no buffered bytes, prompt and read. + if (buf.len == 0) { + if (at_eof) { break; }; + if (cont) { os.write(2, " ".ptr, 2u64); } + else { os.write(2, "> ".ptr, 2u64); }; + cont = false; + let n: i64 = os.read(0, chunk.ptr, 4096u64); + if (n <= 0) { at_eof = true; continue; }; + let i: i32 = 0; + for (i < n: i32) { append(buf, chunk[i]); i += 1; }; + continue; + }; + + // 2. Try to parse one top-level form from `buf[0..]`. Build + // the `src` slice as a local `str` and whole-struct-assign + // into L — `L.src.ptr = ...` is two-level field write + // through *lexer + non-pointer sub-struct, which the cgen + // silently drops (same trap as `L.cur.kind = …`). + let src: str; + src.ptr = buf.ptr; + src.len = buf.len; + let L: lexer; + L.src = src; + L.pos = 0; + + // 2a. Prime — handles "buf is whitespace-only" and tokeniser- + // level errors before parse_expr ever sees them. + match (next(&L)) { + case let _ok: i32 => { }; + case let er: parserr => { + print_err("parse error: ", er: str); + buf.len = 0; + cont = false; + continue; + }; + case eof => { + buf.len = 0; + cont = false; + continue; + }; + }; + + // 2b. Parse a single form. + match (parse_expr(&L)) { + case let v: *value => { + match (eval(v, ep)) { + case let r: *value => print_value(r, true); + case let er: rterror => print_err("error: ", er: str); + }; + // The parser primes one token of lookahead, so L.pos + // already crossed the next form's first byte. Drop up + // to `L.curstart` so that leading byte stays in `buf` + // for the next iteration. + let nc: i32 = L.curstart; + let nleft: i32 = buf.len - nc; + let j: i32 = 0; + for (j < nleft) { buf[j] = buf[nc + j]; j += 1; }; + buf.len = nleft; + cont = false; + }; + case let er: parserr => { + // "unterminated list" / "unterminated string" means we + // need more bytes before the form is complete. Anything + // else is a real syntax error — print, drop, recover. + if (is_unterminated(er: str)) { + if (at_eof) { + print_err("parse error: ", er: str); + return 1; + }; + os.write(2, " ".ptr, 2u64); + let n: i64 = os.read(0, chunk.ptr, 4096u64); + if (n <= 0) { at_eof = true; continue; }; + let i: i32 = 0; + for (i < n: i32) { append(buf, chunk[i]); i += 1; }; + cont = true; + continue; + }; + print_err("parse error: ", er: str); + buf.len = 0; + cont = false; + }; + case eof => { + // next() succeeded but parse_expr ran out: the form was + // a partial atom (e.g., trailing `'`). Read more. + if (at_eof) { return 0; }; + os.write(2, " ".ptr, 2u64); + let n: i64 = os.read(0, chunk.ptr, 4096u64); + if (n <= 0) { at_eof = true; continue; }; + let i: i32 = 0; + for (i < n: i32) { append(buf, chunk[i]); i += 1; }; + cont = true; + }; + }; + }; + + return 0; +}; + diff --git a/examples/lisp/test_arith.lisp b/examples/lisp/test_arith.lisp new file mode 100644 index 00000000..37326510 --- /dev/null +++ b/examples/lisp/test_arith.lisp @@ -0,0 +1,26 @@ +; test_arith.lisp — arithmetic and comparisons. +; Run: cat test_arith.lisp | ./lisp +; +; Each form's expected result is in the trailing comment. + +(+ 1 2 3 4 5) ; => 15 +(* 6 7) ; => 42 +(- 100 25 25) ; => 50 +(/ 100 5) ; => 20 +(/ 1000 10 5) ; => 20 +(mod 17 5) ; => 2 +(- 7) ; => -7 + +(+ (* 2 3) (* 4 5)) ; => 26 +(+ (- 50 10) (* 2 5)) ; => 50 + +(= 5 5) ; => #t +(= 5 6) ; => #f +(< 1 2 3 4) ; => #t +(<= 3 3 4) ; => #t +(> 5 3 1) ; => #t + +; mixed int/float — int operands auto-promote +(+ 1 2.5) ; => 3.5 +(* 2 3.0) ; => 6.0 +(/ 22.0 7.0) ; => 3.142857 diff --git a/examples/lisp/test_error.lisp b/examples/lisp/test_error.lisp new file mode 100644 index 00000000..1ce488b7 --- /dev/null +++ b/examples/lisp/test_error.lisp @@ -0,0 +1,18 @@ +; test_error.lisp — runtime errors. Each form should produce +; `error: ` on stderr; the REPL keeps going and prints +; surviving results on stdout. +; +; Run: cat test_error.lisp | ./lisp + +undefined-symbol ; error: unbound symbol +(car 1) ; error: car: not a pair +(cdr '()) ; error: cdr: not a pair +(/ 5 0) ; error: divide by zero +(mod 7 0) ; error: mod by zero +(+ 'a 'b) ; error: expected number +(car) ; error: car: need 1 arg +(cons 1) ; error: cons: need 2 args + +; sanity: the REPL recovers — these should print normally. +(+ 1 2) ; => 3 +"still alive" ; => "still alive" diff --git a/examples/lisp/test_huge.lisp b/examples/lisp/test_huge.lisp new file mode 100644 index 00000000..b2755369 --- /dev/null +++ b/examples/lisp/test_huge.lisp @@ -0,0 +1,167 @@ +; test_huge.lisp — broad workout for the interpreter. Each section +; defines a set of helpers and then exercises them, so the same +; program touches arithmetic, list-building, closures, recursion, +; tail calls, and a few short-loop computations. +; +; Run: cat test_huge.lisp | ./lisp +; Profile: valgrind --tool=massif --pages-as-heap=yes ./lisp < test_huge.lisp + +;; -- core helpers -------------------------------------------------------- + +(define inc (lambda (n) (+ n 1))) +(define dec (lambda (n) (- n 1))) +(define neg (lambda (n) (- 0 n))) +(define abs (lambda (n) (if (< n 0) (- 0 n) n))) +(define square (lambda (n) (* n n))) +(define cube (lambda (n) (* n n n))) +(define even? (lambda (n) (= 0 (mod n 2)))) +(define odd? (lambda (n) (not (even? n)))) + +;; -- list utilities ------------------------------------------------------ + +(define len (lambda (l) + (if (null? l) 0 (+ 1 (len (cdr l)))))) +(define nth (lambda (l n) + (if (= n 0) (car l) (nth (cdr l) (- n 1))))) +(define last (lambda (l) + (if (null? (cdr l)) (car l) (last (cdr l))))) +(define reverse-onto (lambda (l acc) + (if (null? l) acc (reverse-onto (cdr l) (cons (car l) acc))))) +(define reverse (lambda (l) (reverse-onto l '()))) +(define append2 (lambda (a b) + (if (null? a) b (cons (car a) (append2 (cdr a) b))))) +(define map (lambda (f l) + (if (null? l) '() (cons (f (car l)) (map f (cdr l)))))) +(define filter (lambda (p l) + (if (null? l) '() + (if (p (car l)) + (cons (car l) (filter p (cdr l))) + (filter p (cdr l)))))) +(define reduce (lambda (f acc l) + (if (null? l) acc (reduce f (f acc (car l)) (cdr l))))) +(define iota (lambda (n) + (if (= n 0) '() (cons n (iota (- n 1)))))) +(define range (lambda (n) (reverse (iota n)))) + +;; -- numeric helpers ----------------------------------------------------- + +(define max2 (lambda (a b) (if (> a b) a b))) +(define min2 (lambda (a b) (if (< a b) a b))) +(define max-list (lambda (l) (reduce max2 (car l) (cdr l)))) +(define min-list (lambda (l) (reduce min2 (car l) (cdr l)))) +(define sum (lambda (l) (reduce + 0 l))) +(define product (lambda (l) (reduce * 1 l))) +(define gcd (lambda (a b) + (if (= b 0) a (gcd b (mod a b))))) +(define lcm (lambda (a b) (/ (* a b) (gcd a b)))) + +;; -- recursive showpieces ------------------------------------------------ + +(define fact (lambda (n) + (if (<= n 1) 1 (* n (fact (- n 1)))))) +(define fib (lambda (n) + (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))) +(define ack (lambda (m n) + (if (= m 0) (+ n 1) + (if (= n 0) (ack (- m 1) 1) + (ack (- m 1) (ack m (- n 1))))))) + +;; -- closures (let / let-over-lambda) ----------------------------------- + +(define adder (lambda (k) (lambda (x) (+ x k)))) +(define muller (lambda (k) (lambda (x) (* x k)))) +(define counter (lambda () (begin (define c 0) (lambda () (begin (set! c (+ c 1)) c))))) + +(define add1 (adder 1)) +(define add10 (adder 10)) +(define add100 (adder 100)) +(define dbl (muller 2)) +(define triple (muller 3)) + +;; -- exercise the helpers ----------------------------------------------- + +(map inc '(1 2 3 4 5)) ; => (2 3 4 5 6) +(map square '(1 2 3 4 5 6 7 8 9 10)) ; => (1 4 9 ... 100) +(filter even? '(1 2 3 4 5 6 7 8 9 10)) ; => (2 4 6 8 10) +(filter odd? (range 12)) ; => (1 3 5 7 9 11) +(sum (range 100)) ; => 5050 +(sum (map square (range 10))) ; => 385 +(product '(1 2 3 4 5 6 7)) ; => 5040 +(max-list '(3 1 4 1 5 9 2 6 5 3 5)) ; => 9 +(min-list '(3 1 4 1 5 9 2 6 5 3 5)) ; => 1 +(len (range 50)) ; => 50 +(nth (range 30) 17) ; => 18 +(last (range 25)) ; => 25 +(reverse (range 8)) ; => (8 7 6 5 4 3 2 1) +(append2 '(1 2 3) '(a b c)) ; => (1 2 3 a b c) +(append2 (range 4) (reverse (range 4))) ; => (1 2 3 4 4 3 2 1) + +;; -- gcd / lcm batch ---------------------------------------------------- + +(gcd 1024 768) ; => 256 +(gcd 12345 54321) ; => 3 +(gcd 1000003 1000033) ; => 1 +(lcm 12 18) ; => 36 +(lcm 7 11) ; => 77 + +;; -- factorials ---------------------------------------------------------- + +(fact 1) ; => 1 +(fact 5) ; => 120 +(fact 10) ; => 3628800 +(fact 15) ; => 1307674368000 +(fact 20) ; => 2432902008176640000 + +;; -- fibonacci (exponential — sized for ~few sec under massif) --------- + +(fib 5) ; => 5 +(fib 10) ; => 55 +(fib 15) ; => 610 +(fib 18) ; => 2584 + +;; -- ackermann ----------------------------------------------------------- + +(ack 2 2) ; => 7 +(ack 2 4) ; => 11 +(ack 3 3) ; => 61 + +;; -- closure exercise --------------------------------------------------- + +(add1 41) ; => 42 +(add10 92) ; => 102 +(add100 1) ; => 101 +(dbl 21) ; => 42 +(triple 14) ; => 42 +(map add10 '(1 2 3 4 5)) ; => (11 12 13 14 15) +(map dbl (range 6)) ; => (2 4 6 8 10 12) + +;; -- mixed pipeline (filter → map → reduce) ----------------------------- + +(define pipeline (lambda (l) + (reduce + 0 (map square (filter even? l))))) +(pipeline (range 10)) ; even squares 1..10 = 4+16+36+64+100 = 220 +(pipeline (range 20)) ; even squares 1..20 +(pipeline (range 30)) + +;; -- tail-recursive spin ------------------------------------------------- + +(define spin (lambda (n acc) + (if (= n 0) acc (spin (- n 1) (+ acc 1))))) +(spin 200 0) ; => 200 +(spin 500 0) ; => 500 +(spin 1000 0) ; => 1000 + +;; -- mutual-flavored recursion ------------------------------------------ + +(define ev? (lambda (n) (if (= n 0) #t (od? (- n 1))))) +(define od? (lambda (n) (if (= n 0) #f (ev? (- n 1))))) +(ev? 12) ; => #t +(od? 13) ; => #t +(ev? 27) ; => #f + +;; -- final sanity ------------------------------------------------------- + +(+ (fact 6) (fib 14) (gcd 60 24)) ; 720 + 377 + 12 = 1109 +(reduce + 0 (map (lambda (n) (* n n)) (range 20))) ; 1+4+9+...+400 = 2870 + +"all done" diff --git a/examples/lisp/test_lambda.lisp b/examples/lisp/test_lambda.lisp new file mode 100644 index 00000000..102a5bef --- /dev/null +++ b/examples/lisp/test_lambda.lisp @@ -0,0 +1,63 @@ +; test_lambda.lisp — lambdas, define, recursion, higher-order. +; Run: cat test_lambda.lisp | ./lisp + +; one-liner lambda +((lambda (n) (* n n)) 7) ; => 49 + +; named function +(define square (lambda (n) (* n n))) +(square 9) ; => 81 +(square 12) ; => 144 + +; classic recursion +(define fact (lambda (n) + (if (<= n 1) 1 + (* n (fact (- n 1)))))) +(fact 5) ; => 120 +(fact 10) ; => 3628800 +(fact 12) ; => 479001600 + +(define fib (lambda (n) + (if (< n 2) n + (+ (fib (- n 1)) (fib (- n 2)))))) +(fib 10) ; => 55 +(fib 15) ; => 610 +(fib 20) ; => 6765 + +(define gcd (lambda (a b) + (if (= b 0) a + (gcd b (mod a b))))) +(gcd 60 48) ; => 12 +(gcd 1024 768) ; => 256 + +; higher-order: map / filter / reduce +(define map (lambda (f l) + (if (null? l) '() + (cons (f (car l)) (map f (cdr l)))))) +(define filter (lambda (p l) + (if (null? l) '() + (if (p (car l)) + (cons (car l) (filter p (cdr l))) + (filter p (cdr l)))))) +(define reduce (lambda (f acc l) + (if (null? l) acc + (reduce f (f acc (car l)) (cdr l))))) + +(define inc (lambda (n) (+ n 1))) +(define even? (lambda (n) (= (mod n 2) 0))) + +(map inc '(1 2 3 4 5)) ; => (2 3 4 5 6) +(filter even? '(1 2 3 4 5 6)) ; => (2 4 6) +(reduce + 0 '(1 2 3 4 5 6 7 8 9 10)) ; => 55 + +; closure over the captured env +(define adder (lambda (k) (lambda (x) (+ x k)))) +(define add5 (adder 5)) +(add5 10) ; => 15 +(add5 100) ; => 105 + +; mutual-like with set! +(define c 0) +(set! c 41) +(set! c (+ c 1)) +c ; => 42 diff --git a/examples/lisp/test_list.lisp b/examples/lisp/test_list.lisp new file mode 100644 index 00000000..f6681b38 --- /dev/null +++ b/examples/lisp/test_list.lisp @@ -0,0 +1,31 @@ +; test_list.lisp — pairs, lists, predicates, quoting. +; Run: cat test_list.lisp | ./lisp + +'() ; => () +'(1 2 3) ; => (1 2 3) +'(a b c) ; => (a b c) + +(cons 1 2) ; => (1 . 2) +(cons 1 '(2 3)) ; => (1 2 3) +(list 'x 'y 'z) ; => (x y z) + +(car '(11 22 33)) ; => 11 +(cdr '(11 22 33)) ; => (22 33) +(car (cdr '(1 2 3))) ; => 2 +(car (cdr (cdr '(1 2 3)))) ; => 3 + +(null? '()) ; => #t +(null? '(1)) ; => #f +(pair? '(a)) ; => #t +(pair? 'a) ; => #f + +(number? 42) ; => #t +(number? 'foo) ; => #f +(symbol? 'foo) ; => #t +(symbol? 1) ; => #f +(eq? 'a 'a) ; => #t +(eq? 'a 'b) ; => #f + +; nested literal +'((1 2) (3 4) (5 6)) ; => ((1 2) (3 4) (5 6)) +(car '((a b) (c d))) ; => (a b)