engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
lumbda/c/eval.c
russell@unturf.com f7352b51b0 rename: uncommonlisp -> lumbda throughout the repo 
Historical internal name "uncommonlisp" retired in favor of the
public name "lumbda" ahead of lumbda.com going live. Scope of
this commit:

Source files renamed:
  uncommonlisp.py                     -> lumbda.py
  asm/uncommonlisp.s                  -> asm/lumbda.s
  c/uncommonlisp.h                    -> c/lumbda.h
  whitepaper/uncommonlisp-whitepaper  -> whitepaper/lumbda-whitepaper (.rst + .pdf)

Binaries renamed (tracked ones; c/ was always gitignored):
  asm/uncommonlisp, asm/uncommonlisp-gc, asm/uncommonlisp.o,
  asm/uncommonlisp-gc.o                -> asm/lumbda(-gc)(.o)
  c/.gitignore                          -> ignores lumbda

Internal string updates (sed pass ordered longest-first):
  asm/uncommonlisp -> asm/lumbda
  c/uncommonlisp   -> c/lumbda
  uncommonlisp.py  -> lumbda.py
  UNCOMMONLISP_BIN -> LUMBDA_BIN (asm/test.sh env var)
  "uncommonlisp> " -> "lumbda> " (asm REPL prompt baked into binary)
  UNCOMMONLISP     -> LUMBDA (macros, comments)
  uncommonlisp     -> lumbda (prose)

Binary portal magic updated:
  "ULPORTAL" -> "LUMBDAB1"   # "Lumbda Binary v1"
Old portal files are not backward-compatible — this is a deliberate
break since it's the rename moment. S-expression portals already
carry their own ";; lumbda-portal v1" header and remain cleanly
versioned.

WHITEPAPER.pdf / WHITEPAPER.rst symlinks repointed to the renamed
files. Makefile's whitepaper target targets lumbda-whitepaper.pdf.

