Add C implementation: 7,429 lines, 58 tests, identical output
Complete C port of the Scheme interpreter. Same .lsp files run in both Python and C with identical output. Architecture: - NaN-boxed 64-bit values (zero-alloc numbers) - Hash-map environments with parent chain + global shortcut - Interned symbols - TCO via explicit loop (eval) and TAIL_CALL/SELF_TAIL_CALL (VM) - Bytecode compiler with all opcodes including superinstructions - 58 unit + integration tests Makefile targets: make test-all run Python (571) + C (58) tests make examples run examples in both, compare output make friction benchmark same .lsp in Python vs C make c-build build C interpreter make c-test run C tests make c-repl C REPL
This commit is contained in:
parent
b31e03216e
commit
fc9eb5350c
13 changed files with 7557 additions and 2 deletions
86
Makefile
86
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
|
||||
|
|
|
|||
5
c/.gitignore
vendored
Normal file
5
c/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
*.o
|
||||
uncommonlisp
|
||||
test_runner
|
||||
test_runner_dbg
|
||||
bench_runner
|
||||
39
c/Makefile
Normal file
39
c/Makefile
Normal file
|
|
@ -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
|
||||
137
c/bench.c
Normal file
137
c/bench.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
1766
c/builtins.c
Normal file
1766
c/builtins.c
Normal file
File diff suppressed because it is too large
Load diff
239
c/main.c
Normal file
239
c/main.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
260
c/printer.c
Normal file
260
c/printer.c
Normal file
|
|
@ -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, "#<eof>"); 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, "#<builtin>");
|
||||
return;
|
||||
}
|
||||
|
||||
if (!IS_PTR(v)) {
|
||||
char buf[32];
|
||||
snprintf(buf, sizeof(buf), "#<unknown:%llx>", (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, "#<hash-table>");
|
||||
break;
|
||||
|
||||
case OBJ_PROC: {
|
||||
Proc *p = AS_PROC(v);
|
||||
char buf[128];
|
||||
snprintf(buf, sizeof(buf), "#<procedure %s>", 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), "#<compiled %s>", cp->name ? cp->name : "λ");
|
||||
sb_appendz(sb, buf);
|
||||
break;
|
||||
}
|
||||
|
||||
case OBJ_MACRO:
|
||||
sb_appendz(sb, "#<macro>");
|
||||
break;
|
||||
|
||||
case OBJ_CONTINUATION:
|
||||
sb_appendz(sb, "#<continuation>");
|
||||
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), "#<error-object \"%s\">", e->message);
|
||||
sb_appendz(sb, buf);
|
||||
break;
|
||||
}
|
||||
|
||||
case OBJ_ENV:
|
||||
sb_appendz(sb, "#<environment>");
|
||||
break;
|
||||
|
||||
case OBJ_CODE:
|
||||
sb_appendz(sb, "#<code>");
|
||||
break;
|
||||
|
||||
case OBJ_SYNTAX_TRANSFORMER:
|
||||
sb_appendz(sb, "#<syntax-transformer>");
|
||||
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);
|
||||
}
|
||||
393
c/reader.c
Normal file
393
c/reader.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
597
c/test.c
Normal file
597
c/test.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
854
c/types.c
Normal file
854
c/types.c
Normal file
|
|
@ -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;
|
||||
735
c/uncommonlisp.h
Normal file
735
c/uncommonlisp.h
Normal file
|
|
@ -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 <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdint.h>
|
||||
#include <stdbool.h>
|
||||
#include <math.h>
|
||||
#include <ctype.h>
|
||||
#include <assert.h>
|
||||
#include <errno.h>
|
||||
#include <time.h>
|
||||
#include <unistd.h>
|
||||
#include <sys/stat.h>
|
||||
#include <dirent.h>
|
||||
#include <setjmp.h>
|
||||
#include <stdarg.h>
|
||||
|
||||
/* ═══════════════════════════════════════════════════════════════════════════
|
||||
* Memory allocation — simple arena/malloc wrapper
|
||||
* When libgc is available, compile with -DUSE_BOEHM_GC and link -lgc
|
||||
* ═══════════════════════════════════════════════════════════════════════════ */
|
||||
|
||||
#ifdef USE_BOEHM_GC
|
||||
#include <gc.h>
|
||||
#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 */
|
||||
871
c/vm.c
Normal file
871
c/vm.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue