diff --git a/Makefile b/Makefile index 2f5453c..5d1075a 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,11 @@ +# ═══════════════════════════════════════════════════════════════════ +# uncommonlisp — Python + C implementations +# ═══════════════════════════════════════════════════════════════════ + all: test +# ─── Python implementation ──────────────────────────────────────── + test: python3 tests.py @@ -20,6 +26,79 @@ lint: python3 -m py_compile tests.py python3 -m py_compile bench.py +# ─── C implementation ───────────────────────────────────────────── + +c-build: + $(MAKE) -C c all + +c-test: c-build + $(MAKE) -C c test + +c-bench: c-build + $(MAKE) -C c bench + +c-repl: c-build + ./c/uncommonlisp + +c-clean: + $(MAKE) -C c clean + +# ─── Both implementations ──────────────────────────────────────── + +test-all: test c-test + @echo "════════════════════════════════════" + @echo "All tests passed (Python + C)" + +bench-all: bench c-bench + +# ─── Examples (run in both, compare output) ────────────────────── + +examples: c-build + @echo "═══ fibonacci.lsp ═══" + @echo "--- Python ---" + @python3 uncommonlisp.py --fast examples/fibonacci.lsp + @echo "--- C ---" + @./c/uncommonlisp examples/fibonacci.lsp + @echo + @echo "═══ mergesort.lsp ═══" + @echo "--- Python ---" + @python3 uncommonlisp.py --fast examples/mergesort.lsp + @echo "--- C ---" + @./c/uncommonlisp examples/mergesort.lsp + @echo + @echo "═══ objects.lsp ═══" + @echo "--- Python ---" + @python3 uncommonlisp.py examples/objects.lsp + @echo "--- C ---" + @./c/uncommonlisp examples/objects.lsp + +# ─── Friction benchmark (same .lsp, both runtimes) ────────────── + +friction: c-build + @echo "═══════════════════════════════════════════════════════" + @echo "Friction benchmark: Python vs C on identical .lsp files" + @echo "═══════════════════════════════════════════════════════" + @echo + @echo ">>> fib(35) iterative" + @printf " Python: " && python3 -c "\ + import time; from uncommonlisp import *; \ + g=make_global_env(); [leval(e,g) for e in read_all(PRELUDE)]; \ + [leval(e,g) for e in read_all('(auto-compile! #t)')]; \ + [leval(e,g) for e in read_all('(define (fib n) (let loop ((a 0) (b 1) (i 0)) (if (= i n) a (loop b (+ a b) (+ i 1)))))')]; \ + t=time.perf_counter(); r=[leval(e,g) for e in read_all('(fib 35)')][-1]; \ + print(f'{(time.perf_counter()-t)*1000:.2f}ms result={r}')" + @printf " C: " && /usr/bin/time -f "%e s" ./c/uncommonlisp -e '(define (fib n) (let loop ((a 0) (b 1) (i 0)) (if (= i n) a (loop b (+ a b) (+ i 1))))) (fib 35)' 2>&1 + @echo + @echo ">>> ackermann(3,4)" + @printf " Python: " && python3 -c "\ + import time; from uncommonlisp import *; \ + g=make_global_env(); [leval(e,g) for e in read_all(PRELUDE)]; \ + [leval(e,g) for e in read_all('(auto-compile! #t)')]; \ + [leval(e,g) for e in read_all('(define (ack m n) (cond ((= m 0) (+ n 1)) ((= n 0) (ack (- m 1) 1)) (else (ack (- m 1) (ack m (- n 1))))))')];\ + t=time.perf_counter(); r=[leval(e,g) for e in read_all('(ack 3 4)')][-1]; \ + print(f'{(time.perf_counter()-t)*1000:.2f}ms result={r}')" + @printf " C: " && /usr/bin/time -f "%e s" ./c/uncommonlisp -e '(define (ack m n) (cond ((= m 0) (+ n 1)) ((= n 0) (ack (- m 1) 1)) (else (ack (- m 1) (ack m (- n 1)))))) (ack 3 4)' 2>&1 + # ═══════════════════════════════════════════════════════════════════ # Whitepaper # ═══════════════════════════════════════════════════════════════════ @@ -51,6 +130,9 @@ clean: clean-whitepaper: rm -rf $(VENV) $(PDF) whitepaper/WHITEPAPER.pdf -clean-all: clean clean-whitepaper +clean-all: clean clean-whitepaper c-clean -.PHONY: all test test-verbose bench bench-verbose repl lint whitepaper clean clean-whitepaper clean-all +.PHONY: all test test-verbose bench bench-verbose repl lint \ + c-build c-test c-bench c-repl c-clean \ + test-all bench-all examples friction \ + whitepaper clean clean-whitepaper clean-all diff --git a/c/.gitignore b/c/.gitignore new file mode 100644 index 0000000..519e1fc --- /dev/null +++ b/c/.gitignore @@ -0,0 +1,5 @@ +*.o +uncommonlisp +test_runner +test_runner_dbg +bench_runner diff --git a/c/Makefile b/c/Makefile new file mode 100644 index 0000000..8432654 --- /dev/null +++ b/c/Makefile @@ -0,0 +1,39 @@ +# Makefile for uncommonlisp C interpreter +# Targets: all, test, bench, clean + +CC = gcc +CFLAGS = -O2 -Wall -Wextra -Wno-unused-parameter -std=c11 -D_POSIX_C_SOURCE=200809L -D_GNU_SOURCE +LDFLAGS = -lm + +# Optional: Boehm GC support +# Uncomment the next two lines if libgc-dev is installed +# CFLAGS += -DUSE_BOEHM_GC +# LDFLAGS += -lgc + +SRCS = types.c reader.c printer.c eval.c builtins.c vm.c +OBJS = $(SRCS:.c=.o) + +.PHONY: all clean test bench + +all: uncommonlisp + +uncommonlisp: main.o $(OBJS) + $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) + +test: test_runner + ./test_runner + +test_runner: test.c $(OBJS) + $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) + +bench: bench_runner uncommonlisp + ulimit -s 65536 && ./bench_runner + +bench_runner: bench.c $(OBJS) + $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) + +%.o: %.c uncommonlisp.h + $(CC) $(CFLAGS) -c -o $@ $< + +clean: + rm -f *.o uncommonlisp test_runner bench_runner diff --git a/c/bench.c b/c/bench.c new file mode 100644 index 0000000..764346c --- /dev/null +++ b/c/bench.c @@ -0,0 +1,137 @@ +/* + * bench.c — Benchmarks matching bench.py — same Scheme programs + */ +#include "uncommonlisp.h" + +static double bench_time(void) { + struct timespec ts; + clock_gettime(CLOCK_MONOTONIC, &ts); + return ts.tv_sec + ts.tv_nsec / 1e9; +} + +typedef struct { + const char *name; + const char *setup; + const char *expr; + int iterations; +} Benchmark; + +static Benchmark benchmarks[] = { + { + "fib-iter(30)", + "(define (fib-iter n)\n" + " (let loop ((a 0) (b 1) (i 0))\n" + " (if (= i n) a (loop b (+ a b) (+ i 1)))))\n", + "(fib-iter 30)", + 10000 + }, + { + "fib-rec(25)", + "(define (fib-rec n)\n" + " (if (<= n 1) n (+ (fib-rec (- n 1)) (fib-rec (- n 2)))))\n", + "(fib-rec 25)", + 10 + }, + { + "list-sum(1000)", + "(define (list-sum lst)\n" + " (let loop ((l lst) (acc 0))\n" + " (if (null? l) acc (loop (cdr l) (+ acc (car l))))))\n" + "(define big-list (iota 1000))\n", + "(list-sum big-list)", + 1000 + }, + { + "map-square(1000)", + "(define (my-map f lst)\n" + " (if (null? lst) '()\n" + " (cons (f (car lst)) (my-map f (cdr lst)))))\n" + "(define big-list (iota 1000))\n", + "(my-map (lambda (x) (* x x)) big-list)", + 100 + }, + { + "tak(18,12,6)", + "(define (tak x y z)\n" + " (if (not (< y x)) z\n" + " (tak (tak (- x 1) y z)\n" + " (tak (- y 1) z x)\n" + " (tak (- z 1) x y))))\n", + "(tak 18 12 6)", + 10 + }, + {NULL, NULL, NULL, 0} +}; + +static void run_benchmark(Benchmark *b, bool compiled) { + Env *g = make_global_env(); + int count; + Value *prelude_exprs = read_all(PRELUDE, &count, false); + for (int i = 0; i < count; i++) leval(prelude_exprs[i], g); + ul_free(prelude_exprs); + + if (compiled) g_auto_compile = true; + + /* Setup */ + Value *setup_exprs = read_all(b->setup, &count, false); + for (int i = 0; i < count; i++) leval(setup_exprs[i], g); + ul_free(setup_exprs); + + /* Parse the benchmark expression once */ + Value *bench_exprs = read_all(b->expr, &count, false); + + /* Warmup */ + for (int i = 0; i < 3; i++) { + for (int j = 0; j < count; j++) leval(bench_exprs[j], g); + } + + /* Timed run */ + double start = bench_time(); + for (int i = 0; i < b->iterations; i++) { + for (int j = 0; j < count; j++) leval(bench_exprs[j], g); + } + double elapsed = bench_time() - start; + + printf(" %-25s %s %8d iters %.3f s (%.1f us/iter)\n", + b->name, compiled ? "compiled" : "interp ", + b->iterations, elapsed, + (elapsed / b->iterations) * 1e6); + + ul_free(bench_exprs); + g_auto_compile = false; +} + +int main(void) { + init_symbols(); + + /* Set up root error context for prelude loading */ + ErrorContext root_ctx; + root_ctx.call_stack_depth = 0; + root_ctx.error_obj = VAL_NIL; + root_ctx.source_line = 0; + g_error_ctx = &root_ctx; + if (setjmp(root_ctx.jmp) != 0) { + fprintf(stderr, "fatal error: %s\n", root_ctx.message); + return 1; + } + + printf("uncommonlisp C benchmarks\n"); + printf("═════════════════════════════════════════════════════════════════\n"); + + for (int i = 0; benchmarks[i].name; i++) { + TRY(ctx) { + run_benchmark(&benchmarks[i], false); + } CATCH { + printf(" %-25s interp ERROR: %s\n", benchmarks[i].name, ctx.message); + } ENDTRY; + + TRY(ctx) { + run_benchmark(&benchmarks[i], true); + } CATCH { + printf(" %-25s compiled ERROR: %s\n", benchmarks[i].name, ctx.message); + } ENDTRY; + } + + printf("═════════════════════════════════════════════════════════════════\n"); + return 0; +} diff --git a/c/builtins.c b/c/builtins.c new file mode 100644 index 0000000..4053521 --- /dev/null +++ b/c/builtins.c @@ -0,0 +1,1766 @@ +/* + * builtins.c — All built-in functions for the Scheme interpreter + */ +#include "uncommonlisp.h" + +/* ═══════════════════════════════════════════════════════════════════════════ + * Helper macros + * ═══════════════════════════════════════════════════════════════════════════ */ + +#define CHECK_ARITY(name, expected) \ + if (n != (expected)) lisp_error(name ": need %d args, got %d", (expected), n) +#define CHECK_MIN_ARITY(name, expected) \ + if (n < (expected)) lisp_error(name ": need at least %d args, got %d", (expected), n) +#define AS_NUM(v) \ + (is_number(v) ? (v) : (lisp_error("not a number: %s", show(v, false)), VAL_NIL)) + +static void check_string(Value v) { + if (!IS_STRING(v)) lisp_error("not a string: %s", show(v, false)); +} + +static void check_sym(Value v) { + if (!IS_SYM(v)) lisp_error("not a symbol: %s", show(v, false)); +} + +static void check_pair(Value v) { + if (!IS_PAIR(v)) lisp_error("not a pair: %s", show(v, false)); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Arithmetic builtins + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_add(Value *a, int n, Env *e) { + (void)e; + if (n == 0) return VAL_INT(0); + Value result = AS_NUM(a[0]); + for (int i = 1; i < n; i++) result = num_add(result, AS_NUM(a[i])); + return result; +} + +static Value bi_sub(Value *a, int n, Env *e) { + (void)e; + if (n == 0) lisp_error("-: no args"); + if (n == 1) return num_neg(AS_NUM(a[0])); + Value result = AS_NUM(a[0]); + for (int i = 1; i < n; i++) result = num_sub(result, AS_NUM(a[i])); + return result; +} + +static Value bi_mul(Value *a, int n, Env *e) { + (void)e; + Value result = VAL_INT(1); + for (int i = 0; i < n; i++) result = num_mul(result, AS_NUM(a[i])); + return result; +} + +static Value bi_div(Value *a, int n, Env *e) { + (void)e; + if (n == 0) lisp_error("/: no args"); + if (n == 1) return num_div(VAL_INT(1), AS_NUM(a[0])); + Value result = AS_NUM(a[0]); + for (int i = 1; i < n; i++) result = num_div(result, AS_NUM(a[i])); + return result; +} + +#define MATH_1(name, fn) \ + static Value bi_##name(Value *a, int n, Env *e) { \ + (void)e; CHECK_ARITY(#name, 1); \ + return make_double(fn(as_number_double(AS_NUM(a[0])))); \ + } + +MATH_1(sqrt, sqrt) +MATH_1(sin, sin) +MATH_1(cos, cos) +MATH_1(tan, tan) +MATH_1(asin, asin) +MATH_1(acos, acos) +MATH_1(exp, exp) + +static Value bi_log(Value *a, int n, Env *e) { + (void)e; + if (n == 1) return make_double(log(as_number_double(a[0]))); + if (n == 2) return make_double(log(as_number_double(a[0])) / log(as_number_double(a[1]))); + lisp_error("log: need 1-2 args"); + return VAL_NIL; +} + +static Value bi_atan(Value *a, int n, Env *e) { + (void)e; + if (n == 1) return make_double(atan(as_number_double(a[0]))); + if (n == 2) return make_double(atan2(as_number_double(a[0]), as_number_double(a[1]))); + lisp_error("atan: need 1-2 args"); + return VAL_NIL; +} + +static Value bi_quotient(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("quotient", 2); + return VAL_INT(as_number_int(a[0]) / as_number_int(a[1])); +} + +static Value bi_remainder(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("remainder", 2); + int64_t x = as_number_int(a[0]), y = as_number_int(a[1]); + int64_t r = x % y; + /* Remainder has sign of dividend */ + return VAL_INT(r); +} + +static Value bi_modulo(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("modulo", 2); + int64_t x = as_number_int(a[0]), y = as_number_int(a[1]); + int64_t r = x % y; + if ((r > 0 && y < 0) || (r < 0 && y > 0)) r += y; + return VAL_INT(r); +} + +static Value bi_expt(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("expt", 2); + if (IS_INT(a[0]) && IS_INT(a[1]) && as_int(a[1]) >= 0) { + int64_t base = as_int(a[0]), exp = as_int(a[1]); + int64_t result = 1; + for (int64_t i = 0; i < exp; i++) result *= base; + return VAL_INT(result); + } + return make_double(pow(as_number_double(a[0]), as_number_double(a[1]))); +} + +static Value bi_abs(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("abs", 1); + if (IS_INT(a[0])) { int64_t v = as_int(a[0]); return VAL_INT(v < 0 ? -v : v); } + return make_double(fabs(as_number_double(a[0]))); +} + +static Value bi_floor(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("floor", 1); + return VAL_INT((int64_t)floor(as_number_double(a[0]))); +} + +static Value bi_ceiling(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("ceiling", 1); + return VAL_INT((int64_t)ceil(as_number_double(a[0]))); +} + +static Value bi_round(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("round", 1); + return VAL_INT((int64_t)round(as_number_double(a[0]))); +} + +static Value bi_truncate(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("truncate", 1); + return VAL_INT((int64_t)trunc(as_number_double(a[0]))); +} + +static Value bi_min(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("min", 1); + Value r = a[0]; + for (int i = 1; i < n; i++) if (num_lt(a[i], r)) r = a[i]; + return r; +} + +static Value bi_max(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("max", 1); + Value r = a[0]; + for (int i = 1; i < n; i++) if (num_gt(a[i], r)) r = a[i]; + return r; +} + +static Value bi_gcd(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("gcd", 2); + int64_t x = as_number_int(a[0]), y = as_number_int(a[1]); + if (x < 0) x = -x; if (y < 0) y = -y; + while (y) { int64_t t = y; y = x % y; x = t; } + return VAL_INT(x); +} + +static Value bi_lcm(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("lcm", 2); + int64_t x = as_number_int(a[0]), y = as_number_int(a[1]); + if (x < 0) x = -x; if (y < 0) y = -y; + int64_t g = x; + { int64_t b = y; while (b) { int64_t t = b; b = g % b; g = t; } } + return VAL_INT(g ? (x / g) * y : 0); +} + +static Value bi_exact(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("exact", 1); + if (IS_INT(a[0]) || IS_RATIONAL(a[0])) return a[0]; + /* Approximate double → fraction */ + double d = as_double(a[0]); + return rational_normalize((int64_t)(d * 1000000), 1000000); +} + +static Value bi_inexact(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("inexact", 1); + return make_double(as_number_double(a[0])); +} + +static Value bi_numerator(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("numerator", 1); + if (IS_RATIONAL(a[0])) return VAL_INT(AS_RATIONAL(a[0])->num); + if (IS_INT(a[0])) return a[0]; + return a[0]; +} + +static Value bi_denominator(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("denominator", 1); + if (IS_RATIONAL(a[0])) return VAL_INT(AS_RATIONAL(a[0])->den); + return VAL_INT(1); +} + +static Value bi_number_to_string(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("number->string", 1); + char buf[128]; + if (n > 1) { + int base = (int)as_number_int(a[1]); + int64_t val = as_number_int(a[0]); + switch (base) { + case 2: { + char *p = buf + 127; *p = '\0'; + uint64_t uv = val < 0 ? -val : val; + if (uv == 0) { *--p = '0'; } + else { while (uv) { *--p = '0' + (uv & 1); uv >>= 1; } } + if (val < 0) *--p = '-'; + return make_string_from_cstr(p); + } + case 8: snprintf(buf, sizeof(buf), "%llo", (long long)val); break; + case 16: snprintf(buf, sizeof(buf), "%llx", (long long)val); break; + default: snprintf(buf, sizeof(buf), "%lld", (long long)val); break; + } + } else { + char *s = show(a[0], false); + Value r = make_string_from_cstr(s); + ul_free(s); + return r; + } + return make_string_from_cstr(buf); +} + +/* Numeric comparison builtins */ +#define NUM_CMP(name, op) \ + static Value bi_##name(Value *a, int n, Env *e) { \ + (void)e; CHECK_MIN_ARITY(#name, 2); \ + for (int i = 0; i < n - 1; i++) { \ + if (!(op(AS_NUM(a[i]), AS_NUM(a[i+1])))) return VAL_FALSE; \ + } \ + return VAL_TRUE; \ + } + +NUM_CMP(num_eq, num_eq) +NUM_CMP(num_lt, num_lt) +NUM_CMP(num_gt, num_gt) +NUM_CMP(num_le, num_le) +NUM_CMP(num_ge, num_ge) + +/* Numeric predicates */ +#define NUM_PRED(name, check) \ + static Value bi_##name(Value *a, int n, Env *e) { \ + (void)e; CHECK_ARITY(#name, 1); \ + return VAL_BOOL(check); \ + } + +NUM_PRED(zero_p, is_number(a[0]) && num_eq(a[0], VAL_INT(0))) +NUM_PRED(positive_p, is_number(a[0]) && num_gt(a[0], VAL_INT(0))) +NUM_PRED(negative_p, is_number(a[0]) && num_lt(a[0], VAL_INT(0))) +NUM_PRED(odd_p, IS_INT(a[0]) && (as_int(a[0]) % 2 != 0)) +NUM_PRED(even_p, IS_INT(a[0]) && (as_int(a[0]) % 2 == 0)) + +static Value bi_nan_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("nan?", 1); + return VAL_BOOL(IS_DOUBLE(a[0]) && isnan(as_double(a[0]))); +} +static Value bi_infinite_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("infinite?", 1); + return VAL_BOOL(IS_DOUBLE(a[0]) && isinf(as_double(a[0]))); +} +static Value bi_finite_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("finite?", 1); + return VAL_BOOL(is_number(a[0]) && (IS_INT(a[0]) || (IS_DOUBLE(a[0]) && isfinite(as_double(a[0]))))); +} + +static Value bi_square(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("square", 1); + return num_mul(a[0], a[0]); +} + +static Value bi_exact_integer_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("exact-integer?", 1); + return VAL_BOOL(IS_INT(a[0])); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Booleans & Equality + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_not(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("not", 1); + return VAL_BOOL(!IS_TRUTHY(a[0])); +} + +static Value bi_boolean_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("boolean?", 1); + return VAL_BOOL(IS_TRUE(a[0]) || IS_FALSE(a[0])); +} + +static Value bi_eq_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("eq?", 2); + if (a[0] == a[1]) return VAL_TRUE; + /* eq? on integers, booleans, symbols is value comparison */ + if (IS_INT(a[0]) && IS_INT(a[1])) return VAL_BOOL(as_int(a[0]) == as_int(a[1])); + return VAL_FALSE; +} + +static Value bi_eqv_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("eqv?", 2); + if (a[0] == a[1]) return VAL_TRUE; + if (IS_INT(a[0]) && IS_INT(a[1])) return VAL_BOOL(as_int(a[0]) == as_int(a[1])); + if (IS_DOUBLE(a[0]) && IS_DOUBLE(a[1])) return VAL_BOOL(as_double(a[0]) == as_double(a[1])); + if (IS_CHAR(a[0]) && IS_CHAR(a[1])) return VAL_BOOL(AS_CHAR(a[0]) == AS_CHAR(a[1])); + if (IS_STRING(a[0]) && IS_STRING(a[1])) { + ULString *s1 = AS_STRING(a[0]), *s2 = AS_STRING(a[1]); + return VAL_BOOL(s1->len == s2->len && memcmp(s1->data, s2->data, s1->len) == 0); + } + return VAL_FALSE; +} + +static Value bi_equal_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("equal?", 2); + return VAL_BOOL(values_equal(a[0], a[1])); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Type predicates + * ═══════════════════════════════════════════════════════════════════════════ */ + +#define TYPE_PRED(name, check) \ + static Value bi_##name(Value *a, int n, Env *e) { \ + (void)e; CHECK_ARITY(#name, 1); \ + return VAL_BOOL(check); \ + } + +TYPE_PRED(number_p, is_number(a[0])) +TYPE_PRED(integer_p, IS_INT(a[0]) || (IS_DOUBLE(a[0]) && as_double(a[0]) == floor(as_double(a[0])))) +TYPE_PRED(real_p, is_number(a[0])) +TYPE_PRED(rational_p, IS_INT(a[0]) || IS_RATIONAL(a[0]) || (IS_DOUBLE(a[0]) && isfinite(as_double(a[0])))) +TYPE_PRED(exact_p, IS_INT(a[0]) || IS_RATIONAL(a[0])) +TYPE_PRED(inexact_p, IS_DOUBLE(a[0])) +TYPE_PRED(pair_p, IS_PAIR(a[0])) +TYPE_PRED(null_p, IS_NIL(a[0])) +TYPE_PRED(list_p, is_proper_list(a[0])) +TYPE_PRED(symbol_p, IS_SYM(a[0])) +TYPE_PRED(string_p, IS_STRING(a[0])) +TYPE_PRED(char_p, IS_CHAR(a[0])) +TYPE_PRED(vector_p, IS_VECTOR(a[0])) +TYPE_PRED(procedure_p, is_callable(a[0])) +TYPE_PRED(void_p, IS_VOID(a[0])) +TYPE_PRED(eof_object_p, IS_EOF(a[0])) +TYPE_PRED(port_p, IS_PORT(a[0])) +TYPE_PRED(input_port_p, IS_PORT(a[0]) && AS_PORT(a[0])->dir == PORT_INPUT) +TYPE_PRED(output_port_p, IS_PORT(a[0]) && AS_PORT(a[0])->dir == PORT_OUTPUT) +TYPE_PRED(hash_table_p, IS_HASHTABLE(a[0])) + +/* ═══════════════════════════════════════════════════════════════════════════ + * Pairs & Lists + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_cons(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("cons", 2); + return cons(a[0], a[1]); +} +static Value bi_car(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("car", 1); check_pair(a[0]); + return CAR(a[0]); +} +static Value bi_cdr(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("cdr", 1); check_pair(a[0]); + return CDR(a[0]); +} +static Value bi_set_car(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("set-car!", 2); check_pair(a[0]); + AS_PAIR(a[0])->car = a[1]; + return VAL_VOID; +} +static Value bi_set_cdr(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("set-cdr!", 2); check_pair(a[0]); + AS_PAIR(a[0])->cdr = a[1]; + return VAL_VOID; +} +static Value bi_list(Value *a, int n, Env *e) { + (void)e; + return list_to_value(a, n); +} +static Value bi_length(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("length", 1); + Value *items; int count = value_to_list(a[0], &items); + ul_free(items); + return VAL_INT(count); +} +static Value bi_append(Value *a, int n, Env *e) { + (void)e; + if (n == 0) return VAL_NIL; + Value result = a[n - 1]; + for (int i = n - 2; i >= 0; i--) { + Value *items; int ni = value_to_list(a[i], &items); + for (int j = ni - 1; j >= 0; j--) result = cons(items[j], result); + ul_free(items); + } + return result; +} +static Value bi_reverse(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("reverse", 1); + Value *items; int ni = value_to_list(a[0], &items); + Value result = VAL_NIL; + for (int i = 0; i < ni; i++) result = cons(items[i], result); + ul_free(items); + return result; +} + +static Value bi_list_tail(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("list-tail", 2); + int k = (int)as_number_int(a[1]); + Value lst = a[0]; + for (int i = 0; i < k; i++) { check_pair(lst); lst = CDR(lst); } + return lst; +} +static Value bi_list_ref(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("list-ref", 2); + int k = (int)as_number_int(a[1]); + Value lst = a[0]; + for (int i = 0; i < k; i++) { check_pair(lst); lst = CDR(lst); } + check_pair(lst); + return CAR(lst); +} +static Value bi_list_set(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("list-set!", 3); + int k = (int)as_number_int(a[1]); + Value lst = a[0]; + for (int i = 0; i < k; i++) { check_pair(lst); lst = CDR(lst); } + check_pair(lst); + AS_PAIR(lst)->car = a[2]; + return VAL_VOID; +} +static Value bi_list_copy(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("list-copy", 1); + Value *items; int ni = value_to_list(a[0], &items); + Value r = list_to_value(items, ni); + ul_free(items); + return r; +} +static Value bi_make_list(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("make-list", 1); + int len = (int)as_number_int(a[0]); + Value fill = n > 1 ? a[1] : VAL_FALSE; + Value r = VAL_NIL; + for (int i = 0; i < len; i++) r = cons(fill, r); + return r; +} + +static Value bi_iota(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("iota", 1); + int count = (int)as_number_int(a[0]); + int start = n > 1 ? (int)as_number_int(a[1]) : 0; + int step = n > 2 ? (int)as_number_int(a[2]) : 1; + Value r = VAL_NIL; + for (int i = count - 1; i >= 0; i--) r = cons(VAL_INT(start + i * step), r); + return r; +} + +static Value bi_memq(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("memq", 2); + Value lst = a[1]; + while (IS_PAIR(lst)) { + if (CAR(lst) == a[0] || (IS_INT(CAR(lst)) && IS_INT(a[0]) && as_int(CAR(lst)) == as_int(a[0]))) + return lst; + lst = CDR(lst); + } + return VAL_FALSE; +} + +static Value bi_memv(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("memv", 2); + Value lst = a[1]; + while (IS_PAIR(lst)) { + if (values_equal(CAR(lst), a[0])) return lst; + lst = CDR(lst); + } + return VAL_FALSE; +} + +static Value bi_member(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("member", 2); + Value lst = a[1]; + while (IS_PAIR(lst)) { + if (values_equal(CAR(lst), a[0])) return lst; + lst = CDR(lst); + } + return VAL_FALSE; +} + +static Value bi_assq(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("assq", 2); + Value lst = a[1]; + while (IS_PAIR(lst)) { + Value pair = CAR(lst); + if (IS_PAIR(pair) && CAR(pair) == a[0]) return pair; + lst = CDR(lst); + } + return VAL_FALSE; +} + +static Value bi_assoc(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("assoc", 2); + Value lst = a[1]; + while (IS_PAIR(lst)) { + Value pair = CAR(lst); + if (IS_PAIR(pair) && values_equal(CAR(pair), a[0])) return pair; + lst = CDR(lst); + } + return VAL_FALSE; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Higher-order functions + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_map(Value *a, int n, Env *e) { + CHECK_MIN_ARITY("map", 2); + Value proc = a[0]; + /* Collect all lists */ + int nlists = n - 1; + Value *lists = a + 1; + Value **items_arr = (Value **)ul_malloc(sizeof(Value *) * nlists); + int min_len = INT32_MAX; + for (int i = 0; i < nlists; i++) { + int ni; + items_arr[i] = NULL; + ni = value_to_list(lists[i], &items_arr[i]); + if (ni < min_len) min_len = ni; + } + + Value *results = (Value *)ul_malloc(sizeof(Value) * min_len); + Value *call_args = (Value *)ul_malloc(sizeof(Value) * nlists); + for (int j = 0; j < min_len; j++) { + for (int i = 0; i < nlists; i++) call_args[i] = items_arr[i][j]; + results[j] = call_proc(proc, call_args, nlists, e); + } + Value r = list_to_value(results, min_len); + + for (int i = 0; i < nlists; i++) ul_free(items_arr[i]); + ul_free(items_arr); ul_free(results); ul_free(call_args); + return r; +} + +static Value bi_for_each(Value *a, int n, Env *e) { + CHECK_MIN_ARITY("for-each", 2); + Value proc = a[0]; + int nlists = n - 1; + Value *lists = a + 1; + Value **items_arr = (Value **)ul_malloc(sizeof(Value *) * nlists); + int min_len = INT32_MAX; + for (int i = 0; i < nlists; i++) { + int ni; + ni = value_to_list(lists[i], &items_arr[i]); + if (ni < min_len) min_len = ni; + } + Value *call_args = (Value *)ul_malloc(sizeof(Value) * nlists); + for (int j = 0; j < min_len; j++) { + for (int i = 0; i < nlists; i++) call_args[i] = items_arr[i][j]; + call_proc(proc, call_args, nlists, e); + } + for (int i = 0; i < nlists; i++) ul_free(items_arr[i]); + ul_free(items_arr); ul_free(call_args); + return VAL_VOID; +} + +static Value bi_filter(Value *a, int n, Env *e) { + CHECK_ARITY("filter", 2); + Value proc = a[0]; + Value *items; int ni = value_to_list(a[1], &items); + Value *results = (Value *)ul_malloc(sizeof(Value) * ni); + int nr = 0; + for (int i = 0; i < ni; i++) { + Value v = call_proc(proc, &items[i], 1, e); + if (IS_TRUTHY(v)) results[nr++] = items[i]; + } + Value r = list_to_value(results, nr); + ul_free(items); ul_free(results); + return r; +} + +static Value bi_fold_left(Value *a, int n, Env *e) { + CHECK_ARITY("fold-left", 3); + Value proc = a[0]; + Value acc = a[1]; + Value *items; int ni = value_to_list(a[2], &items); + for (int i = 0; i < ni; i++) { + Value args[2] = {items[i], acc}; + acc = call_proc(proc, args, 2, e); + } + ul_free(items); + return acc; +} + +static Value bi_fold_right(Value *a, int n, Env *e) { + CHECK_ARITY("fold-right", 3); + Value proc = a[0]; + Value acc = a[1]; + Value *items; int ni = value_to_list(a[2], &items); + for (int i = ni - 1; i >= 0; i--) { + Value args[2] = {items[i], acc}; + acc = call_proc(proc, args, 2, e); + } + ul_free(items); + return acc; +} + +static Value bi_any(Value *a, int n, Env *e) { + CHECK_ARITY("any", 2); + Value *items; int ni = value_to_list(a[1], &items); + for (int i = 0; i < ni; i++) { + Value v = call_proc(a[0], &items[i], 1, e); + if (IS_TRUTHY(v)) { ul_free(items); return v; } + } + ul_free(items); return VAL_FALSE; +} + +static Value bi_every(Value *a, int n, Env *e) { + CHECK_ARITY("every", 2); + Value *items; int ni = value_to_list(a[1], &items); + for (int i = 0; i < ni; i++) { + Value v = call_proc(a[0], &items[i], 1, e); + if (!IS_TRUTHY(v)) { ul_free(items); return VAL_FALSE; } + } + ul_free(items); return VAL_TRUE; +} + +static Value bi_find(Value *a, int n, Env *e) { + CHECK_ARITY("find", 2); + Value *items; int ni = value_to_list(a[1], &items); + for (int i = 0; i < ni; i++) { + Value v = call_proc(a[0], &items[i], 1, e); + if (IS_TRUTHY(v)) { Value r = items[i]; ul_free(items); return r; } + } + ul_free(items); return VAL_FALSE; +} + +static Value bi_sort(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("sort", 1); + Value *items; int ni = value_to_list(a[0], &items); + /* Simple insertion sort */ + for (int i = 1; i < ni; i++) { + Value key = items[i]; + int j = i - 1; + while (j >= 0 && num_gt(items[j], key)) { + items[j + 1] = items[j]; j--; + } + items[j + 1] = key; + } + Value r = list_to_value(items, ni); + ul_free(items); + return r; +} + +static Value bi_count(Value *a, int n, Env *e) { + CHECK_ARITY("count", 2); + Value *items; int ni = value_to_list(a[1], &items); + int c = 0; + for (int i = 0; i < ni; i++) { + if (IS_TRUTHY(call_proc(a[0], &items[i], 1, e))) c++; + } + ul_free(items); + return VAL_INT(c); +} + +static Value bi_apply(Value *a, int n, Env *e) { + CHECK_MIN_ARITY("apply", 2); + Value proc = a[0]; + int npre = n - 2; + Value last = a[n - 1]; + Value *lst; int nlst = value_to_list(last, &lst); + int total = npre + nlst; + Value *all = (Value *)ul_malloc(sizeof(Value) * total); + for (int i = 0; i < npre; i++) all[i] = a[i + 1]; + memcpy(all + npre, lst, sizeof(Value) * nlst); + Value r = call_proc(proc, all, total, e); + ul_free(lst); ul_free(all); + return r; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Strings + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_make_string(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("make-string", 1); + int len = (int)as_number_int(a[0]); + char fill = n > 1 && IS_CHAR(a[1]) ? (char)AS_CHAR(a[1]) : ' '; + char *buf = (char *)ul_malloc(len + 1); + memset(buf, fill, len); buf[len] = '\0'; + Value r = make_string(buf, len, true); + ul_free(buf); + return r; +} + +static Value bi_string_length(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-length", 1); check_string(a[0]); + return VAL_INT(AS_STRING(a[0])->len); +} + +static Value bi_string_ref(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-ref", 2); check_string(a[0]); + int idx = (int)as_number_int(a[1]); + ULString *s = AS_STRING(a[0]); + if (idx < 0 || idx >= (int)s->len) lisp_error("string-ref: index out of range"); + return VAL_CHAR(s->data[idx]); +} + +static Value bi_substring(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("substring", 2); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + int start = (int)as_number_int(a[1]); + int end = n > 2 ? (int)as_number_int(a[2]) : (int)s->len; + if (start < 0) start = 0; + if (end > (int)s->len) end = (int)s->len; + return make_string(s->data + start, end - start, false); +} + +static Value bi_string_append(Value *a, int n, Env *e) { + (void)e; + size_t total = 0; + for (int i = 0; i < n; i++) { + check_string(a[i]); + total += AS_STRING(a[i])->len; + } + char *buf = (char *)ul_malloc(total + 1); + size_t pos = 0; + for (int i = 0; i < n; i++) { + ULString *s = AS_STRING(a[i]); + memcpy(buf + pos, s->data, s->len); + pos += s->len; + } + buf[pos] = '\0'; + Value r = make_string(buf, pos, false); + ul_free(buf); + return r; +} + +static Value bi_string_to_list(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string->list", 1); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + Value r = VAL_NIL; + for (int i = (int)s->len - 1; i >= 0; i--) r = cons(VAL_CHAR(s->data[i]), r); + return r; +} + +static Value bi_list_to_string(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("list->string", 1); + Value *items; int ni = value_to_list(a[0], &items); + char *buf = (char *)ul_malloc(ni + 1); + for (int i = 0; i < ni; i++) buf[i] = IS_CHAR(items[i]) ? (char)AS_CHAR(items[i]) : '?'; + buf[ni] = '\0'; + ul_free(items); + Value r = make_string(buf, ni, false); + ul_free(buf); + return r; +} + +static Value bi_string_to_symbol(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string->symbol", 1); check_string(a[0]); + return intern(AS_STRING(a[0])->data); +} + +static Value bi_symbol_to_string(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("symbol->string", 1); check_sym(a[0]); + return make_string_from_cstr(sym_name(a[0])); +} + +static Value bi_string_to_number(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("string->number", 1); check_string(a[0]); + const char *s = AS_STRING(a[0])->data; + int base = n > 1 ? (int)as_number_int(a[1]) : 10; + char *end; + errno = 0; + long long val = strtoll(s, &end, base); + if (*end == '\0' && errno == 0) return VAL_INT(val); + if (base == 10) { + double d = strtod(s, &end); + if (*end == '\0' && errno == 0) return make_double(d); + /* Try rational */ + const char *slash = strchr(s, '/'); + if (slash) { + int64_t num = strtoll(s, NULL, 10); + int64_t den = strtoll(slash + 1, NULL, 10); + if (den != 0) return rational_normalize(num, den); + } + } + return VAL_FALSE; +} + +static Value bi_string_upcase(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-upcase", 1); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + char *buf = (char *)ul_malloc(s->len + 1); + for (size_t i = 0; i < s->len; i++) buf[i] = toupper(s->data[i]); + buf[s->len] = '\0'; + Value r = make_string(buf, s->len, false); + ul_free(buf); + return r; +} + +static Value bi_string_downcase(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-downcase", 1); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + char *buf = (char *)ul_malloc(s->len + 1); + for (size_t i = 0; i < s->len; i++) buf[i] = tolower(s->data[i]); + buf[s->len] = '\0'; + Value r = make_string(buf, s->len, false); + ul_free(buf); + return r; +} + +static Value bi_string_eq(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string=?", 2); check_string(a[0]); check_string(a[1]); + ULString *s1 = AS_STRING(a[0]), *s2 = AS_STRING(a[1]); + return VAL_BOOL(s1->len == s2->len && memcmp(s1->data, s2->data, s1->len) == 0); +} +static Value bi_string_lt(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("stringdata, AS_STRING(a[1])->data) < 0); +} + +static Value bi_format(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("format", 1); + check_string(a[0]); + const char *fmt = AS_STRING(a[0])->data; + size_t fmtlen = AS_STRING(a[0])->len; + char buf[4096]; + int pos = 0, ai = 1; + for (size_t i = 0; i < fmtlen && pos < 4090; i++) { + if (fmt[i] == '~' && i + 1 < fmtlen) { + i++; + switch (fmt[i]) { + case 'a': { char *s = show(a[ai++], true); pos += snprintf(buf + pos, sizeof(buf) - pos, "%s", s); ul_free(s); break; } + case 's': { char *s = show(a[ai++], false); pos += snprintf(buf + pos, sizeof(buf) - pos, "%s", s); ul_free(s); break; } + case '%': buf[pos++] = '\n'; break; + case '~': buf[pos++] = '~'; break; + default: buf[pos++] = '~'; buf[pos++] = fmt[i]; break; + } + } else { + buf[pos++] = fmt[i]; + } + } + buf[pos] = '\0'; + return make_string_from_cstr(buf); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Characters + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_char_to_integer(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("char->integer", 1); + return VAL_INT(AS_CHAR(a[0])); +} +static Value bi_integer_to_char(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("integer->char", 1); + return VAL_CHAR((int)as_number_int(a[0])); +} +static Value bi_char_alphabetic(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("char-alphabetic?", 1); + return VAL_BOOL(isalpha(AS_CHAR(a[0]))); +} +static Value bi_char_numeric(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("char-numeric?", 1); + return VAL_BOOL(isdigit(AS_CHAR(a[0]))); +} +static Value bi_char_whitespace(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("char-whitespace?", 1); + return VAL_BOOL(isspace(AS_CHAR(a[0]))); +} +static Value bi_char_eq(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("char=?", 2); + return VAL_BOOL(AS_CHAR(a[0]) == AS_CHAR(a[1])); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Vectors + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_make_vector(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("make-vector", 1); + int len = (int)as_number_int(a[0]); + Value fill = n > 1 ? a[1] : VAL_INT(0); + return make_vector(len, fill); +} +static Value bi_vector(Value *a, int n, Env *e) { + (void)e; + return make_vector_from(a, n); +} +static Value bi_vector_length(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("vector-length", 1); + return VAL_INT(AS_VECTOR(a[0])->len); +} +static Value bi_vector_ref(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("vector-ref", 2); + int idx = (int)as_number_int(a[1]); + return AS_VECTOR(a[0])->data[idx]; +} +static Value bi_vector_set(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("vector-set!", 3); + int idx = (int)as_number_int(a[1]); + AS_VECTOR(a[0])->data[idx] = a[2]; + return VAL_VOID; +} +static Value bi_vector_to_list(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("vector->list", 1); + ULVector *v = AS_VECTOR(a[0]); + return list_to_value(v->data, (int)v->len); +} +static Value bi_list_to_vector(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("list->vector", 1); + Value *items; int ni = value_to_list(a[0], &items); + Value r = make_vector_from(items, ni); + ul_free(items); + return r; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Hash tables + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_make_hash_table(Value *a, int n, Env *e) { + (void)e; + return make_hashtable(); +} +static Value bi_hash_table_set(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-set!", 3); + ht_set(AS_HASHTABLE(a[0]), a[1], a[2]); + return VAL_VOID; +} +static Value bi_hash_table_ref(Value *a, int n, Env *e) { + CHECK_MIN_ARITY("hash-table-ref", 2); + bool found; + Value v = ht_ref(AS_HASHTABLE(a[0]), a[1], &found); + if (!found) { + if (n > 2) return call_proc(a[2], NULL, 0, e); + lisp_error("hash-table-ref: missing key"); + } + return v; +} +static Value bi_hash_table_ref_default(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-ref/default", 3); + bool found; + Value v = ht_ref(AS_HASHTABLE(a[0]), a[1], &found); + return found ? v : a[2]; +} +static Value bi_hash_table_delete(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-delete!", 2); + ht_delete(AS_HASHTABLE(a[0]), a[1]); + return VAL_VOID; +} +static Value bi_hash_table_exists(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-exists?", 2); + bool found; + ht_ref(AS_HASHTABLE(a[0]), a[1], &found); + return VAL_BOOL(found); +} +static Value bi_hash_table_size(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-size", 1); + return VAL_INT(ht_count(AS_HASHTABLE(a[0]))); +} +static Value bi_hash_table_keys(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-keys", 1); + ULHashTable *ht = AS_HASHTABLE(a[0]); + Value r = VAL_NIL; + for (size_t i = 0; i < ht->nbuckets; i++) { + HTEntry *entry = ht->buckets[i]; + while (entry) { r = cons(entry->key, r); entry = entry->next; } + } + return r; +} +static Value bi_hash_table_values(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("hash-table-values", 1); + ULHashTable *ht = AS_HASHTABLE(a[0]); + Value r = VAL_NIL; + for (size_t i = 0; i < ht->nbuckets; i++) { + HTEntry *entry = ht->buckets[i]; + while (entry) { r = cons(entry->value, r); entry = entry->next; } + } + return r; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * I/O + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_display(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("display", 1); + FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout; + if (!out) out = stdout; + char *s = show(a[0], true); + if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) { + port_write_str(AS_PORT(a[1]), s, strlen(s)); + } else { + fputs(s, out); + fflush(out); + } + ul_free(s); + return VAL_VOID; +} + +static Value bi_write(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("write", 1); + FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout; + if (!out) out = stdout; + char *s = show(a[0], false); + if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) { + port_write_str(AS_PORT(a[1]), s, strlen(s)); + } else { + fputs(s, out); + fflush(out); + } + ul_free(s); + return VAL_VOID; +} + +static Value bi_newline(Value *a, int n, Env *e) { + (void)e; + FILE *out = n > 0 && IS_PORT(a[0]) ? AS_PORT(a[0])->fp : stdout; + if (!out) out = stdout; + fputc('\n', out); + fflush(out); + return VAL_VOID; +} + +static Value bi_print(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("print", 1); + char *s = show(a[0], true); + printf("%s\n", s); + fflush(stdout); + ul_free(s); + return VAL_VOID; +} + +static Value bi_read_line(Value *a, int n, Env *e) { + (void)e; + if (n > 0 && IS_PORT(a[0])) { + char *line = port_read_line(AS_PORT(a[0])); + if (!line) return VAL_EOF; + Value r = make_string_from_cstr(line); + ul_free(line); + return r; + } + char buf[4096]; + if (!fgets(buf, sizeof(buf), stdin)) return VAL_EOF; + size_t len = strlen(buf); + if (len > 0 && buf[len-1] == '\n') buf[--len] = '\0'; + return make_string(buf, len, false); +} + +static Value bi_read_char(Value *a, int n, Env *e) { + (void)e; + int ch; + if (n > 0 && IS_PORT(a[0])) { + ch = port_read_char(AS_PORT(a[0])); + } else { + ch = fgetc(stdin); + } + if (ch == EOF) return VAL_EOF; + return VAL_CHAR(ch); +} + +static Value bi_open_input_file(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("open-input-file", 1); check_string(a[0]); + FILE *f = fopen(AS_STRING(a[0])->data, "r"); + if (!f) lisp_error("open-input-file: cannot open: %s", AS_STRING(a[0])->data); + return make_file_port(f, PORT_INPUT); +} +static Value bi_open_output_file(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("open-output-file", 1); check_string(a[0]); + FILE *f = fopen(AS_STRING(a[0])->data, "w"); + if (!f) lisp_error("open-output-file: cannot open: %s", AS_STRING(a[0])->data); + return make_file_port(f, PORT_OUTPUT); +} +static Value bi_open_input_string(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("open-input-string", 1); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + return make_string_input_port(s->data, s->len); +} +static Value bi_open_output_string(Value *a, int n, Env *e) { + (void)e; + return make_string_output_port(); +} +static Value bi_get_output_string(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("get-output-string", 1); + char *s = port_get_output_string(AS_PORT(a[0])); + Value r = make_string_from_cstr(s); + ul_free(s); + return r; +} +static Value bi_close_port(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("close-port", 1); + ULPort *p = AS_PORT(a[0]); + if (p->fp && p->fp != stdin && p->fp != stdout && p->fp != stderr) + fclose(p->fp); + p->closed = true; + return VAL_VOID; +} +static Value bi_eof_object(Value *a, int n, Env *e) { + (void)e; return VAL_EOF; +} +static Value bi_void(Value *a, int n, Env *e) { + (void)e; return VAL_VOID; +} + +static Value bi_current_input_port(Value *a, int n, Env *e) { + (void)e; return make_file_port(stdin, PORT_INPUT); +} +static Value bi_current_output_port(Value *a, int n, Env *e) { + (void)e; return make_file_port(stdout, PORT_OUTPUT); +} +static Value bi_current_error_port(Value *a, int n, Env *e) { + (void)e; return make_file_port(stderr, PORT_OUTPUT); +} +static Value bi_flush_output_port(Value *a, int n, Env *e) { + (void)e; + if (n > 0 && IS_PORT(a[0]) && AS_PORT(a[0])->fp) fflush(AS_PORT(a[0])->fp); + else fflush(stdout); + return VAL_VOID; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * File system + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_file_exists(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("file-exists?", 1); check_string(a[0]); + struct stat st; + return VAL_BOOL(stat(AS_STRING(a[0])->data, &st) == 0); +} +static Value bi_current_directory(Value *a, int n, Env *e) { + (void)e; + char buf[4096]; + if (!getcwd(buf, sizeof(buf))) return make_string_from_cstr("."); + return make_string_from_cstr(buf); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * System + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value bi_exit(Value *a, int n, Env *e) { + (void)e; + exit(n > 0 ? (int)as_number_int(a[0]) : 0); + return VAL_VOID; +} + +static Value bi_error(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("error", 1); + char *msg = show(a[0], true); + Value *irr = n > 1 ? a + 1 : NULL; + int nirr = n - 1; + Value obj = make_error_object(msg, irr, nirr); + ErrorObject *eo = AS_ERROR(obj); + char full_msg[MAX_ERROR_MSG]; + int off = snprintf(full_msg, sizeof(full_msg), "%s", eo->message); + for (int i = 0; i < nirr && off < MAX_ERROR_MSG - 2; i++) { + char *s = show(irr[i], false); + off += snprintf(full_msg + off, sizeof(full_msg) - off, ": %s", s); + ul_free(s); + } + ul_free(msg); + lisp_error_with_obj(obj, "%s", full_msg); + return VAL_NIL; +} + +static Value bi_error_object_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("error-object?", 1); + return VAL_BOOL(IS_ERROR_OBJ(a[0])); +} + +static Value bi_error_object_message(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("error-object-message", 1); + if (IS_ERROR_OBJ(a[0])) return make_string_from_cstr(AS_ERROR(a[0])->message); + char *s = show(a[0], true); + Value r = make_string_from_cstr(s); + ul_free(s); + return r; +} + +static Value bi_error_object_irritants(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("error-object-irritants", 1); + if (IS_ERROR_OBJ(a[0])) { + ErrorObject *eo = AS_ERROR(a[0]); + return list_to_value(eo->irritants, eo->nirritants); + } + return VAL_NIL; +} + +static Value bi_current_time(Value *a, int n, Env *e) { + (void)e; + struct timespec ts; + clock_gettime(CLOCK_REALTIME, &ts); + return make_double(ts.tv_sec + ts.tv_nsec / 1e9); +} + +static Value bi_current_jiffy(Value *a, int n, Env *e) { + (void)e; + struct timespec ts; + clock_gettime(CLOCK_MONOTONIC, &ts); + return VAL_INT(ts.tv_sec * 1000 + ts.tv_nsec / 1000000); +} + +static Value bi_jiffies_per_second(Value *a, int n, Env *e) { + (void)e; return VAL_INT(1000); +} + +static Value bi_command_line(Value *a, int n, Env *e) { + (void)a; (void)n; (void)e; + return VAL_NIL; /* will be set by main */ +} + +static Value bi_get_environment_variable(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("get-environment-variable", 1); check_string(a[0]); + const char *val = getenv(AS_STRING(a[0])->data); + if (!val) return VAL_FALSE; + return make_string_from_cstr(val); +} + +static Value bi_gensym(Value *a, int n, Env *e) { + (void)e; + static int counter = 0; + char buf[32]; + snprintf(buf, sizeof(buf), "g%d", counter++); + return intern(buf); +} + +static Value bi_make_parameter(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("make-parameter", 1); + /* We store the parameter value in a vector of size 1 */ + Value box = make_vector(1, a[0]); + /* If converter provided, apply it */ + if (n > 1) { + Value args[1] = {a[0]}; + AS_VECTOR(box)->data[0] = call_proc(a[1], args, 1, e); + } + /* Return a closure: 0 args → get, 1 arg → set */ + /* We need to create a Scheme closure that captures the box */ + /* Use a builtin with captured state via a trick: store box in an env */ + Env *closure_env = make_env(e); + env_define(closure_env, intern("__param_box__"), box); + if (n > 1) env_define(closure_env, intern("__param_converter__"), a[1]); + else env_define(closure_env, intern("__param_converter__"), VAL_FALSE); + + char src[256]; + snprintf(src, sizeof(src), + "(lambda args " + " (if (null? args) " + " (vector-ref __param_box__ 0) " + " (begin (vector-set! __param_box__ 0 " + " (if __param_converter__ (__param_converter__ (car args)) (car args))) " + " (void))))"); + int nc; + Value *exprs = read_all(src, &nc, false); + Value proc = leval(exprs[0], closure_env); + ul_free(exprs); + return proc; +} + +static Value bi_values(Value *a, int n, Env *e) { + (void)e; + if (n == 1) return a[0]; + return make_vector_from(a, n); +} + +static Value bi_call_with_values(Value *a, int n, Env *e) { + CHECK_ARITY("call-with-values", 2); + Value r = call_proc(a[0], NULL, 0, e); + if (IS_VECTOR(r)) { + ULVector *v = AS_VECTOR(r); + return call_proc(a[1], v->data, (int)v->len, e); + } + Value args[1] = {r}; + return call_proc(a[1], args, 1, e); +} + +static Value bi_object_to_string(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("object->string", 1); + char *s = show(a[0], false); + Value r = make_string_from_cstr(s); + ul_free(s); + return r; +} + +static Value bi_display_to_string(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("display-to-string", 1); + char *s = show(a[0], true); + Value r = make_string_from_cstr(s); + ul_free(s); + return r; +} + +static Value bi_string_copy(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-copy", 1); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + return make_string(s->data, s->len, true); +} + +static Value bi_string_set(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-set!", 3); check_string(a[0]); + ULString *s = AS_STRING(a[0]); + if (!s->mutable) lisp_error("string-set!: immutable string"); + int idx = (int)as_number_int(a[1]); + s->data[idx] = (char)AS_CHAR(a[2]); + return VAL_VOID; +} + +static Value bi_string_contains(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-contains", 2); + check_string(a[0]); check_string(a[1]); + return VAL_BOOL(strstr(AS_STRING(a[0])->data, AS_STRING(a[1])->data) != NULL); +} + +static Value bi_string_join(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("string-join", 1); + Value *items; int ni = value_to_list(a[0], &items); + const char *sep = n > 1 ? AS_STRING(a[1])->data : " "; + size_t seplen = strlen(sep); + size_t total = 0; + for (int i = 0; i < ni; i++) { + check_string(items[i]); + total += AS_STRING(items[i])->len; + if (i > 0) total += seplen; + } + char *buf = (char *)ul_malloc(total + 1); + size_t pos = 0; + for (int i = 0; i < ni; i++) { + if (i > 0) { memcpy(buf + pos, sep, seplen); pos += seplen; } + ULString *s = AS_STRING(items[i]); + memcpy(buf + pos, s->data, s->len); + pos += s->len; + } + buf[pos] = '\0'; + ul_free(items); + Value r = make_string(buf, pos, false); + ul_free(buf); + return r; +} + +static Value bi_string_split(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("string-split", 1); + check_string(a[0]); + const char *str = AS_STRING(a[0])->data; + const char *sep = n > 1 ? AS_STRING(a[1])->data : " "; + size_t seplen = strlen(sep); + + Value result = VAL_NIL; + Value *items = NULL; + int nitems = 0, cap = 16; + items = (Value *)ul_malloc(sizeof(Value) * cap); + + const char *p = str; + while (*p) { + const char *found = strstr(p, sep); + if (!found) { + if (nitems >= cap) { cap *= 2; items = (Value *)ul_realloc(items, sizeof(Value) * cap); } + items[nitems++] = make_string(p, strlen(p), false); + break; + } + if (nitems >= cap) { cap *= 2; items = (Value *)ul_realloc(items, sizeof(Value) * cap); } + items[nitems++] = make_string(p, found - p, false); + p = found + seplen; + } + result = list_to_value(items, nitems); + ul_free(items); + return result; +} + +/* Record type subtype check — used by define-record-type predicates */ +static Value bi_is_subtype_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("__is-subtype?__", 2); + check_string(a[0]); check_string(a[1]); + return VAL_BOOL(is_subtype(AS_STRING(a[0])->data, AS_STRING(a[1])->data)); +} + +static Value bi_identity(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("identity", 1); + return a[0]; +} + +static Value bi_string_trim(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-trim", 1); check_string(a[0]); + const char *s = AS_STRING(a[0])->data; + size_t len = AS_STRING(a[0])->len; + while (len > 0 && isspace(s[0])) { s++; len--; } + while (len > 0 && isspace(s[len-1])) { len--; } + return make_string(s, len, false); +} + +static Value bi_string_index(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-index", 2); check_string(a[0]); check_string(a[1]); + const char *found = strstr(AS_STRING(a[0])->data, AS_STRING(a[1])->data); + if (!found) return VAL_INT(-1); + return VAL_INT(found - AS_STRING(a[0])->data); +} + +static Value bi_string_replace(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("string-replace", 3); + check_string(a[0]); check_string(a[1]); check_string(a[2]); + const char *src = AS_STRING(a[0])->data; + const char *from = AS_STRING(a[1])->data; + const char *to = AS_STRING(a[2])->data; + size_t from_len = strlen(from), to_len = strlen(to); + + char buf[8192]; + size_t pos = 0; + while (*src && pos < sizeof(buf) - to_len - 1) { + if (strncmp(src, from, from_len) == 0) { + memcpy(buf + pos, to, to_len); + pos += to_len; + src += from_len; + } else { + buf[pos++] = *src++; + } + } + while (*src && pos < sizeof(buf) - 1) buf[pos++] = *src++; + buf[pos] = '\0'; + return make_string_from_cstr(buf); +} + +static Value bi_auto_compile(Value *a, int n, Env *e) { + (void)e; + if (n == 0) return VAL_BOOL(g_auto_compile); + g_auto_compile = IS_TRUTHY(a[0]); + return VAL_VOID; +} + +static Value bi_compile(Value *a, int n, Env *e) { + CHECK_ARITY("compile", 1); + if (!IS_PROC(a[0])) lisp_error("compile: not a procedure"); + CompiledProc *cp = compile_proc(AS_PROC(a[0]), e); + return VAL_PTR(cp); +} + +static Value bi_compiled_p(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("compiled?", 1); + return VAL_BOOL(IS_COMPILED_PROC(a[0])); +} + +static Value bi_procedure_name(Value *a, int n, Env *e) { + (void)e; CHECK_ARITY("procedure-name", 1); + if (IS_PROC(a[0])) { + const char *name = AS_PROC(a[0])->name; + return name ? make_string_from_cstr(name) : VAL_FALSE; + } + if (IS_COMPILED_PROC(a[0])) { + const char *name = AS_COMPILED_PROC(a[0])->name; + return name ? make_string_from_cstr(name) : VAL_FALSE; + } + return VAL_FALSE; +} + +static Value bi_write_string(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("write-string", 1); check_string(a[0]); + FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout; + if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) { + ULString *s = AS_STRING(a[0]); + port_write_str(AS_PORT(a[1]), s->data, s->len); + } else { + fputs(AS_STRING(a[0])->data, out ? out : stdout); + fflush(out ? out : stdout); + } + return VAL_VOID; +} + +static Value bi_write_char(Value *a, int n, Env *e) { + (void)e; CHECK_MIN_ARITY("write-char", 1); + FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout; + fputc(AS_CHAR(a[0]), out ? out : stdout); + fflush(out ? out : stdout); + return VAL_VOID; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Prelude — standard macros defined in Scheme + * ═══════════════════════════════════════════════════════════════════════════ */ + +const char *PRELUDE = +"(define-macro (when test . body)\n" +" `(if ,test (begin ,@body) (void)))\n" +"\n" +"(define-macro (unless test . body)\n" +" `(if ,test (void) (begin ,@body)))\n" +"\n" +"(define-macro (and . args)\n" +" (cond ((null? args) #t)\n" +" ((null? (cdr args)) (car args))\n" +" (else `(if ,(car args) (and ,@(cdr args)) #f))))\n" +"\n" +"(define-macro (or . args)\n" +" (cond ((null? args) #f)\n" +" ((null? (cdr args)) (car args))\n" +" (else (let ((v (gensym)))\n" +" `(let ((,v ,(car args)))\n" +" (if ,v ,v (or ,@(cdr args))))))))\n" +"\n" +"(define-macro (case key . clauses)\n" +" (let ((k (gensym)))\n" +" `(let ((,k ,key))\n" +" (cond ,@(map (lambda (c)\n" +" (if (eq? (car c) 'else)\n" +" c\n" +" `((memv ,k ',(car c)) ,@(cdr c))))\n" +" clauses)))))\n" +"\n" +"(define-macro (while test . body)\n" +" (let ((loop (gensym)))\n" +" `(let ,loop ()\n" +" (when ,test ,@body (,loop)))))\n" +"\n" +"(define-macro (for var lst . body)\n" +" `(for-each (lambda (,var) ,@body) ,lst))\n" +"\n" +"(define (1+ n) (+ n 1))\n" +"(define (1- n) (- n 1))\n" +"(define (-1+ n) (- n 1))\n" +"(define (add1 n) (+ n 1))\n" +"(define (sub1 n) (- n 1))\n" +"\n" +"(define (square x) (* x x))\n" +"(define (cube x) (* x x x))\n" +"\n" +"(define (atom? x) (not (pair? x)))\n" +"\n" +"(define (flatten lst)\n" +" (cond ((null? lst) '())\n" +" ((pair? (car lst)) (append (flatten (car lst)) (flatten (cdr lst))))\n" +" (else (cons (car lst) (flatten (cdr lst))))))\n" +"\n" +"(define (range . args)\n" +" (cond ((= (length args) 1) (iota (car args)))\n" +" ((= (length args) 2) (iota (- (cadr args) (car args)) (car args)))\n" +" ((= (length args) 3) (iota (ceiling (/ (- (cadr args) (car args)) (caddr args)))\n" +" (car args) (caddr args)))\n" +" (else (error \"range: wrong number of args\"))))\n" +"\n" +"(define (char-list->string chars) (apply string chars))\n" +"(define (string-for-each f s) (for-each f (string->list s)))\n" +"(define (string-map f s) (list->string (map f (string->list s))))\n" +"(define (char->string c) (string c))\n" +"(define (boolean->string b) (if b \"#t\" \"#f\"))\n" +"\n" +"(define (caar x) (car (car x)))\n" +"(define (cadr x) (car (cdr x)))\n" +"(define (cdar x) (cdr (car x)))\n" +"(define (cddr x) (cdr (cdr x)))\n" +"(define (caaar x) (car (car (car x))))\n" +"(define (caadr x) (car (car (cdr x))))\n" +"(define (cadar x) (car (cdr (car x))))\n" +"(define (caddr x) (car (cdr (cdr x))))\n" +"(define (cdaar x) (cdr (car (car x))))\n" +"(define (cdadr x) (cdr (car (cdr x))))\n" +"(define (cddar x) (cdr (cdr (car x))))\n" +"(define (cdddr x) (cdr (cdr (cdr x))))\n" +"(define (caaaar x) (car (car (car (car x)))))\n" +"(define (caaadr x) (car (car (car (cdr x)))))\n" +"(define (caaddr x) (car (car (cdr (cdr x)))))\n" +"(define (caddar x) (car (cdr (cdr (car x)))))\n" +"(define (cadddr x) (car (cdr (cdr (cdr x)))))\n" +"\n" +"(define (list* . args)\n" +" (if (null? (cdr args)) (car args)\n" +" (cons (car args) (apply list* (cdr args)))))\n" +"(define cons* list*)\n" +"\n" +"(define (last-pair lst)\n" +" (if (pair? (cdr lst)) (last-pair (cdr lst)) lst))\n" +"\n" +"(define-macro (trace name)\n" +" `(set! ,name (make-traced ,name ',name)))\n" +"\n" +"(define-macro (untrace name)\n" +" `(set! ,name (untrace-proc ',name)))\n" +; + +/* ═══════════════════════════════════════════════════════════════════════════ + * Build the global environment + * ═══════════════════════════════════════════════════════════════════════════ */ + +#define DEF(name, fn) env_define(g, intern(name), VAL_BUILTIN(fn)) + +Env *make_global_env(void) { + Env *g = make_env(NULL); + g->global = g; + + /* Arithmetic */ + DEF("+", bi_add); DEF("-", bi_sub); DEF("*", bi_mul); DEF("/", bi_div); + DEF("quotient", bi_quotient); DEF("remainder", bi_remainder); DEF("modulo", bi_modulo); + DEF("expt", bi_expt); DEF("abs", bi_abs); + DEF("floor", bi_floor); DEF("ceiling", bi_ceiling); DEF("round", bi_round); + DEF("truncate", bi_truncate); + DEF("sqrt", bi_sqrt); DEF("log", bi_log); DEF("exp", bi_exp); + DEF("sin", bi_sin); DEF("cos", bi_cos); DEF("tan", bi_tan); + DEF("asin", bi_asin); DEF("acos", bi_acos); DEF("atan", bi_atan); + DEF("min", bi_min); DEF("max", bi_max); + DEF("gcd", bi_gcd); DEF("lcm", bi_lcm); + DEF("exact", bi_exact); DEF("inexact", bi_inexact); + DEF("exact->inexact", bi_inexact); DEF("inexact->exact", bi_exact); + DEF("numerator", bi_numerator); DEF("denominator", bi_denominator); + DEF("number->string", bi_number_to_string); + DEF("square", bi_square); DEF("exact-integer?", bi_exact_integer_p); + + /* Numeric comparison */ + DEF("=", bi_num_eq); DEF("<", bi_num_lt); DEF(">", bi_num_gt); + DEF("<=", bi_num_le); DEF(">=", bi_num_ge); + + /* Numeric predicates */ + DEF("zero?", bi_zero_p); DEF("positive?", bi_positive_p); DEF("negative?", bi_negative_p); + DEF("odd?", bi_odd_p); DEF("even?", bi_even_p); + DEF("nan?", bi_nan_p); DEF("infinite?", bi_infinite_p); DEF("finite?", bi_finite_p); + + /* Booleans & equality */ + DEF("not", bi_not); DEF("boolean?", bi_boolean_p); + DEF("eq?", bi_eq_p); DEF("eqv?", bi_eqv_p); DEF("equal?", bi_equal_p); + + /* Type predicates */ + DEF("number?", bi_number_p); DEF("integer?", bi_integer_p); + DEF("real?", bi_real_p); DEF("rational?", bi_rational_p); + DEF("exact?", bi_exact_p); DEF("inexact?", bi_inexact_p); + DEF("pair?", bi_pair_p); DEF("null?", bi_null_p); DEF("list?", bi_list_p); + DEF("symbol?", bi_symbol_p); DEF("string?", bi_string_p); + DEF("char?", bi_char_p); DEF("vector?", bi_vector_p); + DEF("procedure?", bi_procedure_p); + DEF("void?", bi_void_p); DEF("eof-object?", bi_eof_object_p); + DEF("port?", bi_port_p); DEF("input-port?", bi_input_port_p); + DEF("output-port?", bi_output_port_p); + DEF("hash-table?", bi_hash_table_p); + + /* Pairs & lists */ + DEF("cons", bi_cons); DEF("car", bi_car); DEF("cdr", bi_cdr); + DEF("set-car!", bi_set_car); DEF("set-cdr!", bi_set_cdr); + DEF("list", bi_list); DEF("length", bi_length); + DEF("append", bi_append); DEF("reverse", bi_reverse); + DEF("list-tail", bi_list_tail); DEF("list-ref", bi_list_ref); + DEF("list-set!", bi_list_set); DEF("list-copy", bi_list_copy); + DEF("make-list", bi_make_list); DEF("iota", bi_iota); + DEF("memq", bi_memq); DEF("memv", bi_memv); DEF("member", bi_member); + DEF("assq", bi_assq); DEF("assoc", bi_assoc); DEF("assv", bi_assoc); + + /* Higher-order */ + DEF("map", bi_map); DEF("for-each", bi_for_each); + DEF("filter", bi_filter); + DEF("fold-left", bi_fold_left); DEF("fold-right", bi_fold_right); + DEF("foldl", bi_fold_left); DEF("foldr", bi_fold_right); + DEF("reduce", bi_fold_left); + DEF("any", bi_any); DEF("every", bi_every); + DEF("find", bi_find); DEF("sort", bi_sort); DEF("count", bi_count); + DEF("apply", bi_apply); + DEF("filter-map", bi_filter); /* simplified */ + DEF("identity", bi_identity); + + /* Strings */ + DEF("make-string", bi_make_string); + DEF("string-length", bi_string_length); DEF("string-ref", bi_string_ref); + DEF("substring", bi_substring); DEF("string-append", bi_string_append); + DEF("string-copy", bi_string_copy); DEF("string-set!", bi_string_set); + DEF("string->list", bi_string_to_list); DEF("list->string", bi_list_to_string); + DEF("string->symbol", bi_string_to_symbol); DEF("symbol->string", bi_symbol_to_string); + DEF("string->number", bi_string_to_number); + DEF("string-upcase", bi_string_upcase); DEF("string-downcase", bi_string_downcase); + DEF("string=?", bi_string_eq); DEF("stringinteger", bi_char_to_integer); DEF("integer->char", bi_integer_to_char); + DEF("char-alphabetic?", bi_char_alphabetic); + DEF("char-numeric?", bi_char_numeric); + DEF("char-whitespace?", bi_char_whitespace); + DEF("char=?", bi_char_eq); + + /* Vectors */ + DEF("make-vector", bi_make_vector); DEF("vector", bi_vector); + DEF("vector-length", bi_vector_length); + DEF("vector-ref", bi_vector_ref); DEF("vector-set!", bi_vector_set); + DEF("vector->list", bi_vector_to_list); DEF("list->vector", bi_list_to_vector); + + /* Hash tables */ + DEF("make-hash-table", bi_make_hash_table); + DEF("make-equal-hash-table", bi_make_hash_table); + DEF("hash-table-set!", bi_hash_table_set); + DEF("hash-table/put!", bi_hash_table_set); + DEF("hash-table-ref", bi_hash_table_ref); + DEF("hash-table-ref/default", bi_hash_table_ref_default); + DEF("hash-table/get", bi_hash_table_ref_default); + DEF("hash-table-delete!", bi_hash_table_delete); + DEF("hash-table-exists?", bi_hash_table_exists); + DEF("hash-table-size", bi_hash_table_size); + DEF("hash-table/count", bi_hash_table_size); + DEF("hash-table-keys", bi_hash_table_keys); + DEF("hash-table-values", bi_hash_table_values); + + /* I/O */ + DEF("display", bi_display); DEF("write", bi_write); + DEF("newline", bi_newline); DEF("print", bi_print); + DEF("println", bi_print); DEF("writeln", bi_write); + DEF("write-string", bi_write_string); DEF("write-char", bi_write_char); + DEF("read-line", bi_read_line); DEF("read-char", bi_read_char); + DEF("open-input-file", bi_open_input_file); + DEF("open-output-file", bi_open_output_file); + DEF("open-input-string", bi_open_input_string); + DEF("open-output-string", bi_open_output_string); + DEF("get-output-string", bi_get_output_string); + DEF("close-port", bi_close_port); + DEF("close-input-port", bi_close_port); + DEF("close-output-port", bi_close_port); + DEF("current-input-port", bi_current_input_port); + DEF("current-output-port", bi_current_output_port); + DEF("current-error-port", bi_current_error_port); + DEF("flush-output-port", bi_flush_output_port); + DEF("eof-object", bi_eof_object); DEF("void", bi_void); + + /* File system */ + DEF("file-exists?", bi_file_exists); + DEF("current-directory", bi_current_directory); + + /* System */ + DEF("exit", bi_exit); DEF("error", bi_error); + DEF("error-object?", bi_error_object_p); + DEF("error?", bi_error_object_p); + DEF("error-object-message", bi_error_object_message); + DEF("error-object-irritants", bi_error_object_irritants); + DEF("error-message", bi_error_object_message); + DEF("current-time", bi_current_time); + DEF("current-jiffy", bi_current_jiffy); + DEF("jiffies-per-second", bi_jiffies_per_second); + DEF("command-line", bi_command_line); + DEF("get-environment-variable", bi_get_environment_variable); + DEF("gensym", bi_gensym); + DEF("make-parameter", bi_make_parameter); + DEF("values", bi_values); + DEF("call-with-values", bi_call_with_values); + DEF("object->string", bi_object_to_string); + DEF("write-to-string", bi_object_to_string); + DEF("display-to-string", bi_display_to_string); + DEF("raise", bi_error); + DEF("procedure-name", bi_procedure_name); + DEF("auto-compile!", bi_auto_compile); + DEF("compile", bi_compile); + DEF("compiled?", bi_compiled_p); + + /* Internal */ + DEF("__is-subtype?__", bi_is_subtype_p); + + /* Constants */ + env_define(g, intern("pi"), make_double(M_PI)); + env_define(g, intern("e"), make_double(M_E)); + env_define(g, intern("else"), VAL_TRUE); + env_define(g, intern("..."), intern("...")); + env_define(g, intern("*version*"), make_string_from_cstr("1.0.0")); + env_define(g, intern("*name*"), make_string_from_cstr("uncommonlisp")); + + return g; +} diff --git a/c/eval.c b/c/eval.c new file mode 100644 index 0000000..e64946c --- /dev/null +++ b/c/eval.c @@ -0,0 +1,1577 @@ +/* + * eval.c — Tree-walking evaluator with TCO via explicit loop + * + * Port of the Python leval() function with full special form support. + */ +#include "uncommonlisp.h" + +/* ═══════════════════════════════════════════════════════════════════════════ + * Helpers + * ═══════════════════════════════════════════════════════════════════════════ */ + +/* Lisp list → C array. Returns count. Caller must free *out. */ +int value_to_list(Value v, Value **out) { + if (IS_NIL(v)) { *out = NULL; return 0; } + /* Count */ + int n = 0; + Value cur = v; + while (IS_PAIR(cur)) { n++; cur = CDR(cur); } + if (!IS_NIL(cur)) lisp_error("not a list"); + + *out = (Value *)ul_malloc(sizeof(Value) * n); + cur = v; + for (int i = 0; i < n; i++) { + (*out)[i] = CAR(cur); + cur = CDR(cur); + } + return n; +} + +/* C array → Lisp list */ +Value list_to_value(Value *items, int count) { + Value r = VAL_NIL; + for (int i = count - 1; i >= 0; i--) { + r = cons(items[i], r); + } + return r; +} + +/* Parse lambda formals */ +Formals parse_formals(Value f) { + Formals result; + result.params = NULL; + result.nparams = 0; + result.rest = VAL_NIL; + + if (IS_SYM(f)) { + /* (lambda x body) — all args as rest */ + result.rest = f; + return result; + } + if (IS_NIL(f)) return result; + + /* Count params */ + int n = 0; + Value cur = f; + while (IS_PAIR(cur)) { n++; cur = CDR(cur); } + bool has_rest = !IS_NIL(cur); + + result.nparams = n; + result.params = (Value *)ul_malloc(sizeof(Value) * n); + cur = f; + for (int i = 0; i < n; i++) { + if (!IS_SYM(CAR(cur))) + lisp_error("param must be symbol"); + result.params[i] = CAR(cur); + cur = CDR(cur); + } + if (has_rest) { + if (!IS_SYM(cur)) + lisp_error("rest param must be symbol"); + result.rest = cur; + } + return result; +} + +bool has_internal_defines(ExprList body) { + if (body.count == 0) return false; + Value first = body.exprs[0]; + if (!IS_PAIR(first)) return false; + Value head = CAR(first); + return head == SYM_DEFINE || head == SYM_BEGIN; +} + +/* Scan internal defines and pre-declare all names as VOID */ +ExprList body_with_env(Value *forms, int count, Env *env) { + if (count == 0) { + ExprList r = {NULL, 0}; + return r; + } + + /* We may need to splice begin forms */ + int cap = count + 64; + Value *expanded = (Value *)ul_malloc(sizeof(Value) * cap); + memcpy(expanded, forms, sizeof(Value) * count); + int n = count; + + int i = 0; + while (i < n) { + Value f = expanded[i]; + if (IS_PAIR(f) && CAR(f) == SYM_DEFINE) { + Value *a; int na = value_to_list(CDR(f), &a); + Value name; + if (IS_PAIR(a[0])) name = CAR(a[0]); + else name = a[0]; + if (IS_SYM(name)) env_define(env, name, VAL_VOID); + ul_free(a); + i++; + } else if (IS_PAIR(f) && CAR(f) == SYM_BEGIN) { + /* Splice */ + Value *spliced; int ns = value_to_list(CDR(f), &spliced); + if (n + ns - 1 >= cap) { + cap = (n + ns) * 2; + expanded = (Value *)ul_realloc(expanded, sizeof(Value) * cap); + } + memmove(expanded + i + ns, expanded + i + 1, sizeof(Value) * (n - i - 1)); + memcpy(expanded + i, spliced, sizeof(Value) * ns); + n = n + ns - 1; + ul_free(spliced); + /* Don't increment i — re-check the first spliced form */ + } else { + break; + } + } + + ExprList r; + r.exprs = expanded; + r.count = n; + return r; +} + +bool is_proper_list(Value v) { + Value slow = v, fast = v; + while (1) { + if (IS_NIL(fast)) return true; + if (!IS_PAIR(fast)) return false; + fast = CDR(fast); + if (IS_NIL(fast)) return true; + if (!IS_PAIR(fast)) return false; + fast = CDR(fast); + slow = CDR(slow); + if (fast == slow) return false; /* cycle */ + } +} + +bool values_equal(Value a, Value b) { + if (a == b) return true; + /* Both numbers */ + if (is_number(a) && is_number(b)) return num_eq(a, b); + /* Both strings */ + if (IS_STRING(a) && IS_STRING(b)) { + ULString *sa = AS_STRING(a), *sb = AS_STRING(b); + return sa->len == sb->len && memcmp(sa->data, sb->data, sa->len) == 0; + } + /* Both pairs — deep comparison */ + if (IS_PAIR(a) && IS_PAIR(b)) { + return values_equal(CAR(a), CAR(b)) && values_equal(CDR(a), CDR(b)); + } + /* Both vectors */ + if (IS_VECTOR(a) && IS_VECTOR(b)) { + ULVector *va = AS_VECTOR(a), *vb = AS_VECTOR(b); + if (va->len != vb->len) return false; + for (size_t i = 0; i < va->len; i++) { + if (!values_equal(va->data[i], vb->data[i])) return false; + } + return true; + } + /* Chars */ + if (IS_CHAR(a) && IS_CHAR(b)) return AS_CHAR(a) == AS_CHAR(b); + return false; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Quasiquote expander + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value qq_expand(Value tmpl, Env *env, int depth) { + if (!IS_PAIR(tmpl)) return tmpl; + + if (CAR(tmpl) == SYM_QUASIQUOTE) { + return cons(SYM_QUASIQUOTE, + cons(qq_expand(CADR(tmpl), env, depth + 1), VAL_NIL)); + } + if (CAR(tmpl) == SYM_UNQUOTE) { + if (depth == 0) return leval(CADR(tmpl), env); + return cons(SYM_UNQUOTE, + cons(qq_expand(CADR(tmpl), env, depth - 1), VAL_NIL)); + } + + /* Collect parts */ + int cap = 64; + Value *parts = (Value *)ul_malloc(sizeof(Value) * cap); + int nparts = 0; + Value n = tmpl; + + while (IS_PAIR(n)) { + Value item = CAR(n); + if (IS_PAIR(item) && CAR(item) == SYM_UNQUOTE_SPLICING) { + if (depth == 0) { + Value spliced = leval(CADR(item), env); + Value *items; int ni = value_to_list(spliced, &items); + for (int i = 0; i < ni; i++) { + if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc(parts, sizeof(Value) * cap); } + parts[nparts++] = items[i]; + } + ul_free(items); + } else { + if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc(parts, sizeof(Value) * cap); } + parts[nparts++] = cons(SYM_UNQUOTE_SPLICING, + cons(qq_expand(CADR(item), env, depth - 1), VAL_NIL)); + } + } else { + if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc(parts, sizeof(Value) * cap); } + parts[nparts++] = qq_expand(item, env, depth); + } + n = CDR(n); + } + + Value tail = IS_NIL(n) ? VAL_NIL : qq_expand(n, env, depth); + Value r = tail; + for (int i = nparts - 1; i >= 0; i--) { + r = cons(parts[i], r); + } + ul_free(parts); + return r; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * call_proc — Non-tail recursive call (for use inside builtins) + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value call_proc(Value proc, Value *args, int nargs, Env *env) { + if (IS_BUILTIN(proc)) { + return AS_BUILTIN(proc)(args, nargs, env); + } + if (IS_PROC(proc)) { + Proc *p = AS_PROC(proc); + Env *c = env_child(p->env, p->params, p->nparams, p->rest, args, nargs); + ExprList body; + if (p->has_defs) { + body = body_with_env(p->body.exprs, p->body.count, c); + } else { + body = p->body; + } + for (int i = 0; i < body.count - 1; i++) leval(body.exprs[i], c); + return leval(body.exprs[body.count - 1], c); + } + if (IS_COMPILED_PROC(proc)) { + CompiledProc *cp = AS_COMPILED_PROC(proc); + Env *c = env_child(cp->env, cp->params, cp->nparams, cp->rest, args, nargs); + return vm_exec(cp->code, c); + } + lisp_error("not callable: %s", show(proc, false)); + return VAL_NIL; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * define-record-type + * ═══════════════════════════════════════════════════════════════════════════ */ + +static Value define_record_type(Value *a, int na, Env *env) { + Value name = a[0]; + int ri = 1; + + /* Check for (inherit parent) */ + const char *parent_name = NULL; + if (ri < na && IS_PAIR(a[ri]) && CAR(a[ri]) == intern("inherit")) { + Value *inh; int ninh = value_to_list(a[ri], &inh); + parent_name = sym_name(inh[1]); + ul_free(inh); + ri++; + } + + /* Constructor spec */ + Value *ctor_spec; int nctor = value_to_list(a[ri], &ctor_spec); + Value ctor_name = ctor_spec[0]; + char **all_fields = (char **)ul_malloc(sizeof(char *) * (nctor - 1)); + int nfields = nctor - 1; + for (int i = 0; i < nfields; i++) { + all_fields[i] = ul_strdup(sym_name(ctor_spec[i + 1])); + } + ri++; + + /* Predicate */ + Value pred_name = a[ri++]; + + /* Register type */ + register_record_type(sym_name(name), all_fields, nfields, parent_name); + + /* Constructor: builds (name field1 field2 ...) */ + /* We create a builtin closure */ + { + /* Capture field count and name symbol */ + const char *type_tag = sym_name(name); + int nf = nfields; + Value *field_syms = (Value *)ul_malloc(sizeof(Value) * nf); + for (int i = 0; i < nf; i++) field_syms[i] = ctor_spec[i + 1]; + + /* Create a Proc that builds (list 'type-name f1 f2 ...) */ + /* For simplicity, we'll use a builtin */ + /* But builtins can't capture — we'll use the type tag in the env */ + /* Actually, let's just define a Proc that builds the list */ + ExprList body; + body.count = 1; + body.exprs = (Value *)ul_malloc(sizeof(Value)); + + /* Build: (list (quote name) f1 f2 ...) */ + Value *listargs = (Value *)ul_malloc(sizeof(Value) * (nf + 2)); + listargs[0] = intern("list"); + listargs[1] = cons(SYM_QUOTE, cons(name, VAL_NIL)); + for (int i = 0; i < nf; i++) listargs[2 + i] = field_syms[i]; + body.exprs[0] = list_to_value(listargs, nf + 2); + ul_free(listargs); + + Proc *ctor = make_proc(field_syms, nf, VAL_NIL, body, env, sym_name(ctor_name)); + Value ctor_val = VAL_PTR(ctor); + if (g_auto_compile) { + TRY(ctx) { + CompiledProc *cp = compile_proc(ctor, env); + ctor_val = VAL_PTR(cp); + } CATCH { + /* ignore compile failure */ + } ENDTRY; + } + env_define(env, ctor_name, ctor_val); + ul_free(field_syms); + } + + /* Predicate: check if instance's type tag matches */ + { + const char *type_str = sym_name(name); + /* Create a builtin that captures type_str */ + /* We need a closure, but builtins are just function pointers. + We'll store the type name in a small env trick. */ + /* Actually for simplicity, we'll create a Proc with the right body */ + Value arg_sym = intern("x"); + ExprList body; + body.count = 1; + body.exprs = (Value *)ul_malloc(sizeof(Value)); + /* Build: (and (pair? x) (symbol? (car x)) (eq? (car x) 'name)) */ + /* Simpler: use a special check that understands subtypes */ + /* We'll need a native predicate. Let's put the type name in an env binding. */ + Value type_sym = intern("__record_type_tag__"); + Env *pred_env = make_env(env); + env_define(pred_env, type_sym, cons(SYM_QUOTE, cons(name, VAL_NIL))); + + /* (and (pair? x) (symbol? (car x)) + ... some way to check subtypes ...) */ + /* For now, build a simple check */ + body.exprs[0] = cons(intern("__record-pred?__"), + cons(arg_sym, cons(cons(SYM_QUOTE, cons(name, VAL_NIL)), VAL_NIL))); + + Proc *pred = make_proc(&arg_sym, 1, VAL_NIL, body, env, sym_name(pred_name)); + /* Actually, this is getting complicated. Let's just register a builtin. */ + /* We'll use a different approach: store a lambda closure that checks. */ + /* Simplest: use a parameter-carrying closure via env */ + (void)pred; /* discard */ + + /* Create the body as Scheme source */ + char src[256]; + snprintf(src, sizeof(src), + "(lambda (x) (and (pair? x) (symbol? (car x)) (__is-subtype?__ (symbol->string (car x)) \"%s\")))", + type_str); + int nc; + Value *exprs = read_all(src, &nc, false); + Value pred_val = leval(exprs[0], env); + env_define(env, pred_name, pred_val); + ul_free(exprs); + } + + /* Accessors and mutators */ + for (int i = ri; i < na; i++) { + Value *spec; int nspec = value_to_list(a[i], &spec); + if (nspec < 2) { ul_free(spec); continue; } + + Value field_tag = spec[0]; + Value getter_name = spec[1]; + Value setter_name = nspec > 2 ? spec[2] : VAL_NIL; + + /* Find field index */ + int idx = -1; + const char *field_str = sym_name(field_tag); + for (int j = 0; j < nfields; j++) { + if (strcmp(all_fields[j], field_str) == 0) { idx = j + 1; break; } /* +1 for type tag */ + } + if (idx < 0) lisp_error("define-record-type %s: field '%s' not found", + sym_name(name), field_str); + + /* Getter: (lambda (x) (list-ref x idx)) */ + { + char src[128]; + snprintf(src, sizeof(src), "(lambda (x) (list-ref x %d))", idx); + int nc; + Value *exprs = read_all(src, &nc, false); + env_define(env, getter_name, leval(exprs[0], env)); + ul_free(exprs); + } + + /* Setter */ + if (!IS_NIL(setter_name)) { + char src[128]; + snprintf(src, sizeof(src), "(lambda (x v) (list-set! x %d v))", idx); + int nc; + Value *exprs = read_all(src, &nc, false); + env_define(env, setter_name, leval(exprs[0], env)); + ul_free(exprs); + } + + ul_free(spec); + } + + for (int i = 0; i < nfields; i++) ul_free(all_fields[i]); + ul_free(all_fields); + ul_free(ctor_spec); + + return VAL_VOID; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Syntax-rules transformer + * ═══════════════════════════════════════════════════════════════════════════ */ + +/* Forward declarations for syntax-rules */ +static bool sr_match(SyntaxTransformer *st, Value pat, Value form, Env *bindings); +static Value sr_expand(SyntaxTransformer *st, Value tmpl, Env *bindings); + +static bool is_literal(SyntaxTransformer *st, const char *name) { + for (int i = 0; i < st->nliterals; i++) { + if (strcmp(st->literals[i], name) == 0) return true; + } + return false; +} + +static bool sr_match(SyntaxTransformer *st, Value pat, Value form, Env *bindings) { + if (IS_NIL(pat)) return IS_NIL(form); + if (pat == VAL_TRUE || pat == VAL_FALSE) return pat == form; + if (IS_INT(pat) || IS_DOUBLE(pat)) return values_equal(pat, form); + + if (IS_SYM(pat)) { + const char *pname = sym_name(pat); + if (is_literal(st, pname)) { + return IS_SYM(form) && strcmp(sym_name(form), pname) == 0; + } + if (pat == SYM_UNDERSCORE) return true; + env_define(bindings, pat, form); + return true; + } + + if (!IS_PAIR(pat)) return values_equal(pat, form); + + /* Check for ellipsis: (sub_pat ... . rest_pat) */ + if (IS_PAIR(CDR(pat)) && CADR(pat) == SYM_ELLIPSIS) { + Value sub_pat = CAR(pat); + Value rest_pat = CDDR(pat); + + /* Count required tail elements */ + int n_rest = 0; + Value rp = rest_pat; + while (IS_PAIR(rp)) { n_rest++; rp = CDR(rp); } + + /* Collect form items */ + Value *items; int nitems = 0; + if (IS_PAIR(form)) { + nitems = value_to_list(form, &items); + } else if (IS_NIL(form)) { + items = NULL; + } else { + return false; + } + + int n_ell = nitems - n_rest; + if (n_ell < 0) { ul_free(items); return false; } + + /* Create ellipsis binding env (using vectors to hold lists) */ + /* For each pattern var in sub_pat, accumulate matches */ + for (int i = 0; i < n_ell; i++) { + Env *ib = make_env(NULL); + if (!sr_match(st, sub_pat, items[i], ib)) { + ul_free(items); return false; + } + /* Merge ib bindings into bindings as vectors */ + for (size_t b = 0; b < ib->nbuckets; b++) { + EnvBinding *bind = ib->buckets[b]; + while (bind) { + /* Accumulate: existing vector or create new one */ + EnvBinding *existing = NULL; + uint32_t h = (uint32_t)((GET_PAYLOAD(bind->sym) * 2654435761ULL) % bindings->nbuckets); + EnvBinding *eb = bindings->buckets[h]; + while (eb) { + if (eb->sym == bind->sym) { existing = eb; break; } + eb = eb->next; + } + if (existing && IS_VECTOR(existing->val)) { + /* Append to vector */ + ULVector *vec = AS_VECTOR(existing->val); + if (vec->len >= vec->cap) { + vec->cap *= 2; + vec->data = (Value *)ul_realloc(vec->data, sizeof(Value) * vec->cap); + } + vec->data[vec->len++] = bind->val; + } else { + /* Create new vector */ + Value vec = make_vector(0, VAL_NIL); + ULVector *v = AS_VECTOR(vec); + v->cap = n_ell > 0 ? (size_t)n_ell : 4; + v->data = (Value *)ul_realloc(v->data, sizeof(Value) * v->cap); + v->data[0] = bind->val; + v->len = 1; + env_define(bindings, bind->sym, vec); + } + bind = bind->next; + } + } + } + + /* Match rest */ + Value rest_form = list_to_value(items + n_ell, nitems - n_ell); + ul_free(items); + return sr_match(st, rest_pat, rest_form, bindings); + } + + /* Normal pair */ + if (!IS_PAIR(form)) return false; + return sr_match(st, CAR(pat), CAR(form), bindings) && + sr_match(st, CDR(pat), CDR(form), bindings); +} + +static Value sr_expand(SyntaxTransformer *st, Value tmpl, Env *bindings) { + if (IS_NIL(tmpl) || tmpl == VAL_TRUE || tmpl == VAL_FALSE) return tmpl; + if (IS_INT(tmpl) || IS_DOUBLE(tmpl)) return tmpl; + if (IS_STRING(tmpl)) return tmpl; + + if (IS_SYM(tmpl)) { + TRY(ctx) { + Value v = env_lookup(bindings, tmpl); + if (IS_VECTOR(v)) { + lisp_error("syntax-rules: %s used without ...", sym_name(tmpl)); + } + return v; + } CATCH { + return tmpl; /* Not bound — return as-is */ + } ENDTRY; + return tmpl; + } + + if (!IS_PAIR(tmpl)) return tmpl; + + /* Check for ellipsis in template: (sub_tmpl ...) */ + if (IS_PAIR(CDR(tmpl)) && CADR(tmpl) == SYM_ELLIPSIS) { + Value sub_tmpl = CAR(tmpl); + Value rest_tmpl = CDDR(tmpl); + + /* Find ellipsis variables in sub_tmpl */ + /* Look for symbols that have vector bindings */ + int n = -1; + /* We need to find the length of ellipsis vectors */ + /* Scan bindings for vectors */ + for (size_t b = 0; b < bindings->nbuckets; b++) { + EnvBinding *bind = bindings->buckets[b]; + while (bind) { + if (IS_VECTOR(bind->val)) { + int vlen = (int)AS_VECTOR(bind->val)->len; + if (n < 0) n = vlen; + /* Use minimum? Actually all should be same length */ + } + bind = bind->next; + } + } + if (n < 0) n = 0; + + /* Expand each iteration */ + Value *expanded = (Value *)ul_malloc(sizeof(Value) * n); + for (int i = 0; i < n; i++) { + /* Create a sub-binding env where vector vars are replaced by their i-th element */ + Env *sb = make_env(NULL); + for (size_t b = 0; b < bindings->nbuckets; b++) { + EnvBinding *bind = bindings->buckets[b]; + while (bind) { + if (IS_VECTOR(bind->val)) { + ULVector *vec = AS_VECTOR(bind->val); + env_define(sb, bind->sym, i < (int)vec->len ? vec->data[i] : VAL_VOID); + } else { + env_define(sb, bind->sym, bind->val); + } + bind = bind->next; + } + } + expanded[i] = sr_expand(st, sub_tmpl, sb); + } + + Value rest = sr_expand(st, rest_tmpl, bindings); + for (int i = n - 1; i >= 0; i--) { + rest = cons(expanded[i], rest); + } + ul_free(expanded); + return rest; + } + + return cons(sr_expand(st, CAR(tmpl), bindings), + sr_expand(st, CDR(tmpl), bindings)); +} + +Value syntax_transform_value(SyntaxTransformer *st, Value form) { + for (int i = 0; i < st->nrules; i++) { + Env *bindings = make_env(NULL); + Value pat = st->rules[i].pattern; + /* pat.cdr is the actual pattern (skip keyword) */ + Value actual_pat = IS_PAIR(pat) ? CDR(pat) : VAL_NIL; + if (sr_match(st, actual_pat, form, bindings)) { + return sr_expand(st, st->rules[i].tmpl, bindings); + } + } + lisp_error("syntax error: no matching syntax-rules pattern"); + return VAL_NIL; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Main evaluator — TCO via explicit while loop + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value leval(Value expr, Env *env) { + while (1) { + /* Self-evaluating */ + if (IS_NIL(expr) || IS_VOID(expr) || IS_TRUE(expr) || IS_FALSE(expr) || + IS_EOF(expr) || IS_CHAR(expr)) return expr; + if (IS_INT(expr) || IS_DOUBLE(expr) || IS_RATIONAL(expr)) return expr; + if (IS_STRING(expr)) return expr; + if (IS_VECTOR(expr)) return expr; + if (IS_BUILTIN(expr)) return expr; + + /* Symbol lookup */ + if (IS_SYM(expr)) return env_lookup(env, expr); + + if (!IS_PAIR(expr)) return expr; + + Value head = CAR(expr); + Value tail = CDR(expr); + + /* ── Special forms ──────────────────────────────────────────────── */ + + if (head == SYM_QUOTE) { + return CAR(tail); + } + + if (head == SYM_IF) { + Value *a; int na = value_to_list(tail, &a); + if (na < 2 || na > 3) lisp_error("if: need 2-3 subforms"); + if (IS_TRUTHY(leval(a[0], env))) { + expr = a[1]; + } else { + expr = na == 3 ? a[2] : VAL_VOID; + } + ul_free(a); + continue; + } + + if (head == SYM_COND) { + Value *clauses; int nc = value_to_list(tail, &clauses); + Value result = VAL_VOID; + bool found = false; + for (int i = 0; i < nc; i++) { + Value *cl; int ncl = value_to_list(clauses[i], &cl); + if (ncl == 0) { ul_free(cl); lisp_error("cond: empty clause"); } + if (cl[0] == SYM_ELSE || IS_TRUTHY(leval(cl[0], env))) { + if (ncl == 1) { + result = cl[0] != SYM_ELSE ? leval(cl[0], env) : VAL_VOID; + ul_free(cl); + found = true; + break; + } + if (ncl == 3 && cl[1] == SYM_ARROW) { + Value v = leval(cl[0], env); + Value f = leval(cl[2], env); + ul_free(cl); + ul_free(clauses); + Value args[1] = {v}; + if (IS_PROC(f)) { + Proc *p = AS_PROC(f); + env = env_child(p->env, p->params, p->nparams, p->rest, args, 1); + Value *body_exprs = p->body.exprs; + int nbody = p->body.count; + for (int j = 0; j < nbody - 1; j++) leval(body_exprs[j], env); + expr = body_exprs[nbody - 1]; + goto next_iter; + } + return call_proc(f, args, 1, env); + } + for (int j = 1; j < ncl - 1; j++) leval(cl[j], env); + expr = cl[ncl - 1]; + ul_free(cl); + ul_free(clauses); + goto next_iter; + } + ul_free(cl); + } + ul_free(clauses); + if (!found) return result; + return result; + } + + if (head == SYM_CASE) { + /* (case key ((datum ...) body ...) ... (else body ...)) */ + Value *a; int na = value_to_list(tail, &a); + Value key = leval(a[0], env); + for (int i = 1; i < na; i++) { + Value *cl; int ncl = value_to_list(a[i], &cl); + if (ncl < 1) { ul_free(cl); continue; } + if (cl[0] == SYM_ELSE) { + for (int j = 1; j < ncl - 1; j++) leval(cl[j], env); + expr = cl[ncl - 1]; + ul_free(cl); ul_free(a); + goto next_iter; + } + /* Check if key is in datum list */ + Value *datums; int nd = value_to_list(cl[0], &datums); + bool match = false; + for (int j = 0; j < nd; j++) { + if (values_equal(key, datums[j])) { match = true; break; } + } + ul_free(datums); + if (match) { + for (int j = 1; j < ncl - 1; j++) leval(cl[j], env); + expr = cl[ncl - 1]; + ul_free(cl); ul_free(a); + goto next_iter; + } + ul_free(cl); + } + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_AND) { + Value *a; int na = value_to_list(tail, &a); + if (na == 0) { ul_free(a); return VAL_TRUE; } + for (int i = 0; i < na - 1; i++) { + Value v = leval(a[i], env); + if (!IS_TRUTHY(v)) { ul_free(a); return VAL_FALSE; } + } + expr = a[na - 1]; + ul_free(a); + continue; + } + + if (head == SYM_OR) { + Value *a; int na = value_to_list(tail, &a); + if (na == 0) { ul_free(a); return VAL_FALSE; } + for (int i = 0; i < na - 1; i++) { + Value v = leval(a[i], env); + if (IS_TRUTHY(v)) { ul_free(a); return v; } + } + expr = a[na - 1]; + ul_free(a); + continue; + } + + if (head == SYM_WHEN) { + Value *a; int na = value_to_list(tail, &a); + if (IS_TRUTHY(leval(a[0], env))) { + for (int i = 1; i < na - 1; i++) leval(a[i], env); + expr = a[na - 1]; + ul_free(a); + continue; + } + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_UNLESS) { + Value *a; int na = value_to_list(tail, &a); + if (!IS_TRUTHY(leval(a[0], env))) { + for (int i = 1; i < na - 1; i++) leval(a[i], env); + expr = a[na - 1]; + ul_free(a); + continue; + } + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_BEGIN) { + Value *a; int na = value_to_list(tail, &a); + if (na == 0) { ul_free(a); return VAL_VOID; } + for (int i = 0; i < na - 1; i++) leval(a[i], env); + expr = a[na - 1]; + ul_free(a); + continue; + } + + if (head == SYM_DEFINE) { + Value *a; int na = value_to_list(tail, &a); + if (na == 0) lisp_error("define: empty"); + if (IS_PAIR(a[0])) { + /* (define (f x) body...) */ + Value fname = CAR(a[0]); + Formals f = parse_formals(CDR(a[0])); + ExprList body = {a + 1, na - 1}; + Proc *p = make_proc(f.params, f.nparams, f.rest, body, env, sym_name(fname)); + Value pval = VAL_PTR(p); + if (g_auto_compile) { + TRY(ctx) { + CompiledProc *cp = compile_proc(p, env); + pval = VAL_PTR(cp); + } CATCH { } ENDTRY; + } + env_define(env, fname, pval); + } else { + Value name = a[0]; + if (!IS_SYM(name)) lisp_error("define: name must be symbol"); + Value val = na > 1 ? leval(a[1], env) : VAL_VOID; + if (IS_PROC(val) && !AS_PROC(val)->name) { + AS_PROC(val)->name = ul_strdup(sym_name(name)); + } + if (g_auto_compile && IS_PROC(val)) { + TRY(ctx) { + CompiledProc *cp = compile_proc(AS_PROC(val), env); + val = VAL_PTR(cp); + } CATCH { } ENDTRY; + } + env_define(env, name, val); + } + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_DEFINE_VALUES) { + Value *a; int na = value_to_list(tail, &a); + Value *names; int nn = value_to_list(a[0], &names); + Value vals = leval(a[1], env); + /* vals could be a vector of multiple values (we use vectors for multi-values) */ + if (IS_VECTOR(vals)) { + ULVector *vv = AS_VECTOR(vals); + for (int i = 0; i < nn && i < (int)vv->len; i++) { + env_define(env, names[i], vv->data[i]); + } + } else { + if (nn > 0) env_define(env, names[0], vals); + } + ul_free(names); ul_free(a); + return VAL_VOID; + } + + if (head == SYM_SET) { + Value *a; int na = value_to_list(tail, &a); + (void)na; + env_set(env, a[0], leval(a[1], env)); + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_LAMBDA || head == SYM_LAMBDA_UC) { + Value *a; int na = value_to_list(tail, &a); + if (na == 0) lisp_error("lambda: empty"); + Formals f = parse_formals(a[0]); + ExprList body = {a + 1, na - 1}; + Proc *p = make_proc(f.params, f.nparams, f.rest, body, env, NULL); + Value pval = VAL_PTR(p); + if (g_auto_compile) { + TRY(ctx) { + CompiledProc *cp = compile_proc(p, env); + pval = VAL_PTR(cp); + } CATCH { } ENDTRY; + } + ul_free(a); + return pval; + } + + if (head == SYM_LET) { + Value *a; int na = value_to_list(tail, &a); + if (na == 0) lisp_error("let: empty"); + if (IS_SYM(a[0])) { + /* Named let: (let name ((v init) ...) body...) */ + Value name = a[0]; + Value *binds; int nb = value_to_list(a[1], &binds); + int nbody = na - 2; + Value *body_arr = a + 2; + + Value *bps = (Value *)ul_malloc(sizeof(Value) * nb); + Value *bvs = (Value *)ul_malloc(sizeof(Value) * nb); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + bps[i] = bp[0]; + bvs[i] = leval(bp[1], env); + ul_free(bp); + } + Env *c = make_env(env); + ExprList body = {body_arr, nbody}; + Proc *p = make_proc(bps, nb, VAL_NIL, body, c, sym_name(name)); + env_define(c, name, VAL_PTR(p)); + env = env_child(c, bps, nb, VAL_NIL, bvs, nb); + if (has_internal_defines(body)) { + ExprList b2 = body_with_env(body_arr, nbody, env); + for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env); + expr = b2.exprs[b2.count - 1]; + } else { + for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env); + expr = body_arr[nbody - 1]; + } + ul_free(bps); ul_free(bvs); ul_free(binds); ul_free(a); + continue; + } + /* Regular let */ + Value *binds; int nb = value_to_list(a[0], &binds); + int nbody = na - 1; + Value *body_arr = a + 1; + Env *c = make_env(env); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + env_define(c, bp[0], leval(bp[1], env)); + ul_free(bp); + } + env = c; + ExprList body = {body_arr, nbody}; + if (has_internal_defines(body)) { + ExprList b2 = body_with_env(body_arr, nbody, env); + for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env); + expr = b2.exprs[b2.count - 1]; + } else { + for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env); + expr = body_arr[nbody - 1]; + } + ul_free(binds); ul_free(a); + continue; + } + + if (head == SYM_LET_STAR) { + Value *a; int na = value_to_list(tail, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + Env *c = make_env(env); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + env_define(c, bp[0], leval(bp[1], c)); + ul_free(bp); + } + int nbody = na - 1; + Value *body_arr = a + 1; + ExprList body = {body_arr, nbody}; + env = c; + if (has_internal_defines(body)) { + ExprList b2 = body_with_env(body_arr, nbody, env); + for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env); + expr = b2.exprs[b2.count - 1]; + } else { + for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env); + expr = body_arr[nbody - 1]; + } + ul_free(binds); ul_free(a); + continue; + } + + if (head == SYM_LETREC || head == SYM_LETREC_STAR) { + Value *a; int na = value_to_list(tail, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + Env *c = make_env(env); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + env_define(c, bp[0], VAL_VOID); + ul_free(bp); + } + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + env_set(c, bp[0], leval(bp[1], c)); + ul_free(bp); + } + int nbody = na - 1; + Value *body_arr = a + 1; + env = c; + ExprList body = {body_arr, nbody}; + if (has_internal_defines(body)) { + ExprList b2 = body_with_env(body_arr, nbody, env); + for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env); + expr = b2.exprs[b2.count - 1]; + } else { + for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env); + expr = body_arr[nbody - 1]; + } + ul_free(binds); ul_free(a); + continue; + } + + if (head == SYM_DO) { + Value *a; int na = value_to_list(tail, &a); + Value *vcs; int nvc = value_to_list(a[0], &vcs); + Value *term; int nterm = value_to_list(a[1], &term); + int nbody = na - 2; + Value *body_arr = a + 2; + + Env *c = make_env(env); + /* Parse variable specs: (var init step) */ + typedef struct { Value var; Value step; } DoSpec; + DoSpec *specs = (DoSpec *)ul_malloc(sizeof(DoSpec) * nvc); + for (int i = 0; i < nvc; i++) { + Value *sp; int nsp = value_to_list(vcs[i], &sp); + specs[i].var = sp[0]; + env_define(c, sp[0], leval(sp[1], env)); + specs[i].step = nsp > 2 ? sp[2] : sp[0]; + ul_free(sp); + } + + while (1) { + if (IS_TRUTHY(leval(term[0], c))) { + if (nterm == 1) { + expr = VAL_VOID; + } else { + for (int i = 1; i < nterm - 1; i++) leval(term[i], c); + expr = term[nterm - 1]; + } + env = c; + break; + } + for (int i = 0; i < nbody; i++) leval(body_arr[i], c); + Value *nvs = (Value *)ul_malloc(sizeof(Value) * nvc); + for (int i = 0; i < nvc; i++) nvs[i] = leval(specs[i].step, c); + for (int i = 0; i < nvc; i++) env_set(c, specs[i].var, nvs[i]); + ul_free(nvs); + } + ul_free(specs); ul_free(vcs); ul_free(term); ul_free(a); + continue; + } + + if (head == SYM_QUASIQUOTE) { + return qq_expand(CAR(tail), env, 0); + } + + if (head == SYM_DEFINE_MACRO || head == SYM_DEFMACRO) { + Value *a; int na = value_to_list(tail, &a); + Value name; + Proc *xfm; + if (IS_PAIR(a[0])) { + name = CAR(a[0]); + Formals f = parse_formals(CDR(a[0])); + ExprList body = {a + 1, na - 1}; + xfm = make_proc(f.params, f.nparams, f.rest, body, env, sym_name(name)); + } else { + name = a[0]; + Formals f = parse_formals(a[1]); + ExprList body = {a + 2, na - 2}; + xfm = make_proc(f.params, f.nparams, f.rest, body, env, sym_name(name)); + } + env_define(env, name, make_macro(VAL_PTR(xfm))); + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_DEFINE_SYNTAX) { + Value *a; int na = value_to_list(tail, &a); + Value val = leval(a[1], env); + if (IS_SYNTAX_TRANSFORMER(val)) { + env_define(env, a[0], make_macro(val)); + } else { + env_define(env, a[0], val); + } + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_SYNTAX_RULES) { + Value *a; int na = value_to_list(tail, &a); + /* a[0] = literals, a[1..] = rules */ + Value *lits; int nlits = value_to_list(a[0], &lits); + SyntaxTransformer *st = (SyntaxTransformer *)ul_malloc(sizeof(SyntaxTransformer)); + st->hdr.type = OBJ_SYNTAX_TRANSFORMER; + st->nliterals = nlits; + st->literals = (char **)ul_malloc(sizeof(char *) * nlits); + for (int i = 0; i < nlits; i++) st->literals[i] = ul_strdup(sym_name(lits[i])); + st->nrules = na - 1; + st->rules = (SyntaxRule *)ul_malloc(sizeof(SyntaxRule) * st->nrules); + for (int i = 0; i < st->nrules; i++) { + Value *rl; int nrl = value_to_list(a[i + 1], &rl); + st->rules[i].pattern = rl[0]; + st->rules[i].tmpl = rl[1]; + ul_free(rl); + } + st->def_env = env; + ul_free(lits); ul_free(a); + return VAL_PTR(st); + } + + if (head == SYM_LET_SYNTAX) { + Value *a; int na = value_to_list(tail, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + Env *c = make_env(env); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + env_define(c, bp[0], make_macro(leval(bp[1], env))); + ul_free(bp); + } + int nbody = na - 1; + for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], c); + expr = a[na - 1]; env = c; + ul_free(binds); ul_free(a); + continue; + } + + if (head == SYM_LETREC_SYNTAX) { + Value *a; int na = value_to_list(tail, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + Env *c = make_env(env); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + env_define(c, bp[0], make_macro(leval(bp[1], c))); + ul_free(bp); + } + int nbody = na - 1; + for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], c); + expr = a[na - 1]; env = c; + ul_free(binds); ul_free(a); + continue; + } + + if (head == SYM_VALUES) { + Value *a; int na = value_to_list(tail, &a); + if (na == 1) { Value r = leval(a[0], env); ul_free(a); return r; } + /* Multiple values: store in a vector */ + Value vec = make_vector(na, VAL_NIL); + ULVector *v = AS_VECTOR(vec); + for (int i = 0; i < na; i++) v->data[i] = leval(a[i], env); + ul_free(a); + return vec; + } + + if (head == SYM_CALL_WITH_VALUES) { + Value *a; int na = value_to_list(tail, &a); + Value prod = leval(a[0], env); + Value consumer = leval(a[1], env); + ul_free(a); + Value r = call_proc(prod, NULL, 0, env); + if (IS_VECTOR(r)) { + ULVector *v = AS_VECTOR(r); + return call_proc(consumer, v->data, (int)v->len, env); + } + Value args[1] = {r}; + return call_proc(consumer, args, 1, env); + } + + if (head == SYM_CALL_CC || head == SYM_CALL_CC2) { + /* Simple escape continuation (not full in tree-walker) */ + Value *a; int na = value_to_list(tail, &a); + Value proc = leval(a[0], env); + ul_free(a); + /* Simplified: just use longjmp-based escape */ + Value args[1]; + /* Create a builtin that raises an exception to escape */ + /* For now, implement simplified call/cc */ + static __thread Value cc_result; + static __thread bool cc_invoked; + static __thread jmp_buf cc_jmp; + + cc_invoked = false; + /* The continuation function */ + /* This is tricky without closures. Use a simplified approach. */ + /* We'll just call the proc with a dummy kont for now */ + /* TODO: full continuations need the VM */ + Value kont_args[1] = {VAL_VOID}; + return call_proc(proc, kont_args, 1, env); + } + + if (head == SYM_APPLY) { + Value *a; int na = value_to_list(tail, &a); + Value proc = leval(a[0], env); + /* Evaluate prefix args */ + int npre = na - 2; + Value *pre = NULL; + if (npre > 0) { + pre = (Value *)ul_malloc(sizeof(Value) * npre); + for (int i = 0; i < npre; i++) pre[i] = leval(a[i + 1], env); + } + Value last = leval(a[na - 1], env); + Value *lst; int nlst = value_to_list(last, &lst); + + Value *all_args = (Value *)ul_malloc(sizeof(Value) * (npre + nlst)); + if (pre) memcpy(all_args, pre, sizeof(Value) * npre); + memcpy(all_args + npre, lst, sizeof(Value) * nlst); + int total = npre + nlst; + + ul_free(pre); ul_free(lst); ul_free(a); + + /* TCO for Proc */ + if (IS_PROC(proc)) { + Proc *p = AS_PROC(proc); + env = env_child(p->env, p->params, p->nparams, p->rest, all_args, total); + ExprList body = p->has_defs ? + body_with_env(p->body.exprs, p->body.count, env) : p->body; + if (body.count == 1) expr = body.exprs[0]; + else { + for (int i = 0; i < body.count - 1; i++) leval(body.exprs[i], env); + expr = body.exprs[body.count - 1]; + } + ul_free(all_args); + continue; + } + Value result = call_proc(proc, all_args, total, env); + ul_free(all_args); + return result; + } + + if (head == SYM_EVAL) { + Value *a; int na = value_to_list(tail, &a); + expr = leval(a[0], env); + ul_free(a); + continue; + } + + if (head == SYM_ERROR) { + Value *a; int na = value_to_list(tail, &a); + char *msg = show(leval(a[0], env), true); + Value *irr = NULL; + int nirr = na - 1; + if (nirr > 0) { + irr = (Value *)ul_malloc(sizeof(Value) * nirr); + for (int i = 0; i < nirr; i++) irr[i] = leval(a[i + 1], env); + } + Value obj = make_error_object(msg, irr, nirr); + ul_free(msg); ul_free(irr); ul_free(a); + /* Format full message */ + char full_msg[MAX_ERROR_MSG]; + ErrorObject *eo = AS_ERROR(obj); + int off = snprintf(full_msg, sizeof(full_msg), "%s", eo->message); + for (int i = 0; i < eo->nirritants && off < MAX_ERROR_MSG - 2; i++) { + char *s = show(eo->irritants[i], false); + off += snprintf(full_msg + off, sizeof(full_msg) - off, ": %s", s); + ul_free(s); + } + lisp_error_with_obj(obj, "%s", full_msg); + } + + if (head == SYM_DEFINE_RECORD_TYPE) { + Value *a; int na = value_to_list(tail, &a); + Value result = define_record_type(a, na, env); + ul_free(a); + return result; + } + + if (head == SYM_MODULE) { + Value *a; int na = value_to_list(tail, &a); + const char *mod_name = sym_name(a[0]); + /* Check for (export sym ...) */ + char **exports = NULL; + int nexports = 0; + int body_start = 1; + if (na > 1 && IS_PAIR(a[1]) && CAR(a[1]) == SYM_EXPORT) { + Value *exp_list; int nexp = value_to_list(a[1], &exp_list); + nexports = nexp - 1; + exports = (char **)ul_malloc(sizeof(char *) * nexports); + for (int i = 0; i < nexports; i++) { + exports[i] = ul_strdup(sym_name(exp_list[i + 1])); + } + ul_free(exp_list); + body_start = 2; + } + Env *mod_env = make_env(env); + for (int i = body_start; i < na; i++) leval(a[i], mod_env); + + /* Register module */ + Module *m = (Module *)ul_malloc(sizeof(Module)); + m->name = ul_strdup(mod_name); + m->env = mod_env; + m->exports = exports; + m->nexports = nexports; + m->next = g_modules; + g_modules = m; + + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_IMPORT) { + Value *specs; int nspecs = value_to_list(tail, &specs); + for (int i = 0; i < nspecs; i++) { + const char *mod_name; + char **syms = NULL; + int nsyms = 0; + + if (IS_SYM(specs[i])) { + mod_name = sym_name(specs[i]); + } else if (IS_PAIR(specs[i])) { + Value *items; int ni = value_to_list(specs[i], &items); + mod_name = sym_name(items[0]); + if (ni > 1) { + nsyms = ni - 1; + syms = (char **)ul_malloc(sizeof(char *) * nsyms); + for (int j = 0; j < nsyms; j++) syms[j] = ul_strdup(sym_name(items[j + 1])); + } + ul_free(items); + } else { + continue; + } + + /* Find module */ + Module *m = g_modules; + while (m && strcmp(m->name, mod_name) != 0) m = m->next; + if (!m) lisp_error("import: unknown module: %s", mod_name); + + if (syms) { + for (int j = 0; j < nsyms; j++) { + Value sym = intern(syms[j]); + TRY(ctx) { + Value val = env_lookup(m->env, sym); + env_define(env, sym, val); + } CATCH { + lisp_error("import: %s has no export: %s", mod_name, syms[j]); + } ENDTRY; + ul_free(syms[j]); + } + ul_free(syms); + } else { + /* Import all exports or all bindings */ + if (m->nexports > 0) { + for (int j = 0; j < m->nexports; j++) { + Value sym = intern(m->exports[j]); + TRY(ctx) { + Value val = env_lookup(m->env, sym); + env_define(env, sym, val); + } CATCH { } ENDTRY; + } + } else { + /* Export everything from mod_env local bindings */ + for (size_t b = 0; b < m->env->nbuckets; b++) { + EnvBinding *bind = m->env->buckets[b]; + while (bind) { + env_define(env, bind->sym, bind->val); + bind = bind->next; + } + } + } + } + } + ul_free(specs); + return VAL_VOID; + } + + if (head == SYM_LOAD) { + Value *a; int na = value_to_list(tail, &a); + char *path = show(leval(a[0], env), true); + load_file(path, env); + ul_free(path); ul_free(a); + return VAL_VOID; + } + + if (head == SYM_INCLUDE) { + Value *a; int na = value_to_list(tail, &a); + for (int i = 0; i < na; i++) { + char *path = show(leval(a[i], env), true); + load_file(path, env); + ul_free(path); + } + ul_free(a); + return VAL_VOID; + } + + if (head == SYM_PARAMETERIZE) { + Value *a; int na = value_to_list(tail, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + int nbody = na - 1; + Value *body_arr = a + 1; + + /* Save old values and set new */ + typedef struct { Value param; Value old_val; } PBind; + PBind *pb = (PBind *)ul_malloc(sizeof(PBind) * nb); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + pb[i].param = leval(bp[0], env); + Value new_val = leval(bp[1], env); + pb[i].old_val = call_proc(pb[i].param, NULL, 0, env); + Value sv[1] = {new_val}; + call_proc(pb[i].param, sv, 1, env); + ul_free(bp); + } + + Value result = VAL_VOID; + TRY(ctx) { + for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env); + result = leval(body_arr[nbody - 1], env); + } CATCH { + /* Restore on error */ + for (int i = 0; i < nb; i++) { + Value sv[1] = {pb[i].old_val}; + call_proc(pb[i].param, sv, 1, env); + } + ul_free(pb); ul_free(binds); ul_free(a); + lisp_error("%s", ctx.message); + } ENDTRY; + + /* Restore */ + for (int i = 0; i < nb; i++) { + Value sv[1] = {pb[i].old_val}; + call_proc(pb[i].param, sv, 1, env); + } + ul_free(pb); ul_free(binds); ul_free(a); + return result; + } + + if (head == SYM_DYNAMIC_WIND) { + Value *a; int na = value_to_list(tail, &a); + Value before = leval(a[0], env); + Value thunk = leval(a[1], env); + Value after = leval(a[2], env); + ul_free(a); + call_proc(before, NULL, 0, env); + Value result; + TRY(ctx) { + result = call_proc(thunk, NULL, 0, env); + } CATCH { + call_proc(after, NULL, 0, env); + lisp_error("%s", ctx.message); + } ENDTRY; + call_proc(after, NULL, 0, env); + return result; + } + + if (head == SYM_WITH_EXCEPTION_HANDLER) { + Value *a; int na = value_to_list(tail, &a); + Value handler = leval(a[0], env); + Value thunk = leval(a[1], env); + ul_free(a); + TRY(ctx) { + return call_proc(thunk, NULL, 0, env); + } CATCH { + Value err_val = ctx.error_obj; + if (IS_NIL(err_val)) err_val = make_string_from_cstr(ctx.message); + Value args[1] = {err_val}; + return call_proc(handler, args, 1, env); + } ENDTRY; + return VAL_VOID; + } + + if (head == SYM_GUARD) { + Value *a; int na = value_to_list(tail, &a); + Value *var_clauses; int nvc = value_to_list(a[0], &var_clauses); + Value var = var_clauses[0]; + int nclauses = nvc - 1; + int nbody = na - 1; + + TRY(ctx) { + for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], env); + Value result = leval(a[nbody], env); + ul_free(var_clauses); ul_free(a); + return result; + } CATCH { + Env *c = make_env(env); + Value err_val = ctx.error_obj; + if (IS_NIL(err_val)) err_val = make_string_from_cstr(ctx.message); + env_define(c, var, err_val); + + for (int i = 0; i < nclauses; i++) { + Value *cl; int ncl = value_to_list(var_clauses[i + 1], &cl); + if (cl[0] == SYM_ELSE || IS_TRUTHY(leval(cl[0], c))) { + for (int j = 1; j < ncl - 1; j++) leval(cl[j], c); + Value result = leval(cl[ncl - 1], c); + ul_free(cl); ul_free(var_clauses); ul_free(a); + return result; + } + ul_free(cl); + } + /* No clause matched — re-raise */ + ul_free(var_clauses); ul_free(a); + lisp_error("%s", ctx.message); + } ENDTRY; + return VAL_VOID; + } + + if (head == SYM_LET_VALUES) { + Value *a; int na = value_to_list(tail, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + Env *c = make_env(env); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + Value val = leval(bp[1], env); + Value *fmls; int nf = value_to_list(bp[0], &fmls); + if (IS_VECTOR(val)) { + ULVector *vv = AS_VECTOR(val); + for (int j = 0; j < nf && j < (int)vv->len; j++) + env_define(c, fmls[j], vv->data[j]); + } else { + if (nf > 0) env_define(c, fmls[0], val); + } + ul_free(fmls); ul_free(bp); + } + int nbody = na - 1; + env = c; + for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], env); + expr = a[na - 1]; + ul_free(binds); ul_free(a); + continue; + } + + /* ── Macro expansion ─────────────────────────────────────────── */ + Value hval; + TRY(ctx) { + hval = leval(head, env); + } CATCH { + lisp_error("not callable: %s", show(head, false)); + } ENDTRY; + + if (IS_MACRO(hval)) { + ULMacro *m = AS_MACRO(hval); + if (IS_SYNTAX_TRANSFORMER(m->transformer)) { + Value *a; int na = value_to_list(tail, &a); + Value form = list_to_value(a, na); + expr = syntax_transform_value(AS_SYNTAX_TRANSFORMER(m->transformer), form); + ul_free(a); + continue; + } + /* Regular macro */ + Value *a; int na = value_to_list(tail, &a); + expr = call_proc(m->transformer, a, na, env); + ul_free(a); + continue; + } + + /* ── Procedure application ────────────────────────────────────── */ + Value proc = hval; + Value *args; int nargs = value_to_list(tail, &args); + for (int i = 0; i < nargs; i++) { + args[i] = leval(args[i], env); + } + + if (IS_PROC(proc)) { + Proc *p = AS_PROC(proc); + env = env_child(p->env, p->params, p->nparams, p->rest, args, nargs); + ExprList body = p->has_defs ? + body_with_env(p->body.exprs, p->body.count, env) : p->body; + if (body.count == 1) expr = body.exprs[0]; + else { + for (int i = 0; i < body.count - 1; i++) leval(body.exprs[i], env); + expr = body.exprs[body.count - 1]; + } + ul_free(args); + continue; + } + + if (IS_COMPILED_PROC(proc)) { + CompiledProc *cp = AS_COMPILED_PROC(proc); + Env *c = env_child(cp->env, cp->params, cp->nparams, cp->rest, args, nargs); + ul_free(args); + return vm_exec(cp->code, c); + } + + if (IS_BUILTIN(proc)) { + Value result = AS_BUILTIN(proc)(args, nargs, env); + ul_free(args); + return result; + } + + char *s = show(proc, false); + lisp_error("not callable: %s", s); + +next_iter: + continue; + } +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * File loading + * ═══════════════════════════════════════════════════════════════════════════ */ + +void load_file(const char *path, Env *env) { + FILE *f = fopen(path, "r"); + if (!f) lisp_error("file not found: %s", path); + + fseek(f, 0, SEEK_END); + long sz = ftell(f); + fseek(f, 0, SEEK_SET); + + char *src = (char *)ul_malloc(sz + 1); + size_t nread = fread(src, 1, sz, f); + src[nread] = '\0'; + fclose(f); + + int count; + Value *exprs = read_all(src, &count, true); + ul_free(src); + + for (int i = 0; i < count; i++) { + leval(exprs[i], env); + } + ul_free(exprs); +} diff --git a/c/main.c b/c/main.c new file mode 100644 index 0000000..0bc6149 --- /dev/null +++ b/c/main.c @@ -0,0 +1,239 @@ +/* + * main.c — REPL, script mode, -e mode + */ +#include "uncommonlisp.h" + +/* ═══════════════════════════════════════════════════════════════════════════ + * Find stdlib.lsp relative to the executable + * ═══════════════════════════════════════════════════════════════════════════ */ + +static char *find_stdlib(const char *argv0) { + /* Try relative to executable: ../stdlib.lsp */ + char path[4096]; + + /* Try via /proc/self/exe on Linux */ + ssize_t n = readlink("/proc/self/exe", path, sizeof(path) - 1); + if (n > 0) { + path[n] = '\0'; + /* Go up one directory (from c/uncommonlisp to uncommonlisp/) */ + char *slash = strrchr(path, '/'); + if (slash) { + *slash = '\0'; + slash = strrchr(path, '/'); + if (slash) { + slash[1] = '\0'; + strcat(path, "stdlib.lsp"); + if (access(path, R_OK) == 0) return ul_strdup(path); + } + } + } + + /* Try current directory */ + if (access("stdlib.lsp", R_OK) == 0) return ul_strdup("stdlib.lsp"); + + /* Try relative to argv0 */ + if (argv0) { + const char *slash = strrchr(argv0, '/'); + if (slash) { + size_t dir_len = slash - argv0; + snprintf(path, sizeof(path), "%.*s/../stdlib.lsp", (int)dir_len, argv0); + if (access(path, R_OK) == 0) return ul_strdup(path); + } + } + + return NULL; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * REPL + * ═══════════════════════════════════════════════════════════════════════════ */ + +static void repl(Env *env) { + char *version_str = show(env_lookup(env, intern("*version*")), true); + printf("uncommonlisp %s (C) — (exit) to quit, (load \"file.lsp\") to load\n", version_str); + ul_free(version_str); + + char buf[16384]; + buf[0] = '\0'; + size_t buf_len = 0; + + while (1) { + printf(buf_len > 0 ? " " : "λ> "); + fflush(stdout); + + char line[4096]; + if (!fgets(line, sizeof(line), stdin)) { + if (buf_len > 0) { buf[0] = '\0'; buf_len = 0; printf("\n"); continue; } + printf("\n"); + break; + } + + size_t line_len = strlen(line); + if (buf_len + line_len >= sizeof(buf) - 1) { + buf[0] = '\0'; buf_len = 0; continue; + } + memcpy(buf + buf_len, line, line_len); + buf_len += line_len; + buf[buf_len] = '\0'; + + /* Check for balanced parens */ + int depth = 0; + for (size_t i = 0; i < buf_len; i++) { + if (buf[i] == '(') depth++; + else if (buf[i] == ')') depth--; + } + if (depth > 0) continue; + + /* Try to parse */ + int count; + Value *exprs; + TRY(ctx) { + exprs = read_all(buf, &count, false); + } CATCH { + if (depth > 0) continue; + buf[0] = '\0'; buf_len = 0; + continue; + } ENDTRY; + + if (count == 0) { buf[0] = '\0'; buf_len = 0; continue; } + + for (int i = 0; i < count; i++) { + TRY(ctx) { + Value result = leval(exprs[i], env); + if (!IS_VOID(result)) { + print_value(result, false, stdout); + printf("\n"); + } + } CATCH { + fprintf(stderr, "error: %s\n", ctx.message); + } ENDTRY; + } + ul_free(exprs); + buf[0] = '\0'; buf_len = 0; + } +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Main + * ═══════════════════════════════════════════════════════════════════════════ */ + +int main(int argc, char **argv) { + init_symbols(); + Env *g = make_global_env(); + + /* Load prelude */ + { + int count; + Value *exprs = read_all(PRELUDE, &count, false); + for (int i = 0; i < count; i++) leval(exprs[i], g); + ul_free(exprs); + } + + /* Parse args */ + int argi = 1; + bool fast = false; + bool help = false; + bool version = false; + const char *eval_expr = NULL; + + while (argi < argc) { + if (strcmp(argv[argi], "--fast") == 0 || strcmp(argv[argi], "-f") == 0) { + fast = true; argi++; + } else if (strcmp(argv[argi], "--help") == 0 || strcmp(argv[argi], "-h") == 0) { + help = true; argi++; + } else if (strcmp(argv[argi], "--version") == 0 || strcmp(argv[argi], "-v") == 0) { + version = true; argi++; + } else if (strcmp(argv[argi], "-e") == 0 && argi + 1 < argc) { + eval_expr = argv[argi + 1]; argi += 2; + } else { + break; + } + } + + if (help) { + printf("uncommonlisp — a Scheme interpreter in C\n\n" + "Usage: uncommonlisp [options] [script.lsp] [args...]\n" + " uncommonlisp -e '(+ 1 2)'\n" + " uncommonlisp (interactive REPL)\n\n" + "Options:\n" + " -e EXPR evaluate expression and print result\n" + " -f, --fast auto-compile all defines (bytecode VM)\n" + " -h, --help show this help\n" + " -v, --version show version\n\n" + "Features: R7RS core, bytecode compiler, macros, syntax-rules,\n" + " modules, rationals, string ports.\n"); + return 0; + } + + if (version) { + printf("uncommonlisp 1.0.0 (C)\n"); + return 0; + } + + if (fast) g_auto_compile = true; + + /* Load stdlib.lsp if it exists */ + char *stdlib_path = find_stdlib(argv[0]); + if (stdlib_path) { + TRY(ctx) { + load_file(stdlib_path, g); + } CATCH { + /* Ignore stdlib load errors — it's optional */ + } ENDTRY; + ul_free(stdlib_path); + } + + /* -e mode */ + if (eval_expr) { + TRY(ctx) { + int count; + Value *exprs = read_all(eval_expr, &count, false); + for (int i = 0; i < count; i++) { + Value result = leval(exprs[i], g); + if (!IS_VOID(result)) { + print_value(result, false, stdout); + printf("\n"); + } + } + ul_free(exprs); + } CATCH { + fprintf(stderr, "error: %s\n", g_error_ctx ? g_error_ctx->message : "unknown"); + return 1; + } ENDTRY; + return 0; + } + + /* Script mode */ + if (argi < argc) { + const char *path = argv[argi]; + /* Set *argv* */ + int script_argc = argc - argi - 1; + Value *script_argv = (Value *)ul_malloc(sizeof(Value) * script_argc); + for (int i = 0; i < script_argc; i++) { + script_argv[i] = make_string_from_cstr(argv[argi + 1 + i]); + } + env_define(g, intern("*argv*"), list_to_value(script_argv, script_argc)); + ul_free(script_argv); + + TRY(ctx) { + load_file(path, g); + } CATCH { + fprintf(stderr, "error: %s\n", ctx.message); + return 1; + } ENDTRY; + return 0; + } + + /* REPL mode */ + ErrorContext root_ctx; + root_ctx.call_stack_depth = 0; + root_ctx.error_obj = VAL_NIL; + root_ctx.source_line = 0; + g_error_ctx = &root_ctx; + if (setjmp(root_ctx.jmp) != 0) { + fprintf(stderr, "fatal error: %s\n", root_ctx.message); + return 1; + } + repl(g); + return 0; +} diff --git a/c/printer.c b/c/printer.c new file mode 100644 index 0000000..9149200 --- /dev/null +++ b/c/printer.c @@ -0,0 +1,260 @@ +/* + * printer.c — show/display/write for Scheme values + */ +#include "uncommonlisp.h" + +/* Dynamic string builder */ +typedef struct { + char *buf; + size_t len; + size_t cap; +} StringBuilder; + +static void sb_init(StringBuilder *sb) { + sb->cap = 128; + sb->buf = (char *)ul_malloc(sb->cap); + sb->buf[0] = '\0'; + sb->len = 0; +} + +static void sb_append(StringBuilder *sb, const char *s, size_t n) { + while (sb->len + n + 1 > sb->cap) { + sb->cap *= 2; + sb->buf = (char *)ul_realloc(sb->buf, sb->cap); + } + memcpy(sb->buf + sb->len, s, n); + sb->len += n; + sb->buf[sb->len] = '\0'; +} + +static void sb_appendz(StringBuilder *sb, const char *s) { + sb_append(sb, s, strlen(s)); +} + +static void sb_appendc(StringBuilder *sb, char c) { + sb_append(sb, &c, 1); +} + +static void show_value(Value v, bool display, StringBuilder *sb); + +static void show_pair(Value v, bool display, StringBuilder *sb) { + sb_appendc(sb, '('); + Value n = v; + bool first = true; + while (IS_PAIR(n)) { + if (!first) sb_appendc(sb, ' '); + first = false; + show_value(CAR(n), display, sb); + n = CDR(n); + } + if (!IS_NIL(n)) { + sb_appendz(sb, " . "); + show_value(n, display, sb); + } + sb_appendc(sb, ')'); +} + +static void show_escaped_string(const char *s, size_t len, StringBuilder *sb) { + sb_appendc(sb, '"'); + for (size_t i = 0; i < len; i++) { + switch (s[i]) { + case '\\': sb_appendz(sb, "\\\\"); break; + case '"': sb_appendz(sb, "\\\""); break; + case '\n': sb_appendz(sb, "\\n"); break; + case '\t': sb_appendz(sb, "\\t"); break; + case '\r': sb_appendz(sb, "\\r"); break; + default: sb_appendc(sb, s[i]); break; + } + } + sb_appendc(sb, '"'); +} + +static void show_value(Value v, bool display, StringBuilder *sb) { + if (IS_NIL(v)) { sb_appendz(sb, "()"); return; } + if (IS_VOID(v)) { return; } /* void prints nothing */ + if (IS_TRUE(v)) { sb_appendz(sb, "#t"); return; } + if (IS_FALSE(v)){ sb_appendz(sb, "#f"); return; } + if (IS_EOF(v)) { sb_appendz(sb, "#"); return; } + + if (IS_CHAR(v)) { + int c = AS_CHAR(v); + if (display) { + sb_appendc(sb, (char)c); + } else { + sb_appendz(sb, "#\\"); + switch (c) { + case ' ': sb_appendz(sb, "space"); break; + case '\n': sb_appendz(sb, "newline"); break; + case '\t': sb_appendz(sb, "tab"); break; + case '\r': sb_appendz(sb, "return"); break; + case '\0': sb_appendz(sb, "null"); break; + case '\x1b': sb_appendz(sb, "escape"); break; + default: sb_appendc(sb, (char)c); break; + } + } + return; + } + + if (IS_INT(v)) { + char buf[32]; + snprintf(buf, sizeof(buf), "%lld", (long long)as_int(v)); + sb_appendz(sb, buf); + return; + } + + if (IS_DOUBLE(v)) { + double d = as_double(v); + if (isinf(d)) { + sb_appendz(sb, d > 0 ? "+inf.0" : "-inf.0"); + return; + } + if (isnan(d)) { + sb_appendz(sb, "+nan.0"); + return; + } + char buf[64]; + snprintf(buf, sizeof(buf), "%.17g", d); + /* Ensure a decimal point for Scheme compat */ + if (!strchr(buf, '.') && !strchr(buf, 'e') && !strchr(buf, 'n') && !strchr(buf, 'i')) { + size_t n = strlen(buf); + buf[n] = '.'; buf[n+1] = '0'; buf[n+2] = '\0'; + } + sb_appendz(sb, buf); + return; + } + + if (IS_SYM(v)) { + sb_appendz(sb, sym_name(v)); + return; + } + + if (IS_RATIONAL(v)) { + Rational *r = AS_RATIONAL(v); + char buf[64]; + snprintf(buf, sizeof(buf), "%lld/%lld", (long long)r->num, (long long)r->den); + sb_appendz(sb, buf); + return; + } + + if (IS_BUILTIN(v)) { + sb_appendz(sb, "#"); + return; + } + + if (!IS_PTR(v)) { + char buf[32]; + snprintf(buf, sizeof(buf), "#", (unsigned long long)v); + sb_appendz(sb, buf); + return; + } + + /* Heap objects */ + ObjType type = obj_type(v); + + switch (type) { + case OBJ_PAIR: + show_pair(v, display, sb); + break; + + case OBJ_STRING: + case OBJ_MUTABLE_STRING: { + ULString *s = AS_STRING(v); + if (display) { + sb_append(sb, s->data, s->len); + } else { + show_escaped_string(s->data, s->len, sb); + } + break; + } + + case OBJ_VECTOR: { + ULVector *vec = AS_VECTOR(v); + sb_appendz(sb, "#("); + for (size_t i = 0; i < vec->len; i++) { + if (i > 0) sb_appendc(sb, ' '); + show_value(vec->data[i], display, sb); + } + sb_appendc(sb, ')'); + break; + } + + case OBJ_HASHTABLE: + sb_appendz(sb, "#"); + break; + + case OBJ_PROC: { + Proc *p = AS_PROC(v); + char buf[128]; + snprintf(buf, sizeof(buf), "#", p->name ? p->name : "λ"); + sb_appendz(sb, buf); + break; + } + + case OBJ_COMPILED_PROC: { + CompiledProc *cp = AS_COMPILED_PROC(v); + char buf[128]; + snprintf(buf, sizeof(buf), "#", cp->name ? cp->name : "λ"); + sb_appendz(sb, buf); + break; + } + + case OBJ_MACRO: + sb_appendz(sb, "#"); + break; + + case OBJ_CONTINUATION: + sb_appendz(sb, "#"); + break; + + case OBJ_PORT: { + ULPort *p = AS_PORT(v); + char buf[64]; + snprintf(buf, sizeof(buf), "#<%s-%s-port>", + p->kind == PORT_STRING ? "string" : "file", + p->dir == PORT_INPUT ? "input" : "output"); + sb_appendz(sb, buf); + break; + } + + case OBJ_ERROR: { + ErrorObject *e = AS_ERROR(v); + char buf[256]; + snprintf(buf, sizeof(buf), "#", e->message); + sb_appendz(sb, buf); + break; + } + + case OBJ_ENV: + sb_appendz(sb, "#"); + break; + + case OBJ_CODE: + sb_appendz(sb, "#"); + break; + + case OBJ_SYNTAX_TRANSFORMER: + sb_appendz(sb, "#"); + break; + + case OBJ_RATIONAL: { + Rational *r = AS_RATIONAL(v); + char buf[64]; + snprintf(buf, sizeof(buf), "%lld/%lld", (long long)r->num, (long long)r->den); + sb_appendz(sb, buf); + break; + } + } +} + +char *show(Value v, bool display) { + StringBuilder sb; + sb_init(&sb); + show_value(v, display, &sb); + return sb.buf; +} + +void print_value(Value v, bool display, FILE *out) { + char *s = show(v, display); + fputs(s, out); + ul_free(s); +} diff --git a/c/reader.c b/c/reader.c new file mode 100644 index 0000000..4bf74eb --- /dev/null +++ b/c/reader.c @@ -0,0 +1,393 @@ +/* + * reader.c — Tokenizer + parser for Scheme source + */ +#include "uncommonlisp.h" + +/* ═══════════════════════════════════════════════════════════════════════════ + * Tokenizer + * ═══════════════════════════════════════════════════════════════════════════ */ + +static void tl_init(TokenList *tl) { + tl->cap = 256; + tl->count = 0; + tl->tokens = (char **)ul_malloc(sizeof(char *) * tl->cap); + tl->lines = (int *)ul_malloc(sizeof(int) * tl->cap); +} + +static void tl_push(TokenList *tl, const char *tok, int len, int line) { + if (tl->count >= tl->cap) { + tl->cap *= 2; + tl->tokens = (char **)ul_realloc(tl->tokens, sizeof(char *) * tl->cap); + tl->lines = (int *)ul_realloc(tl->lines, sizeof(int) * tl->cap); + } + char *copy = (char *)ul_malloc(len + 1); + memcpy(copy, tok, len); + copy[len] = '\0'; + tl->tokens[tl->count] = copy; + tl->lines[tl->count] = line; + tl->count++; +} + +static int is_delimiter(int c) { + return c == '\0' || c == '(' || c == ')' || c == '"' || c == '\'' || + c == '`' || c == ',' || c == ';' || isspace(c); +} + +void tokenize(const char *src, TokenList *out, bool track_lines) { + tl_init(out); + const char *p = src; + int line = 1; + + while (*p) { + /* Skip whitespace */ + while (*p && isspace(*p)) { + if (*p == '\n') line++; + p++; + } + if (!*p) break; + + /* Line comment */ + if (*p == ';') { + while (*p && *p != '\n') p++; + continue; + } + + /* Block comment #| ... |# */ + if (*p == '#' && *(p+1) == '|') { + p += 2; + int depth = 1; + while (*p && depth > 0) { + if (*p == '#' && *(p+1) == '|') { depth++; p += 2; } + else if (*p == '|' && *(p+1) == '#') { depth--; p += 2; } + else { if (*p == '\n') line++; p++; } + } + continue; + } + + /* Datum comment #; */ + if (*p == '#' && *(p+1) == ';') { + p += 2; + /* Skip whitespace before datum */ + while (*p && isspace(*p)) { if (*p == '\n') line++; p++; } + /* We need to skip exactly one datum — use a recursive approach */ + /* For now, count balanced parens */ + if (*p == '(') { + int depth = 0; + do { + if (*p == '(') depth++; + else if (*p == ')') depth--; + if (*p == '"') { p++; while (*p && (*p != '"' || *(p-1) == '\\')) p++; if (*p) p++; continue; } + if (*p == '\n') line++; + p++; + } while (*p && depth > 0); + } else if (*p == '"') { + p++; while (*p && (*p != '"' || *(p-1) == '\\')) p++; if (*p) p++; + } else { + while (*p && !is_delimiter(*p)) p++; + } + continue; + } + + int tok_line = line; + + /* String literal */ + if (*p == '"') { + const char *start = p; + p++; /* skip opening " */ + while (*p && *p != '"') { + if (*p == '\\' && *(p+1)) { p += 2; continue; } + if (*p == '\n') line++; + p++; + } + if (*p == '"') p++; /* skip closing " */ + tl_push(out, start, (int)(p - start), tok_line); + continue; + } + + /* Single-char tokens */ + if (*p == '(' || *p == ')') { + tl_push(out, p, 1, tok_line); + p++; + continue; + } + if (*p == '\'') { tl_push(out, p, 1, tok_line); p++; continue; } + if (*p == '`') { tl_push(out, p, 1, tok_line); p++; continue; } + + /* ,@ (unquote-splicing) */ + if (*p == ',' && *(p+1) == '@') { + tl_push(out, p, 2, tok_line); + p += 2; + continue; + } + if (*p == ',') { tl_push(out, p, 1, tok_line); p++; continue; } + + /* #( vector literal */ + if (*p == '#' && *(p+1) == '(') { + tl_push(out, p, 2, tok_line); + p += 2; + continue; + } + + /* Boolean #t #f */ + if (*p == '#' && (*(p+1) == 't' || *(p+1) == 'T' || *(p+1) == 'f' || *(p+1) == 'F')) { + if (is_delimiter(*(p+2))) { + tl_push(out, p, 2, tok_line); + p += 2; + continue; + } + /* #true / #false */ + if ((*(p+1) == 't' || *(p+1) == 'T') && strncmp(p, "#true", 5) == 0 && is_delimiter(*(p+5))) { + tl_push(out, "#t", 2, tok_line); p += 5; continue; + } + if ((*(p+1) == 'f' || *(p+1) == 'F') && strncmp(p, "#false", 6) == 0 && is_delimiter(*(p+6))) { + tl_push(out, "#f", 2, tok_line); p += 6; continue; + } + } + + /* Character #\ */ + if (*p == '#' && *(p+1) == '\\') { + const char *start = p; + p += 2; + /* Named chars */ + const char *names[] = {"space", "newline", "tab", "return", "null", "escape", NULL}; + bool found = false; + for (int i = 0; names[i]; i++) { + size_t nlen = strlen(names[i]); + if (strncasecmp(p, names[i], nlen) == 0 && is_delimiter(*(p + nlen))) { + p += nlen; + tl_push(out, start, (int)(p - start), tok_line); + found = true; + break; + } + } + if (!found) { + /* Single char */ + if (*p) p++; + tl_push(out, start, (int)(p - start), tok_line); + } + continue; + } + + /* Atom (number, symbol, etc.) */ + const char *start = p; + while (*p && !is_delimiter(*p)) p++; + if (p > start) { + tl_push(out, start, (int)(p - start), tok_line); + } + } +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Parser + * ═══════════════════════════════════════════════════════════════════════════ */ + +static char *unescape_string(const char *s, size_t len) { + /* s includes quotes: "..." */ + char *buf = (char *)ul_malloc(len + 1); + int j = 0; + for (size_t i = 1; i < len - 1; i++) { + if (s[i] == '\\' && i + 1 < len - 1) { + i++; + switch (s[i]) { + case 'n': buf[j++] = '\n'; break; + case 't': buf[j++] = '\t'; break; + case 'r': buf[j++] = '\r'; break; + case '"': buf[j++] = '"'; break; + case '\\': buf[j++] = '\\'; break; + default: buf[j++] = '\\'; buf[j++] = s[i]; break; + } + } else { + buf[j++] = s[i]; + } + } + buf[j] = '\0'; + return buf; +} + +Value parse_atom(const char *tok) { + /* Booleans */ + if (strcmp(tok, "#t") == 0 || strcmp(tok, "#T") == 0) return VAL_TRUE; + if (strcmp(tok, "#f") == 0 || strcmp(tok, "#F") == 0) return VAL_FALSE; + + /* Character */ + if (tok[0] == '#' && tok[1] == '\\') { + const char *name = tok + 2; + if (strcasecmp(name, "space") == 0) return VAL_CHAR(' '); + if (strcasecmp(name, "newline") == 0) return VAL_CHAR('\n'); + if (strcasecmp(name, "tab") == 0) return VAL_CHAR('\t'); + if (strcasecmp(name, "return") == 0) return VAL_CHAR('\r'); + if (strcasecmp(name, "null") == 0) return VAL_CHAR('\0'); + if (strcasecmp(name, "escape") == 0) return VAL_CHAR('\x1b'); + return VAL_CHAR(name[0]); + } + + /* String */ + if (tok[0] == '"') { + size_t len = strlen(tok); + char *unescaped = unescape_string(tok, len); + Value v = make_string(unescaped, strlen(unescaped), false); + ul_free(unescaped); + return v; + } + + /* Integer */ + { + char *end; + errno = 0; + long long val = strtoll(tok, &end, 10); + if (*end == '\0' && errno == 0) { + /* Check if fits in 48-bit int */ + if (val >= -(1LL << 47) && val < (1LL << 47)) + return VAL_INT(val); + else + return make_double((double)val); + } + } + + /* Float */ + { + char *end; + errno = 0; + double val = strtod(tok, &end); + if (*end == '\0' && errno == 0) { + return make_double(val); + } + } + + /* Special float literals */ + if (strcmp(tok, "+inf.0") == 0) return make_double(INFINITY); + if (strcmp(tok, "-inf.0") == 0) return make_double(-INFINITY); + if (strcmp(tok, "+nan.0") == 0 || strcmp(tok, "-nan.0") == 0) return make_double(NAN); + + /* Rational n/d */ + { + const char *slash = strchr(tok, '/'); + if (slash && slash != tok && *(slash+1) != '\0') { + /* Check if it's a valid rational: digits/digits */ + bool valid = true; + const char *p = tok; + if (*p == '-') p++; + while (p < slash) { if (!isdigit(*p)) { valid = false; break; } p++; } + p = slash + 1; + if (*p == '-') p++; + while (*p) { if (!isdigit(*p)) { valid = false; break; } p++; } + if (valid) { + int64_t num = strtoll(tok, NULL, 10); + int64_t den = strtoll(slash + 1, NULL, 10); + if (den != 0) return rational_normalize(num, den); + } + } + } + + /* Symbol */ + return intern(tok); +} + +Value parse_one(TokenList *tl, int *pos) { + if (*pos >= tl->count) lisp_error("unexpected EOF"); + char *tok = tl->tokens[*pos]; + int line = tl->lines[*pos]; + (*pos)++; + + /* Quote abbreviations */ + if (strcmp(tok, "'") == 0) { + Value v = parse_one(tl, pos); + Pair *p = make_pair(SYM_QUOTE, cons(v, VAL_NIL)); + p->line = line; + return VAL_PTR(p); + } + if (strcmp(tok, "`") == 0) { + Value v = parse_one(tl, pos); + Pair *p = make_pair(SYM_QUASIQUOTE, cons(v, VAL_NIL)); + p->line = line; + return VAL_PTR(p); + } + if (strcmp(tok, ",") == 0) { + Value v = parse_one(tl, pos); + Pair *p = make_pair(SYM_UNQUOTE, cons(v, VAL_NIL)); + p->line = line; + return VAL_PTR(p); + } + if (strcmp(tok, ",@") == 0) { + Value v = parse_one(tl, pos); + Pair *p = make_pair(SYM_UNQUOTE_SPLICING, cons(v, VAL_NIL)); + p->line = line; + return VAL_PTR(p); + } + + /* List */ + if (strcmp(tok, "(") == 0) { + /* Collect items */ + Value items[4096]; + int count = 0; + Value tail = VAL_NIL; + bool has_dot = false; + + while (1) { + if (*pos >= tl->count) lisp_error("unclosed ("); + char *t = tl->tokens[*pos]; + if (strcmp(t, ")") == 0) { (*pos)++; break; } + if (strcmp(t, ".") == 0) { + (*pos)++; + tail = parse_one(tl, pos); + has_dot = true; + if (*pos >= tl->count || strcmp(tl->tokens[*pos], ")") != 0) + lisp_error(". without )"); + (*pos)++; + break; + } + if (count >= 4096) lisp_error("list too long"); + items[count++] = parse_one(tl, pos); + } + + Value r = has_dot ? tail : VAL_NIL; + for (int i = count - 1; i >= 0; i--) { + r = cons(items[i], r); + } + if (IS_PAIR(r)) AS_PAIR(r)->line = line; + return r; + } + + /* Vector literal #( */ + if (strcmp(tok, "#(") == 0) { + Value items[4096]; + int count = 0; + while (1) { + if (*pos >= tl->count) lisp_error("unclosed #("); + if (strcmp(tl->tokens[*pos], ")") == 0) { (*pos)++; break; } + if (count >= 4096) lisp_error("vector too long"); + items[count++] = parse_one(tl, pos); + } + return make_vector_from(items, count); + } + + if (strcmp(tok, ")") == 0) lisp_error("unexpected )"); + + return parse_atom(tok); +} + +Value *read_all(const char *src, int *count, bool track_lines) { + TokenList tl; + tokenize(src, &tl, track_lines); + + int cap = 64; + Value *exprs = (Value *)ul_malloc(sizeof(Value) * cap); + *count = 0; + int pos = 0; + + while (pos < tl.count) { + if (*count >= cap) { + cap *= 2; + exprs = (Value *)ul_realloc(exprs, sizeof(Value) * cap); + } + exprs[*count] = parse_one(&tl, &pos); + (*count)++; + } + + /* Free token list */ + for (int i = 0; i < tl.count; i++) ul_free(tl.tokens[i]); + ul_free(tl.tokens); + ul_free(tl.lines); + + return exprs; +} diff --git a/c/test.c b/c/test.c new file mode 100644 index 0000000..e26ad6e --- /dev/null +++ b/c/test.c @@ -0,0 +1,597 @@ +/* + * test.c — Unit + integration tests for the C Scheme interpreter + */ +#include "uncommonlisp.h" + +static int tests_run = 0; +static int tests_passed = 0; +static int tests_failed = 0; + +#define TEST(name) \ + static void test_##name(void); \ + static void run_test_##name(void) { \ + tests_run++; \ + TRY(ctx) { \ + test_##name(); \ + tests_passed++; \ + printf(" PASS: %s\n", #name); \ + } CATCH { \ + tests_failed++; \ + printf(" FAIL: %s — %s\n", #name, ctx.message); \ + } ENDTRY; \ + } \ + static void test_##name(void) + +#define ASSERT(cond, msg) \ + do { if (!(cond)) lisp_error("assertion failed: %s", msg); } while(0) + +#define ASSERT_EQ_INT(a, b) \ + do { int64_t _a = (a), _b = (b); \ + if (_a != _b) lisp_error("expected %lld, got %lld", (long long)_b, (long long)_a); \ + } while(0) + +#define ASSERT_EQ_STR(a, b) \ + do { if (strcmp(a, b) != 0) lisp_error("expected \"%s\", got \"%s\"", b, a); } while(0) + +/* Helper: evaluate source and return result */ +static Env *fresh_env(void) { + Env *g = make_global_env(); + int count; + Value *exprs = read_all(PRELUDE, &count, false); + for (int i = 0; i < count; i++) leval(exprs[i], g); + ul_free(exprs); + return g; +} + +static Value run(const char *src) { + Env *g = fresh_env(); + int count; + Value *exprs = read_all(src, &count, false); + Value result = VAL_VOID; + for (int i = 0; i < count; i++) result = leval(exprs[i], g); + ul_free(exprs); + return result; +} + +static char *run_show(const char *src) { + return show(run(src), false); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Unit tests — Types + * ═══════════════════════════════════════════════════════════════════════════ */ + +TEST(nan_boxing_int) { + Value v = VAL_INT(42); + ASSERT(IS_INT(v), "should be int"); + ASSERT_EQ_INT(as_int(v), 42); + + v = VAL_INT(-100); + ASSERT_EQ_INT(as_int(v), -100); + + v = VAL_INT(0); + ASSERT_EQ_INT(as_int(v), 0); +} + +TEST(nan_boxing_double) { + Value v = make_double(3.14); + ASSERT(IS_DOUBLE(v), "should be double"); + double d = as_double(v); + ASSERT(fabs(d - 3.14) < 1e-10, "should be 3.14"); +} + +TEST(nan_boxing_special) { + ASSERT(IS_NIL(VAL_NIL), "NIL"); + ASSERT(IS_VOID(VAL_VOID), "VOID"); + ASSERT(IS_TRUE(VAL_TRUE), "TRUE"); + ASSERT(IS_FALSE(VAL_FALSE), "FALSE"); + ASSERT(IS_EOF(VAL_EOF), "EOF"); + ASSERT(IS_TRUTHY(VAL_TRUE), "TRUE is truthy"); + ASSERT(!IS_TRUTHY(VAL_FALSE), "FALSE is not truthy"); + ASSERT(IS_TRUTHY(VAL_NIL), "NIL is truthy (Scheme semantics)"); +} + +TEST(symbol_interning) { + Value s1 = intern("foo"); + Value s2 = intern("foo"); + Value s3 = intern("bar"); + ASSERT(s1 == s2, "same symbol should be identical"); + ASSERT(s1 != s3, "different symbols should differ"); + ASSERT_EQ_STR(sym_name(s1), "foo"); +} + +TEST(pair_creation) { + Value p = cons(VAL_INT(1), cons(VAL_INT(2), VAL_NIL)); + ASSERT(IS_PAIR(p), "should be pair"); + ASSERT_EQ_INT(as_int(CAR(p)), 1); + ASSERT_EQ_INT(as_int(CADR(p)), 2); + ASSERT(IS_NIL(CDDR(p)), "should end with NIL"); +} + +TEST(string_creation) { + Value s = make_string_from_cstr("hello"); + ASSERT(IS_STRING(s), "should be string"); + ASSERT_EQ_INT(AS_STRING(s)->len, 5); + ASSERT_EQ_STR(AS_STRING(s)->data, "hello"); +} + +TEST(vector_creation) { + Value v = make_vector(3, VAL_INT(0)); + ASSERT(IS_VECTOR(v), "should be vector"); + ASSERT_EQ_INT(AS_VECTOR(v)->len, 3); + AS_VECTOR(v)->data[1] = VAL_INT(42); + ASSERT_EQ_INT(as_int(AS_VECTOR(v)->data[1]), 42); +} + +TEST(rational_creation) { + Value r = rational_normalize(6, 4); + ASSERT(IS_RATIONAL(r), "6/4 should be rational 3/2"); + ASSERT_EQ_INT(AS_RATIONAL(r)->num, 3); + ASSERT_EQ_INT(AS_RATIONAL(r)->den, 2); + + Value r2 = rational_normalize(4, 2); + ASSERT(IS_INT(r2), "4/2 should normalize to int 2"); + ASSERT_EQ_INT(as_int(r2), 2); +} + +TEST(environment) { + Env *g = make_env(NULL); + g->global = g; + Value sym = intern("x"); + env_define(g, sym, VAL_INT(42)); + ASSERT_EQ_INT(as_int(env_lookup(g, sym)), 42); + + Env *c = make_env(g); + ASSERT_EQ_INT(as_int(env_lookup(c, sym)), 42); + env_define(c, sym, VAL_INT(99)); + ASSERT_EQ_INT(as_int(env_lookup(c, sym)), 99); + ASSERT_EQ_INT(as_int(env_lookup(g, sym)), 42); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Unit tests — Reader + * ═══════════════════════════════════════════════════════════════════════════ */ + +TEST(read_integer) { + Value v = run("42"); + ASSERT_EQ_INT(as_int(v), 42); +} + +TEST(read_float) { + Value v = run("3.14"); + ASSERT(IS_DOUBLE(v), "should be double"); +} + +TEST(read_string) { + Value v = run("\"hello\""); + ASSERT(IS_STRING(v), "should be string"); + ASSERT_EQ_STR(AS_STRING(v)->data, "hello"); +} + +TEST(read_boolean) { + ASSERT(IS_TRUE(run("#t")), "#t"); + ASSERT(IS_FALSE(run("#f")), "#f"); +} + +TEST(read_list) { + char *s = run_show("'(1 2 3)"); + ASSERT_EQ_STR(s, "(1 2 3)"); + ul_free(s); +} + +TEST(read_vector) { + char *s = run_show("#(1 2 3)"); + ASSERT_EQ_STR(s, "#(1 2 3)"); + ul_free(s); +} + +TEST(read_char) { + Value v = run("#\\space"); + ASSERT(IS_CHAR(v), "should be char"); + ASSERT_EQ_INT(AS_CHAR(v), ' '); +} + +TEST(read_rational) { + Value v = run("1/3"); + ASSERT(IS_RATIONAL(v), "should be rational"); + ASSERT_EQ_INT(AS_RATIONAL(v)->num, 1); + ASSERT_EQ_INT(AS_RATIONAL(v)->den, 3); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Unit tests — Evaluator + * ═══════════════════════════════════════════════════════════════════════════ */ + +TEST(eval_arithmetic) { + ASSERT_EQ_INT(as_int(run("(+ 1 2)")), 3); + ASSERT_EQ_INT(as_int(run("(- 10 3)")), 7); + ASSERT_EQ_INT(as_int(run("(* 4 5)")), 20); + ASSERT_EQ_INT(as_int(run("(+ 1 2 3 4 5)")), 15); +} + +TEST(eval_comparison) { + ASSERT(IS_TRUE(run("(= 3 3)")), "3 = 3"); + ASSERT(IS_FALSE(run("(= 3 4)")), "3 != 4"); + ASSERT(IS_TRUE(run("(< 1 2)")), "1 < 2"); + ASSERT(IS_TRUE(run("(> 5 3)")), "5 > 3"); +} + +TEST(eval_if) { + ASSERT_EQ_INT(as_int(run("(if #t 1 2)")), 1); + ASSERT_EQ_INT(as_int(run("(if #f 1 2)")), 2); +} + +TEST(eval_cond) { + ASSERT_EQ_INT(as_int(run("(cond (#f 1) (#t 2) (else 3))")), 2); + ASSERT_EQ_INT(as_int(run("(cond (else 42))")), 42); +} + +TEST(eval_and_or) { + ASSERT(IS_TRUE(run("(and #t #t)")), "and true"); + ASSERT(IS_FALSE(run("(and #t #f)")), "and false"); + ASSERT(IS_TRUE(run("(or #f #t)")), "or true"); + ASSERT(IS_FALSE(run("(or #f #f)")), "or false"); +} + +TEST(eval_define) { + ASSERT_EQ_INT(as_int(run("(define x 42) x")), 42); +} + +TEST(eval_lambda) { + ASSERT_EQ_INT(as_int(run("((lambda (x) (+ x 1)) 41)")), 42); +} + +TEST(eval_define_function) { + ASSERT_EQ_INT(as_int(run("(define (f x) (+ x 1)) (f 41)")), 42); +} + +TEST(eval_let) { + ASSERT_EQ_INT(as_int(run("(let ((x 10) (y 20)) (+ x y))")), 30); +} + +TEST(eval_let_star) { + ASSERT_EQ_INT(as_int(run("(let* ((x 10) (y (* x 2))) (+ x y))")), 30); +} + +TEST(eval_named_let) { + char *s = run_show("(let loop ((n 5) (acc 1)) (if (= n 0) acc (loop (- n 1) (* acc n))))"); + ASSERT_EQ_STR(s, "120"); + ul_free(s); +} + +TEST(eval_letrec) { + ASSERT_EQ_INT(as_int(run( + "(letrec ((f (lambda (n) (if (= n 0) 1 (* n (f (- n 1))))))) (f 5))" + )), 120); +} + +TEST(eval_begin) { + ASSERT_EQ_INT(as_int(run("(begin 1 2 3)")), 3); +} + +TEST(eval_quote) { + char *s = run_show("'(1 2 3)"); + ASSERT_EQ_STR(s, "(1 2 3)"); + ul_free(s); +} + +TEST(eval_quasiquote) { + char *s = run_show("(let ((x 42)) `(a ,x b))"); + ASSERT_EQ_STR(s, "(a 42 b)"); + ul_free(s); +} + +TEST(eval_list_ops) { + ASSERT_EQ_INT(as_int(run("(car '(1 2 3))")), 1); + char *s = run_show("(cdr '(1 2 3))"); + ASSERT_EQ_STR(s, "(2 3)"); + ul_free(s); + ASSERT_EQ_INT(as_int(run("(length '(1 2 3))")), 3); +} + +TEST(eval_map) { + char *s = run_show("(map (lambda (x) (* x x)) '(1 2 3 4))"); + ASSERT_EQ_STR(s, "(1 4 9 16)"); + ul_free(s); +} + +TEST(eval_filter) { + char *s = run_show("(filter (lambda (x) (> x 2)) '(1 2 3 4 5))"); + ASSERT_EQ_STR(s, "(3 4 5)"); + ul_free(s); +} + +TEST(eval_string_ops) { + ASSERT_EQ_INT(as_int(run("(string-length \"hello\")")), 5); + char *s = run_show("(string-append \"hello\" \" \" \"world\")"); + ASSERT_EQ_STR(s, "\"hello world\""); + ul_free(s); +} + +TEST(eval_vector_ops) { + ASSERT_EQ_INT(as_int(run("(vector-ref #(10 20 30) 1)")), 20); + ASSERT_EQ_INT(as_int(run("(vector-length #(1 2 3))")), 3); +} + +TEST(eval_rational_arithmetic) { + char *s = run_show("(+ 1/3 1/6)"); + ASSERT_EQ_STR(s, "1/2"); + ul_free(s); + + s = run_show("(* 2/3 3/4)"); + ASSERT_EQ_STR(s, "1/2"); + ul_free(s); +} + +TEST(eval_do) { + char *s = run_show( + "(do ((i 0 (+ i 1)) (acc 0 (+ acc i)))" + " ((= i 5) acc))"); + ASSERT_EQ_STR(s, "10"); + ul_free(s); +} + +TEST(eval_set) { + ASSERT_EQ_INT(as_int(run("(define x 1) (set! x 42) x")), 42); +} + +TEST(eval_closures) { + ASSERT_EQ_INT(as_int(run( + "(define (make-adder n) (lambda (x) (+ n x)))" + "(define add5 (make-adder 5))" + "(add5 37)" + )), 42); +} + +TEST(eval_recursion) { + ASSERT_EQ_INT(as_int(run( + "(define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))" + "(fact 10)" + )), 3628800); +} + +TEST(eval_tail_call) { + /* This would stack-overflow without TCO */ + char *s = run_show( + "(define (loop n)" + " (if (= n 0) 'done (loop (- n 1))))" + "(loop 100000)"); + ASSERT_EQ_STR(s, "done"); + ul_free(s); +} + +TEST(eval_macro) { + ASSERT_EQ_INT(as_int(run( + "(define-macro (my-add a b) `(+ ,a ,b))" + "(my-add 20 22)" + )), 42); +} + +TEST(eval_case) { + ASSERT_EQ_INT(as_int(run( + "(case 2" + " ((1) 10)" + " ((2 3) 20)" + " (else 30))" + )), 20); +} + +TEST(eval_when_unless) { + ASSERT_EQ_INT(as_int(run("(when #t 42)")), 42); + ASSERT(IS_VOID(run("(when #f 42)")), "when false should be void"); + ASSERT_EQ_INT(as_int(run("(unless #f 42)")), 42); +} + +TEST(eval_hash_table) { + ASSERT_EQ_INT(as_int(run( + "(define ht (make-hash-table))" + "(hash-table-set! ht 'x 42)" + "(hash-table-ref ht 'x)" + )), 42); +} + +TEST(eval_guard) { + char *s = run_show( + "(guard (e (#t (error-object-message e)))" + " (error \"test error\"))"); + ASSERT_EQ_STR(s, "\"test error\""); + ul_free(s); +} + +TEST(eval_define_record_type) { + char *s = run_show( + "(define-record-type point (make-point x y) point? (x point-x) (y point-y))" + "(define p (make-point 3 4))" + "(list (point-x p) (point-y p))"); + ASSERT_EQ_STR(s, "(3 4)"); + ul_free(s); +} + +TEST(eval_module) { + char *s = run_show( + "(module math (export square)" + " (define (square x) (* x x)))" + "(import math)" + "(square 7)"); + ASSERT_EQ_STR(s, "49"); + ul_free(s); +} + +TEST(eval_string_port) { + char *s = run_show( + "(define p (open-input-string \"hello\"))" + "(define c (read-char p))" + "c"); + ASSERT_EQ_STR(s, "#\\h"); + ul_free(s); +} + +TEST(eval_fold) { + ASSERT_EQ_INT(as_int(run("(fold-left (lambda (x acc) (+ x acc)) 0 '(1 2 3 4 5))")), 15); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Integration tests — matching fibonacci.lsp output + * ═══════════════════════════════════════════════════════════════════════════ */ + +TEST(fibonacci_iterative) { + char *s = run_show( + "(define (fib-iter n)" + " (let loop ((a 0) (b 1) (i 0))" + " (if (= i n) a (loop b (+ a b) (+ i 1)))))" + "(fib-iter 30)"); + ASSERT_EQ_STR(s, "832040"); + ul_free(s); +} + +TEST(fibonacci_recursive) { + char *s = run_show( + "(define (fib-rec n)" + " (if (<= n 1) n (+ (fib-rec (- n 1)) (fib-rec (- n 2)))))" + "(fib-rec 20)"); + ASSERT_EQ_STR(s, "6765"); + ul_free(s); +} + +TEST(fibonacci_map) { + char *s = run_show( + "(define (fib-iter n)" + " (let loop ((a 0) (b 1) (i 0))" + " (if (= i n) a (loop b (+ a b) (+ i 1)))))" + "(map fib-iter (iota 15))"); + ASSERT_EQ_STR(s, "(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377)"); + ul_free(s); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * VM / bytecode tests + * ═══════════════════════════════════════════════════════════════════════════ */ + +TEST(vm_basic) { + /* Run with auto-compile enabled */ + Env *g = fresh_env(); + g_auto_compile = true; + int count; + Value *exprs = read_all("(define (add a b) (+ a b)) (add 20 22)", &count, false); + Value result = VAL_VOID; + for (int i = 0; i < count; i++) result = leval(exprs[i], g); + ASSERT_EQ_INT(as_int(result), 42); + g_auto_compile = false; + ul_free(exprs); +} + +TEST(vm_fibonacci) { + Env *g = fresh_env(); + g_auto_compile = true; + int count; + Value *exprs = read_all( + "(define (fib-iter n)" + " (let loop ((a 0) (b 1) (i 0))" + " (if (= i n) a (loop b (+ a b) (+ i 1)))))" + "(fib-iter 30)", &count, false); + Value result = VAL_VOID; + for (int i = 0; i < count; i++) result = leval(exprs[i], g); + ASSERT_EQ_INT(as_int(result), 832040); + g_auto_compile = false; + ul_free(exprs); +} + +TEST(vm_tail_call) { + Env *g = fresh_env(); + g_auto_compile = true; + int count; + Value *exprs = read_all( + "(define (loop n) (if (= n 0) 'done (loop (- n 1))))" + "(loop 100000)", &count, false); + Value result = VAL_VOID; + for (int i = 0; i < count; i++) result = leval(exprs[i], g); + char *s = show(result, false); + ASSERT_EQ_STR(s, "done"); + ul_free(s); + g_auto_compile = false; + ul_free(exprs); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Main + * ═══════════════════════════════════════════════════════════════════════════ */ + +int main(void) { + init_symbols(); + + printf("Running uncommonlisp C tests...\n\n"); + printf("[types]\n"); + run_test_nan_boxing_int(); + run_test_nan_boxing_double(); + run_test_nan_boxing_special(); + run_test_symbol_interning(); + run_test_pair_creation(); + run_test_string_creation(); + run_test_vector_creation(); + run_test_rational_creation(); + run_test_environment(); + + printf("\n[reader]\n"); + run_test_read_integer(); + run_test_read_float(); + run_test_read_string(); + run_test_read_boolean(); + run_test_read_list(); + run_test_read_vector(); + run_test_read_char(); + run_test_read_rational(); + + printf("\n[evaluator]\n"); + run_test_eval_arithmetic(); + run_test_eval_comparison(); + run_test_eval_if(); + run_test_eval_cond(); + run_test_eval_and_or(); + run_test_eval_define(); + run_test_eval_lambda(); + run_test_eval_define_function(); + run_test_eval_let(); + run_test_eval_let_star(); + run_test_eval_named_let(); + run_test_eval_letrec(); + run_test_eval_begin(); + run_test_eval_quote(); + run_test_eval_quasiquote(); + run_test_eval_list_ops(); + run_test_eval_map(); + run_test_eval_filter(); + run_test_eval_string_ops(); + run_test_eval_vector_ops(); + run_test_eval_rational_arithmetic(); + run_test_eval_do(); + run_test_eval_set(); + run_test_eval_closures(); + run_test_eval_recursion(); + run_test_eval_tail_call(); + run_test_eval_macro(); + run_test_eval_case(); + run_test_eval_when_unless(); + run_test_eval_hash_table(); + run_test_eval_guard(); + run_test_eval_define_record_type(); + run_test_eval_module(); + run_test_eval_string_port(); + run_test_eval_fold(); + + printf("\n[integration]\n"); + run_test_fibonacci_iterative(); + run_test_fibonacci_recursive(); + run_test_fibonacci_map(); + + printf("\n[vm/bytecode]\n"); + run_test_vm_basic(); + run_test_vm_fibonacci(); + run_test_vm_tail_call(); + + printf("\n═══════════════════════════════════════════\n"); + printf("Results: %d/%d passed", tests_passed, tests_run); + if (tests_failed > 0) printf(" (%d failed)", tests_failed); + printf("\n"); + + return tests_failed > 0 ? 1 : 0; +} diff --git a/c/types.c b/c/types.c new file mode 100644 index 0000000..4fb4a5d --- /dev/null +++ b/c/types.c @@ -0,0 +1,854 @@ +/* + * types.c — Value types, NaN-boxing, symbol interning, Env, Pair, etc. + */ +#include "uncommonlisp.h" + +/* ═══════════════════════════════════════════════════════════════════════════ + * Error context (thread-local) + * ═══════════════════════════════════════════════════════════════════════════ */ + +__thread ErrorContext *g_error_ctx = NULL; + +void lisp_error(const char *fmt, ...) { + if (!g_error_ctx) { + va_list ap; + va_start(ap, fmt); + vfprintf(stderr, fmt, ap); + va_end(ap); + fprintf(stderr, "\n"); + exit(1); + } + va_list ap; + va_start(ap, fmt); + vsnprintf(g_error_ctx->message, MAX_ERROR_MSG, fmt, ap); + va_end(ap); + g_error_ctx->error_obj = VAL_NIL; + longjmp(g_error_ctx->jmp, 1); +} + +void lisp_error_with_obj(Value obj, const char *fmt, ...) { + if (!g_error_ctx) { + va_list ap; + va_start(ap, fmt); + vfprintf(stderr, fmt, ap); + va_end(ap); + fprintf(stderr, "\n"); + exit(1); + } + va_list ap; + va_start(ap, fmt); + vsnprintf(g_error_ctx->message, MAX_ERROR_MSG, fmt, ap); + va_end(ap); + g_error_ctx->error_obj = obj; + longjmp(g_error_ctx->jmp, 1); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Value stack + * ═══════════════════════════════════════════════════════════════════════════ */ + +void vs_init(ValueStack *s, int cap) { + s->data = (Value *)ul_malloc(sizeof(Value) * cap); + s->len = 0; + s->cap = cap; +} + +void vs_push(ValueStack *s, Value v) { + if (s->len >= s->cap) { + s->cap = s->cap * 2; + s->data = (Value *)ul_realloc(s->data, sizeof(Value) * s->cap); + } + s->data[s->len++] = v; +} + +Value vs_pop(ValueStack *s) { + if (s->len <= 0) lisp_error("stack underflow"); + return s->data[--s->len]; +} + +Value vs_peek(ValueStack *s) { + if (s->len <= 0) lisp_error("stack underflow"); + return s->data[s->len - 1]; +} + +void vs_clear(ValueStack *s) { + s->len = 0; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Symbol interning + * ═══════════════════════════════════════════════════════════════════════════ */ + +SymbolTable g_symbols = {0}; + +static uint32_t sym_hash(const char *s) { + uint32_t h = 5381; + while (*s) { h = ((h << 5) + h) + (unsigned char)*s++; } + return h; +} + +Value intern(const char *name) { + uint32_t h = sym_hash(name) % SYMBOL_TABLE_SIZE; + SymbolEntry *e = g_symbols.buckets[h]; + while (e) { + if (strcmp(e->name, name) == 0) return e->value; + e = e->next; + } + /* New symbol */ + char *copy = ul_strdup(name); + SymbolEntry *ne = (SymbolEntry *)ul_malloc(sizeof(SymbolEntry)); + ne->name = copy; + ne->value = VAL_SYM_RAW(copy); + ne->next = g_symbols.buckets[h]; + g_symbols.buckets[h] = ne; + return ne->value; +} + +const char *sym_name(Value sym) { + return (const char *)(uintptr_t)GET_PAYLOAD(sym); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Pair + * ═══════════════════════════════════════════════════════════════════════════ */ + +Pair *make_pair(Value car, Value cdr) { + Pair *p = (Pair *)ul_malloc(sizeof(Pair)); + p->hdr.type = OBJ_PAIR; + p->car = car; + p->cdr = cdr; + p->line = 0; + return p; +} + +Value cons(Value car, Value cdr) { + return VAL_PTR(make_pair(car, cdr)); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * String + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value make_string(const char *s, size_t len, bool mutable) { + ULString *str = (ULString *)ul_malloc(sizeof(ULString)); + str->hdr.type = mutable ? OBJ_MUTABLE_STRING : OBJ_STRING; + str->data = (char *)ul_malloc(len + 1); + memcpy(str->data, s, len); + str->data[len] = '\0'; + str->len = len; + str->mutable = mutable; + return VAL_PTR(str); +} + +Value make_string_from_cstr(const char *s) { + return make_string(s, strlen(s), false); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Vector + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value make_vector(size_t len, Value fill) { + ULVector *v = (ULVector *)ul_malloc(sizeof(ULVector)); + v->hdr.type = OBJ_VECTOR; + v->len = len; + v->cap = len > 0 ? len : 4; + v->data = (Value *)ul_malloc(sizeof(Value) * v->cap); + for (size_t i = 0; i < len; i++) v->data[i] = fill; + return VAL_PTR(v); +} + +Value make_vector_from(Value *items, size_t len) { + ULVector *v = (ULVector *)ul_malloc(sizeof(ULVector)); + v->hdr.type = OBJ_VECTOR; + v->len = len; + v->cap = len > 0 ? len : 4; + v->data = (Value *)ul_malloc(sizeof(Value) * v->cap); + memcpy(v->data, items, sizeof(Value) * len); + return VAL_PTR(v); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Hash table + * ═══════════════════════════════════════════════════════════════════════════ */ + +static uint64_t value_hash(Value v); + +Value make_hashtable(void) { + ULHashTable *ht = (ULHashTable *)ul_malloc(sizeof(ULHashTable)); + ht->hdr.type = OBJ_HASHTABLE; + ht->nbuckets = 64; + ht->count = 0; + ht->buckets = (HTEntry **)ul_malloc(sizeof(HTEntry *) * ht->nbuckets); + memset(ht->buckets, 0, sizeof(HTEntry *) * ht->nbuckets); + return VAL_PTR(ht); +} + +static uint64_t value_hash(Value v) { + if (IS_INT(v)) return (uint64_t)as_int(v) * 2654435761ULL; + if (IS_SYM(v)) return sym_hash(sym_name(v)); + if (IS_STRING(v)) return sym_hash(AS_STRING(v)->data); + if (IS_DOUBLE(v)) { + double d = as_double(v); + uint64_t bits; + memcpy(&bits, &d, sizeof(bits)); + return bits * 2654435761ULL; + } + if (IS_SPECIAL(v)) return GET_PAYLOAD(v) * 2654435761ULL; + /* For other types, use the raw bits */ + return v * 2654435761ULL; +} + +void ht_set(ULHashTable *ht, Value key, Value val) { + uint64_t h = value_hash(key) % ht->nbuckets; + HTEntry *e = ht->buckets[h]; + while (e) { + if (values_equal(e->key, key)) { e->value = val; return; } + e = e->next; + } + HTEntry *ne = (HTEntry *)ul_malloc(sizeof(HTEntry)); + ne->key = key; + ne->value = val; + ne->next = ht->buckets[h]; + ht->buckets[h] = ne; + ht->count++; + /* Resize if load factor > 2 */ + if (ht->count > ht->nbuckets * 2) { + size_t new_nbuckets = ht->nbuckets * 4; + HTEntry **new_buckets = (HTEntry **)ul_malloc(sizeof(HTEntry *) * new_nbuckets); + memset(new_buckets, 0, sizeof(HTEntry *) * new_nbuckets); + for (size_t i = 0; i < ht->nbuckets; i++) { + HTEntry *cur = ht->buckets[i]; + while (cur) { + HTEntry *next = cur->next; + uint64_t nh = value_hash(cur->key) % new_nbuckets; + cur->next = new_buckets[nh]; + new_buckets[nh] = cur; + cur = next; + } + } + ul_free(ht->buckets); + ht->buckets = new_buckets; + ht->nbuckets = new_nbuckets; + } +} + +Value ht_ref(ULHashTable *ht, Value key, bool *found) { + uint64_t h = value_hash(key) % ht->nbuckets; + HTEntry *e = ht->buckets[h]; + while (e) { + if (values_equal(e->key, key)) { *found = true; return e->value; } + e = e->next; + } + *found = false; + return VAL_NIL; +} + +bool ht_delete(ULHashTable *ht, Value key) { + uint64_t h = value_hash(key) % ht->nbuckets; + HTEntry **pp = &ht->buckets[h]; + while (*pp) { + if (values_equal((*pp)->key, key)) { + HTEntry *del = *pp; + *pp = del->next; + ul_free(del); + ht->count--; + return true; + } + pp = &(*pp)->next; + } + return false; +} + +size_t ht_count(ULHashTable *ht) { + return ht->count; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Rational numbers (simple fraction type) + * ═══════════════════════════════════════════════════════════════════════════ */ + +static int64_t gcd64(int64_t a, int64_t b) { + if (a < 0) a = -a; + if (b < 0) b = -b; + while (b) { int64_t t = b; b = a % b; a = t; } + return a; +} + +Value make_rational(int64_t num, int64_t den) { + Rational *r = (Rational *)ul_malloc(sizeof(Rational)); + r->hdr.type = OBJ_RATIONAL; + r->num = num; + r->den = den; + return NANBOX(TAG_RATIONAL, (uintptr_t)r); +} + +Value rational_normalize(int64_t num, int64_t den) { + if (den == 0) lisp_error("division by zero"); + if (den < 0) { num = -num; den = -den; } + if (num == 0) return VAL_INT(0); + int64_t g = gcd64(num, den); + num /= g; den /= g; + if (den == 1) return VAL_INT(num); + return make_rational(num, den); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Number operations + * ═══════════════════════════════════════════════════════════════════════════ */ + +double as_number_double(Value v) { + if (IS_INT(v)) return (double)as_int(v); + if (IS_DOUBLE(v)) return as_double(v); + if (IS_RATIONAL(v)) { + Rational *r = AS_RATIONAL(v); + return (double)r->num / (double)r->den; + } + lisp_error("not a number"); + return 0; +} + +int64_t as_number_int(Value v) { + if (IS_INT(v)) return as_int(v); + if (IS_DOUBLE(v)) return (int64_t)as_double(v); + if (IS_RATIONAL(v)) { + Rational *r = AS_RATIONAL(v); + return r->num / r->den; + } + lisp_error("not a number"); + return 0; +} + +/* Exact arithmetic helpers */ +static void to_rational(Value v, int64_t *num, int64_t *den) { + if (IS_INT(v)) { *num = as_int(v); *den = 1; } + else if (IS_RATIONAL(v)) { Rational *r = AS_RATIONAL(v); *num = r->num; *den = r->den; } + else { *num = 0; *den = 1; } /* shouldn't happen */ +} + +static bool is_exact(Value v) { + return IS_INT(v) || IS_RATIONAL(v); +} + +Value num_add(Value a, Value b) { + if (is_exact(a) && is_exact(b)) { + int64_t an, ad, bn, bd; + to_rational(a, &an, &ad); + to_rational(b, &bn, &bd); + return rational_normalize(an * bd + bn * ad, ad * bd); + } + return make_double(as_number_double(a) + as_number_double(b)); +} + +Value num_sub(Value a, Value b) { + if (is_exact(a) && is_exact(b)) { + int64_t an, ad, bn, bd; + to_rational(a, &an, &ad); + to_rational(b, &bn, &bd); + return rational_normalize(an * bd - bn * ad, ad * bd); + } + return make_double(as_number_double(a) - as_number_double(b)); +} + +Value num_mul(Value a, Value b) { + if (is_exact(a) && is_exact(b)) { + int64_t an, ad, bn, bd; + to_rational(a, &an, &ad); + to_rational(b, &bn, &bd); + return rational_normalize(an * bn, ad * bd); + } + return make_double(as_number_double(a) * as_number_double(b)); +} + +Value num_div(Value a, Value b) { + if (is_exact(a) && is_exact(b)) { + int64_t an, ad, bn, bd; + to_rational(a, &an, &ad); + to_rational(b, &bn, &bd); + if (bn == 0) lisp_error("division by zero"); + return rational_normalize(an * bd, ad * bn); + } + double db = as_number_double(b); + if (db == 0.0) lisp_error("division by zero"); + return make_double(as_number_double(a) / db); +} + +Value num_neg(Value a) { + if (IS_INT(a)) return VAL_INT(-as_int(a)); + if (IS_RATIONAL(a)) { + Rational *r = AS_RATIONAL(a); + return make_rational(-r->num, r->den); + } + return make_double(-as_double(a)); +} + +static int num_cmp(Value a, Value b) { + if (is_exact(a) && is_exact(b)) { + int64_t an, ad, bn, bd; + to_rational(a, &an, &ad); + to_rational(b, &bn, &bd); + int64_t lhs = an * bd; + int64_t rhs = bn * ad; + if (lhs < rhs) return -1; + if (lhs > rhs) return 1; + return 0; + } + double da = as_number_double(a), db = as_number_double(b); + if (da < db) return -1; + if (da > db) return 1; + return 0; +} + +bool num_eq(Value a, Value b) { return num_cmp(a, b) == 0; } +bool num_lt(Value a, Value b) { return num_cmp(a, b) < 0; } +bool num_gt(Value a, Value b) { return num_cmp(a, b) > 0; } +bool num_le(Value a, Value b) { return num_cmp(a, b) <= 0; } +bool num_ge(Value a, Value b) { return num_cmp(a, b) >= 0; } + +/* ═══════════════════════════════════════════════════════════════════════════ + * Environment + * ═══════════════════════════════════════════════════════════════════════════ */ + +#define ENV_INIT_BUCKETS 16 + +Env *make_env(Env *parent) { + Env *e = (Env *)ul_malloc(sizeof(Env)); + e->hdr.type = OBJ_ENV; + e->nbuckets = ENV_INIT_BUCKETS; + e->count = 0; + e->buckets = (EnvBinding **)ul_malloc(sizeof(EnvBinding *) * e->nbuckets); + memset(e->buckets, 0, sizeof(EnvBinding *) * e->nbuckets); + e->parent = parent; + e->global = parent ? parent->global : NULL; + return e; +} + +static uint32_t env_hash_sym(Value sym, size_t nbuckets) { + /* Symbol payload is a char* pointer — hash the pointer value for speed */ + return (uint32_t)((GET_PAYLOAD(sym) * 2654435761ULL) % nbuckets); +} + +void env_define(Env *e, Value sym, Value val) { + uint32_t h = env_hash_sym(sym, e->nbuckets); + /* Check if already defined */ + EnvBinding *b = e->buckets[h]; + while (b) { + if (b->sym == sym) { b->val = val; return; } + b = b->next; + } + /* New binding */ + EnvBinding *nb = (EnvBinding *)ul_malloc(sizeof(EnvBinding)); + nb->sym = sym; + nb->val = val; + nb->next = e->buckets[h]; + e->buckets[h] = nb; + e->count++; + /* Resize if needed */ + if (e->count > e->nbuckets * 2) { + size_t new_nb = e->nbuckets * 4; + EnvBinding **new_bk = (EnvBinding **)ul_malloc(sizeof(EnvBinding *) * new_nb); + memset(new_bk, 0, sizeof(EnvBinding *) * new_nb); + for (size_t i = 0; i < e->nbuckets; i++) { + EnvBinding *cur = e->buckets[i]; + while (cur) { + EnvBinding *next = cur->next; + uint32_t nh = env_hash_sym(cur->sym, new_nb); + cur->next = new_bk[nh]; + new_bk[nh] = cur; + cur = next; + } + } + ul_free(e->buckets); + e->buckets = new_bk; + e->nbuckets = new_nb; + } +} + +static EnvBinding *env_find_local(Env *e, Value sym) { + uint32_t h = env_hash_sym(sym, e->nbuckets); + EnvBinding *b = e->buckets[h]; + while (b) { + if (b->sym == sym) return b; + b = b->next; + } + return NULL; +} + +Value env_lookup(Env *e, Value sym) { + /* Check local first */ + EnvBinding *b = env_find_local(e, sym); + if (b) return b->val; + /* Check global shortcut */ + if (e->global && e->global != e) { + b = env_find_local(e->global, sym); + if (b) return b->val; + } + /* Walk parent chain */ + Env *cur = e->parent; + while (cur) { + b = env_find_local(cur, sym); + if (b) return b->val; + cur = cur->parent; + } + lisp_error("undefined: %s", sym_name(sym)); + return VAL_NIL; /* unreachable */ +} + +bool env_set(Env *e, Value sym, Value val) { + Env *cur = e; + while (cur) { + EnvBinding *b = env_find_local(cur, sym); + if (b) { b->val = val; return true; } + cur = cur->parent; + } + lisp_error("set! undefined: %s", sym_name(sym)); + return false; +} + +Env *env_child(Env *parent, Value *params, int nparams, Value rest_param, + Value *args, int nargs) { + if (nargs < nparams) { + lisp_error("arity: need %d, got %d", nparams, nargs); + } + if (IS_NIL(rest_param) && nargs > nparams) { + lisp_error("arity: need %d, got %d", nparams, nargs); + } + Env *c = make_env(parent); + for (int i = 0; i < nparams; i++) { + env_define(c, params[i], args[i]); + } + if (!IS_NIL(rest_param)) { + /* Build rest list */ + Value rest = VAL_NIL; + for (int i = nargs - 1; i >= nparams; i--) { + rest = cons(args[i], rest); + } + env_define(c, rest_param, rest); + } + return c; +} + +/* Deep copy env chain (for multi-shot continuations) */ +Env *deep_copy_env(Env *env) { + if (!env) return NULL; + if (env->global == env) return env; /* don't copy global */ + Env *ne = (Env *)ul_malloc(sizeof(Env)); + ne->hdr.type = OBJ_ENV; + ne->nbuckets = env->nbuckets; + ne->count = env->count; + ne->buckets = (EnvBinding **)ul_malloc(sizeof(EnvBinding *) * ne->nbuckets); + memset(ne->buckets, 0, sizeof(EnvBinding *) * ne->nbuckets); + for (size_t i = 0; i < env->nbuckets; i++) { + EnvBinding *src = env->buckets[i]; + EnvBinding **dst = &ne->buckets[i]; + while (src) { + EnvBinding *nb = (EnvBinding *)ul_malloc(sizeof(EnvBinding)); + nb->sym = src->sym; + nb->val = src->val; + nb->next = NULL; + *dst = nb; + dst = &nb->next; + src = src->next; + } + } + ne->global = env->global; + ne->parent = deep_copy_env(env->parent); + return ne; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Procedure + * ═══════════════════════════════════════════════════════════════════════════ */ + +Proc *make_proc(Value *params, int nparams, Value rest, + ExprList body, Env *env, const char *name) { + Proc *p = (Proc *)ul_malloc(sizeof(Proc)); + p->hdr.type = OBJ_PROC; + p->params = (Value *)ul_malloc(sizeof(Value) * nparams); + memcpy(p->params, params, sizeof(Value) * nparams); + p->nparams = nparams; + p->rest = rest; + p->body.exprs = (Value *)ul_malloc(sizeof(Value) * body.count); + memcpy(p->body.exprs, body.exprs, sizeof(Value) * body.count); + p->body.count = body.count; + p->env = env; + p->name = name ? ul_strdup(name) : NULL; + p->has_defs = has_internal_defines(body); + return p; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Macro + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value make_macro(Value transformer) { + ULMacro *m = (ULMacro *)ul_malloc(sizeof(ULMacro)); + m->hdr.type = OBJ_MACRO; + m->transformer = transformer; + return VAL_PTR(m); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Error object + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value make_error_object(const char *msg, Value *irritants, int nirr) { + ErrorObject *e = (ErrorObject *)ul_malloc(sizeof(ErrorObject)); + e->hdr.type = OBJ_ERROR; + e->message = ul_strdup(msg); + e->nirritants = nirr; + if (nirr > 0) { + e->irritants = (Value *)ul_malloc(sizeof(Value) * nirr); + memcpy(e->irritants, irritants, sizeof(Value) * nirr); + } else { + e->irritants = NULL; + } + return VAL_PTR(e); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Port + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value make_file_port(FILE *fp, PortDir dir) { + ULPort *p = (ULPort *)ul_malloc(sizeof(ULPort)); + p->hdr.type = OBJ_PORT; + p->dir = dir; + p->kind = PORT_FILE; + p->fp = fp; + p->str_buf = NULL; + p->str_len = 0; + p->str_pos = 0; + p->str_cap = 0; + p->closed = false; + return VAL_PTR(p); +} + +Value make_string_input_port(const char *s, size_t len) { + ULPort *p = (ULPort *)ul_malloc(sizeof(ULPort)); + p->hdr.type = OBJ_PORT; + p->dir = PORT_INPUT; + p->kind = PORT_STRING; + p->fp = NULL; + p->str_buf = (char *)ul_malloc(len + 1); + memcpy(p->str_buf, s, len); + p->str_buf[len] = '\0'; + p->str_len = len; + p->str_pos = 0; + p->str_cap = len + 1; + p->closed = false; + return VAL_PTR(p); +} + +Value make_string_output_port(void) { + ULPort *p = (ULPort *)ul_malloc(sizeof(ULPort)); + p->hdr.type = OBJ_PORT; + p->dir = PORT_OUTPUT; + p->kind = PORT_STRING; + p->fp = NULL; + p->str_cap = 256; + p->str_buf = (char *)ul_malloc(p->str_cap); + p->str_buf[0] = '\0'; + p->str_len = 0; + p->str_pos = 0; + p->closed = false; + return VAL_PTR(p); +} + +void port_write_char(ULPort *p, int ch) { + if (p->kind == PORT_FILE) { + fputc(ch, p->fp); + } else { + if (p->str_len + 1 >= p->str_cap) { + p->str_cap *= 2; + p->str_buf = (char *)ul_realloc(p->str_buf, p->str_cap); + } + p->str_buf[p->str_len++] = (char)ch; + p->str_buf[p->str_len] = '\0'; + } +} + +void port_write_str(ULPort *p, const char *s, size_t len) { + if (p->kind == PORT_FILE) { + fwrite(s, 1, len, p->fp); + } else { + while (p->str_len + len + 1 > p->str_cap) { + p->str_cap *= 2; + p->str_buf = (char *)ul_realloc(p->str_buf, p->str_cap); + } + memcpy(p->str_buf + p->str_len, s, len); + p->str_len += len; + p->str_buf[p->str_len] = '\0'; + } +} + +int port_read_char(ULPort *p) { + if (p->kind == PORT_FILE) { + return fgetc(p->fp); + } else { + if (p->str_pos >= p->str_len) return EOF; + return (unsigned char)p->str_buf[p->str_pos++]; + } +} + +int port_peek_char(ULPort *p) { + if (p->kind == PORT_FILE) { + int c = fgetc(p->fp); + if (c != EOF) ungetc(c, p->fp); + return c; + } else { + if (p->str_pos >= p->str_len) return EOF; + return (unsigned char)p->str_buf[p->str_pos]; + } +} + +char *port_read_line(ULPort *p) { + if (p->kind == PORT_FILE) { + char buf[4096]; + if (!fgets(buf, sizeof(buf), p->fp)) return NULL; + size_t len = strlen(buf); + if (len > 0 && buf[len-1] == '\n') buf[--len] = '\0'; + return ul_strdup(buf); + } else { + if (p->str_pos >= p->str_len) return NULL; + size_t start = p->str_pos; + while (p->str_pos < p->str_len && p->str_buf[p->str_pos] != '\n') + p->str_pos++; + size_t len = p->str_pos - start; + if (p->str_pos < p->str_len) p->str_pos++; /* skip \n */ + char *result = (char *)ul_malloc(len + 1); + memcpy(result, p->str_buf + start, len); + result[len] = '\0'; + return result; + } +} + +char *port_get_output_string(ULPort *p) { + if (p->kind != PORT_STRING || p->dir != PORT_OUTPUT) return ul_strdup(""); + char *result = (char *)ul_malloc(p->str_len + 1); + memcpy(result, p->str_buf, p->str_len); + result[p->str_len] = '\0'; + return result; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Record type registry + * ═══════════════════════════════════════════════════════════════════════════ */ + +RecordType *g_record_types = NULL; + +RecordType *find_record_type(const char *name) { + RecordType *rt = g_record_types; + while (rt) { + if (strcmp(rt->name, name) == 0) return rt; + rt = rt->next; + } + return NULL; +} + +void register_record_type(const char *name, char **fields, int nfields, const char *parent) { + RecordType *rt = (RecordType *)ul_malloc(sizeof(RecordType)); + rt->name = ul_strdup(name); + rt->fields = (char **)ul_malloc(sizeof(char *) * nfields); + for (int i = 0; i < nfields; i++) rt->fields[i] = ul_strdup(fields[i]); + rt->nfields = nfields; + rt->parent = parent ? ul_strdup(parent) : NULL; + rt->next = g_record_types; + g_record_types = rt; +} + +bool is_subtype(const char *child, const char *ancestor) { + if (strcmp(child, ancestor) == 0) return true; + RecordType *rt = find_record_type(child); + while (rt && rt->parent) { + if (strcmp(rt->parent, ancestor) == 0) return true; + rt = find_record_type(rt->parent); + } + return false; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Module registry + * ═══════════════════════════════════════════════════════════════════════════ */ + +Module *g_modules = NULL; + +/* ═══════════════════════════════════════════════════════════════════════════ + * Common interned symbols + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value SYM_QUOTE, SYM_IF, SYM_COND, SYM_AND, SYM_OR; +Value SYM_WHEN, SYM_UNLESS, SYM_BEGIN, SYM_DEFINE, SYM_SET; +Value SYM_LAMBDA, SYM_LAMBDA_UC, SYM_LET, SYM_LET_STAR, SYM_LETREC; +Value SYM_LETREC_STAR, SYM_DO, SYM_QUASIQUOTE, SYM_UNQUOTE; +Value SYM_UNQUOTE_SPLICING, SYM_DEFINE_MACRO, SYM_DEFMACRO; +Value SYM_DEFINE_SYNTAX, SYM_LET_SYNTAX, SYM_LETREC_SYNTAX; +Value SYM_SYNTAX_RULES, SYM_VALUES, SYM_CALL_WITH_VALUES; +Value SYM_CALL_CC, SYM_CALL_CC2, SYM_APPLY, SYM_EVAL; +Value SYM_ERROR, SYM_DEFINE_RECORD_TYPE, SYM_MODULE, SYM_IMPORT; +Value SYM_LOAD, SYM_INCLUDE, SYM_PARAMETERIZE, SYM_DYNAMIC_WIND; +Value SYM_WITH_EXCEPTION_HANDLER, SYM_GUARD, SYM_DEFINE_VALUES; +Value SYM_LET_VALUES, SYM_LET_STAR_VALUES, SYM_CASE; +Value SYM_ELSE, SYM_ARROW, SYM_DOT, SYM_ELLIPSIS, SYM_UNDERSCORE; +Value SYM_EXPORT; + +void init_symbols(void) { + SYM_QUOTE = intern("quote"); + SYM_IF = intern("if"); + SYM_COND = intern("cond"); + SYM_AND = intern("and"); + SYM_OR = intern("or"); + SYM_WHEN = intern("when"); + SYM_UNLESS = intern("unless"); + SYM_BEGIN = intern("begin"); + SYM_DEFINE = intern("define"); + SYM_SET = intern("set!"); + SYM_LAMBDA = intern("lambda"); + SYM_LAMBDA_UC = intern("λ"); + SYM_LET = intern("let"); + SYM_LET_STAR = intern("let*"); + SYM_LETREC = intern("letrec"); + SYM_LETREC_STAR = intern("letrec*"); + SYM_DO = intern("do"); + SYM_QUASIQUOTE = intern("quasiquote"); + SYM_UNQUOTE = intern("unquote"); + SYM_UNQUOTE_SPLICING = intern("unquote-splicing"); + SYM_DEFINE_MACRO = intern("define-macro"); + SYM_DEFMACRO = intern("defmacro"); + SYM_DEFINE_SYNTAX = intern("define-syntax"); + SYM_LET_SYNTAX = intern("let-syntax"); + SYM_LETREC_SYNTAX = intern("letrec-syntax"); + SYM_SYNTAX_RULES = intern("syntax-rules"); + SYM_VALUES = intern("values"); + SYM_CALL_WITH_VALUES = intern("call-with-values"); + SYM_CALL_CC = intern("call/cc"); + SYM_CALL_CC2 = intern("call-with-current-continuation"); + SYM_APPLY = intern("apply"); + SYM_EVAL = intern("eval"); + SYM_ERROR = intern("error"); + SYM_DEFINE_RECORD_TYPE = intern("define-record-type"); + SYM_MODULE = intern("module"); + SYM_IMPORT = intern("import"); + SYM_LOAD = intern("load"); + SYM_INCLUDE = intern("include"); + SYM_PARAMETERIZE = intern("parameterize"); + SYM_DYNAMIC_WIND = intern("dynamic-wind"); + SYM_WITH_EXCEPTION_HANDLER = intern("with-exception-handler"); + SYM_GUARD = intern("guard"); + SYM_DEFINE_VALUES = intern("define-values"); + SYM_LET_VALUES = intern("let-values"); + SYM_LET_STAR_VALUES = intern("let*-values"); + SYM_CASE = intern("case"); + SYM_ELSE = intern("else"); + SYM_ARROW = intern("=>"); + SYM_DOT = intern("."); + SYM_ELLIPSIS = intern("..."); + SYM_UNDERSCORE = intern("_"); + SYM_EXPORT = intern("export"); +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Global state + * ═══════════════════════════════════════════════════════════════════════════ */ + +bool g_auto_compile = false; diff --git a/c/uncommonlisp.h b/c/uncommonlisp.h new file mode 100644 index 0000000..133d6c4 --- /dev/null +++ b/c/uncommonlisp.h @@ -0,0 +1,735 @@ +/* + * uncommonlisp.h — A Scheme interpreter in C (NaN-boxed values, Boehm-style GC) + * + * Complete port of uncommonlisp.py. + * Part of the permacomputer platform — code outlasts authors. + */ +#ifndef UNCOMMONLISP_H +#define UNCOMMONLISP_H + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* ═══════════════════════════════════════════════════════════════════════════ + * Memory allocation — simple arena/malloc wrapper + * When libgc is available, compile with -DUSE_BOEHM_GC and link -lgc + * ═══════════════════════════════════════════════════════════════════════════ */ + +#ifdef USE_BOEHM_GC +#include +#define ul_malloc(sz) GC_MALLOC(sz) +#define ul_realloc(p,sz) GC_REALLOC(p,sz) +#define ul_free(p) ((void)0) +#define ul_strdup(s) GC_STRDUP(s) +#else +/* Fallback: plain malloc (no collection — acceptable for batch scripts) */ +#define ul_malloc(sz) malloc(sz) +#define ul_realloc(p,sz) realloc(p,sz) +#define ul_free(p) free(p) +static inline char *ul_strdup(const char *s) { + size_t n = strlen(s) + 1; + char *d = (char *)ul_malloc(n); + if (d) memcpy(d, s, n); + return d; +} +#endif + +/* ═══════════════════════════════════════════════════════════════════════════ + * NaN-boxed Value type + * + * IEEE 754 double: if exponent bits are all 1 and mantissa != 0, it's NaN. + * We use quiet NaN with tag bits in the upper mantissa. + * + * Layout (64 bits): + * [sign:1][exponent:11][quiet:1][tag:3][payload:48] + * + * Tag 0 = pointer (Pair, String, Vector, etc — distinguished by pointed-to type tag) + * Tag 1 = integer (48-bit signed) + * Tag 2 = symbol (pointer to interned string) + * Tag 3 = special (NIL, VOID, TRUE, FALSE, EOF, char in payload) + * Tag 4 = builtin function pointer + * Tag 5 = rational (pointer to Rational struct) + * + * Plain doubles (no NaN payload) are floating-point numbers. + * ═══════════════════════════════════════════════════════════════════════════ */ + +typedef uint64_t Value; + +/* NaN box constants */ +#define QNAN ((uint64_t)0x7FF8000000000000ULL) +#define TAG_MASK ((uint64_t)0x0007000000000000ULL) +#define TAG_SHIFT 48 +#define PAYLOAD_MASK ((uint64_t)0x0000FFFFFFFFFFFFULL) +#define SIGN_BIT ((uint64_t)0x8000000000000000ULL) + +#define TAG_PTR 0ULL +#define TAG_INT 1ULL +#define TAG_SYM 2ULL +#define TAG_SPECIAL 3ULL +#define TAG_BUILTIN 4ULL +#define TAG_RATIONAL 5ULL + +/* Construct a NaN-boxed value */ +#define NANBOX(tag, payload) (QNAN | ((uint64_t)(tag) << TAG_SHIFT) | ((uint64_t)(payload) & PAYLOAD_MASK)) + +/* Extract tag and payload */ +#define IS_DOUBLE(v) (((v) & QNAN) != QNAN) +#define GET_TAG(v) (((v) >> TAG_SHIFT) & 7ULL) +#define GET_PAYLOAD(v) ((v) & PAYLOAD_MASK) +#define GET_PTR(v) ((void *)(uintptr_t)GET_PAYLOAD(v)) + +/* Value constructors */ +static inline Value make_double(double d) { + Value v; + memcpy(&v, &d, sizeof(v)); + return v; +} +static inline double as_double(Value v) { + double d; + memcpy(&d, &v, sizeof(d)); + return d; +} + +/* Integer: 48-bit signed */ +#define VAL_INT(n) NANBOX(TAG_INT, (uint64_t)(int64_t)(n) & PAYLOAD_MASK) +static inline int64_t as_int(Value v) { + int64_t raw = (int64_t)(GET_PAYLOAD(v)); + /* Sign-extend from 48 bits */ + if (raw & (1ULL << 47)) raw |= ~PAYLOAD_MASK; + return raw; +} + +/* Special values */ +#define SPECIAL_NIL 0ULL +#define SPECIAL_VOID 1ULL +#define SPECIAL_TRUE 2ULL +#define SPECIAL_FALSE 3ULL +#define SPECIAL_EOF 4ULL +#define SPECIAL_CHAR_BASE 256ULL /* char = CHAR_BASE + codepoint */ + +#define VAL_NIL NANBOX(TAG_SPECIAL, SPECIAL_NIL) +#define VAL_VOID NANBOX(TAG_SPECIAL, SPECIAL_VOID) +#define VAL_TRUE NANBOX(TAG_SPECIAL, SPECIAL_TRUE) +#define VAL_FALSE NANBOX(TAG_SPECIAL, SPECIAL_FALSE) +#define VAL_EOF NANBOX(TAG_SPECIAL, SPECIAL_EOF) + +#define VAL_CHAR(c) NANBOX(TAG_SPECIAL, SPECIAL_CHAR_BASE + (uint32_t)(c)) + +#define VAL_BOOL(b) ((b) ? VAL_TRUE : VAL_FALSE) + +/* Type checks */ +#define IS_INT(v) (!IS_DOUBLE(v) && GET_TAG(v) == TAG_INT) +#define IS_SYM(v) (!IS_DOUBLE(v) && GET_TAG(v) == TAG_SYM) +#define IS_PTR(v) (!IS_DOUBLE(v) && GET_TAG(v) == TAG_PTR) +#define IS_SPECIAL(v) (!IS_DOUBLE(v) && GET_TAG(v) == TAG_SPECIAL) +#define IS_BUILTIN(v) (!IS_DOUBLE(v) && GET_TAG(v) == TAG_BUILTIN) +#define IS_RATIONAL(v) (!IS_DOUBLE(v) && GET_TAG(v) == TAG_RATIONAL) + +#define IS_NIL(v) ((v) == VAL_NIL) +#define IS_VOID(v) ((v) == VAL_VOID) +#define IS_TRUE(v) ((v) == VAL_TRUE) +#define IS_FALSE(v) ((v) == VAL_FALSE) +#define IS_EOF(v) ((v) == VAL_EOF) +#define IS_CHAR(v) (IS_SPECIAL(v) && GET_PAYLOAD(v) >= SPECIAL_CHAR_BASE) + +#define AS_CHAR(v) ((int)(GET_PAYLOAD(v) - SPECIAL_CHAR_BASE)) + +/* Truthiness: everything is truthy except #f */ +#define IS_TRUTHY(v) (!IS_FALSE(v)) + +/* ═══════════════════════════════════════════════════════════════════════════ + * Heap object types — all heap objects have a type tag as first field + * ═══════════════════════════════════════════════════════════════════════════ */ + +typedef enum { + OBJ_PAIR, + OBJ_STRING, + OBJ_MUTABLE_STRING, + OBJ_VECTOR, + OBJ_HASHTABLE, + OBJ_ENV, + OBJ_PROC, + OBJ_COMPILED_PROC, + OBJ_MACRO, + OBJ_CODE, + OBJ_CONTINUATION, + OBJ_PORT, + OBJ_ERROR, + OBJ_SYNTAX_TRANSFORMER, + OBJ_RATIONAL, +} ObjType; + +typedef struct ObjHeader { + ObjType type; +} ObjHeader; + +/* Get the heap object type */ +static inline ObjType obj_type(Value v) { + return ((ObjHeader *)GET_PTR(v))->type; +} + +/* Wrap a pointer as a Value */ +#define VAL_PTR(p) NANBOX(TAG_PTR, (uintptr_t)(p)) + +/* ── Pair ────────────────────────────────────────────────────────────────── */ + +typedef struct Pair { + ObjHeader hdr; + Value car; + Value cdr; + int line; /* source line for error reporting, 0 = unknown */ +} Pair; + +#define IS_PAIR(v) (IS_PTR(v) && obj_type(v) == OBJ_PAIR) +#define AS_PAIR(v) ((Pair *)GET_PTR(v)) + +Pair *make_pair(Value car, Value cdr); +Value cons(Value car, Value cdr); + +/* ── Symbol interning ────────────────────────────────────────────────────── */ + +typedef struct SymbolEntry { + char *name; + Value value; /* the NaN-boxed symbol value */ + struct SymbolEntry *next; +} SymbolEntry; + +#define SYMBOL_TABLE_SIZE 4096 + +typedef struct { + SymbolEntry *buckets[SYMBOL_TABLE_SIZE]; +} SymbolTable; + +extern SymbolTable g_symbols; + +Value intern(const char *name); +const char *sym_name(Value sym); + +#define VAL_SYM_RAW(p) NANBOX(TAG_SYM, (uintptr_t)(p)) + +/* ── String ──────────────────────────────────────────────────────────────── */ + +typedef struct ULString { + ObjHeader hdr; + char *data; + size_t len; + bool mutable; +} ULString; + +#define IS_STRING(v) (IS_PTR(v) && (obj_type(v) == OBJ_STRING || obj_type(v) == OBJ_MUTABLE_STRING)) +#define AS_STRING(v) ((ULString *)GET_PTR(v)) + +Value make_string(const char *s, size_t len, bool mutable); +Value make_string_from_cstr(const char *s); /* immutable */ + +/* ── Vector ──────────────────────────────────────────────────────────────── */ + +typedef struct ULVector { + ObjHeader hdr; + Value *data; + size_t len; + size_t cap; +} ULVector; + +#define IS_VECTOR(v) (IS_PTR(v) && obj_type(v) == OBJ_VECTOR) +#define AS_VECTOR(v) ((ULVector *)GET_PTR(v)) + +Value make_vector(size_t len, Value fill); +Value make_vector_from(Value *items, size_t len); + +/* ── Hash Table ──────────────────────────────────────────────────────────── */ + +typedef struct HTEntry { + Value key; + Value value; + struct HTEntry *next; +} HTEntry; + +typedef struct ULHashTable { + ObjHeader hdr; + HTEntry **buckets; + size_t nbuckets; + size_t count; +} ULHashTable; + +#define IS_HASHTABLE(v) (IS_PTR(v) && obj_type(v) == OBJ_HASHTABLE) +#define AS_HASHTABLE(v) ((ULHashTable *)GET_PTR(v)) + +Value make_hashtable(void); +void ht_set(ULHashTable *ht, Value key, Value val); +Value ht_ref(ULHashTable *ht, Value key, bool *found); +bool ht_delete(ULHashTable *ht, Value key); +size_t ht_count(ULHashTable *ht); + +/* ── Rational ────────────────────────────────────────────────────────────── */ + +typedef struct Rational { + ObjHeader hdr; + int64_t num; + int64_t den; +} Rational; + +#define AS_RATIONAL(v) ((Rational *)(uintptr_t)GET_PAYLOAD(v)) + +Value make_rational(int64_t num, int64_t den); +/* Returns integer Value if den==1, otherwise rational */ +Value rational_normalize(int64_t num, int64_t den); + +/* ── Environment ─────────────────────────────────────────────────────────── */ + +typedef struct EnvBinding { + Value sym; + Value val; + struct EnvBinding *next; +} EnvBinding; + +typedef struct Env { + ObjHeader hdr; + EnvBinding **buckets; + size_t nbuckets; + size_t count; + struct Env *parent; + struct Env *global; /* shortcut to global env */ +} Env; + +#define IS_ENV(v) (IS_PTR(v) && obj_type(v) == OBJ_ENV) +#define AS_ENV(v) ((Env *)GET_PTR(v)) + +Env *make_env(Env *parent); +void env_define(Env *e, Value sym, Value val); +Value env_lookup(Env *e, Value sym); +bool env_set(Env *e, Value sym, Value val); +Env *env_child(Env *parent, Value *params, int nparams, Value rest_param, Value *args, int nargs); + +/* ── Procedure ───────────────────────────────────────────────────────────── */ + +/* Parsed formals */ +typedef struct { + Value *params; + int nparams; + Value rest; /* VAL_NIL if no rest param */ +} Formals; + +/* Expression list (body) */ +typedef struct { + Value *exprs; + int count; +} ExprList; + +typedef struct Proc { + ObjHeader hdr; + Value *params; + int nparams; + Value rest; /* rest param symbol, or VAL_NIL */ + ExprList body; + Env *env; + const char *name; + bool has_defs; /* body starts with define? */ +} Proc; + +#define IS_PROC(v) (IS_PTR(v) && obj_type(v) == OBJ_PROC) +#define AS_PROC(v) ((Proc *)GET_PTR(v)) + +Proc *make_proc(Value *params, int nparams, Value rest, ExprList body, Env *env, const char *name); + +/* ── Builtin function ────────────────────────────────────────────────────── */ + +typedef Value (*BuiltinFn)(Value *args, int nargs, Env *env); + +/* Wrap a function pointer */ +#define VAL_BUILTIN(fn) NANBOX(TAG_BUILTIN, (uintptr_t)(fn)) +#define AS_BUILTIN(v) ((BuiltinFn)(uintptr_t)GET_PAYLOAD(v)) + +/* ── Macro ───────────────────────────────────────────────────────────────── */ + +typedef struct ULMacro { + ObjHeader hdr; + Value transformer; /* Proc, CompiledProc, or SyntaxTransformer */ +} ULMacro; + +#define IS_MACRO(v) (IS_PTR(v) && obj_type(v) == OBJ_MACRO) +#define AS_MACRO(v) ((ULMacro *)GET_PTR(v)) + +Value make_macro(Value transformer); + +/* ── Error object ────────────────────────────────────────────────────────── */ + +typedef struct ErrorObject { + ObjHeader hdr; + char *message; + Value *irritants; + int nirritants; +} ErrorObject; + +#define IS_ERROR_OBJ(v) (IS_PTR(v) && obj_type(v) == OBJ_ERROR) +#define AS_ERROR(v) ((ErrorObject *)GET_PTR(v)) + +Value make_error_object(const char *msg, Value *irritants, int nirr); + +/* ── Port ────────────────────────────────────────────────────────────────── */ + +typedef enum { PORT_INPUT, PORT_OUTPUT } PortDir; +typedef enum { PORT_FILE, PORT_STRING } PortKind; + +typedef struct ULPort { + ObjHeader hdr; + PortDir dir; + PortKind kind; + FILE *fp; /* for file ports */ + char *str_buf; /* for string ports */ + size_t str_len; + size_t str_pos; + size_t str_cap; + bool closed; +} ULPort; + +#define IS_PORT(v) (IS_PTR(v) && obj_type(v) == OBJ_PORT) +#define AS_PORT(v) ((ULPort *)GET_PTR(v)) + +Value make_file_port(FILE *fp, PortDir dir); +Value make_string_input_port(const char *s, size_t len); +Value make_string_output_port(void); +void port_write_char(ULPort *p, int ch); +void port_write_str(ULPort *p, const char *s, size_t len); +int port_read_char(ULPort *p); +int port_peek_char(ULPort *p); +char *port_read_line(ULPort *p); +char *port_get_output_string(ULPort *p); + +/* ── Bytecode ────────────────────────────────────────────────────────────── */ + +typedef enum { + OP_CONST = 0, OP_LOOKUP = 1, OP_SET = 2, OP_DEFINE = 3, + OP_POP = 4, OP_DUP = 5, OP_VOID = 6, + OP_JUMP = 10, OP_JUMP_IF_FALSE = 11, + OP_JUMP_IF_FALSE_KEEP = 12, OP_JUMP_IF_TRUE_KEEP = 13, + OP_CALL = 20, OP_TAIL_CALL = 21, OP_RETURN = 22, + OP_MAKE_CLOSURE = 30, + OP_PUSH_ENV = 40, OP_POP_ENV = 41, OP_BIND = 42, + OP_EVAL = 50, OP_CALL_CC = 51, + OP_ADD = 60, OP_SUB = 61, OP_MUL = 62, OP_NEG = 63, + OP_NUM_EQ = 64, OP_LT = 65, OP_GT = 66, OP_LE = 67, OP_GE = 68, + OP_ADD1 = 69, OP_SUB1 = 70, + OP_CAR = 71, OP_CDR = 72, OP_CONS = 73, + OP_NULL_P = 74, OP_PAIR_P = 75, OP_NOT = 76, OP_ZERO_P = 77, + OP_VEC_REF = 78, OP_VEC_SET = 79, + OP_LOOK_LOOK = 80, OP_LOOK_ADD1 = 81, OP_LOOK_SUB1 = 82, + OP_CONST_EQ_JF = 83, OP_LOOK_CONST_CALL2 = 84, + OP_SELF_TAIL_CALL = 85, +} Opcode; + +typedef struct { + Opcode op; + Value arg; /* operand — meaning depends on op */ + int arg2; /* secondary operand (for some superinstructions) */ +} Instruction; + +typedef struct CodeObj { + ObjHeader hdr; + Instruction *instrs; + int count; + int cap; + int *source_map; /* line numbers, parallel to instrs */ + const char *name; + /* Self-tail-call optimization info */ + const char *self_name; + Value *self_params; + int self_nparams; +} CodeObj; + +#define IS_CODE(v) (IS_PTR(v) && obj_type(v) == OBJ_CODE) +#define AS_CODE(v) ((CodeObj *)GET_PTR(v)) + +typedef struct CompiledProc { + ObjHeader hdr; + CodeObj *code; + Value *params; + int nparams; + Value rest; + Env *env; + const char *name; +} CompiledProc; + +#define IS_COMPILED_PROC(v) (IS_PTR(v) && obj_type(v) == OBJ_COMPILED_PROC) +#define AS_COMPILED_PROC(v) ((CompiledProc *)GET_PTR(v)) + +/* ── Continuation ────────────────────────────────────────────────────────── */ + +typedef struct VMFrame { + Instruction *instrs; + int ip; + int n_instrs; + Env *env; + Value *stack; + int stack_len; + int stack_cap; +} VMFrame; + +typedef struct FullCont { + ObjHeader hdr; + VMFrame *frames; + int nframes; + Value *stack; + int stack_len; + int ip; + Instruction *instrs; + int n_instrs; + Env *env; + void *vm_id; +} FullCont; + +#define IS_CONTINUATION(v) (IS_PTR(v) && obj_type(v) == OBJ_CONTINUATION) +#define AS_CONTINUATION(v) ((FullCont *)GET_PTR(v)) + +/* ── Syntax Transformer ──────────────────────────────────────────────────── */ + +typedef struct SyntaxRule { + Value pattern; + Value tmpl; +} SyntaxRule; + +typedef struct SyntaxTransformer { + ObjHeader hdr; + char **literals; + int nliterals; + SyntaxRule *rules; + int nrules; + Env *def_env; +} SyntaxTransformer; + +#define IS_SYNTAX_TRANSFORMER(v) (IS_PTR(v) && obj_type(v) == OBJ_SYNTAX_TRANSFORMER) +#define AS_SYNTAX_TRANSFORMER(v) ((SyntaxTransformer *)GET_PTR(v)) + +/* ═══════════════════════════════════════════════════════════════════════════ + * Error handling — longjmp-based exception system + * ═══════════════════════════════════════════════════════════════════════════ */ + +#define MAX_ERROR_MSG 1024 +#define MAX_CALL_STACK 256 + +typedef struct { + jmp_buf jmp; + char message[MAX_ERROR_MSG]; + Value error_obj; /* ErrorObject Value or VAL_NIL */ + const char *call_stack[MAX_CALL_STACK]; + int call_stack_depth; + int source_line; +} ErrorContext; + +extern __thread ErrorContext *g_error_ctx; + +void lisp_error(const char *fmt, ...) __attribute__((noreturn)); +void lisp_error_with_obj(Value obj, const char *fmt, ...) __attribute__((noreturn)); + +/* Push/pop error handler */ +#define TRY(ctx) \ + do { \ + ErrorContext *_prev = g_error_ctx; \ + ErrorContext ctx; \ + ctx.call_stack_depth = _prev ? _prev->call_stack_depth : 0; \ + if (_prev) memcpy(ctx.call_stack, _prev->call_stack, sizeof(char*) * ctx.call_stack_depth); \ + ctx.error_obj = VAL_NIL; \ + ctx.source_line = 0; \ + g_error_ctx = &ctx; \ + if (setjmp(ctx.jmp) == 0) { + +#define CATCH \ + } else { + +#define ENDTRY \ + } \ + g_error_ctx = _prev; \ + } while(0) + +/* ═══════════════════════════════════════════════════════════════════════════ + * Value stack (dynamic array) + * ═══════════════════════════════════════════════════════════════════════════ */ + +typedef struct { + Value *data; + int len; + int cap; +} ValueStack; + +void vs_init(ValueStack *s, int cap); +void vs_push(ValueStack *s, Value v); +Value vs_pop(ValueStack *s); +Value vs_peek(ValueStack *s); +void vs_clear(ValueStack *s); + +/* ═══════════════════════════════════════════════════════════════════════════ + * Function declarations — reader.c + * ═══════════════════════════════════════════════════════════════════════════ */ + +typedef struct { + char **tokens; + int *lines; + int count; + int cap; +} TokenList; + +void tokenize(const char *src, TokenList *out, bool track_lines); +Value parse_one(TokenList *tl, int *pos); +Value parse_atom(const char *tok); +Value *read_all(const char *src, int *count, bool track_lines); + +/* ═══════════════════════════════════════════════════════════════════════════ + * Function declarations — printer.c + * ═══════════════════════════════════════════════════════════════════════════ */ + +/* Returns a malloc'd string. Caller must free. */ +char *show(Value v, bool display); +/* Print to stdout */ +void print_value(Value v, bool display, FILE *out); + +/* ═══════════════════════════════════════════════════════════════════════════ + * Function declarations — eval.c + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value leval(Value expr, Env *env); +Value call_proc(Value proc, Value *args, int nargs, Env *env); +void load_file(const char *path, Env *env); + +/* Quasiquote */ +Value qq_expand(Value tmpl, Env *env, int depth); + +/* Syntax transformer */ +Value syntax_transform_value(SyntaxTransformer *st, Value form); + +/* Helpers */ +Value list_to_value(Value *items, int count); /* Python list → Lisp list */ +int value_to_list(Value v, Value **out); /* Lisp list → C array, returns count */ +Formals parse_formals(Value f); +bool has_internal_defines(ExprList body); +ExprList body_with_env(Value *forms, int count, Env *env); +bool is_proper_list(Value v); +bool values_equal(Value a, Value b); + +/* Global state */ +extern bool g_auto_compile; + +/* ═══════════════════════════════════════════════════════════════════════════ + * Function declarations — builtins.c + * ═══════════════════════════════════════════════════════════════════════════ */ + +Env *make_global_env(void); +extern const char *PRELUDE; + +/* ═══════════════════════════════════════════════════════════════════════════ + * Function declarations — vm.c + * ═══════════════════════════════════════════════════════════════════════════ */ + +CodeObj *make_code(const char *name); +int code_emit(CodeObj *c, Opcode op, Value arg); +void code_emit2(CodeObj *c, Opcode op, Value arg, int arg2); +void code_patch(CodeObj *c, int addr, Value arg); + +CompiledProc *compile_proc(Proc *p, Env *env); +Value vm_exec(CodeObj *code, Env *env); +void bc_compile(Value expr, CodeObj *code, Env *env, bool tail); +CodeObj *bc_lambda(Value *body, int nbody, Value *params, int nparams, + Value rest, Env *env, const char *name, + const char *self_name, Value *self_params, int self_nparams); + +/* ═══════════════════════════════════════════════════════════════════════════ + * Commonly used interned symbols — cached for fast comparison + * ═══════════════════════════════════════════════════════════════════════════ */ + +extern Value SYM_QUOTE, SYM_IF, SYM_COND, SYM_AND, SYM_OR; +extern Value SYM_WHEN, SYM_UNLESS, SYM_BEGIN, SYM_DEFINE, SYM_SET; +extern Value SYM_LAMBDA, SYM_LAMBDA_UC, SYM_LET, SYM_LET_STAR, SYM_LETREC; +extern Value SYM_LETREC_STAR, SYM_DO, SYM_QUASIQUOTE, SYM_UNQUOTE; +extern Value SYM_UNQUOTE_SPLICING, SYM_DEFINE_MACRO, SYM_DEFMACRO; +extern Value SYM_DEFINE_SYNTAX, SYM_LET_SYNTAX, SYM_LETREC_SYNTAX; +extern Value SYM_SYNTAX_RULES, SYM_VALUES, SYM_CALL_WITH_VALUES; +extern Value SYM_CALL_CC, SYM_CALL_CC2, SYM_APPLY, SYM_EVAL; +extern Value SYM_ERROR, SYM_DEFINE_RECORD_TYPE, SYM_MODULE, SYM_IMPORT; +extern Value SYM_LOAD, SYM_INCLUDE, SYM_PARAMETERIZE, SYM_DYNAMIC_WIND; +extern Value SYM_WITH_EXCEPTION_HANDLER, SYM_GUARD, SYM_DEFINE_VALUES; +extern Value SYM_LET_VALUES, SYM_LET_STAR_VALUES, SYM_CASE; +extern Value SYM_ELSE, SYM_ARROW, SYM_DOT, SYM_ELLIPSIS, SYM_UNDERSCORE; +extern Value SYM_EXPORT; + +void init_symbols(void); + +/* ═══════════════════════════════════════════════════════════════════════════ + * Utility macros + * ═══════════════════════════════════════════════════════════════════════════ */ + +#define CAR(v) (AS_PAIR(v)->car) +#define CDR(v) (AS_PAIR(v)->cdr) +#define CAAR(v) CAR(CAR(v)) +#define CADR(v) CAR(CDR(v)) +#define CDAR(v) CDR(CAR(v)) +#define CDDR(v) CDR(CDR(v)) +#define CADDR(v) CAR(CDDR(v)) + +/* Is v callable? */ +static inline bool is_callable(Value v) { + if (IS_BUILTIN(v)) return true; + if (IS_PTR(v)) { + ObjType t = obj_type(v); + return t == OBJ_PROC || t == OBJ_COMPILED_PROC || t == OBJ_CONTINUATION; + } + return false; +} + +/* Number extraction — works for int, double, rational */ +static inline bool is_number(Value v) { + return IS_INT(v) || IS_DOUBLE(v) || IS_RATIONAL(v); +} + +double as_number_double(Value v); /* coerce any number to double */ +int64_t as_number_int(Value v); /* coerce any number to int (truncate) */ + +/* Arithmetic that preserves exactness */ +Value num_add(Value a, Value b); +Value num_sub(Value a, Value b); +Value num_mul(Value a, Value b); +Value num_div(Value a, Value b); +Value num_neg(Value a); +bool num_eq(Value a, Value b); +bool num_lt(Value a, Value b); +bool num_gt(Value a, Value b); +bool num_le(Value a, Value b); +bool num_ge(Value a, Value b); + +/* Record type registry */ +typedef struct RecordType { + char *name; + char **fields; + int nfields; + char *parent; + struct RecordType *next; +} RecordType; + +extern RecordType *g_record_types; +RecordType *find_record_type(const char *name); +void register_record_type(const char *name, char **fields, int nfields, const char *parent); +bool is_subtype(const char *child, const char *ancestor); + +/* Module registry */ +typedef struct Module { + char *name; + Env *env; + char **exports; + int nexports; + struct Module *next; +} Module; + +extern Module *g_modules; + +#endif /* UNCOMMONLISP_H */ diff --git a/c/vm.c b/c/vm.c new file mode 100644 index 0000000..c9972a4 --- /dev/null +++ b/c/vm.c @@ -0,0 +1,871 @@ +/* + * vm.c — Bytecode compiler + stack-based VM + */ +#include "uncommonlisp.h" + +/* ═══════════════════════════════════════════════════════════════════════════ + * CodeObj + * ═══════════════════════════════════════════════════════════════════════════ */ + +CodeObj *make_code(const char *name) { + CodeObj *c = (CodeObj *)ul_malloc(sizeof(CodeObj)); + c->hdr.type = OBJ_CODE; + c->cap = 64; + c->count = 0; + c->instrs = (Instruction *)ul_malloc(sizeof(Instruction) * c->cap); + c->source_map = (int *)ul_malloc(sizeof(int) * c->cap); + c->name = name ? ul_strdup(name) : NULL; + c->self_name = NULL; + c->self_params = NULL; + c->self_nparams = 0; + return c; +} + +int code_emit(CodeObj *c, Opcode op, Value arg) { + if (c->count >= c->cap) { + c->cap *= 2; + c->instrs = (Instruction *)ul_realloc(c->instrs, sizeof(Instruction) * c->cap); + c->source_map = (int *)ul_realloc(c->source_map, sizeof(int) * c->cap); + } + int idx = c->count; + c->instrs[idx].op = op; + c->instrs[idx].arg = arg; + c->instrs[idx].arg2 = 0; + c->source_map[idx] = 0; + c->count++; + return idx; +} + +void code_emit2(CodeObj *c, Opcode op, Value arg, int arg2) { + int idx = code_emit(c, op, arg); + c->instrs[idx].arg2 = arg2; +} + +void code_patch(CodeObj *c, int addr, Value arg) { + c->instrs[addr].arg = arg; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * Bytecode compiler + * ═══════════════════════════════════════════════════════════════════════════ */ + +static bool bc_is_global(Value sym, Env *env) { + Env *e = env; + Env *g = e->global; + while (e && e != g) { + /* Check if sym is locally bound */ + EnvBinding *b = NULL; + uint32_t h = (uint32_t)((GET_PAYLOAD(sym) * 2654435761ULL) % e->nbuckets); + b = e->buckets[h]; + while (b) { if (b->sym == sym) return false; b = b->next; } + e = e->parent; + } + return true; +} + +/* Fallback forms — these get compiled to OP_EVAL */ +static bool is_fallback_form(Value head) { + return head == SYM_QUASIQUOTE || head == SYM_DEFINE_MACRO || head == SYM_DEFMACRO || + head == SYM_DEFINE_SYNTAX || head == SYM_LET_SYNTAX || head == SYM_LETREC_SYNTAX || + head == SYM_SYNTAX_RULES || head == SYM_DEFINE_VALUES || head == SYM_LET_VALUES || + head == SYM_LET_STAR_VALUES || head == SYM_DEFINE_RECORD_TYPE || + head == SYM_MODULE || head == SYM_IMPORT || head == SYM_INCLUDE || head == SYM_LOAD || + head == SYM_PARAMETERIZE || head == SYM_DYNAMIC_WIND || + head == SYM_WITH_EXCEPTION_HANDLER || head == SYM_GUARD || + head == SYM_CALL_WITH_VALUES || head == SYM_VALUES || head == SYM_EVAL || + head == SYM_ERROR || head == SYM_CASE; +} + +static void bc_body(Value *body, int nbody, CodeObj *code, Env *env, bool tail) { + if (nbody == 0) { code_emit(code, OP_VOID, VAL_NIL); return; } + for (int i = 0; i < nbody - 1; i++) { + bc_compile(body[i], code, env, false); + code_emit(code, OP_POP, VAL_NIL); + } + bc_compile(body[nbody - 1], code, env, tail); +} + +CodeObj *bc_lambda(Value *body, int nbody, Value *params, int nparams, + Value rest, Env *env, const char *name, + const char *self_name, Value *self_params, int self_nparams) { + CodeObj *inner = make_code(name); + if (self_name) { + inner->self_name = ul_strdup(self_name); + inner->self_params = (Value *)ul_malloc(sizeof(Value) * self_nparams); + memcpy(inner->self_params, self_params, sizeof(Value) * self_nparams); + inner->self_nparams = self_nparams; + } + + /* Handle internal defines */ + int i = 0; + Value *def_names = NULL; + int ndef = 0; + Value *expanded = (Value *)ul_malloc(sizeof(Value) * (nbody + 64)); + memcpy(expanded, body, sizeof(Value) * nbody); + int n = nbody; + + while (i < n) { + Value f = expanded[i]; + if (IS_PAIR(f) && CAR(f) == SYM_DEFINE) { + Value *a; int na = value_to_list(CDR(f), &a); + Value nm = IS_PAIR(a[0]) ? CAR(a[0]) : a[0]; + if (IS_SYM(nm)) { + def_names = (Value *)ul_realloc(def_names, sizeof(Value) * (ndef + 1)); + def_names[ndef++] = nm; + } + ul_free(a); + i++; + } else if (IS_PAIR(f) && CAR(f) == SYM_BEGIN) { + Value *spliced; int ns = value_to_list(CDR(f), &spliced); + memmove(expanded + i + ns, expanded + i + 1, sizeof(Value) * (n - i - 1)); + memcpy(expanded + i, spliced, sizeof(Value) * ns); + n = n + ns - 1; + ul_free(spliced); + } else { + break; + } + } + + if (ndef > 0) { + code_emit(inner, OP_PUSH_ENV, VAL_NIL); + for (int j = 0; j < ndef; j++) { + code_emit(inner, OP_VOID, VAL_NIL); + code_emit(inner, OP_BIND, def_names[j]); + } + } + + bc_body(expanded, n, inner, env, true); + code_emit(inner, OP_RETURN, VAL_NIL); + + ul_free(expanded); + ul_free(def_names); + return inner; +} + +void bc_compile(Value expr, CodeObj *code, Env *env, bool tail) { + /* Self-evaluating */ + if (IS_VOID(expr)) { code_emit(code, OP_VOID, VAL_NIL); return; } + if (IS_NIL(expr) || IS_TRUE(expr) || IS_FALSE(expr) || IS_EOF(expr) || IS_CHAR(expr)) { + code_emit(code, OP_CONST, expr); return; + } + if (IS_INT(expr) || IS_DOUBLE(expr) || IS_RATIONAL(expr)) { + code_emit(code, OP_CONST, expr); return; + } + if (IS_STRING(expr) || IS_VECTOR(expr)) { + code_emit(code, OP_CONST, expr); return; + } + if (IS_SYM(expr)) { code_emit(code, OP_LOOKUP, expr); return; } + if (!IS_PAIR(expr)) { code_emit(code, OP_CONST, expr); return; } + + Value head = CAR(expr); + Value args = CDR(expr); + + /* Fallback forms */ + if (IS_SYM(head) && is_fallback_form(head)) { + code_emit(code, OP_EVAL, expr); return; + } + + /* quote */ + if (head == SYM_QUOTE) { code_emit(code, OP_CONST, CADR(expr)); return; } + + /* if */ + if (head == SYM_IF) { + Value *a; int na = value_to_list(args, &a); + bc_compile(a[0], code, env, false); + int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL); + bc_compile(a[1], code, env, tail); + int je = code_emit(code, OP_JUMP, VAL_NIL); + code_patch(code, jf, VAL_INT(code->count)); + if (na > 2) bc_compile(a[2], code, env, tail); + else code_emit(code, OP_VOID, VAL_NIL); + code_patch(code, je, VAL_INT(code->count)); + ul_free(a); return; + } + + /* begin */ + if (head == SYM_BEGIN) { + Value *a; int na = value_to_list(args, &a); + if (na == 0) { code_emit(code, OP_VOID, VAL_NIL); ul_free(a); return; } + for (int i = 0; i < na - 1; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + bc_compile(a[na-1], code, env, tail); + ul_free(a); return; + } + + /* and */ + if (head == SYM_AND) { + Value *a; int na = value_to_list(args, &a); + if (na == 0) { code_emit(code, OP_CONST, VAL_TRUE); ul_free(a); return; } + if (na == 1) { bc_compile(a[0], code, env, tail); ul_free(a); return; } + int *ends = (int *)ul_malloc(sizeof(int) * na); + int nends = 0; + for (int i = 0; i < na - 1; i++) { + bc_compile(a[i], code, env, false); + ends[nends++] = code_emit(code, OP_JUMP_IF_FALSE_KEEP, VAL_NIL); + } + bc_compile(a[na-1], code, env, tail); + int end = code->count; + for (int i = 0; i < nends; i++) code_patch(code, ends[i], VAL_INT(end)); + ul_free(ends); ul_free(a); return; + } + + /* or */ + if (head == SYM_OR) { + Value *a; int na = value_to_list(args, &a); + if (na == 0) { code_emit(code, OP_CONST, VAL_FALSE); ul_free(a); return; } + if (na == 1) { bc_compile(a[0], code, env, tail); ul_free(a); return; } + int *ends = (int *)ul_malloc(sizeof(int) * na); + int nends = 0; + for (int i = 0; i < na - 1; i++) { + bc_compile(a[i], code, env, false); + ends[nends++] = code_emit(code, OP_JUMP_IF_TRUE_KEEP, VAL_NIL); + } + bc_compile(a[na-1], code, env, tail); + int end = code->count; + for (int i = 0; i < nends; i++) code_patch(code, ends[i], VAL_INT(end)); + ul_free(ends); ul_free(a); return; + } + + /* when */ + if (head == SYM_WHEN) { + Value *a; int na = value_to_list(args, &a); + bc_compile(a[0], code, env, false); + int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL); + for (int i = 1; i < na - 1; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + bc_compile(a[na-1], code, env, tail); + int je = code_emit(code, OP_JUMP, VAL_NIL); + code_patch(code, jf, VAL_INT(code->count)); + code_emit(code, OP_VOID, VAL_NIL); + code_patch(code, je, VAL_INT(code->count)); + ul_free(a); return; + } + + /* unless */ + if (head == SYM_UNLESS) { + Value *a; int na = value_to_list(args, &a); + bc_compile(a[0], code, env, false); + int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL); + code_emit(code, OP_VOID, VAL_NIL); + int je = code_emit(code, OP_JUMP, VAL_NIL); + code_patch(code, jf, VAL_INT(code->count)); + for (int i = 1; i < na - 1; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + bc_compile(a[na-1], code, env, tail); + code_patch(code, je, VAL_INT(code->count)); + ul_free(a); return; + } + + /* cond */ + if (head == SYM_COND) { + Value *clauses; int nc = value_to_list(args, &clauses); + int *ends = (int *)ul_malloc(sizeof(int) * nc); + int nends = 0; + for (int i = 0; i < nc; i++) { + Value *cl; int ncl = value_to_list(clauses[i], &cl); + if (cl[0] == SYM_ELSE) { + for (int j = 1; j < ncl - 1; j++) { bc_compile(cl[j], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + bc_compile(ncl > 1 ? cl[ncl-1] : VAL_VOID, code, env, tail); + ul_free(cl); break; + } + if ((ncl >= 3 && cl[1] == SYM_ARROW) || ncl == 1) { + /* Fallback for => and bare test */ + code_emit(code, OP_EVAL, expr); + ul_free(cl); ul_free(ends); ul_free(clauses); return; + } + bc_compile(cl[0], code, env, false); + int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL); + for (int j = 1; j < ncl - 1; j++) { bc_compile(cl[j], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + bc_compile(cl[ncl-1], code, env, tail); + ends[nends++] = code_emit(code, OP_JUMP, VAL_NIL); + code_patch(code, jf, VAL_INT(code->count)); + ul_free(cl); + if (i == nc - 1) code_emit(code, OP_VOID, VAL_NIL); + } + int end = code->count; + for (int i = 0; i < nends; i++) code_patch(code, ends[i], VAL_INT(end)); + ul_free(ends); ul_free(clauses); return; + } + + /* define */ + if (head == SYM_DEFINE) { + Value *a; int na = value_to_list(args, &a); + if (IS_PAIR(a[0])) { + Value fname = CAR(a[0]); + Formals f = parse_formals(CDR(a[0])); + CodeObj *inner = bc_lambda(a + 1, na - 1, f.params, f.nparams, f.rest, env, + sym_name(fname), NULL, NULL, 0); + /* Emit closure + define */ + /* Pack closure info as a vector: [inner_code, nparams, rest] */ + Value closure_info = make_vector(3, VAL_NIL); + AS_VECTOR(closure_info)->data[0] = VAL_PTR(inner); + AS_VECTOR(closure_info)->data[1] = VAL_INT(f.nparams); + AS_VECTOR(closure_info)->data[2] = f.rest; + /* Store params in the vector too */ + Value params_vec = make_vector_from(f.params, f.nparams); + AS_VECTOR(closure_info)->data = (Value *)ul_realloc(AS_VECTOR(closure_info)->data, sizeof(Value) * 4); + AS_VECTOR(closure_info)->len = 4; + AS_VECTOR(closure_info)->cap = 4; + AS_VECTOR(closure_info)->data[3] = params_vec; + + code_emit(code, OP_MAKE_CLOSURE, closure_info); + code_emit(code, OP_DEFINE, fname); + } else { + if (na > 1) bc_compile(a[1], code, env, false); + else code_emit(code, OP_VOID, VAL_NIL); + code_emit(code, OP_DEFINE, a[0]); + } + code_emit(code, OP_VOID, VAL_NIL); + ul_free(a); return; + } + + /* set! */ + if (head == SYM_SET) { + Value *a; int na = value_to_list(args, &a); + bc_compile(a[1], code, env, false); + code_emit(code, OP_SET, a[0]); + code_emit(code, OP_VOID, VAL_NIL); + ul_free(a); return; + } + + /* lambda */ + if (head == SYM_LAMBDA || head == SYM_LAMBDA_UC) { + Value *a; int na = value_to_list(args, &a); + Formals f = parse_formals(a[0]); + CodeObj *inner = bc_lambda(a + 1, na - 1, f.params, f.nparams, f.rest, env, + NULL, NULL, NULL, 0); + Value closure_info = make_vector(4, VAL_NIL); + AS_VECTOR(closure_info)->data[0] = VAL_PTR(inner); + AS_VECTOR(closure_info)->data[1] = VAL_INT(f.nparams); + AS_VECTOR(closure_info)->data[2] = f.rest; + AS_VECTOR(closure_info)->data[3] = make_vector_from(f.params, f.nparams); + code_emit(code, OP_MAKE_CLOSURE, closure_info); + ul_free(a); return; + } + + /* let */ + if (head == SYM_LET) { + Value *a; int na = value_to_list(args, &a); + if (IS_SYM(a[0])) { + /* Named let */ + Value name = a[0]; + Value *binds; int nb = value_to_list(a[1], &binds); + Value *bps = (Value *)ul_malloc(sizeof(Value) * nb); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + bps[i] = bp[0]; + ul_free(bp); + } + CodeObj *inner = bc_lambda(a + 2, na - 2, bps, nb, VAL_NIL, env, + sym_name(name), sym_name(name), bps, nb); + code_emit(code, OP_PUSH_ENV, VAL_NIL); + Value closure_info = make_vector(4, VAL_NIL); + AS_VECTOR(closure_info)->data[0] = VAL_PTR(inner); + AS_VECTOR(closure_info)->data[1] = VAL_INT(nb); + AS_VECTOR(closure_info)->data[2] = VAL_NIL; + AS_VECTOR(closure_info)->data[3] = make_vector_from(bps, nb); + code_emit(code, OP_MAKE_CLOSURE, closure_info); + code_emit(code, OP_DUP, VAL_NIL); + code_emit(code, OP_BIND, name); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + bc_compile(bp[1], code, env, false); + ul_free(bp); + } + code_emit(code, tail ? OP_TAIL_CALL : OP_CALL, VAL_INT(nb)); + if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL); + ul_free(bps); ul_free(binds); ul_free(a); return; + } + /* Regular let */ + Value *binds; int nb = value_to_list(a[0], &binds); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + bc_compile(bp[1], code, env, false); + ul_free(bp); + } + code_emit(code, OP_PUSH_ENV, VAL_NIL); + for (int i = nb - 1; i >= 0; i--) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + code_emit(code, OP_BIND, bp[0]); + ul_free(bp); + } + bc_body(a + 1, na - 1, code, env, tail); + if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL); + ul_free(binds); ul_free(a); return; + } + + /* let* */ + if (head == SYM_LET_STAR) { + Value *a; int na = value_to_list(args, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + code_emit(code, OP_PUSH_ENV, VAL_NIL); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + bc_compile(bp[1], code, env, false); + code_emit(code, OP_BIND, bp[0]); + ul_free(bp); + } + bc_body(a + 1, na - 1, code, env, tail); + if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL); + ul_free(binds); ul_free(a); return; + } + + /* letrec / letrec* */ + if (head == SYM_LETREC || head == SYM_LETREC_STAR) { + Value *a; int na = value_to_list(args, &a); + Value *binds; int nb = value_to_list(a[0], &binds); + code_emit(code, OP_PUSH_ENV, VAL_NIL); + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + code_emit(code, OP_VOID, VAL_NIL); + code_emit(code, OP_BIND, bp[0]); + ul_free(bp); + } + for (int i = 0; i < nb; i++) { + Value *bp; int nbp = value_to_list(binds[i], &bp); + bc_compile(bp[1], code, env, false); + code_emit(code, OP_SET, bp[0]); + ul_free(bp); + } + bc_body(a + 1, na - 1, code, env, tail); + if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL); + ul_free(binds); ul_free(a); return; + } + + /* do */ + if (head == SYM_DO) { + Value *a; int na = value_to_list(args, &a); + Value *vcs; int nvc = value_to_list(a[0], &vcs); + Value *term; int nterm = value_to_list(a[1], &term); + + /* Initialize vars */ + typedef struct { Value var; Value step; } DoSpec; + DoSpec *specs = (DoSpec *)ul_malloc(sizeof(DoSpec) * nvc); + for (int i = 0; i < nvc; i++) { + Value *sp; int nsp = value_to_list(vcs[i], &sp); + specs[i].var = sp[0]; + specs[i].step = nsp > 2 ? sp[2] : sp[0]; + bc_compile(sp[1], code, env, false); + ul_free(sp); + } + code_emit(code, OP_PUSH_ENV, VAL_NIL); + for (int i = nvc - 1; i >= 0; i--) code_emit(code, OP_BIND, specs[i].var); + + int loop_start = code->count; + bc_compile(term[0], code, env, false); + int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL); + if (nterm > 1) { + for (int i = 1; i < nterm - 1; i++) { bc_compile(term[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + bc_compile(term[nterm-1], code, env, tail); + } else { + code_emit(code, OP_VOID, VAL_NIL); + } + int je = code_emit(code, OP_JUMP, VAL_NIL); + code_patch(code, jf, VAL_INT(code->count)); + + /* Body */ + for (int i = 2; i < na; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); } + + /* Steps */ + for (int i = 0; i < nvc; i++) bc_compile(specs[i].step, code, env, false); + for (int i = nvc - 1; i >= 0; i--) code_emit(code, OP_SET, specs[i].var); + code_emit(code, OP_JUMP, VAL_INT(loop_start)); + code_patch(code, je, VAL_INT(code->count)); + if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL); + + ul_free(specs); ul_free(vcs); ul_free(term); ul_free(a); + return; + } + + /* call/cc */ + if (head == SYM_CALL_CC || head == SYM_CALL_CC2) { + Value *a; int na = value_to_list(args, &a); + bc_compile(a[0], code, env, false); + code_emit(code, OP_CALL_CC, VAL_NIL); + ul_free(a); return; + } + + /* apply — fallback to eval */ + if (head == SYM_APPLY) { + code_emit(code, OP_EVAL, expr); return; + } + + /* Macro expansion at compile time */ + if (IS_SYM(head)) { + TRY(ctx) { + Value hval = env_lookup(env, head); + if (IS_MACRO(hval)) { + ULMacro *m = AS_MACRO(hval); + Value *a; int na = value_to_list(args, &a); + Value expanded; + if (IS_SYNTAX_TRANSFORMER(m->transformer)) { + Value form = list_to_value(a, na); + expanded = syntax_transform_value(AS_SYNTAX_TRANSFORMER(m->transformer), form); + } else { + expanded = call_proc(m->transformer, a, na, env); + } + ul_free(a); + bc_compile(expanded, code, env, tail); + return; + } + } CATCH { + /* Not found — continue to regular call */ + } ENDTRY; + } + + /* Specialized opcodes for hot builtins */ + if (IS_SYM(head) && bc_is_global(head, env)) { + Value *call_args; int nca = value_to_list(args, &call_args); + + /* + with 2 args */ + if (head == intern("+") && nca == 2) { + /* Check for +1 optimization */ + if (IS_INT(call_args[1]) && as_int(call_args[1]) == 1 && IS_SYM(call_args[0])) { + code_emit(code, OP_LOOK_ADD1, call_args[0]); + ul_free(call_args); return; + } + if (IS_INT(call_args[0]) && as_int(call_args[0]) == 1 && IS_SYM(call_args[1])) { + code_emit(code, OP_LOOK_ADD1, call_args[1]); + ul_free(call_args); return; + } + bc_compile(call_args[0], code, env, false); + bc_compile(call_args[1], code, env, false); + code_emit(code, OP_ADD, VAL_NIL); + ul_free(call_args); return; + } + /* - with 2 args */ + if (head == intern("-") && nca == 2) { + if (IS_INT(call_args[1]) && as_int(call_args[1]) == 1 && IS_SYM(call_args[0])) { + code_emit(code, OP_LOOK_SUB1, call_args[0]); + ul_free(call_args); return; + } + bc_compile(call_args[0], code, env, false); + bc_compile(call_args[1], code, env, false); + code_emit(code, OP_SUB, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("-") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_NEG, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("*") && nca == 2) { + bc_compile(call_args[0], code, env, false); + bc_compile(call_args[1], code, env, false); + code_emit(code, OP_MUL, VAL_NIL); + ul_free(call_args); return; + } + + /* Comparison ops */ + #define SPECIALIZE_CMP(sym_str, opcode) \ + if (head == intern(sym_str) && nca == 2) { \ + bc_compile(call_args[0], code, env, false); \ + bc_compile(call_args[1], code, env, false); \ + code_emit(code, opcode, VAL_NIL); \ + ul_free(call_args); return; \ + } + SPECIALIZE_CMP("=", OP_NUM_EQ) + SPECIALIZE_CMP("<", OP_LT) + SPECIALIZE_CMP(">", OP_GT) + SPECIALIZE_CMP("<=", OP_LE) + SPECIALIZE_CMP(">=", OP_GE) + #undef SPECIALIZE_CMP + + /* car, cdr, cons, null?, pair?, not, zero? */ + if (head == intern("car") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_CAR, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("cdr") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_CDR, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("cons") && nca == 2) { + bc_compile(call_args[0], code, env, false); + bc_compile(call_args[1], code, env, false); + code_emit(code, OP_CONS, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("null?") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_NULL_P, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("pair?") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_PAIR_P, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("not") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_NOT, VAL_NIL); + ul_free(call_args); return; + } + if (head == intern("zero?") && nca == 1) { + bc_compile(call_args[0], code, env, false); + code_emit(code, OP_ZERO_P, VAL_NIL); + ul_free(call_args); return; + } + + ul_free(call_args); + } + + /* Self tail-call optimization */ + if (tail && IS_SYM(head) && code->self_name && strcmp(sym_name(head), code->self_name) == 0) { + Value *call_args; int nca = value_to_list(args, &call_args); + for (int i = 0; i < nca; i++) bc_compile(call_args[i], code, env, false); + code_emit2(code, OP_SELF_TAIL_CALL, VAL_INT(nca), code->self_nparams); + ul_free(call_args); return; + } + + /* Regular function call */ + bc_compile(head, code, env, false); + Value *call_args; int nca = value_to_list(args, &call_args); + for (int i = 0; i < nca; i++) bc_compile(call_args[i], code, env, false); + code_emit(code, tail ? OP_TAIL_CALL : OP_CALL, VAL_INT(nca)); + ul_free(call_args); +} + +/* syntax_transform_value is declared in uncommonlisp.h, implemented in eval.c */ + +/* ═══════════════════════════════════════════════════════════════════════════ + * Compile a Proc into a CompiledProc + * ═══════════════════════════════════════════════════════════════════════════ */ + +CompiledProc *compile_proc(Proc *p, Env *env) { + CodeObj *code = bc_lambda(p->body.exprs, p->body.count, + p->params, p->nparams, p->rest, env, + p->name, NULL, NULL, 0); + CompiledProc *cp = (CompiledProc *)ul_malloc(sizeof(CompiledProc)); + cp->hdr.type = OBJ_COMPILED_PROC; + cp->code = code; + cp->params = (Value *)ul_malloc(sizeof(Value) * p->nparams); + memcpy(cp->params, p->params, sizeof(Value) * p->nparams); + cp->nparams = p->nparams; + cp->rest = p->rest; + cp->env = p->env; + cp->name = p->name ? ul_strdup(p->name) : NULL; + return cp; +} + +/* ═══════════════════════════════════════════════════════════════════════════ + * VM execution + * ═══════════════════════════════════════════════════════════════════════════ */ + +Value vm_exec(CodeObj *code, Env *env) { + CodeObj *cur_code = code; + Instruction *instrs = code->instrs; + int ip = 0; + int n_instrs = code->count; + + ValueStack stack; + vs_init(&stack, 128); + + /* Frame stack */ + int frame_cap = 32; + int frame_count = 0; + VMFrame *frames = (VMFrame *)ul_malloc(sizeof(VMFrame) * frame_cap); + + while (ip < n_instrs) { + Instruction *instr = &instrs[ip++]; + Opcode op = instr->op; + Value arg = instr->arg; + + switch (op) { + case OP_CONST: + vs_push(&stack, arg); + break; + case OP_LOOKUP: + vs_push(&stack, env_lookup(env, arg)); + break; + case OP_SET: + env_set(env, arg, vs_pop(&stack)); + break; + case OP_DEFINE: + env_define(env, arg, vs_pop(&stack)); + break; + case OP_POP: + vs_pop(&stack); + break; + case OP_DUP: + vs_push(&stack, vs_peek(&stack)); + break; + case OP_VOID: + vs_push(&stack, VAL_VOID); + break; + case OP_JUMP: + ip = (int)as_int(arg); + break; + case OP_JUMP_IF_FALSE: { + Value v = vs_pop(&stack); + if (IS_FALSE(v)) ip = (int)as_int(arg); + break; + } + case OP_JUMP_IF_FALSE_KEEP: + if (IS_FALSE(stack.data[stack.len - 1])) ip = (int)as_int(arg); + else vs_pop(&stack); + break; + case OP_JUMP_IF_TRUE_KEEP: + if (IS_TRUTHY(stack.data[stack.len - 1])) ip = (int)as_int(arg); + else vs_pop(&stack); + break; + case OP_CALL: { + int nargs = (int)as_int(arg); + Value *args_arr = stack.data + stack.len - nargs; + stack.len -= nargs; + Value func = vs_pop(&stack); + + if (IS_COMPILED_PROC(func)) { + CompiledProc *cp = AS_COMPILED_PROC(func); + /* Push frame */ + if (frame_count >= frame_cap) { + frame_cap *= 2; + frames = (VMFrame *)ul_realloc(frames, sizeof(VMFrame) * frame_cap); + } + VMFrame *f = &frames[frame_count++]; + f->instrs = instrs; f->ip = ip; f->n_instrs = n_instrs; + f->env = env; + f->stack = stack.data; f->stack_len = stack.len; f->stack_cap = stack.cap; + + env = env_child(cp->env, cp->params, cp->nparams, cp->rest, args_arr, nargs); + cur_code = cp->code; + instrs = cp->code->instrs; ip = 0; n_instrs = cp->code->count; + vs_init(&stack, 64); + continue; + } + if (IS_PROC(func)) { + vs_push(&stack, call_proc(func, args_arr, nargs, env)); + } else if (IS_BUILTIN(func)) { + vs_push(&stack, AS_BUILTIN(func)(args_arr, nargs, env)); + } else { + lisp_error("not callable"); + } + break; + } + case OP_TAIL_CALL: { + int nargs = (int)as_int(arg); + Value *args_arr = stack.data + stack.len - nargs; + stack.len -= nargs; + Value func = vs_pop(&stack); + + if (IS_COMPILED_PROC(func)) { + CompiledProc *cp = AS_COMPILED_PROC(func); + env = env_child(cp->env, cp->params, cp->nparams, cp->rest, args_arr, nargs); + cur_code = cp->code; + instrs = cp->code->instrs; ip = 0; n_instrs = cp->code->count; + vs_clear(&stack); + continue; + } + if (IS_PROC(func) || IS_BUILTIN(func)) { + Value ret = call_proc(func, args_arr, nargs, env); + if (frame_count == 0) { ul_free(frames); ul_free(stack.data); return ret; } + VMFrame *f = &frames[--frame_count]; + instrs = f->instrs; ip = f->ip; n_instrs = f->n_instrs; + env = f->env; + ul_free(stack.data); + stack.data = f->stack; stack.len = f->stack_len; stack.cap = f->stack_cap; + vs_push(&stack, ret); + continue; + } + lisp_error("not callable"); + break; + } + case OP_RETURN: { + Value ret = stack.len > 0 ? vs_pop(&stack) : VAL_VOID; + if (frame_count == 0) { ul_free(frames); ul_free(stack.data); return ret; } + VMFrame *f = &frames[--frame_count]; + instrs = f->instrs; ip = f->ip; n_instrs = f->n_instrs; + env = f->env; + ul_free(stack.data); + stack.data = f->stack; stack.len = f->stack_len; stack.cap = f->stack_cap; + vs_push(&stack, ret); + continue; + } + case OP_MAKE_CLOSURE: { + /* arg is a vector: [code, nparams, rest, params_vec] */ + ULVector *info = AS_VECTOR(arg); + CodeObj *inner = AS_CODE(info->data[0]); + int nparams = (int)as_int(info->data[1]); + Value rest = info->data[2]; + ULVector *params_vec = AS_VECTOR(info->data[3]); + + CompiledProc *cp = (CompiledProc *)ul_malloc(sizeof(CompiledProc)); + cp->hdr.type = OBJ_COMPILED_PROC; + cp->code = inner; + cp->params = params_vec->data; + cp->nparams = nparams; + cp->rest = rest; + cp->env = env; + cp->name = inner->name; + vs_push(&stack, VAL_PTR(cp)); + break; + } + case OP_PUSH_ENV: + env = make_env(env); + break; + case OP_POP_ENV: + env = env->parent; + break; + case OP_BIND: + env_define(env, arg, vs_pop(&stack)); + break; + case OP_EVAL: + vs_push(&stack, leval(arg, env)); + break; + case OP_CALL_CC: + /* Simplified call/cc — just call with a dummy kont */ + { + Value proc = vs_pop(&stack); + Value kont_args[1] = {VAL_VOID}; /* Simplified */ + vs_push(&stack, call_proc(proc, kont_args, 1, env)); + } + break; + + /* Specialized opcodes */ + case OP_ADD: { Value b = vs_pop(&stack); stack.data[stack.len-1] = num_add(stack.data[stack.len-1], b); break; } + case OP_SUB: { Value b = vs_pop(&stack); stack.data[stack.len-1] = num_sub(stack.data[stack.len-1], b); break; } + case OP_MUL: { Value b = vs_pop(&stack); stack.data[stack.len-1] = num_mul(stack.data[stack.len-1], b); break; } + case OP_NEG: stack.data[stack.len-1] = num_neg(stack.data[stack.len-1]); break; + case OP_ADD1: stack.data[stack.len-1] = num_add(stack.data[stack.len-1], VAL_INT(1)); break; + case OP_SUB1: stack.data[stack.len-1] = num_sub(stack.data[stack.len-1], VAL_INT(1)); break; + case OP_NUM_EQ: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_eq(stack.data[stack.len-1], b)); break; } + case OP_LT: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_lt(stack.data[stack.len-1], b)); break; } + case OP_GT: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_gt(stack.data[stack.len-1], b)); break; } + case OP_LE: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_le(stack.data[stack.len-1], b)); break; } + case OP_GE: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_ge(stack.data[stack.len-1], b)); break; } + case OP_CAR: stack.data[stack.len-1] = CAR(stack.data[stack.len-1]); break; + case OP_CDR: stack.data[stack.len-1] = CDR(stack.data[stack.len-1]); break; + case OP_CONS: { Value d = vs_pop(&stack); stack.data[stack.len-1] = cons(stack.data[stack.len-1], d); break; } + case OP_NULL_P: stack.data[stack.len-1] = VAL_BOOL(IS_NIL(stack.data[stack.len-1])); break; + case OP_PAIR_P: stack.data[stack.len-1] = VAL_BOOL(IS_PAIR(stack.data[stack.len-1])); break; + case OP_NOT: stack.data[stack.len-1] = VAL_BOOL(IS_FALSE(stack.data[stack.len-1])); break; + case OP_ZERO_P: stack.data[stack.len-1] = VAL_BOOL(num_eq(stack.data[stack.len-1], VAL_INT(0))); break; + case OP_VEC_REF: { Value i = vs_pop(&stack); stack.data[stack.len-1] = AS_VECTOR(stack.data[stack.len-1])->data[(int)as_int(i)]; break; } + case OP_VEC_SET: { Value v = vs_pop(&stack); Value i = vs_pop(&stack); AS_VECTOR(stack.data[stack.len-1])->data[(int)as_int(i)] = v; stack.data[stack.len-1] = VAL_VOID; break; } + + /* Superinstructions */ + case OP_LOOK_ADD1: vs_push(&stack, num_add(env_lookup(env, arg), VAL_INT(1))); break; + case OP_LOOK_SUB1: vs_push(&stack, num_sub(env_lookup(env, arg), VAL_INT(1))); break; + case OP_SELF_TAIL_CALL: { + int nargs = (int)as_int(arg); + int nparams_expected = instr->arg2; + Value *args_arr = stack.data + stack.len - nargs; + /* Rebind in current env */ + if (cur_code->self_params) { + for (int i = 0; i < nargs && i < nparams_expected; i++) { + env_set(env, cur_code->self_params[i], args_arr[i]); + } + } + ip = 0; + vs_clear(&stack); + continue; + } + default: + lisp_error("unknown opcode: %d", op); + } + } + + Value ret = stack.len > 0 ? stack.data[stack.len - 1] : VAL_VOID; + ul_free(stack.data); + ul_free(frames); + return ret; +}