Not changed (intentional, separate phases):
  - Filesystem directory /home/fox/git/uncommonlisp itself
    (fox renames locally and the gitlab repo URL in a follow-up)
  - tests.py hardcoded cwd=/home/fox/git/uncommonlisp
    (matches the current on-disk location; will flip when the
    directory rename ships)
  - Git history (immutable; old commits still say uncommonlisp,
    which is correct — that's what they were)

Verified:
  137 asm no-GC + 137 asm GC + 571 Python + 83 C + 189 shared
  functional tests all pass under the new names.
  bench-gc-http (2000 req): all 4 cells behave as expected
  (cells 1/2 flat, 3 leaks, 4 bounded at 1 chunk).
  Python REPL, C REPL, asm REPL all start cleanly.
2026-04-19 10:20:11 -04:00

1656 lines
64 KiB
C
Raw Blame History

/*
* eval.c — Tree-walking evaluator with TCO via explicit loop
*
* Port of the Python leval() function with full special form support.
*/
#include "lumbda.h"
#include "jit.h"
/* ═══════════════════════════════════════════════════════════════════════════
* call/cc support — thread-local escape state
*
* MOAD-0002: These thread-locals are intentional coupling, required by the
* setjmp/longjmp escape-only call/cc implementation. The continuation closure
* (ul_callcc_kont) writes cc_escape_val and longjmps to cc_active_jmp; the
* setjmp site in eval reads them back. Threading these through every call
* frame would defeat the purpose of longjmp-based unwinding. Thread-local
* storage ensures thread safety without a context parameter.
* ═══════════════════════════════════════════════════════════════════════════ */
static __thread Value cc_escape_val;
static __thread jmp_buf *cc_active_jmp;
static Value ul_callcc_kont(Value *args, int nargs, Env *env) {
(void)env;
cc_escape_val = (nargs > 0) ? args[0] : VAL_VOID;
if (cc_active_jmp) longjmp(*cc_active_jmp, 1);
lisp_error("continuation invoked outside call/cc");
return VAL_VOID; /* unreachable */
}
/* ═══════════════════════════════════════════════════════════════════════════
* Helpers
* ═══════════════════════════════════════════════════════════════════════════ */
/* Lisp list → C array. Returns count. Caller must free *out. */
int value_to_list(Value v, Value **out) {
if (IS_NIL(v)) { *out = NULL; return 0; }
/* Count */
int n = 0;
Value cur = v;
while (IS_PAIR(cur)) { n++; cur = CDR(cur); }
if (!IS_NIL(cur)) lisp_error("not a list");
*out = (Value *)ul_malloc(sizeof(Value) * n);
cur = v;
for (int i = 0; i < n; i++) {
(*out)[i] = CAR(cur);
cur = CDR(cur);
}
return n;
}
/* C array → Lisp list */
Value list_to_value(Value *items, int count) {
Value r = VAL_NIL;
for (int i = count - 1; i >= 0; i--) {
r = cons(items[i], r);
}
return r;
}
/* Parse lambda formals */
Formals parse_formals(Value f) {
Formals result;
result.params = NULL;
result.nparams = 0;
result.rest = VAL_NIL;
if (IS_SYM(f)) {
/* (lambda x body) — all args as rest */
result.rest = f;
return result;
}
if (IS_NIL(f)) return result;
/* Count params */
int n = 0;
Value cur = f;
while (IS_PAIR(cur)) { n++; cur = CDR(cur); }
bool has_rest = !IS_NIL(cur);
result.nparams = n;
result.params = (Value *)ul_malloc(sizeof(Value) * n);
cur = f;
for (int i = 0; i < n; i++) {
if (!IS_SYM(CAR(cur)))
lisp_error("param must be symbol");
result.params[i] = CAR(cur);
cur = CDR(cur);
}
if (has_rest) {
if (!IS_SYM(cur))
lisp_error("rest param must be symbol");
result.rest = cur;
}
return result;
}
bool has_internal_defines(ExprList body) {
if (body.count == 0) return false;
Value first = body.exprs[0];
if (!IS_PAIR(first)) return false;
Value head = CAR(first);
return head == SYM_DEFINE || head == SYM_BEGIN;
}
/* Scan internal defines and pre-declare all names as VOID */
ExprList body_with_env(Value *forms, int count, Env *env) {
if (count == 0) {
ExprList r = {NULL, 0};
return r;
}
/* We may need to splice begin forms */
int cap = count + 64;
Value *expanded = (Value *)ul_malloc(sizeof(Value) * cap);
memcpy(expanded, forms, sizeof(Value) * count);
int n = count;
int i = 0;
while (i < n) {
Value f = expanded[i];
if (IS_PAIR(f) && CAR(f) == SYM_DEFINE) {
Value *a; int na = value_to_list(CDR(f), &a);
Value name;
if (IS_PAIR(a[0])) name = CAR(a[0]);
else name = a[0];
if (IS_SYM(name)) env_define(env, name, VAL_VOID);
ul_free(a);
i++;
} else if (IS_PAIR(f) && CAR(f) == SYM_BEGIN) {
/* Splice */
Value *spliced; int ns = value_to_list(CDR(f), &spliced);
if (n + ns - 1 >= cap) {
cap = (n + ns) * 2;
expanded = (Value *)ul_realloc(expanded, sizeof(Value) * cap);
}
memmove(expanded + i + ns, expanded + i + 1, sizeof(Value) * (n - i - 1));
memcpy(expanded + i, spliced, sizeof(Value) * ns);
n = n + ns - 1;
ul_free(spliced);
/* Don't increment i — re-check the first spliced form */
} else {
break;
}
}
ExprList r;
r.exprs = expanded;
r.count = n;
return r;
}
bool is_proper_list(Value v) {
Value slow = v, fast = v;
while (1) {
if (IS_NIL(fast)) return true;
if (!IS_PAIR(fast)) return false;
fast = CDR(fast);
if (IS_NIL(fast)) return true;
if (!IS_PAIR(fast)) return false;
fast = CDR(fast);
slow = CDR(slow);
if (fast == slow) return false; /* cycle */
}
}
bool values_equal(Value a, Value b) {
if (a == b) return true;
/* Both numbers */
if (is_number(a) && is_number(b)) return num_eq(a, b);
/* Both strings */
if (IS_STRING(a) && IS_STRING(b)) {
ULString *sa = AS_STRING(a), *sb = AS_STRING(b);
return sa->len == sb->len && memcmp(sa->data, sb->data, sa->len) == 0;
}
/* Both pairs — deep comparison */
if (IS_PAIR(a) && IS_PAIR(b)) {
return values_equal(CAR(a), CAR(b)) && values_equal(CDR(a), CDR(b));
}
/* Both vectors */
if (IS_VECTOR(a) && IS_VECTOR(b)) {
ULVector *va = AS_VECTOR(a), *vb = AS_VECTOR(b);
if (va->len != vb->len) return false;
for (size_t i = 0; i < va->len; i++) {
if (!values_equal(va->data[i], vb->data[i])) return false;
}
return true;
}
/* Chars */
if (IS_CHAR(a) && IS_CHAR(b)) return AS_CHAR(a) == AS_CHAR(b);
return false;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Quasiquote expander
* ═══════════════════════════════════════════════════════════════════════════ */
Value qq_expand(Value tmpl, Env *env, int depth) {
if (!IS_PAIR(tmpl)) return tmpl;
if (CAR(tmpl) == SYM_QUASIQUOTE) {
return cons(SYM_QUASIQUOTE,
cons(qq_expand(CADR(tmpl), env, depth + 1), VAL_NIL));
}
if (CAR(tmpl) == SYM_UNQUOTE) {
if (depth == 0) return leval(CADR(tmpl), env);
return cons(SYM_UNQUOTE,
cons(qq_expand(CADR(tmpl), env, depth - 1), VAL_NIL));
}
/* Collect parts */
int cap = 64;
Value *parts = (Value *)ul_malloc(sizeof(Value) * cap);
int nparts = 0;
Value n = tmpl;
while (IS_PAIR(n)) {
Value item = CAR(n);
if (IS_PAIR(item) && CAR(item) == SYM_UNQUOTE_SPLICING) {
if (depth == 0) {
Value spliced = leval(CADR(item), env);
Value *items; int ni = value_to_list(spliced, &items);
for (int i = 0; i < ni; i++) {
if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc(parts, sizeof(Value) * cap); }
parts[nparts++] = items[i];
}
ul_free(items);
} else {
if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc(parts, sizeof(Value) * cap); }
parts[nparts++] = cons(SYM_UNQUOTE_SPLICING,
cons(qq_expand(CADR(item), env, depth - 1), VAL_NIL));
}
} else {
if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc(parts, sizeof(Value) * cap); }
parts[nparts++] = qq_expand(item, env, depth);
}
n = CDR(n);
}
Value tail = IS_NIL(n) ? VAL_NIL : qq_expand(n, env, depth);
Value r = tail;
for (int i = nparts - 1; i >= 0; i--) {
r = cons(parts[i], r);
}
ul_free(parts);
return r;
}
/* ═══════════════════════════════════════════════════════════════════════════
* call_proc — Non-tail recursive call (for use inside builtins)
* ═══════════════════════════════════════════════════════════════════════════ */
Value call_proc(Value proc, Value *args, int nargs, Env *env) {
if (IS_BUILTIN(proc)) {
return AS_BUILTIN(proc)(args, nargs, env);
}
if (IS_PROC(proc)) {
Proc *p = AS_PROC(proc);
/* JIT path: try to compile and cache native code */
if (g_jit_enabled && p->jit_block == NULL && nargs <= 6) {
JitBlock *jb = jit_compile(p);
p->jit_block = jb ? (void *)jb : (void *)(uintptr_t)1;
}
if (p->jit_block && p->jit_block != (void *)(uintptr_t)1) {
JitBlock *jb = (JitBlock *)p->jit_block;
Value pad[6] = {0};
for (int i = 0; i < nargs && i < 6; i++) pad[i] = args[i];
return jb->func(pad[0], pad[1], pad[2], pad[3], pad[4], pad[5]);
}
Env *c = env_child(p->env, p->params, p->nparams, p->rest, args, nargs);
ExprList body;
if (p->has_defs) {
body = body_with_env(p->body.exprs, p->body.count, c);
} else {
body = p->body;
}
for (int i = 0; i < body.count - 1; i++) leval(body.exprs[i], c);
return leval(body.exprs[body.count - 1], c);
}
if (IS_COMPILED_PROC(proc)) {
CompiledProc *cp = AS_COMPILED_PROC(proc);
Env *c = env_child(cp->env, cp->params, cp->nparams, cp->rest, args, nargs);
return vm_exec(cp->code, c);
}
if (IS_CONTINUATION(proc)) {
/* Invoke the continuation via the VM trampoline */
FullCont *cont = AS_CONTINUATION(proc);
Value val = (nargs > 0) ? args[0] : VAL_VOID;
if (!g_cont_trampoline || !g_cont_trampoline->active) {
lisp_error("continuation invoked outside VM execution");
}
g_cont_invoked = cont;
g_cont_invoked_val = val;
longjmp(g_cont_trampoline->jmp, 1);
}
lisp_error("not callable: %s", show(proc, false));
return VAL_NIL;
}
/* ═══════════════════════════════════════════════════════════════════════════
* define-record-type
* ═══════════════════════════════════════════════════════════════════════════ */
static Value define_record_type(Value *a, int na, Env *env) {
Value name = a[0];
int ri = 1;
/* Check for (inherit parent) */
const char *parent_name = NULL;
if (ri < na && IS_PAIR(a[ri]) && CAR(a[ri]) == intern("inherit")) {
Value *inh; int ninh = value_to_list(a[ri], &inh);
parent_name = sym_name(inh[1]);
ul_free(inh);
ri++;
}
/* Constructor spec */
Value *ctor_spec; int nctor = value_to_list(a[ri], &ctor_spec);
Value ctor_name = ctor_spec[0];
char **all_fields = (char **)ul_malloc(sizeof(char *) * (nctor - 1));
int nfields = nctor - 1;
for (int i = 0; i < nfields; i++) {
all_fields[i] = ul_strdup(sym_name(ctor_spec[i + 1]));
}
ri++;
/* Predicate */
Value pred_name = a[ri++];
/* Register type */
register_record_type(sym_name(name), all_fields, nfields, parent_name);
/* Constructor: builds (name field1 field2 ...) */
/* We create a builtin closure */
{
/* Capture field count and name symbol */
const char *type_tag = sym_name(name);
int nf = nfields;
Value *field_syms = (Value *)ul_malloc(sizeof(Value) * nf);
for (int i = 0; i < nf; i++) field_syms[i] = ctor_spec[i + 1];
/* Create a Proc that builds (list 'type-name f1 f2 ...) */
/* For simplicity, we'll use a builtin */
/* But builtins can't capture — we'll use the type tag in the env */
/* Actually, let's just define a Proc that builds the list */
ExprList body;
body.count = 1;
body.exprs = (Value *)ul_malloc(sizeof(Value));
/* Build: (list (quote name) f1 f2 ...) */
Value *listargs = (Value *)ul_malloc(sizeof(Value) * (nf + 2));
listargs[0] = intern("list");
listargs[1] = cons(SYM_QUOTE, cons(name, VAL_NIL));
for (int i = 0; i < nf; i++) listargs[2 + i] = field_syms[i];
body.exprs[0] = list_to_value(listargs, nf + 2);
ul_free(listargs);
Proc *ctor = make_proc(field_syms, nf, VAL_NIL, body, env, sym_name(ctor_name));
Value ctor_val = VAL_PTR(ctor);
if (g_auto_compile) {
TRY(ctx) {
CompiledProc *cp = compile_proc(ctor, env);
ctor_val = VAL_PTR(cp);
} CATCH {
/* ignore compile failure */
} ENDTRY;
}
env_define(env, ctor_name, ctor_val);
ul_free(field_syms);
}
/* Predicate: check if instance's type tag matches */
{
const char *type_str = sym_name(name);
/* Create a builtin that captures type_str */
/* We need a closure, but builtins are just function pointers.
We'll store the type name in a small env trick. */
/* Actually for simplicity, we'll create a Proc with the right body */
Value arg_sym = intern("x");
ExprList body;
body.count = 1;
body.exprs = (Value *)ul_malloc(sizeof(Value));
/* Build: (and (pair? x) (symbol? (car x)) (eq? (car x) 'name)) */
/* Simpler: use a special check that understands subtypes */
/* We'll need a native predicate. Let's put the type name in an env binding. */
Value type_sym = intern("__record_type_tag__");
Env *pred_env = make_env(env);
env_define(pred_env, type_sym, cons(SYM_QUOTE, cons(name, VAL_NIL)));
/* (and (pair? x) (symbol? (car x))
... some way to check subtypes ...) */
/* For now, build a simple check */
body.exprs[0] = cons(intern("__record-pred?__"),
cons(arg_sym, cons(cons(SYM_QUOTE, cons(name, VAL_NIL)), VAL_NIL)));
Proc *pred = make_proc(&arg_sym, 1, VAL_NIL, body, env, sym_name(pred_name));
/* Actually, this is getting complicated. Let's just register a builtin. */
/* We'll use a different approach: store a lambda closure that checks. */
/* Simplest: use a parameter-carrying closure via env */
(void)pred; /* discard */
/* Create the body as Scheme source */
char src[256];
snprintf(src, sizeof(src),
"(lambda (x) (and (pair? x) (symbol? (car x)) (__is-subtype?__ (symbol->string (car x)) \"%s\")))",
type_str);
int nc;
Value *exprs = read_all(src, &nc, false);
Value pred_val = leval(exprs[0], env);
env_define(env, pred_name, pred_val);
ul_free(exprs);
}
/* Accessors and mutators */
for (int i = ri; i < na; i++) {
Value *spec; int nspec = value_to_list(a[i], &spec);
if (nspec < 2) { ul_free(spec); continue; }
Value field_tag = spec[0];
Value getter_name = spec[1];
Value setter_name = nspec > 2 ? spec[2] : VAL_NIL;
/* Find field index */
int idx = -1;
const char *field_str = sym_name(field_tag);
for (int j = 0; j < nfields; j++) {
if (strcmp(all_fields[j], field_str) == 0) { idx = j + 1; break; } /* +1 for type tag */
}
if (idx < 0) lisp_error("define-record-type %s: field '%s' not found",
sym_name(name), field_str);
/* Getter: (lambda (x) (list-ref x idx)) */
{
char src[128];
snprintf(src, sizeof(src), "(lambda (x) (list-ref x %d))", idx);
int nc;
Value *exprs = read_all(src, &nc, false);
env_define(env, getter_name, leval(exprs[0], env));
ul_free(exprs);
}
/* Setter */
if (!IS_NIL(setter_name)) {
char src[128];
snprintf(src, sizeof(src), "(lambda (x v) (list-set! x %d v))", idx);
int nc;
Value *exprs = read_all(src, &nc, false);
env_define(env, setter_name, leval(exprs[0], env));
ul_free(exprs);
}
ul_free(spec);
}
for (int i = 0; i < nfields; i++) ul_free(all_fields[i]);
ul_free(all_fields);
ul_free(ctor_spec);
return VAL_VOID;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Syntax-rules transformer
* ═══════════════════════════════════════════════════════════════════════════ */
/* Forward declarations for syntax-rules */
static bool sr_match(SyntaxTransformer *st, Value pat, Value form, Env *bindings);
static Value sr_expand(SyntaxTransformer *st, Value tmpl, Env *bindings);
static bool is_literal(SyntaxTransformer *st, const char *name) {
for (int i = 0; i < st->nliterals; i++) {
if (strcmp(st->literals[i], name) == 0) return true;
}
return false;
}
static bool sr_match(SyntaxTransformer *st, Value pat, Value form, Env *bindings) {
if (IS_NIL(pat)) return IS_NIL(form);
if (pat == VAL_TRUE || pat == VAL_FALSE) return pat == form;
if (IS_INT(pat) || IS_DOUBLE(pat)) return values_equal(pat, form);
if (IS_SYM(pat)) {
const char *pname = sym_name(pat);
if (is_literal(st, pname)) {
return IS_SYM(form) && strcmp(sym_name(form), pname) == 0;
}
if (pat == SYM_UNDERSCORE) return true;
env_define(bindings, pat, form);
return true;
}
if (!IS_PAIR(pat)) return values_equal(pat, form);
/* Check for ellipsis: (sub_pat ... . rest_pat) */
if (IS_PAIR(CDR(pat)) && CADR(pat) == SYM_ELLIPSIS) {
Value sub_pat = CAR(pat);
Value rest_pat = CDDR(pat);
/* Count required tail elements */
int n_rest = 0;
Value rp = rest_pat;
while (IS_PAIR(rp)) { n_rest++; rp = CDR(rp); }
/* Collect form items */
Value *items; int nitems = 0;
if (IS_PAIR(form)) {
nitems = value_to_list(form, &items);
} else if (IS_NIL(form)) {
items = NULL;
} else {
return false;
}
int n_ell = nitems - n_rest;
if (n_ell < 0) { ul_free(items); return false; }
/* Create ellipsis binding env (using vectors to hold lists) */
/* For each pattern var in sub_pat, accumulate matches */
for (int i = 0; i < n_ell; i++) {
Env *ib = make_env(NULL);
if (!sr_match(st, sub_pat, items[i], ib)) {
ul_free(items); return false;
}
/* Merge ib bindings into bindings as vectors */
for (size_t b = 0; b < ib->nbuckets; b++) {
EnvBinding *bind = ib->buckets[b];
while (bind) {
/* Accumulate: existing vector or create new one */
EnvBinding *existing = NULL;
uint32_t h = (uint32_t)((GET_PAYLOAD(bind->sym) * 2654435761ULL) % bindings->nbuckets);
EnvBinding *eb = bindings->buckets[h];
while (eb) {
if (eb->sym == bind->sym) { existing = eb; break; }
eb = eb->next;
}
if (existing && IS_VECTOR(existing->val)) {
/* Append to vector */
ULVector *vec = AS_VECTOR(existing->val);
if (vec->len >= vec->cap) {
vec->cap *= 2;
vec->data = (Value *)ul_realloc(vec->data, sizeof(Value) * vec->cap);
}
vec->data[vec->len++] = bind->val;
} else {
/* Create new vector */
Value vec = make_vector(0, VAL_NIL);
ULVector *v = AS_VECTOR(vec);
v->cap = n_ell > 0 ? (size_t)n_ell : 4;
v->data = (Value *)ul_realloc(v->data, sizeof(Value) * v->cap);
v->data[0] = bind->val;
v->len = 1;
env_define(bindings, bind->sym, vec);
}
bind = bind->next;
}
}
}
/* Match rest */
Value rest_form = list_to_value(items + n_ell, nitems - n_ell);
ul_free(items);
return sr_match(st, rest_pat, rest_form, bindings);
}
/* Normal pair */
if (!IS_PAIR(form)) return false;
return sr_match(st, CAR(pat), CAR(form), bindings) &&
sr_match(st, CDR(pat), CDR(form), bindings);
}
static Value sr_expand(SyntaxTransformer *st, Value tmpl, Env *bindings) {
if (IS_NIL(tmpl) || tmpl == VAL_TRUE || tmpl == VAL_FALSE) return tmpl;
if (IS_INT(tmpl) || IS_DOUBLE(tmpl)) return tmpl;
if (IS_STRING(tmpl)) return tmpl;
if (IS_SYM(tmpl)) {
TRY(ctx) {
Value v = env_lookup(bindings, tmpl);
if (IS_VECTOR(v)) {
lisp_error("syntax-rules: %s used without ...", sym_name(tmpl));
}
return v;
} CATCH {
return tmpl; /* Not bound — return as-is */
} ENDTRY;
return tmpl;
}
if (!IS_PAIR(tmpl)) return tmpl;
/* Check for ellipsis in template: (sub_tmpl ...) */
if (IS_PAIR(CDR(tmpl)) && CADR(tmpl) == SYM_ELLIPSIS) {
Value sub_tmpl = CAR(tmpl);
Value rest_tmpl = CDDR(tmpl);
/* Find ellipsis variables in sub_tmpl */
/* Look for symbols that have vector bindings */
int n = -1;
/* We need to find the length of ellipsis vectors */
/* Scan bindings for vectors */
for (size_t b = 0; b < bindings->nbuckets; b++) {
EnvBinding *bind = bindings->buckets[b];
while (bind) {
if (IS_VECTOR(bind->val)) {
int vlen = (int)AS_VECTOR(bind->val)->len;
if (n < 0) n = vlen;
/* Use minimum? Actually all should be same length */
}
bind = bind->next;
}
}
if (n < 0) n = 0;
/* Expand each iteration */
Value *expanded = (Value *)ul_malloc(sizeof(Value) * n);
for (int i = 0; i < n; i++) {
/* Create a sub-binding env where vector vars are replaced by their i-th element */
Env *sb = make_env(NULL);
for (size_t b = 0; b < bindings->nbuckets; b++) {
EnvBinding *bind = bindings->buckets[b];
while (bind) {
if (IS_VECTOR(bind->val)) {
ULVector *vec = AS_VECTOR(bind->val);
env_define(sb, bind->sym, i < (int)vec->len ? vec->data[i] : VAL_VOID);
} else {
env_define(sb, bind->sym, bind->val);
}
bind = bind->next;
}
}
expanded[i] = sr_expand(st, sub_tmpl, sb);
}
Value rest = sr_expand(st, rest_tmpl, bindings);
for (int i = n - 1; i >= 0; i--) {
rest = cons(expanded[i], rest);
}
ul_free(expanded);
return rest;
}
return cons(sr_expand(st, CAR(tmpl), bindings),
sr_expand(st, CDR(tmpl), bindings));
}
Value syntax_transform_value(SyntaxTransformer *st, Value form) {
for (int i = 0; i < st->nrules; i++) {
Env *bindings = make_env(NULL);
Value pat = st->rules[i].pattern;
/* pat.cdr is the actual pattern (skip keyword) */
Value actual_pat = IS_PAIR(pat) ? CDR(pat) : VAL_NIL;
if (sr_match(st, actual_pat, form, bindings)) {
return sr_expand(st, st->rules[i].tmpl, bindings);
}
}
lisp_error("syntax error: no matching syntax-rules pattern");
return VAL_NIL;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Main evaluator — TCO via explicit while loop
* ═══════════════════════════════════════════════════════════════════════════ */
Value leval(Value expr, Env *env) {
while (1) {
/* Self-evaluating */
if (IS_NIL(expr) || IS_VOID(expr) || IS_TRUE(expr) || IS_FALSE(expr) ||
IS_EOF(expr) || IS_CHAR(expr)) return expr;
if (IS_INT(expr) || IS_DOUBLE(expr) || IS_RATIONAL(expr)) return expr;
if (IS_STRING(expr)) return expr;
if (IS_VECTOR(expr)) return expr;
if (IS_BUILTIN(expr)) return expr;
/* Symbol lookup */
if (IS_SYM(expr)) return env_lookup(env, expr);
if (!IS_PAIR(expr)) return expr;
Value head = CAR(expr);
Value tail = CDR(expr);
/* ── Special forms ──────────────────────────────────────────────── */
if (head == SYM_QUOTE) {
return CAR(tail);
}
if (head == SYM_IF) {
Value *a; int na = value_to_list(tail, &a);
if (na < 2 || na > 3) lisp_error("if: need 2-3 subforms");
if (IS_TRUTHY(leval(a[0], env))) {
expr = a[1];
} else {
expr = na == 3 ? a[2] : VAL_VOID;
}
ul_free(a);
continue;
}
if (head == SYM_COND) {
Value *clauses; int nc = value_to_list(tail, &clauses);
Value result = VAL_VOID;
bool found = false;
for (int i = 0; i < nc; i++) {
Value *cl; int ncl = value_to_list(clauses[i], &cl);
if (ncl == 0) { ul_free(cl); lisp_error("cond: empty clause"); }
if (cl[0] == SYM_ELSE || IS_TRUTHY(leval(cl[0], env))) {
if (ncl == 1) {
result = cl[0] != SYM_ELSE ? leval(cl[0], env) : VAL_VOID;
ul_free(cl);
found = true;
break;
}
if (ncl == 3 && cl[1] == SYM_ARROW) {
Value v = leval(cl[0], env);
Value f = leval(cl[2], env);
ul_free(cl);
ul_free(clauses);
Value args[1] = {v};
if (IS_PROC(f)) {
Proc *p = AS_PROC(f);
env = env_child(p->env, p->params, p->nparams, p->rest, args, 1);
Value *body_exprs = p->body.exprs;
int nbody = p->body.count;
for (int j = 0; j < nbody - 1; j++) leval(body_exprs[j], env);
expr = body_exprs[nbody - 1];
goto next_iter;
}
return call_proc(f, args, 1, env);
}
for (int j = 1; j < ncl - 1; j++) leval(cl[j], env);
expr = cl[ncl - 1];
ul_free(cl);
ul_free(clauses);
goto next_iter;
}
ul_free(cl);
}
ul_free(clauses);
if (!found) return result;
return result;
}
if (head == SYM_CASE) {
/* (case key ((datum ...) body ...) ... (else body ...)) */
Value *a; int na = value_to_list(tail, &a);
Value key = leval(a[0], env);
for (int i = 1; i < na; i++) {
Value *cl; int ncl = value_to_list(a[i], &cl);
if (ncl < 1) { ul_free(cl); continue; }
if (cl[0] == SYM_ELSE) {
for (int j = 1; j < ncl - 1; j++) leval(cl[j], env);
expr = cl[ncl - 1];
ul_free(cl); ul_free(a);
goto next_iter;
}
/* Check if key is in datum list */
Value *datums; int nd = value_to_list(cl[0], &datums);
bool match = false;
for (int j = 0; j < nd; j++) {
if (values_equal(key, datums[j])) { match = true; break; }
}
ul_free(datums);
if (match) {
for (int j = 1; j < ncl - 1; j++) leval(cl[j], env);
expr = cl[ncl - 1];
ul_free(cl); ul_free(a);
goto next_iter;
}
ul_free(cl);
}
ul_free(a);
return VAL_VOID;
}
if (head == SYM_AND) {
Value *a; int na = value_to_list(tail, &a);
if (na == 0) { ul_free(a); return VAL_TRUE; }
for (int i = 0; i < na - 1; i++) {
Value v = leval(a[i], env);
if (!IS_TRUTHY(v)) { ul_free(a); return VAL_FALSE; }
}
expr = a[na - 1];
ul_free(a);
continue;
}
if (head == SYM_OR) {
Value *a; int na = value_to_list(tail, &a);
if (na == 0) { ul_free(a); return VAL_FALSE; }
for (int i = 0; i < na - 1; i++) {
Value v = leval(a[i], env);
if (IS_TRUTHY(v)) { ul_free(a); return v; }
}
expr = a[na - 1];
ul_free(a);
continue;
}
if (head == SYM_WHEN) {
Value *a; int na = value_to_list(tail, &a);
if (IS_TRUTHY(leval(a[0], env))) {
for (int i = 1; i < na - 1; i++) leval(a[i], env);
expr = a[na - 1];
ul_free(a);
continue;
}
ul_free(a);
return VAL_VOID;
}
if (head == SYM_UNLESS) {
Value *a; int na = value_to_list(tail, &a);
if (!IS_TRUTHY(leval(a[0], env))) {
for (int i = 1; i < na - 1; i++) leval(a[i], env);
expr = a[na - 1];
ul_free(a);
continue;
}
ul_free(a);
return VAL_VOID;
}
if (head == SYM_BEGIN) {
Value *a; int na = value_to_list(tail, &a);
if (na == 0) { ul_free(a); return VAL_VOID; }
for (int i = 0; i < na - 1; i++) leval(a[i], env);
expr = a[na - 1];
ul_free(a);
continue;
}
if (head == SYM_DEFINE) {
Value *a; int na = value_to_list(tail, &a);
if (na == 0) lisp_error("define: empty");
if (IS_PAIR(a[0])) {
/* (define (f x) body...) */
Value fname = CAR(a[0]);
Formals f = parse_formals(CDR(a[0]));
ExprList body = {a + 1, na - 1};
Proc *p = make_proc(f.params, f.nparams, f.rest, body, env, sym_name(fname));
Value pval = VAL_PTR(p);
if (g_auto_compile) {
TRY(ctx) {
CompiledProc *cp = compile_proc(p, env);
pval = VAL_PTR(cp);
} CATCH { } ENDTRY;
}
env_define(env, fname, pval);
} else {
Value name = a[0];
if (!IS_SYM(name)) lisp_error("define: name must be symbol");
Value val = na > 1 ? leval(a[1], env) : VAL_VOID;
if (IS_PROC(val) && !AS_PROC(val)->name) {
AS_PROC(val)->name = ul_strdup(sym_name(name));
}
if (g_auto_compile && IS_PROC(val)) {
TRY(ctx) {
CompiledProc *cp = compile_proc(AS_PROC(val), env);
val = VAL_PTR(cp);
} CATCH { } ENDTRY;
}
env_define(env, name, val);
}
ul_free(a);
return VAL_VOID;
}
if (head == SYM_DEFINE_VALUES) {
Value *a; int na = value_to_list(tail, &a);
Value *names; int nn = value_to_list(a[0], &names);
Value vals = leval(a[1], env);
/* vals could be a vector of multiple values (we use vectors for multi-values) */
if (IS_VECTOR(vals)) {
ULVector *vv = AS_VECTOR(vals);
for (int i = 0; i < nn && i < (int)vv->len; i++) {
env_define(env, names[i], vv->data[i]);
}
} else {
if (nn > 0) env_define(env, names[0], vals);
}
ul_free(names); ul_free(a);
return VAL_VOID;
}
if (head == SYM_SET) {
Value *a; int na = value_to_list(tail, &a);
(void)na;
env_set(env, a[0], leval(a[1], env));
ul_free(a);
return VAL_VOID;
}
if (head == SYM_LAMBDA || head == SYM_LAMBDA_UC) {
Value *a; int na = value_to_list(tail, &a);
if (na == 0) lisp_error("lambda: empty");
Formals f = parse_formals(a[0]);
ExprList body = {a + 1, na - 1};
Proc *p = make_proc(f.params, f.nparams, f.rest, body, env, NULL);
Value pval = VAL_PTR(p);
if (g_auto_compile) {
TRY(ctx) {
CompiledProc *cp = compile_proc(p, env);
pval = VAL_PTR(cp);
} CATCH { } ENDTRY;
}
ul_free(a);
return pval;
}
if (head == SYM_LET) {
Value *a; int na = value_to_list(tail, &a);
if (na == 0) lisp_error("let: empty");
if (IS_SYM(a[0])) {
/* Named let: (let name ((v init) ...) body...) */
Value name = a[0];
Value *binds; int nb = value_to_list(a[1], &binds);
int nbody = na - 2;
Value *body_arr = a + 2;
Value *bps = (Value *)ul_malloc(sizeof(Value) * nb);
Value *bvs = (Value *)ul_malloc(sizeof(Value) * nb);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
bps[i] = bp[0];
bvs[i] = leval(bp[1], env);
ul_free(bp);
}
Env *c = make_env(env);
ExprList body = {body_arr, nbody};
Proc *p = make_proc(bps, nb, VAL_NIL, body, c, sym_name(name));
env_define(c, name, VAL_PTR(p));
env = env_child(c, bps, nb, VAL_NIL, bvs, nb);
if (has_internal_defines(body)) {
ExprList b2 = body_with_env(body_arr, nbody, env);
for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env);
expr = b2.exprs[b2.count - 1];
} else {
for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env);
expr = body_arr[nbody - 1];
}
ul_free(bps); ul_free(bvs); ul_free(binds); ul_free(a);
continue;
}
/* Regular let */
Value *binds; int nb = value_to_list(a[0], &binds);
int nbody = na - 1;
Value *body_arr = a + 1;
Env *c = make_env(env);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
env_define(c, bp[0], leval(bp[1], env));
ul_free(bp);
}
env = c;
ExprList body = {body_arr, nbody};
if (has_internal_defines(body)) {
ExprList b2 = body_with_env(body_arr, nbody, env);
for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env);
expr = b2.exprs[b2.count - 1];
} else {
for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env);
expr = body_arr[nbody - 1];
}
ul_free(binds); ul_free(a);
continue;
}
if (head == SYM_LET_STAR) {
Value *a; int na = value_to_list(tail, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
Env *c = make_env(env);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
env_define(c, bp[0], leval(bp[1], c));
ul_free(bp);
}
int nbody = na - 1;
Value *body_arr = a + 1;
ExprList body = {body_arr, nbody};
env = c;
if (has_internal_defines(body)) {
ExprList b2 = body_with_env(body_arr, nbody, env);
for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env);
expr = b2.exprs[b2.count - 1];
} else {
for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env);
expr = body_arr[nbody - 1];
}
ul_free(binds); ul_free(a);
continue;
}
if (head == SYM_LETREC || head == SYM_LETREC_STAR) {
Value *a; int na = value_to_list(tail, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
Env *c = make_env(env);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
env_define(c, bp[0], VAL_VOID);
ul_free(bp);
}
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
env_set(c, bp[0], leval(bp[1], c));
ul_free(bp);
}
int nbody = na - 1;
Value *body_arr = a + 1;
env = c;
ExprList body = {body_arr, nbody};
if (has_internal_defines(body)) {
ExprList b2 = body_with_env(body_arr, nbody, env);
for (int i = 0; i < b2.count - 1; i++) leval(b2.exprs[i], env);
expr = b2.exprs[b2.count - 1];
} else {
for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env);
expr = body_arr[nbody - 1];
}
ul_free(binds); ul_free(a);
continue;
}
if (head == SYM_DO) {
Value *a; int na = value_to_list(tail, &a);
Value *vcs; int nvc = value_to_list(a[0], &vcs);
Value *term; int nterm = value_to_list(a[1], &term);
int nbody = na - 2;
Value *body_arr = a + 2;
Env *c = make_env(env);
/* Parse variable specs: (var init step) */
typedef struct { Value var; Value step; } DoSpec;
DoSpec *specs = (DoSpec *)ul_malloc(sizeof(DoSpec) * nvc);
for (int i = 0; i < nvc; i++) {
Value *sp; int nsp = value_to_list(vcs[i], &sp);
specs[i].var = sp[0];
env_define(c, sp[0], leval(sp[1], env));
specs[i].step = nsp > 2 ? sp[2] : sp[0];
ul_free(sp);
}
while (1) {
if (IS_TRUTHY(leval(term[0], c))) {
if (nterm == 1) {
expr = VAL_VOID;
} else {
for (int i = 1; i < nterm - 1; i++) leval(term[i], c);
expr = term[nterm - 1];
}
env = c;
break;
}
for (int i = 0; i < nbody; i++) leval(body_arr[i], c);
Value *nvs = (Value *)ul_malloc(sizeof(Value) * nvc);
for (int i = 0; i < nvc; i++) nvs[i] = leval(specs[i].step, c);
for (int i = 0; i < nvc; i++) env_set(c, specs[i].var, nvs[i]);
ul_free(nvs);
}
ul_free(specs); ul_free(vcs); ul_free(term); ul_free(a);
continue;
}
if (head == SYM_QUASIQUOTE) {
return qq_expand(CAR(tail), env, 0);
}
if (head == SYM_DEFINE_MACRO || head == SYM_DEFMACRO) {
Value *a; int na = value_to_list(tail, &a);
Value name;
Proc *xfm;
if (IS_PAIR(a[0])) {
name = CAR(a[0]);
Formals f = parse_formals(CDR(a[0]));
ExprList body = {a + 1, na - 1};
xfm = make_proc(f.params, f.nparams, f.rest, body, env, sym_name(name));
} else {
name = a[0];
Formals f = parse_formals(a[1]);
ExprList body = {a + 2, na - 2};
xfm = make_proc(f.params, f.nparams, f.rest, body, env, sym_name(name));
}
env_define(env, name, make_macro(VAL_PTR(xfm)));
ul_free(a);
return VAL_VOID;
}
if (head == SYM_DEFINE_SYNTAX) {
Value *a; int na = value_to_list(tail, &a);
Value val = leval(a[1], env);
if (IS_SYNTAX_TRANSFORMER(val)) {
env_define(env, a[0], make_macro(val));
} else {
env_define(env, a[0], val);
}
ul_free(a);
return VAL_VOID;
}
if (head == SYM_SYNTAX_RULES) {
Value *a; int na = value_to_list(tail, &a);
/* a[0] = literals, a[1..] = rules */
Value *lits; int nlits = value_to_list(a[0], &lits);
SyntaxTransformer *st = (SyntaxTransformer *)ul_malloc(sizeof(SyntaxTransformer));
st->hdr.type = OBJ_SYNTAX_TRANSFORMER;
st->nliterals = nlits;
st->literals = (char **)ul_malloc(sizeof(char *) * nlits);
for (int i = 0; i < nlits; i++) st->literals[i] = ul_strdup(sym_name(lits[i]));
st->nrules = na - 1;
st->rules = (SyntaxRule *)ul_malloc(sizeof(SyntaxRule) * st->nrules);
for (int i = 0; i < st->nrules; i++) {
Value *rl; int nrl = value_to_list(a[i + 1], &rl);
st->rules[i].pattern = rl[0];
st->rules[i].tmpl = rl[1];
ul_free(rl);
}
st->def_env = env;
ul_free(lits); ul_free(a);
return VAL_PTR(st);
}
if (head == SYM_LET_SYNTAX) {
Value *a; int na = value_to_list(tail, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
Env *c = make_env(env);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
env_define(c, bp[0], make_macro(leval(bp[1], env)));
ul_free(bp);
}
int nbody = na - 1;
for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], c);
expr = a[na - 1]; env = c;
ul_free(binds); ul_free(a);
continue;
}
if (head == SYM_LETREC_SYNTAX) {
Value *a; int na = value_to_list(tail, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
Env *c = make_env(env);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
env_define(c, bp[0], make_macro(leval(bp[1], c)));
ul_free(bp);
}
int nbody = na - 1;
for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], c);
expr = a[na - 1]; env = c;
ul_free(binds); ul_free(a);
continue;
}
if (head == SYM_VALUES) {
Value *a; int na = value_to_list(tail, &a);
if (na == 1) { Value r = leval(a[0], env); ul_free(a); return r; }
/* Multiple values: store in a vector */
Value vec = make_vector(na, VAL_NIL);
ULVector *v = AS_VECTOR(vec);
for (int i = 0; i < na; i++) v->data[i] = leval(a[i], env);
ul_free(a);
return vec;
}
if (head == SYM_CALL_WITH_VALUES) {
Value *a; int na = value_to_list(tail, &a);
Value prod = leval(a[0], env);
Value consumer = leval(a[1], env);
ul_free(a);
Value r = call_proc(prod, NULL, 0, env);
if (IS_VECTOR(r)) {
ULVector *v = AS_VECTOR(r);
return call_proc(consumer, v->data, (int)v->len, env);
}
Value args[1] = {r};
return call_proc(consumer, args, 1, env);
}
if (head == SYM_CALL_CC || head == SYM_CALL_CC2) {
/* Simple escape continuation (not full in tree-walker) */
Value *a; int na = value_to_list(tail, &a);
Value proc = leval(a[0], env);
ul_free(a);
/* Escape-only call/cc using setjmp/longjmp */
jmp_buf *saved_jmp = cc_active_jmp;
jmp_buf local_jmp;
cc_active_jmp = &local_jmp;
if (setjmp(local_jmp) != 0) {
/* Continuation was invoked — return the escape value */
cc_active_jmp = saved_jmp;
return cc_escape_val;
}
/* Build the continuation as a builtin function */
Value kont = VAL_BUILTIN(ul_callcc_kont);
Value kont_args[1] = {kont};
Value result = call_proc(proc, kont_args, 1, env);
cc_active_jmp = saved_jmp;
return result;
}
if (head == SYM_APPLY) {
Value *a; int na = value_to_list(tail, &a);
Value proc = leval(a[0], env);
/* Evaluate prefix args */
int npre = na - 2;
Value *pre = NULL;
if (npre > 0) {
pre = (Value *)ul_malloc(sizeof(Value) * npre);
for (int i = 0; i < npre; i++) pre[i] = leval(a[i + 1], env);
}
Value last = leval(a[na - 1], env);
Value *lst; int nlst = value_to_list(last, &lst);
Value *all_args = (Value *)ul_malloc(sizeof(Value) * (npre + nlst));
if (pre) memcpy(all_args, pre, sizeof(Value) * npre);
memcpy(all_args + npre, lst, sizeof(Value) * nlst);
int total = npre + nlst;
ul_free(pre); ul_free(lst); ul_free(a);
/* TCO for Proc */
if (IS_PROC(proc)) {
Proc *p = AS_PROC(proc);
env = env_child(p->env, p->params, p->nparams, p->rest, all_args, total);
ExprList body = p->has_defs ?
body_with_env(p->body.exprs, p->body.count, env) : p->body;
if (body.count == 1) expr = body.exprs[0];
else {
for (int i = 0; i < body.count - 1; i++) leval(body.exprs[i], env);
expr = body.exprs[body.count - 1];
}
ul_free(all_args);
continue;
}
Value result = call_proc(proc, all_args, total, env);
ul_free(all_args);
return result;
}
if (head == SYM_EVAL) {
/* Argument evaluates in the current env; result evaluates
* in the global env so a (define ...) inside an (eval ...)
* installs the binding where callers can see it. Matches
* Python's leval and asm's bi_eval. */
Value *a; int na = value_to_list(tail, &a);
expr = leval(a[0], env);
ul_free(a);
env = env->global ? env->global : env;
continue;
}
if (head == SYM_ERROR) {
Value *a; int na = value_to_list(tail, &a);
char *msg = show(leval(a[0], env), true);
Value *irr = NULL;
int nirr = na - 1;
if (nirr > 0) {
irr = (Value *)ul_malloc(sizeof(Value) * nirr);
for (int i = 0; i < nirr; i++) irr[i] = leval(a[i + 1], env);
}
Value obj = make_error_object(msg, irr, nirr);
ul_free(msg); ul_free(irr); ul_free(a);
/* Format full message */
char full_msg[MAX_ERROR_MSG];
ErrorObject *eo = AS_ERROR(obj);
int off = snprintf(full_msg, sizeof(full_msg), "%s", eo->message);
for (int i = 0; i < eo->nirritants && off < MAX_ERROR_MSG - 2; i++) {
char *s = show(eo->irritants[i], false);
off += snprintf(full_msg + off, sizeof(full_msg) - off, ": %s", s);
ul_free(s);
}
lisp_error_with_obj(obj, "%s", full_msg);
}
if (head == SYM_DEFINE_RECORD_TYPE) {
Value *a; int na = value_to_list(tail, &a);
Value result = define_record_type(a, na, env);
ul_free(a);
return result;
}
if (head == SYM_MODULE) {
Value *a; int na = value_to_list(tail, &a);
const char *mod_name = sym_name(a[0]);
/* Check for (export sym ...) */
char **exports = NULL;
int nexports = 0;
int body_start = 1;
if (na > 1 && IS_PAIR(a[1]) && CAR(a[1]) == SYM_EXPORT) {
Value *exp_list; int nexp = value_to_list(a[1], &exp_list);
nexports = nexp - 1;
exports = (char **)ul_malloc(sizeof(char *) * nexports);
for (int i = 0; i < nexports; i++) {
exports[i] = ul_strdup(sym_name(exp_list[i + 1]));
}
ul_free(exp_list);
body_start = 2;
}
Env *mod_env = make_env(env);
for (int i = body_start; i < na; i++) leval(a[i], mod_env);
/* Register module */
Module *m = (Module *)ul_malloc(sizeof(Module));
m->name = ul_strdup(mod_name);
m->env = mod_env;
m->exports = exports;
m->nexports = nexports;
m->next = g_modules;
g_modules = m;
ul_free(a);
return VAL_VOID;
}
if (head == SYM_IMPORT) {
Value *specs; int nspecs = value_to_list(tail, &specs);
for (int i = 0; i < nspecs; i++) {
const char *mod_name;
char **syms = NULL;
int nsyms = 0;
if (IS_SYM(specs[i])) {
mod_name = sym_name(specs[i]);
} else if (IS_PAIR(specs[i])) {
Value *items; int ni = value_to_list(specs[i], &items);
mod_name = sym_name(items[0]);
if (ni > 1) {
nsyms = ni - 1;
syms = (char **)ul_malloc(sizeof(char *) * nsyms);
for (int j = 0; j < nsyms; j++) syms[j] = ul_strdup(sym_name(items[j + 1]));
}
ul_free(items);
} else {
continue;
}
/* Find module */
Module *m = g_modules;
while (m && strcmp(m->name, mod_name) != 0) m = m->next;
if (!m) lisp_error("import: unknown module: %s", mod_name);
if (syms) {
for (int j = 0; j < nsyms; j++) {
Value sym = intern(syms[j]);
TRY(ctx) {
Value val = env_lookup(m->env, sym);
env_define(env, sym, val);
} CATCH {
lisp_error("import: %s has no export: %s", mod_name, syms[j]);
} ENDTRY;
ul_free(syms[j]);
}
ul_free(syms);
} else {
/* Import all exports or all bindings */
if (m->nexports > 0) {
for (int j = 0; j < m->nexports; j++) {
Value sym = intern(m->exports[j]);
TRY(ctx) {
Value val = env_lookup(m->env, sym);
env_define(env, sym, val);
} CATCH { } ENDTRY;
}
} else {
/* Export everything from mod_env local bindings */
for (size_t b = 0; b < m->env->nbuckets; b++) {
EnvBinding *bind = m->env->buckets[b];
while (bind) {
env_define(env, bind->sym, bind->val);
bind = bind->next;
}
}
}
}
}
ul_free(specs);
return VAL_VOID;
}
if (head == SYM_LOAD) {
Value *a; int na = value_to_list(tail, &a);
char *path = show(leval(a[0], env), true);
load_file(path, env);
ul_free(path); ul_free(a);
return VAL_VOID;
}
if (head == SYM_INCLUDE) {
Value *a; int na = value_to_list(tail, &a);
for (int i = 0; i < na; i++) {
char *path = show(leval(a[i], env), true);
load_file(path, env);
ul_free(path);
}
ul_free(a);
return VAL_VOID;
}
if (head == SYM_PARAMETERIZE) {
Value *a; int na = value_to_list(tail, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
int nbody = na - 1;
Value *body_arr = a + 1;
/* Save old values and set new */
typedef struct { Value param; Value old_val; } PBind;
PBind *pb = (PBind *)ul_malloc(sizeof(PBind) * nb);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
pb[i].param = leval(bp[0], env);
Value new_val = leval(bp[1], env);
pb[i].old_val = call_proc(pb[i].param, NULL, 0, env);
Value sv[1] = {new_val};
call_proc(pb[i].param, sv, 1, env);
ul_free(bp);
}
Value result = VAL_VOID;
TRY(ctx) {
for (int i = 0; i < nbody - 1; i++) leval(body_arr[i], env);
result = leval(body_arr[nbody - 1], env);
} CATCH {
/* Restore on error */
for (int i = 0; i < nb; i++) {
Value sv[1] = {pb[i].old_val};
call_proc(pb[i].param, sv, 1, env);
}
ul_free(pb); ul_free(binds); ul_free(a);
lisp_error("%s", ctx.message);
} ENDTRY;
/* Restore */
for (int i = 0; i < nb; i++) {
Value sv[1] = {pb[i].old_val};
call_proc(pb[i].param, sv, 1, env);
}
ul_free(pb); ul_free(binds); ul_free(a);
return result;
}
if (head == SYM_DYNAMIC_WIND) {
Value *a; int na = value_to_list(tail, &a);
Value before = leval(a[0], env);
Value thunk = leval(a[1], env);
Value after = leval(a[2], env);
ul_free(a);
call_proc(before, NULL, 0, env);
Value result;
TRY(ctx) {
result = call_proc(thunk, NULL, 0, env);
} CATCH {
call_proc(after, NULL, 0, env);
lisp_error("%s", ctx.message);
} ENDTRY;
call_proc(after, NULL, 0, env);
return result;
}
if (head == SYM_WITH_EXCEPTION_HANDLER) {
Value *a; int na = value_to_list(tail, &a);
Value handler = leval(a[0], env);
Value thunk = leval(a[1], env);
ul_free(a);
TRY(ctx) {
return call_proc(thunk, NULL, 0, env);
} CATCH {
Value err_val = ctx.error_obj;
if (IS_NIL(err_val)) err_val = make_string_from_cstr(ctx.message);
Value args[1] = {err_val};
return call_proc(handler, args, 1, env);
} ENDTRY;
return VAL_VOID;
}
if (head == SYM_GUARD) {
Value *a; int na = value_to_list(tail, &a);
Value *var_clauses; int nvc = value_to_list(a[0], &var_clauses);
Value var = var_clauses[0];
int nclauses = nvc - 1;
int nbody = na - 1;
TRY(ctx) {
for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], env);
Value result = leval(a[nbody], env);
ul_free(var_clauses); ul_free(a);
return result;
} CATCH {
Env *c = make_env(env);
Value err_val = ctx.error_obj;
if (IS_NIL(err_val)) err_val = make_string_from_cstr(ctx.message);
env_define(c, var, err_val);
for (int i = 0; i < nclauses; i++) {
Value *cl; int ncl = value_to_list(var_clauses[i + 1], &cl);
if (cl[0] == SYM_ELSE || IS_TRUTHY(leval(cl[0], c))) {
for (int j = 1; j < ncl - 1; j++) leval(cl[j], c);
Value result = leval(cl[ncl - 1], c);
ul_free(cl); ul_free(var_clauses); ul_free(a);
return result;
}
ul_free(cl);
}
/* No clause matched — re-raise */
ul_free(var_clauses); ul_free(a);
lisp_error("%s", ctx.message);
} ENDTRY;
return VAL_VOID;
}
if (head == SYM_LET_VALUES) {
Value *a; int na = value_to_list(tail, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
Env *c = make_env(env);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
Value val = leval(bp[1], env);
Value *fmls; int nf = value_to_list(bp[0], &fmls);
if (IS_VECTOR(val)) {
ULVector *vv = AS_VECTOR(val);
for (int j = 0; j < nf && j < (int)vv->len; j++)
env_define(c, fmls[j], vv->data[j]);
} else {
if (nf > 0) env_define(c, fmls[0], val);
}
ul_free(fmls); ul_free(bp);
}
int nbody = na - 1;
env = c;
for (int i = 0; i < nbody - 1; i++) leval(a[i + 1], env);
expr = a[na - 1];
ul_free(binds); ul_free(a);
continue;
}
/* ── Macro expansion ─────────────────────────────────────────── */
Value hval;
TRY(ctx) {
hval = leval(head, env);
} CATCH {
lisp_error("not callable: %s", show(head, false));
} ENDTRY;
if (IS_MACRO(hval)) {
ULMacro *m = AS_MACRO(hval);
if (IS_SYNTAX_TRANSFORMER(m->transformer)) {
Value *a; int na = value_to_list(tail, &a);
Value form = list_to_value(a, na);
expr = syntax_transform_value(AS_SYNTAX_TRANSFORMER(m->transformer), form);
ul_free(a);
continue;
}
/* Regular macro */
Value *a; int na = value_to_list(tail, &a);
expr = call_proc(m->transformer, a, na, env);
ul_free(a);
continue;
}
/* ── Procedure application ────────────────────────────────────── */
Value proc = hval;
Value *args; int nargs = value_to_list(tail, &args);
for (int i = 0; i < nargs; i++) {
args[i] = leval(args[i], env);
}
if (IS_PROC(proc)) {
Proc *p = AS_PROC(proc);
/* JIT fast path */
if (g_jit_enabled && p->jit_block == NULL && nargs <= 6) {
JitBlock *jb2 = jit_compile(p);
p->jit_block = jb2 ? (void *)jb2 : (void *)(uintptr_t)1;
}
if (p->jit_block && p->jit_block != (void *)(uintptr_t)1) {
JitBlock *jb = (JitBlock *)p->jit_block;
Value pad[6] = {0};
for (int i = 0; i < nargs && i < 6; i++) pad[i] = args[i];
ul_free(args);
return jb->func(pad[0], pad[1], pad[2], pad[3], pad[4], pad[5]);
}
env = env_child(p->env, p->params, p->nparams, p->rest, args, nargs);
ExprList body = p->has_defs ?
body_with_env(p->body.exprs, p->body.count, env) : p->body;
if (body.count == 1) expr = body.exprs[0];
else {
for (int i = 0; i < body.count - 1; i++) leval(body.exprs[i], env);
expr = body.exprs[body.count - 1];
}
ul_free(args);
continue;
}
if (IS_COMPILED_PROC(proc)) {
CompiledProc *cp = AS_COMPILED_PROC(proc);
Env *c = env_child(cp->env, cp->params, cp->nparams, cp->rest, args, nargs);
ul_free(args);
return vm_exec(cp->code, c);
}
if (IS_BUILTIN(proc)) {
Value result = AS_BUILTIN(proc)(args, nargs, env);
ul_free(args);
return result;
}
if (IS_CONTINUATION(proc)) {
Value val = (nargs > 0) ? args[0] : VAL_VOID;
ul_free(args);
if (!g_cont_trampoline || !g_cont_trampoline->active) {
lisp_error("continuation invoked outside VM execution");
}
g_cont_invoked = AS_CONTINUATION(proc);
g_cont_invoked_val = val;
longjmp(g_cont_trampoline->jmp, 1);
}
char *s = show(proc, false);
lisp_error("not callable: %s", s);
next_iter:
continue;
}
}
/* ═══════════════════════════════════════════════════════════════════════════
* File loading
* ═══════════════════════════════════════════════════════════════════════════ */
void load_file(const char *path, Env *env) {
FILE *f = fopen(path, "r");
if (!f) lisp_error("file not found: %s", path);
fseek(f, 0, SEEK_END);
long sz = ftell(f);
fseek(f, 0, SEEK_SET);
char *src = (char *)ul_malloc(sz + 1);
size_t nread = fread(src, 1, sz, f);
src[nread] = '\0';
fclose(f);
int count;
Value *exprs = read_all(src, &count, true);
ul_free(src);
for (int i = 0; i < count; i++) {
leval(exprs[i], env);
}
ul_free(exprs);
}
Reference in a new issue View git blame Copy permalink