russell@unturf.com
b841b30bc4
Boehm's conservative pointer scan cannot recognize lumbda's Value layout — heap pointers live in the low 48 bits with QNAN + tag bits in the upper mantissa, so a raw word never looks like a heap address. Until now main.c neutralized this with GC_disable(): every allocation leaked, OOMing any long-running workload. Add precise tracing via a custom Boehm kind: - New c/gc.c: mark proc walks 8-byte words in mixed mode — when the QNAN bits are set with a pointer-bearing tag (0/2/4/5/6) extract the low-48 pointer; otherwise fall through to raw-pointer validation. GC_set_push_other_roots callback decodes NaN-boxed Values on the C stack via setjmp anchor + scan up to the stack base captured at process start. - Allocations holding Values (Pair, Env bindings, ValueStack data, ULVector data, HTEntry, Proc params + body, FullCont stack, CodeObj instrs, SymbolEntry) route through lumbda_value_malloc. Pure-byte sites (bignum limbs, char buffers, source files) stay on regular GC_MALLOC. - main.c / test.c / bench.c capture stack-base then drop GC_disable. types.c also zeros popped slots on the value stack so stale pointers do not survive a vs_pop and pin freed objects — independent correctness fix that pays off once GC actually runs. Build: USE_GC=1 (default when /usr/include/gc.h exists). Tests with GC enabled: - 88/88 c-test - 4/4 regression-named-let-leak (test that motivated GC_disable) - 205/205 functional (Python + C) - zoe-favorites all tiers (Python + C + asm + asm-full) alloc-test 1M cons drop-loop: - Before: 0.60s wall, 156 MB RSS, leaks every cell - After: 0.37s wall, 4 MB RSS, ~1500 GC cycles each freeing ~370 KB
1679 lines
65 KiB
C
1679 lines
65 KiB
C
/*
|
|
* 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_values(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_values(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_values(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_values(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_values(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_values(parts, sizeof(Value) * cap); }
|
|
parts[nparts++] = items[i];
|
|
}
|
|
ul_free(items);
|
|
} else {
|
|
if (nparts >= cap) { cap *= 2; parts = (Value *)ul_realloc_values(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_values(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_values(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_values(sizeof(Value));
|
|
|
|
/* Build: (list (quote name) f1 f2 ...) */
|
|
Value *listargs = (Value *)ul_malloc_values(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_values(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_values(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_values(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_values(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_values(sizeof(Value) * nb);
|
|
Value *bvs = (Value *)ul_malloc_values(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_values(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_values(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_values(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_values(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_values(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_values(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_values(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);
|
|
}
|