/* * 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) || IS_BIGNUM(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) || IS_BIGNUM(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) || IS_BIGNUM(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); /* Seekable files (regular): size up-front, single read. * Non-seekable files (pipes, FIFOs, sockets — e.g. bash process * substitution <(...) yields /proc/self/fd/N pointing at a pipe): * ftell returns -1, which silently casts to SIZE_MAX inside fread * and overruns the heap. Stream-read into a growable buffer instead. */ char *src = NULL; long sz = -1; if (fseek(f, 0, SEEK_END) == 0) { sz = ftell(f); if (fseek(f, 0, SEEK_SET) != 0) sz = -1; } if (sz >= 0) { src = (char *)ul_malloc((size_t)sz + 1); size_t nread = fread(src, 1, (size_t)sz, f); src[nread] = '\0'; } else { size_t cap = 4096; size_t len = 0; src = (char *)ul_malloc(cap); for (;;) { if (len + 1 >= cap) { cap *= 2; src = (char *)ul_realloc(src, cap); } size_t got = fread(src + len, 1, cap - 1 - len, f); len += got; if (got == 0) break; } src[len] = '\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); }