engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
lumbda/c/builtins.c
russell@unturf.com 81ac49ece0
fork-self + waitpid-nonblock + exit-immediate + sleep primitives across c-tier + python-tier 
Substrate for fork-per-accept pattern in gpu-worker.lsp — enables
async bend dispatch with internal load balancing.

c-tier (builtins.c):
- bi_fork_self: fork() wrapper, returns 0 in child / pid in parent / #f on fail
- bi_waitpid_nonblock: waitpid(-1, WNOHANG), returns reaped pid or 0
- bi_exit_immediate: _exit() wrapper — REQUIRED in fork-self children,
  regular exit() runs atexit handlers against shared parent state and
  hangs the child (observed empirically 2026-06-11 via vm-runner.sh).
- bi_sleep: real wall-clock sleep(3) — yields CPU. Replaces busy-loop
  patterns that would (a) burn CPU and (b) SIGKILL in cgroup-limited
  VMs (observed: 100M iter let-loop SIGKILL'd after 5s in qemu vm).

python-tier (lumbda.py): _fork_self / _waitpid_nonblock / _exit_immediate
/ _sleep mirrors via os.fork / os.waitpid / os._exit / time.sleep.

Tested in vm-runner.sh VM (Ubuntu 2G/2vCPU): 3-child fork-cycle test
spawns + reaps cleanly 3/3 in both c-tier + python-tier. The exact
test pattern that crashed neoblanka host pre-fix now works fine.

Asm tier: deferred. Lock retained at chmod a-x ~/git/lumbda/asm/lumbda*
per CLAUDE.md threat model.
2026-06-11 09:24:51 -04:00

2847 lines
107 KiB
C
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/*
* builtins.c — All built-in functions for the Scheme interpreter
*/
#include "lumbda.h"
/* ═══════════════════════════════════════════════════════════════════════════
* Helper macros
* ═══════════════════════════════════════════════════════════════════════════ */
#define CHECK_ARITY(name, expected) \
if (n != (expected)) lisp_error(name ": need %d args, got %d", (expected), n)
#define CHECK_MIN_ARITY(name, expected) \
if (n < (expected)) lisp_error(name ": need at least %d args, got %d", (expected), n)
#define AS_NUM(v) \
(is_number(v) ? (v) : (lisp_error("not a number: %s", show(v, false)), VAL_NIL))
static void check_string(Value v) {
if (!IS_STRING(v)) lisp_error("not a string: %s", show(v, false));
}
static void check_sym(Value v) {
if (!IS_SYM(v)) lisp_error("not a symbol: %s", show(v, false));
}
static void check_pair(Value v) {
if (!IS_PAIR(v)) lisp_error("not a pair: %s", show(v, false));
}
/* ═══════════════════════════════════════════════════════════════════════════
* Arithmetic builtins
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_add(Value *a, int n, Env *e) {
(void)e;
if (n == 0) return VAL_INT(0);
Value result = AS_NUM(a[0]);
for (int i = 1; i < n; i++) result = num_add(result, AS_NUM(a[i]));
return result;
}
static Value bi_sub(Value *a, int n, Env *e) {
(void)e;
if (n == 0) lisp_error("-: no args");
if (n == 1) return num_neg(AS_NUM(a[0]));
Value result = AS_NUM(a[0]);
for (int i = 1; i < n; i++) result = num_sub(result, AS_NUM(a[i]));
return result;
}
static Value bi_mul(Value *a, int n, Env *e) {
(void)e;
Value result = VAL_INT(1);
for (int i = 0; i < n; i++) result = num_mul(result, AS_NUM(a[i]));
return result;
}
static Value bi_div(Value *a, int n, Env *e) {
(void)e;
if (n == 0) lisp_error("/: no args");
if (n == 1) return num_div(VAL_INT(1), AS_NUM(a[0]));
Value result = AS_NUM(a[0]);
for (int i = 1; i < n; i++) result = num_div(result, AS_NUM(a[i]));
return result;
}
#define MATH_1(name, fn) \
static Value bi_##name(Value *a, int n, Env *e) { \
(void)e; CHECK_ARITY(#name, 1); \
return make_double(fn(as_number_double(AS_NUM(a[0])))); \
}
MATH_1(sqrt, sqrt)
static Value bi_isqrt(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("isqrt", 1);
int64_t v = as_number_int(AS_NUM(a[0]));
if (v < 0) lisp_error("isqrt: negative argument: %lld", (long long)v);
if (v < 2) return VAL_INT(v);
uint64_t x = (uint64_t)v;
uint64_t res = 0;
uint64_t bit = (uint64_t)1 << 62;
while (bit > x) bit >>= 2;
while (bit != 0) {
if (x >= res + bit) { x -= res + bit; res = (res >> 1) + bit; }
else { res >>= 1; }
bit >>= 2;
}
return VAL_INT((int64_t)res);
}
MATH_1(sin, sin)
MATH_1(cos, cos)
MATH_1(tan, tan)
MATH_1(asin, asin)
MATH_1(acos, acos)
MATH_1(exp, exp)
static Value bi_log(Value *a, int n, Env *e) {
(void)e;
if (n == 1) return make_double(log(as_number_double(a[0])));
if (n == 2) return make_double(log(as_number_double(a[0])) / log(as_number_double(a[1])));
lisp_error("log: need 1-2 args");
return VAL_NIL;
}
static Value bi_atan(Value *a, int n, Env *e) {
(void)e;
if (n == 1) return make_double(atan(as_number_double(a[0])));
if (n == 2) return make_double(atan2(as_number_double(a[0]), as_number_double(a[1])));
lisp_error("atan: need 1-2 args");
return VAL_NIL;
}
static Value bi_quotient(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("quotient", 2);
if (IS_INTEGER(a[0]) && IS_INTEGER(a[1])) return big_quotient(a[0], a[1]);
return VAL_INT(as_number_int(a[0]) / as_number_int(a[1]));
}
static Value bi_remainder(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("remainder", 2);
if (IS_INTEGER(a[0]) && IS_INTEGER(a[1])) return big_remainder(a[0], a[1]);
int64_t x = as_number_int(a[0]), y = as_number_int(a[1]);
int64_t r = x % y;
/* Remainder has sign of dividend */
return VAL_INT(r);
}
static Value bi_modulo(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("modulo", 2);
if (IS_INTEGER(a[0]) && IS_INTEGER(a[1])) return big_modulo(a[0], a[1]);
int64_t x = as_number_int(a[0]), y = as_number_int(a[1]);
int64_t r = x % y;
if ((r > 0 && y < 0) || (r < 0 && y > 0)) r += y;
return VAL_INT(r);
}
static Value bi_expt(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("expt", 2);
/* Integer-base / non-negative integer-exp → bignum-aware path.
* This catches (expt 2 256) and friends — fixnum * fixnum would
* silently overflow inside the old int64 loop. */
if (IS_INTEGER(a[0]) && IS_INTEGER(a[1])) {
bool nonneg = (IS_INT(a[1]) && as_int(a[1]) >= 0) ||
(IS_BIGNUM(a[1]) && AS_BIGNUM(a[1])->sign >= 0);
if (nonneg) return big_expt(a[0], a[1]);
}
return make_double(pow(as_number_double(a[0]), as_number_double(a[1])));
}
static Value bi_abs(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("abs", 1);
if (IS_INT(a[0])) {
int64_t v = as_int(a[0]);
if (v == FIXNUM_MIN) return big_abs(a[0]); /* avoid -INT_MIN overflow */
return VAL_INT(v < 0 ? -v : v);
}
if (IS_BIGNUM(a[0])) return big_abs(a[0]);
return make_double(fabs(as_number_double(a[0])));
}
static Value bi_floor(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("floor", 1);
return VAL_INT((int64_t)floor(as_number_double(a[0])));
}
static Value bi_ceiling(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("ceiling", 1);
return VAL_INT((int64_t)ceil(as_number_double(a[0])));
}
static Value bi_round(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("round", 1);
return VAL_INT((int64_t)round(as_number_double(a[0])));
}
static Value bi_truncate(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("truncate", 1);
return VAL_INT((int64_t)trunc(as_number_double(a[0])));
}
static Value bi_min(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("min", 1);
Value r = a[0];
for (int i = 1; i < n; i++) if (num_lt(a[i], r)) r = a[i];
return r;
}
static Value bi_max(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("max", 1);
Value r = a[0];
for (int i = 1; i < n; i++) if (num_gt(a[i], r)) r = a[i];
return r;
}
static Value bi_gcd(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("gcd", 2);
int64_t x = as_number_int(a[0]), y = as_number_int(a[1]);
if (x < 0) x = -x; if (y < 0) y = -y;
while (y) { int64_t t = y; y = x % y; x = t; }
return VAL_INT(x);
}
static Value bi_lcm(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("lcm", 2);
int64_t x = as_number_int(a[0]), y = as_number_int(a[1]);
if (x < 0) x = -x; if (y < 0) y = -y;
int64_t g = x;
{ int64_t b = y; while (b) { int64_t t = b; b = g % b; g = t; } }
return VAL_INT(g ? (x / g) * y : 0);
}
static Value bi_exact(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("exact", 1);
if (IS_INT(a[0]) || IS_RATIONAL(a[0])) return a[0];
/* Approximate double → fraction */
double d = as_double(a[0]);
return rational_normalize((int64_t)(d * 1000000), 1000000);
}
static Value bi_inexact(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("inexact", 1);
return make_double(as_number_double(a[0]));
}
static Value bi_numerator(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("numerator", 1);
if (IS_RATIONAL(a[0])) return VAL_INT(AS_RATIONAL(a[0])->num);
if (IS_INT(a[0])) return a[0];
return a[0];
}
static Value bi_denominator(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("denominator", 1);
if (IS_RATIONAL(a[0])) return VAL_INT(AS_RATIONAL(a[0])->den);
return VAL_INT(1);
}
static Value bi_number_to_string(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("number->string", 1);
char buf[128];
if (n > 1) {
int base = (int)as_number_int(a[1]);
/* Bignum decimal path uses our renderer; other bases fall through to
* int64 — at our scale (256-bit secp256k1) base-10 covers every site
* that actually needs precision. */
if (IS_BIGNUM(a[0]) && base == 10) {
char *s = bignum_to_str(AS_BIGNUM(a[0]));
Value r = make_string_from_cstr(s);
ul_free(s);
return r;
}
int64_t val = as_number_int(a[0]);
switch (base) {
case 2: {
char *p = buf + 127; *p = '\0';
uint64_t uv = val < 0 ? -val : val;
if (uv == 0) { *--p = '0'; }
else { while (uv) { *--p = '0' + (uv & 1); uv >>= 1; } }
if (val < 0) *--p = '-';
return make_string_from_cstr(p);
}
case 8: snprintf(buf, sizeof(buf), "%llo", (long long)val); break;
case 16: snprintf(buf, sizeof(buf), "%llx", (long long)val); break;
default: snprintf(buf, sizeof(buf), "%lld", (long long)val); break;
}
} else {
char *s = show(a[0], false);
Value r = make_string_from_cstr(s);
ul_free(s);
return r;
}
return make_string_from_cstr(buf);
}
/* Numeric comparison builtins */
#define NUM_CMP(name, op) \
static Value bi_##name(Value *a, int n, Env *e) { \
(void)e; CHECK_MIN_ARITY(#name, 2); \
for (int i = 0; i < n - 1; i++) { \
if (!(op(AS_NUM(a[i]), AS_NUM(a[i+1])))) return VAL_FALSE; \
} \
return VAL_TRUE; \
}
NUM_CMP(num_eq, num_eq)
NUM_CMP(num_lt, num_lt)
NUM_CMP(num_gt, num_gt)
NUM_CMP(num_le, num_le)
NUM_CMP(num_ge, num_ge)
/* Numeric predicates */
#define NUM_PRED(name, check) \
static Value bi_##name(Value *a, int n, Env *e) { \
(void)e; CHECK_ARITY(#name, 1); \
return VAL_BOOL(check); \
}
NUM_PRED(zero_p, is_number(a[0]) && num_eq(a[0], VAL_INT(0)))
NUM_PRED(positive_p, is_number(a[0]) && num_gt(a[0], VAL_INT(0)))
NUM_PRED(negative_p, is_number(a[0]) && num_lt(a[0], VAL_INT(0)))
NUM_PRED(odd_p, IS_INTEGER(a[0]) && big_is_odd(a[0]))
NUM_PRED(even_p, IS_INTEGER(a[0]) && !big_is_odd(a[0]))
static Value bi_nan_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("nan?", 1);
return VAL_BOOL(IS_DOUBLE(a[0]) && isnan(as_double(a[0])));
}
static Value bi_infinite_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("infinite?", 1);
return VAL_BOOL(IS_DOUBLE(a[0]) && isinf(as_double(a[0])));
}
static Value bi_finite_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("finite?", 1);
return VAL_BOOL(is_number(a[0]) && (IS_INT(a[0]) || (IS_DOUBLE(a[0]) && isfinite(as_double(a[0])))));
}
static Value bi_square(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("square", 1);
return num_mul(a[0], a[0]);
}
static Value bi_exact_integer_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("exact-integer?", 1);
return VAL_BOOL(IS_INT(a[0]));
}
/* ═══════════════════════════════════════════════════════════════════════════
* Booleans & Equality
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_not(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("not", 1);
return VAL_BOOL(!IS_TRUTHY(a[0]));
}
static Value bi_boolean_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("boolean?", 1);
return VAL_BOOL(IS_TRUE(a[0]) || IS_FALSE(a[0]));
}
static Value bi_eq_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("eq?", 2);
if (a[0] == a[1]) return VAL_TRUE;
/* eq? on integers, booleans, symbols is value comparison */
if (IS_INT(a[0]) && IS_INT(a[1])) return VAL_BOOL(as_int(a[0]) == as_int(a[1]));
return VAL_FALSE;
}
static Value bi_eqv_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("eqv?", 2);
if (a[0] == a[1]) return VAL_TRUE;
if (IS_INT(a[0]) && IS_INT(a[1])) return VAL_BOOL(as_int(a[0]) == as_int(a[1]));
if (IS_DOUBLE(a[0]) && IS_DOUBLE(a[1])) return VAL_BOOL(as_double(a[0]) == as_double(a[1]));
if (IS_CHAR(a[0]) && IS_CHAR(a[1])) return VAL_BOOL(AS_CHAR(a[0]) == AS_CHAR(a[1]));
if (IS_STRING(a[0]) && IS_STRING(a[1])) {
ULString *s1 = AS_STRING(a[0]), *s2 = AS_STRING(a[1]);
return VAL_BOOL(s1->len == s2->len && memcmp(s1->data, s2->data, s1->len) == 0);
}
return VAL_FALSE;
}
static Value bi_equal_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("equal?", 2);
return VAL_BOOL(values_equal(a[0], a[1]));
}
/* ═══════════════════════════════════════════════════════════════════════════
* Type predicates
* ═══════════════════════════════════════════════════════════════════════════ */
#define TYPE_PRED(name, check) \
static Value bi_##name(Value *a, int n, Env *e) { \
(void)e; CHECK_ARITY(#name, 1); \
return VAL_BOOL(check); \
}
TYPE_PRED(number_p, is_number(a[0]))
TYPE_PRED(integer_p, IS_INT(a[0]) || IS_BIGNUM(a[0]) || (IS_DOUBLE(a[0]) && as_double(a[0]) == floor(as_double(a[0]))))
TYPE_PRED(real_p, is_number(a[0]))
TYPE_PRED(rational_p, IS_INT(a[0]) || IS_BIGNUM(a[0]) || IS_RATIONAL(a[0]) || (IS_DOUBLE(a[0]) && isfinite(as_double(a[0]))))
TYPE_PRED(exact_p, IS_INT(a[0]) || IS_BIGNUM(a[0]) || IS_RATIONAL(a[0]))
TYPE_PRED(inexact_p, IS_DOUBLE(a[0]))
TYPE_PRED(pair_p, IS_PAIR(a[0]))
TYPE_PRED(null_p, IS_NIL(a[0]))
TYPE_PRED(list_p, is_proper_list(a[0]))
TYPE_PRED(symbol_p, IS_SYM(a[0]))
TYPE_PRED(string_p, IS_STRING(a[0]))
TYPE_PRED(char_p, IS_CHAR(a[0]))
TYPE_PRED(vector_p, IS_VECTOR(a[0]))
TYPE_PRED(procedure_p, is_callable(a[0]))
TYPE_PRED(void_p, IS_VOID(a[0]))
TYPE_PRED(eof_object_p, IS_EOF(a[0]))
TYPE_PRED(port_p, IS_PORT(a[0]))
TYPE_PRED(input_port_p, IS_PORT(a[0]) && AS_PORT(a[0])->dir == PORT_INPUT)
TYPE_PRED(output_port_p, IS_PORT(a[0]) && AS_PORT(a[0])->dir == PORT_OUTPUT)
TYPE_PRED(hash_table_p, IS_HASHTABLE(a[0]))
/* ═══════════════════════════════════════════════════════════════════════════
* Pairs & Lists
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_cons(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("cons", 2);
return cons(a[0], a[1]);
}
static Value bi_car(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("car", 1); check_pair(a[0]);
return CAR(a[0]);
}
static Value bi_cdr(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("cdr", 1); check_pair(a[0]);
return CDR(a[0]);
}
static Value bi_set_car(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("set-car!", 2); check_pair(a[0]);
AS_PAIR(a[0])->car = a[1];
return VAL_VOID;
}
static Value bi_set_cdr(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("set-cdr!", 2); check_pair(a[0]);
AS_PAIR(a[0])->cdr = a[1];
return VAL_VOID;
}
static Value bi_list(Value *a, int n, Env *e) {
(void)e;
return list_to_value(a, n);
}
static Value bi_length(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("length", 1);
Value *items; int count = value_to_list(a[0], &items);
ul_free(items);
return VAL_INT(count);
}
static Value bi_append(Value *a, int n, Env *e) {
(void)e;
if (n == 0) return VAL_NIL;
Value result = a[n - 1];
for (int i = n - 2; i >= 0; i--) {
Value *items; int ni = value_to_list(a[i], &items);
for (int j = ni - 1; j >= 0; j--) result = cons(items[j], result);
ul_free(items);
}
return result;
}
static Value bi_reverse(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("reverse", 1);
Value *items; int ni = value_to_list(a[0], &items);
Value result = VAL_NIL;
for (int i = 0; i < ni; i++) result = cons(items[i], result);
ul_free(items);
return result;
}
static Value bi_list_tail(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("list-tail", 2);
int k = (int)as_number_int(a[1]);
Value lst = a[0];
for (int i = 0; i < k; i++) { check_pair(lst); lst = CDR(lst); }
return lst;
}
static Value bi_list_ref(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("list-ref", 2);
int k = (int)as_number_int(a[1]);
Value lst = a[0];
for (int i = 0; i < k; i++) { check_pair(lst); lst = CDR(lst); }
check_pair(lst);
return CAR(lst);
}
static Value bi_list_set(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("list-set!", 3);
int k = (int)as_number_int(a[1]);
Value lst = a[0];
for (int i = 0; i < k; i++) { check_pair(lst); lst = CDR(lst); }
check_pair(lst);
AS_PAIR(lst)->car = a[2];
return VAL_VOID;
}
static Value bi_list_copy(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("list-copy", 1);
Value *items; int ni = value_to_list(a[0], &items);
Value r = list_to_value(items, ni);
ul_free(items);
return r;
}
static Value bi_make_list(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("make-list", 1);
int len = (int)as_number_int(a[0]);
Value fill = n > 1 ? a[1] : VAL_FALSE;
Value r = VAL_NIL;
for (int i = 0; i < len; i++) r = cons(fill, r);
return r;
}
static Value bi_iota(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("iota", 1);
int count = (int)as_number_int(a[0]);
int start = n > 1 ? (int)as_number_int(a[1]) : 0;
int step = n > 2 ? (int)as_number_int(a[2]) : 1;
Value r = VAL_NIL;
for (int i = count - 1; i >= 0; i--) r = cons(VAL_INT(start + i * step), r);
return r;
}
static Value bi_memq(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("memq", 2);
Value lst = a[1];
while (IS_PAIR(lst)) {
if (CAR(lst) == a[0] || (IS_INT(CAR(lst)) && IS_INT(a[0]) && as_int(CAR(lst)) == as_int(a[0])))
return lst;
lst = CDR(lst);
}
return VAL_FALSE;
}
static Value bi_memv(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("memv", 2);
Value lst = a[1];
while (IS_PAIR(lst)) {
if (values_equal(CAR(lst), a[0])) return lst;
lst = CDR(lst);
}
return VAL_FALSE;
}
static Value bi_member(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("member", 2);
Value lst = a[1];
while (IS_PAIR(lst)) {
if (values_equal(CAR(lst), a[0])) return lst;
lst = CDR(lst);
}
return VAL_FALSE;
}
static Value bi_assq(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("assq", 2);
Value lst = a[1];
while (IS_PAIR(lst)) {
Value pair = CAR(lst);
if (IS_PAIR(pair) && CAR(pair) == a[0]) return pair;
lst = CDR(lst);
}
return VAL_FALSE;
}
static Value bi_assoc(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("assoc", 2);
Value lst = a[1];
while (IS_PAIR(lst)) {
Value pair = CAR(lst);
if (IS_PAIR(pair) && values_equal(CAR(pair), a[0])) return pair;
lst = CDR(lst);
}
return VAL_FALSE;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Higher-order functions
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_map(Value *a, int n, Env *e) {
CHECK_MIN_ARITY("map", 2);
Value proc = a[0];
/* Collect all lists */
int nlists = n - 1;
Value *lists = a + 1;
Value **items_arr = (Value **)ul_malloc(sizeof(Value *) * nlists);
int min_len = INT32_MAX;
for (int i = 0; i < nlists; i++) {
int ni;
items_arr[i] = NULL;
ni = value_to_list(lists[i], &items_arr[i]);
if (ni < min_len) min_len = ni;
}
Value *results = (Value *)ul_malloc_values(sizeof(Value) * min_len);
Value *call_args = (Value *)ul_malloc_values(sizeof(Value) * nlists);
for (int j = 0; j < min_len; j++) {
for (int i = 0; i < nlists; i++) call_args[i] = items_arr[i][j];
results[j] = call_proc(proc, call_args, nlists, e);
}
Value r = list_to_value(results, min_len);
for (int i = 0; i < nlists; i++) ul_free(items_arr[i]);
ul_free(items_arr); ul_free(results); ul_free(call_args);
return r;
}
static Value bi_for_each(Value *a, int n, Env *e) {
CHECK_MIN_ARITY("for-each", 2);
Value proc = a[0];
int nlists = n - 1;
Value *lists = a + 1;
Value **items_arr = (Value **)ul_malloc(sizeof(Value *) * nlists);
int min_len = INT32_MAX;
for (int i = 0; i < nlists; i++) {
int ni;
ni = value_to_list(lists[i], &items_arr[i]);
if (ni < min_len) min_len = ni;
}
Value *call_args = (Value *)ul_malloc_values(sizeof(Value) * nlists);
for (int j = 0; j < min_len; j++) {
for (int i = 0; i < nlists; i++) call_args[i] = items_arr[i][j];
call_proc(proc, call_args, nlists, e);
}
for (int i = 0; i < nlists; i++) ul_free(items_arr[i]);
ul_free(items_arr); ul_free(call_args);
return VAL_VOID;
}
static Value bi_filter(Value *a, int n, Env *e) {
CHECK_ARITY("filter", 2);
Value proc = a[0];
Value *items; int ni = value_to_list(a[1], &items);
Value *results = (Value *)ul_malloc_values(sizeof(Value) * ni);
int nr = 0;
for (int i = 0; i < ni; i++) {
Value v = call_proc(proc, &items[i], 1, e);
if (IS_TRUTHY(v)) results[nr++] = items[i];
}
Value r = list_to_value(results, nr);
ul_free(items); ul_free(results);
return r;
}
static Value bi_fold_left(Value *a, int n, Env *e) {
CHECK_ARITY("fold-left", 3);
Value proc = a[0];
Value acc = a[1];
Value *items; int ni = value_to_list(a[2], &items);
for (int i = 0; i < ni; i++) {
Value args[2] = {items[i], acc};
acc = call_proc(proc, args, 2, e);
}
ul_free(items);
return acc;
}
static Value bi_fold_right(Value *a, int n, Env *e) {
CHECK_ARITY("fold-right", 3);
Value proc = a[0];
Value acc = a[1];
Value *items; int ni = value_to_list(a[2], &items);
for (int i = ni - 1; i >= 0; i--) {
Value args[2] = {items[i], acc};
acc = call_proc(proc, args, 2, e);
}
ul_free(items);
return acc;
}
static Value bi_any(Value *a, int n, Env *e) {
CHECK_ARITY("any", 2);
Value *items; int ni = value_to_list(a[1], &items);
for (int i = 0; i < ni; i++) {
Value v = call_proc(a[0], &items[i], 1, e);
if (IS_TRUTHY(v)) { ul_free(items); return v; }
}
ul_free(items); return VAL_FALSE;
}
static Value bi_every(Value *a, int n, Env *e) {
CHECK_ARITY("every", 2);
Value *items; int ni = value_to_list(a[1], &items);
for (int i = 0; i < ni; i++) {
Value v = call_proc(a[0], &items[i], 1, e);
if (!IS_TRUTHY(v)) { ul_free(items); return VAL_FALSE; }
}
ul_free(items); return VAL_TRUE;
}
static Value bi_find(Value *a, int n, Env *e) {
CHECK_ARITY("find", 2);
Value *items; int ni = value_to_list(a[1], &items);
for (int i = 0; i < ni; i++) {
Value v = call_proc(a[0], &items[i], 1, e);
if (IS_TRUTHY(v)) { Value r = items[i]; ul_free(items); return r; }
}
ul_free(items); return VAL_FALSE;
}
static Value bi_sort(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("sort", 1);
Value *items; int ni = value_to_list(a[0], &items);
/* Simple insertion sort */
for (int i = 1; i < ni; i++) {
Value key = items[i];
int j = i - 1;
while (j >= 0 && num_gt(items[j], key)) {
items[j + 1] = items[j]; j--;
}
items[j + 1] = key;
}
Value r = list_to_value(items, ni);
ul_free(items);
return r;
}
static Value bi_count(Value *a, int n, Env *e) {
CHECK_ARITY("count", 2);
Value *items; int ni = value_to_list(a[1], &items);
int c = 0;
for (int i = 0; i < ni; i++) {
if (IS_TRUTHY(call_proc(a[0], &items[i], 1, e))) c++;
}
ul_free(items);
return VAL_INT(c);
}
static Value bi_apply(Value *a, int n, Env *e) {
CHECK_MIN_ARITY("apply", 2);
Value proc = a[0];
int npre = n - 2;
Value last = a[n - 1];
Value *lst; int nlst = value_to_list(last, &lst);
int total = npre + nlst;
Value *all = (Value *)ul_malloc_values(sizeof(Value) * total);
for (int i = 0; i < npre; i++) all[i] = a[i + 1];
memcpy(all + npre, lst, sizeof(Value) * nlst);
Value r = call_proc(proc, all, total, e);
ul_free(lst); ul_free(all);
return r;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Strings
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_make_string(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("make-string", 1);
int len = (int)as_number_int(a[0]);
char fill = n > 1 && IS_CHAR(a[1]) ? (char)AS_CHAR(a[1]) : ' ';
char *buf = (char *)ul_malloc(len + 1);
memset(buf, fill, len); buf[len] = '\0';
Value r = make_string(buf, len, true);
ul_free(buf);
return r;
}
static Value bi_string_length(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-length", 1); check_string(a[0]);
return VAL_INT(AS_STRING(a[0])->len);
}
static Value bi_string_ref(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-ref", 2); check_string(a[0]);
int idx = (int)as_number_int(a[1]);
ULString *s = AS_STRING(a[0]);
if (idx < 0 || idx >= (int)s->len) lisp_error("string-ref: index out of range");
/* Cast through unsigned char so bytes 0x80..0xFF map to codepoints
* 128..255 rather than sign-extending to negative ints — emit-stream
* stores binary op bytes through (make-string 1 (integer->char b))
* + (string-ref s 0); without this, char->integer of 0xFF returned
* -1, so u64-le's serialization produced a sentinel-shaped giant. */
return VAL_CHAR((unsigned char)s->data[idx]);
}
static Value bi_substring(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("substring", 2); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
int start = (int)as_number_int(a[1]);
int end = n > 2 ? (int)as_number_int(a[2]) : (int)s->len;
if (start < 0) start = 0;
if (end > (int)s->len) end = (int)s->len;
return make_string(s->data + start, end - start, false);
}
static Value bi_string_append(Value *a, int n, Env *e) {
(void)e;
size_t total = 0;
for (int i = 0; i < n; i++) {
check_string(a[i]);
total += AS_STRING(a[i])->len;
}
char *buf = (char *)ul_malloc(total + 1);
size_t pos = 0;
for (int i = 0; i < n; i++) {
ULString *s = AS_STRING(a[i]);
memcpy(buf + pos, s->data, s->len);
pos += s->len;
}
buf[pos] = '\0';
Value r = make_string(buf, pos, false);
ul_free(buf);
return r;
}
static Value bi_string_to_list(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string->list", 1); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
Value r = VAL_NIL;
for (int i = (int)s->len - 1; i >= 0; i--) r = cons(VAL_CHAR(s->data[i]), r);
return r;
}
static Value bi_list_to_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("list->string", 1);
Value *items; int ni = value_to_list(a[0], &items);
char *buf = (char *)ul_malloc(ni + 1);
for (int i = 0; i < ni; i++) buf[i] = IS_CHAR(items[i]) ? (char)AS_CHAR(items[i]) : '?';
buf[ni] = '\0';
ul_free(items);
Value r = make_string(buf, ni, false);
ul_free(buf);
return r;
}
static Value bi_string_to_symbol(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string->symbol", 1); check_string(a[0]);
return intern(AS_STRING(a[0])->data);
}
static Value bi_symbol_to_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("symbol->string", 1); check_sym(a[0]);
return make_string_from_cstr(sym_name(a[0]));
}
static Value bi_string_to_number(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("string->number", 1); check_string(a[0]);
const char *s = AS_STRING(a[0])->data;
int base = n > 1 ? (int)as_number_int(a[1]) : 10;
/* Detect all-digit (optionally signed) shape → integer (fixnum or
* bignum on overflow). */
{
const char *p = s;
if (*p == '-' || *p == '+') p++;
bool all_digits = (*p != '\0');
for (const char *q = p; *q; q++) {
char c = *q;
int dval;
if (c >= '0' && c <= '9') dval = c - '0';
else if (base > 10 && c >= 'a' && c <= 'z') dval = c - 'a' + 10;
else if (base > 10 && c >= 'A' && c <= 'Z') dval = c - 'A' + 10;
else { all_digits = false; break; }
if (dval >= base) { all_digits = false; break; }
}
if (all_digits) {
char *end;
errno = 0;
long long val = strtoll(s, &end, base);
if (*end == '\0' && errno == 0 && FITS_FIXNUM(val))
return VAL_INT(val);
return make_bignum_from_str(s, base);
}
}
char *end;
errno = 0;
long long val = strtoll(s, &end, base);
if (*end == '\0' && errno == 0) return VAL_INT(val);
if (base == 10) {
double d = strtod(s, &end);
if (*end == '\0' && errno == 0) return make_double(d);
/* Try rational */
const char *slash = strchr(s, '/');
if (slash) {
int64_t num = strtoll(s, NULL, 10);
int64_t den = strtoll(slash + 1, NULL, 10);
if (den != 0) return rational_normalize(num, den);
}
}
return VAL_FALSE;
}
static Value bi_string_upcase(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-upcase", 1); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
char *buf = (char *)ul_malloc(s->len + 1);
for (size_t i = 0; i < s->len; i++) buf[i] = toupper(s->data[i]);
buf[s->len] = '\0';
Value r = make_string(buf, s->len, false);
ul_free(buf);
return r;
}
static Value bi_string_downcase(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-downcase", 1); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
char *buf = (char *)ul_malloc(s->len + 1);
for (size_t i = 0; i < s->len; i++) buf[i] = tolower(s->data[i]);
buf[s->len] = '\0';
Value r = make_string(buf, s->len, false);
ul_free(buf);
return r;
}
static Value bi_string_eq(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string=?", 2); check_string(a[0]); check_string(a[1]);
ULString *s1 = AS_STRING(a[0]), *s2 = AS_STRING(a[1]);
return VAL_BOOL(s1->len == s2->len && memcmp(s1->data, s2->data, s1->len) == 0);
}
static Value bi_string_lt(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string<?", 2); check_string(a[0]); check_string(a[1]);
return VAL_BOOL(strcmp(AS_STRING(a[0])->data, AS_STRING(a[1])->data) < 0);
}
static Value bi_format(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("format", 1);
check_string(a[0]);
const char *fmt = AS_STRING(a[0])->data;
size_t fmtlen = AS_STRING(a[0])->len;
char buf[4096];
int pos = 0, ai = 1;
for (size_t i = 0; i < fmtlen && pos < 4090; i++) {
if (fmt[i] == '~' && i + 1 < fmtlen) {
i++;
switch (fmt[i]) {
case 'a': { char *s = show(a[ai++], true); pos += snprintf(buf + pos, sizeof(buf) - pos, "%s", s); ul_free(s); break; }
case 's': { char *s = show(a[ai++], false); pos += snprintf(buf + pos, sizeof(buf) - pos, "%s", s); ul_free(s); break; }
case '%': buf[pos++] = '\n'; break;
case '~': buf[pos++] = '~'; break;
default: buf[pos++] = '~'; buf[pos++] = fmt[i]; break;
}
} else {
buf[pos++] = fmt[i];
}
}
buf[pos] = '\0';
return make_string_from_cstr(buf);
}
/* ═══════════════════════════════════════════════════════════════════════════
* Characters
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_char_to_integer(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("char->integer", 1);
return VAL_INT(AS_CHAR(a[0]));
}
static Value bi_integer_to_char(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("integer->char", 1);
return VAL_CHAR((int)as_number_int(a[0]));
}
static Value bi_char_alphabetic(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("char-alphabetic?", 1);
return VAL_BOOL(isalpha(AS_CHAR(a[0])));
}
static Value bi_char_numeric(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("char-numeric?", 1);
return VAL_BOOL(isdigit(AS_CHAR(a[0])));
}
static Value bi_char_whitespace(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("char-whitespace?", 1);
return VAL_BOOL(isspace(AS_CHAR(a[0])));
}
static Value bi_char_eq(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("char=?", 2);
return VAL_BOOL(AS_CHAR(a[0]) == AS_CHAR(a[1]));
}
/* ═══════════════════════════════════════════════════════════════════════════
* Vectors
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_make_vector(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("make-vector", 1);
int len = (int)as_number_int(a[0]);
Value fill = n > 1 ? a[1] : VAL_INT(0);
return make_vector(len, fill);
}
static Value bi_vector(Value *a, int n, Env *e) {
(void)e;
return make_vector_from(a, n);
}
static Value bi_vector_length(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("vector-length", 1);
return VAL_INT(AS_VECTOR(a[0])->len);
}
static Value bi_vector_ref(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("vector-ref", 2);
int idx = (int)as_number_int(a[1]);
return AS_VECTOR(a[0])->data[idx];
}
static Value bi_vector_set(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("vector-set!", 3);
int idx = (int)as_number_int(a[1]);
AS_VECTOR(a[0])->data[idx] = a[2];
return VAL_VOID;
}
static Value bi_vector_to_list(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("vector->list", 1);
ULVector *v = AS_VECTOR(a[0]);
return list_to_value(v->data, (int)v->len);
}
static Value bi_list_to_vector(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("list->vector", 1);
Value *items; int ni = value_to_list(a[0], &items);
Value r = make_vector_from(items, ni);
ul_free(items);
return r;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Hash tables
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_make_hash_table(Value *a, int n, Env *e) {
(void)e;
return make_hashtable();
}
static Value bi_hash_table_set(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-set!", 3);
ht_set(AS_HASHTABLE(a[0]), a[1], a[2]);
return VAL_VOID;
}
static Value bi_hash_table_ref(Value *a, int n, Env *e) {
CHECK_MIN_ARITY("hash-table-ref", 2);
bool found;
Value v = ht_ref(AS_HASHTABLE(a[0]), a[1], &found);
if (!found) {
if (n > 2) return call_proc(a[2], NULL, 0, e);
lisp_error("hash-table-ref: missing key");
}
return v;
}
static Value bi_hash_table_ref_default(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-ref/default", 3);
bool found;
Value v = ht_ref(AS_HASHTABLE(a[0]), a[1], &found);
return found ? v : a[2];
}
static Value bi_hash_table_delete(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-delete!", 2);
ht_delete(AS_HASHTABLE(a[0]), a[1]);
return VAL_VOID;
}
static Value bi_hash_table_exists(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-exists?", 2);
bool found;
ht_ref(AS_HASHTABLE(a[0]), a[1], &found);
return VAL_BOOL(found);
}
static Value bi_hash_table_size(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-size", 1);
return VAL_INT(ht_count(AS_HASHTABLE(a[0])));
}
static Value bi_hash_table_keys(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-keys", 1);
ULHashTable *ht = AS_HASHTABLE(a[0]);
Value r = VAL_NIL;
for (size_t i = 0; i < ht->nbuckets; i++) {
HTEntry *entry = ht->buckets[i];
while (entry) { r = cons(entry->key, r); entry = entry->next; }
}
return r;
}
static Value bi_hash_table_values(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("hash-table-values", 1);
ULHashTable *ht = AS_HASHTABLE(a[0]);
Value r = VAL_NIL;
for (size_t i = 0; i < ht->nbuckets; i++) {
HTEntry *entry = ht->buckets[i];
while (entry) { r = cons(entry->value, r); entry = entry->next; }
}
return r;
}
/* ═══════════════════════════════════════════════════════════════════════════
* I/O
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_display(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("display", 1);
FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout;
if (!out) out = stdout;
char *s = show(a[0], true);
if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) {
port_write_str(AS_PORT(a[1]), s, strlen(s));
} else {
fputs(s, out);
fflush(out);
}
ul_free(s);
return VAL_VOID;
}
static Value bi_write(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("write", 1);
FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout;
if (!out) out = stdout;
char *s = show(a[0], false);
if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) {
port_write_str(AS_PORT(a[1]), s, strlen(s));
} else {
fputs(s, out);
fflush(out);
}
ul_free(s);
return VAL_VOID;
}
static Value bi_newline(Value *a, int n, Env *e) {
(void)e;
FILE *out = n > 0 && IS_PORT(a[0]) ? AS_PORT(a[0])->fp : stdout;
if (!out) out = stdout;
fputc('\n', out);
fflush(out);
return VAL_VOID;
}
static Value bi_print(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("print", 1);
char *s = show(a[0], true);
printf("%s\n", s);
fflush(stdout);
ul_free(s);
return VAL_VOID;
}
static Value bi_read_line(Value *a, int n, Env *e) {
(void)e;
if (n > 0 && IS_PORT(a[0])) {
char *line = port_read_line(AS_PORT(a[0]));
if (!line) return VAL_EOF;
Value r = make_string_from_cstr(line);
ul_free(line);
return r;
}
char buf[4096];
if (!fgets(buf, sizeof(buf), stdin)) return VAL_EOF;
size_t len = strlen(buf);
if (len > 0 && buf[len-1] == '\n') buf[--len] = '\0';
return make_string(buf, len, false);
}
static Value bi_read_char(Value *a, int n, Env *e) {
(void)e;
int ch;
if (n > 0 && IS_PORT(a[0])) {
ch = port_read_char(AS_PORT(a[0]));
} else {
ch = fgetc(stdin);
}
if (ch == EOF) return VAL_EOF;
return VAL_CHAR(ch);
}
static Value bi_open_input_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("open-input-file", 1); check_string(a[0]);
FILE *f = fopen(AS_STRING(a[0])->data, "r");
if (!f) lisp_error("open-input-file: cannot open: %s", AS_STRING(a[0])->data);
return make_file_port(f, PORT_INPUT);
}
static Value bi_open_output_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("open-output-file", 1); check_string(a[0]);
FILE *f = fopen(AS_STRING(a[0])->data, "w");
if (!f) lisp_error("open-output-file: cannot open: %s", AS_STRING(a[0])->data);
return make_file_port(f, PORT_OUTPUT);
}
/* open-binary-output-file: like open-output-file but opens in w+b mode
* so emit-stream can stream gates directly to disk AND seek back to
* rewrite the header once n_ops is known. Pairs with port-set-position!. */
static Value bi_open_binary_output_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("open-binary-output-file", 1); check_string(a[0]);
FILE *f = fopen(AS_STRING(a[0])->data, "w+b");
if (!f) lisp_error("open-binary-output-file: cannot open: %s", AS_STRING(a[0])->data);
return make_file_port(f, PORT_OUTPUT);
}
/* port-set-position!: fseek to absolute byte offset on a file port.
* Errors on string ports. Returns VOID. */
static Value bi_port_set_position(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("port-set-position!", 2);
ULPort *p = AS_PORT(a[0]);
if (p->kind != PORT_FILE) {
lisp_error("port-set-position!: port must be a file port");
}
long offset = (long)as_int(a[1]);
if (fseek(p->fp, offset, SEEK_SET) != 0) {
lisp_error("port-set-position!: fseek failed");
}
return VAL_VOID;
}
static Value bi_write_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("write-file", 2); check_string(a[0]); check_string(a[1]);
FILE *f = fopen(AS_STRING(a[0])->data, "w");
if (!f) return VAL_FALSE;
ULString *s = AS_STRING(a[1]);
size_t wrote = fwrite(s->data, 1, s->len, f);
fclose(f);
return wrote == (size_t)s->len ? VAL_TRUE : VAL_FALSE;
}
static Value bi_file_to_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("file->string", 1); check_string(a[0]);
FILE *f = fopen(AS_STRING(a[0])->data, "rb");
if (!f) return VAL_FALSE;
fseek(f, 0, SEEK_END);
long size = ftell(f);
fseek(f, 0, SEEK_SET);
char *buf = ul_malloc(size + 1);
size_t got = fread(buf, 1, size, f);
fclose(f);
buf[got] = '\0';
Value r = make_string(buf, got, false);
ul_free(buf);
return r;
}
static Value bi_open_input_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("open-input-string", 1); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
return make_string_input_port(s->data, s->len);
}
/* ── TCP sockets: fd wrapped in a FILE* via fdopen, unbuffered ─ */
#include <sys/socket.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include <netdb.h>
#include <unistd.h>
#include <fcntl.h>
static Value wrap_fd_as_port(int fd, PortDir dir) {
FILE *fp = fdopen(fd, dir == PORT_INPUT ? "rb" : "r+b");
if (!fp) { close(fd); return VAL_FALSE; }
setvbuf(fp, NULL, _IONBF, 0);
return make_file_port(fp, dir);
}
static Value bi_tcp_listen(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("tcp-listen", 1);
int port = (int)as_int(a[0]);
int fd = socket(AF_INET, SOCK_STREAM, 0);
if (fd < 0) return VAL_FALSE;
int one = 1;
setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(one));
/* SO_REUSEPORT lets N processes bind() the same port. Kernel hashes
incoming connections across the listening sockets so each accept()
returns a fresh client to whichever process is ready. Used by bend
to run multiple workers behind one port without an external
distributor. */
setsockopt(fd, SOL_SOCKET, SO_REUSEPORT, &one, sizeof(one));
struct sockaddr_in addr = {0};
addr.sin_family = AF_INET;
addr.sin_addr.s_addr = htonl(INADDR_ANY);
addr.sin_port = htons((uint16_t)port);
if (bind(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { close(fd); return VAL_FALSE; }
if (listen(fd, 128) < 0) { close(fd); return VAL_FALSE; }
return wrap_fd_as_port(fd, PORT_INPUT);
}
static Value bi_tcp_accept(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("tcp-accept", 1);
ULPort *p = AS_PORT(a[0]);
int server_fd = fileno(p->fp);
struct sockaddr_in caddr;
socklen_t clen = sizeof(caddr);
int cfd = accept(server_fd, (struct sockaddr *)&caddr, &clen);
if (cfd < 0) return VAL_FALSE;
return wrap_fd_as_port(cfd, PORT_OUTPUT);
}
static Value bi_tcp_connect(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("tcp-connect", 2); check_string(a[0]);
const char *host = AS_STRING(a[0])->data;
int port = (int)as_int(a[1]);
int fd = socket(AF_INET, SOCK_STREAM, 0);
if (fd < 0) return VAL_FALSE;
struct sockaddr_in addr = {0};
addr.sin_family = AF_INET;
addr.sin_port = htons((uint16_t)port);
if (inet_pton(AF_INET, host, &addr.sin_addr) <= 0) {
struct hostent *he = gethostbyname(host);
if (!he) { close(fd); return VAL_FALSE; }
memcpy(&addr.sin_addr, he->h_addr_list[0], he->h_length);
}
if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { close(fd); return VAL_FALSE; }
return wrap_fd_as_port(fd, PORT_OUTPUT);
}
static Value bi_tcp_recv(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("tcp-recv", 2);
ULPort *p = AS_PORT(a[0]);
size_t cap = (size_t)as_int(a[1]);
if (cap > (1u << 20)) cap = (1u << 20);
char *buf = ul_malloc(cap + 1);
int fd = fileno(p->fp);
ssize_t got = read(fd, buf, cap);
if (got < 0) { ul_free(buf); return VAL_FALSE; }
buf[got] = '\0';
Value r = make_string(buf, got, false);
ul_free(buf);
return r;
}
static Value bi_tcp_send(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("tcp-send", 2); check_string(a[1]);
ULPort *p = AS_PORT(a[0]);
ULString *s = AS_STRING(a[1]);
int fd = fileno(p->fp);
ssize_t wrote = write(fd, s->data, s->len);
if (wrote < 0) return VAL_FALSE;
return VAL_INT(wrote);
}
static Value bi_tcp_close(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("tcp-close", 1);
ULPort *p = AS_PORT(a[0]);
if (p->fp && p->fp != stdin && p->fp != stdout && p->fp != stderr)
fclose(p->fp);
p->closed = true;
return VAL_VOID;
}
#include <sys/wait.h>
/* spawn-process-stdio: fork+exec a child with its stdin & stdout piped
* back to us; return (stdin-port . stdout-port). Lets gpu-worker.lsp
* (and any other lumbda code) hold a long-lived subprocess across many
* request cycles without spawning per request.
*
* (spawn-process-stdio "path/to/binary" '("arg1" "arg2"))
* ⇒ (#<port> . #<port>)
*/
static Value bi_spawn_process_stdio(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("spawn-process-stdio", 2); check_string(a[0]);
const char *path = AS_STRING(a[0])->data;
/* count args */
int argc = 1;
Value lst = a[1];
while (IS_PAIR(lst)) { argc++; lst = CDR(lst); }
char **argv = (char**)ul_malloc(sizeof(char*) * (argc + 1));
argv[0] = (char*)path;
int i = 1; lst = a[1];
while (IS_PAIR(lst)) {
Value v = CAR(lst);
if (IS_STRING(v)) {
argv[i++] = AS_STRING(v)->data;
} else if (IS_SYM(v)) {
argv[i++] = (char*)sym_name(v);
} else {
ul_free(argv);
lisp_error("spawn-process-stdio: arg must be string or symbol");
}
lst = CDR(lst);
}
argv[argc] = NULL;
int in_pipe[2]; /* parent writes → child reads (child's stdin) */
int out_pipe[2]; /* child writes → parent reads (child's stdout)*/
if (pipe(in_pipe) < 0 || pipe(out_pipe) < 0) {
ul_free(argv); return VAL_FALSE;
}
pid_t pid = fork();
if (pid < 0) {
close(in_pipe[0]); close(in_pipe[1]);
close(out_pipe[0]); close(out_pipe[1]);
ul_free(argv); return VAL_FALSE;
}
if (pid == 0) {
/* child */
dup2(in_pipe[0], STDIN_FILENO);
dup2(out_pipe[1], STDOUT_FILENO);
close(in_pipe[0]); close(in_pipe[1]);
close(out_pipe[0]); close(out_pipe[1]);
execvp(path, argv);
_exit(127);
}
/* parent */
close(in_pipe[0]);
close(out_pipe[1]);
ul_free(argv);
/* line-buffer the parent's write end so daemon sees newlines promptly */
FILE *win = fdopen(in_pipe[1], "w");
FILE *rout = fdopen(out_pipe[0], "r");
if (!win || !rout) {
if (win) fclose(win); else close(in_pipe[1]);
if (rout) fclose(rout); else close(out_pipe[0]);
return VAL_FALSE;
}
setvbuf(win, NULL, _IOLBF, 0);
Value pin = make_file_port(win, PORT_OUTPUT);
Value pout = make_file_port(rout, PORT_INPUT);
return cons(pin, pout);
}
/* sleep: pause execution for N seconds (integer). Wraps libc sleep(3).
* Returns void. Real wall-clock wait — yields CPU.
*
* Needed for fork-per-accept admission loops (waitpid-nonblock between
* sleeps) and any cooperative pacing. Without this, scripts busy-loop
* with (let loop () ... (loop)) which (a) burns CPU and (b) hangs in
* resource-constrained VMs / fork contexts (SIGKILL after a few sec
* under cgroup limits — observed 2026-06-11 vm-runner.sh testing).
*/
static Value bi_sleep(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("sleep", 1);
unsigned int secs = (unsigned int)as_number_int(a[0]);
sleep(secs);
return VAL_VOID;
}
/* exit-immediate: _exit() wrapper. No atexit handlers, no stdio
* flush, no GC cleanup. REQUIRED in fork-self children — calling
* regular exit() in a forked child runs libc atexit + stdio
* flush against parent's already-shared state, which can hang
* or corrupt (seen empirically: minimal `(let ((pid (fork-self)))
* (exit 0))` hangs the child until SIGTERM).
*
* Use (exit-immediate 0) in fork-self child branches. */
static Value bi_exit_immediate(Value *a, int n, Env *e) {
(void)e;
_exit(n > 0 ? (int)as_number_int(a[0]) : 0);
return VAL_VOID;
}
/* fork-self: fork() wrapper.
*
* (fork-self) ⇒ 0 in child, pid in parent, #f on failure
*
* Used by gpu-worker.lsp to fork-per-accept — parent immediately
* returns to accept while child handles the request and exits.
* Single-PID-many-handler pattern: parent PID persists, ephemeral
* children carry the per-request work + bend-cuda subprocess.
*
* Caller's responsibility: reap children via (waitpid-nonblock) in
* the accept loop, or set SIGCHLD handler. We do NOT install a
* default reaper because that would interfere with spawn-process-stdio
* which expects synchronous waitpid in handle-request.
*/
static Value bi_fork_self(Value *a, int n, Env *e) {
(void)a; (void)n; (void)e; CHECK_ARITY("fork-self", 0);
pid_t pid = fork();
if (pid < 0) return VAL_FALSE;
return VAL_INT((int64_t)pid);
}
/* waitpid-nonblock: reap one completed child (WNOHANG).
*
* (waitpid-nonblock) ⇒ pid (int) if child reaped, 0 if none ready
*
* Reaps zombies left by fork-self. Call from accept loop before each
* accept to keep zombie count bounded.
*/
static Value bi_waitpid_nonblock(Value *a, int n, Env *e) {
(void)a; (void)n; (void)e; CHECK_ARITY("waitpid-nonblock", 0);
int status;
pid_t pid = waitpid(-1, &status, WNOHANG);
if (pid <= 0) return VAL_INT(0);
return VAL_INT((int64_t)pid);
}
static Value bi_flush_port(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("flush-port", 1);
ULPort *p = AS_PORT(a[0]);
if (p->fp) fflush(p->fp);
return VAL_VOID;
}
/* write-binary-file / read-binary-file: byte-for-byte file I/O,
* Latin-1 encoded in our string representation (1:1 byte mapping).
* Used by gpu-worker.lsp's binary wire mode to bypass S-expression
* serialization on huge payloads. */
static Value bi_write_binary_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("write-binary-file", 2);
check_string(a[0]); check_string(a[1]);
const char *path = AS_STRING(a[0])->data;
ULString *data = AS_STRING(a[1]);
FILE *f = fopen(path, "wb");
if (!f) return VAL_FALSE;
size_t wrote = fwrite(data->data, 1, data->len, f);
fclose(f);
return wrote == data->len ? VAL_VOID : VAL_FALSE;
}
static Value bi_append_binary_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("append-binary-file", 2);
check_string(a[0]); check_string(a[1]);
const char *path = AS_STRING(a[0])->data;
ULString *data = AS_STRING(a[1]);
FILE *f = fopen(path, "ab");
if (!f) return VAL_FALSE;
size_t wrote = fwrite(data->data, 1, data->len, f);
fclose(f);
return wrote == data->len ? VAL_VOID : VAL_FALSE;
}
/* append-port-to-binary-file: stream a string-output port's buffer
* directly to a file via fwrite, skipping the Scheme-side string
* materialization (get-output-string + append-binary-file would copy
* the buffer twice — at multi-GB body sizes this blows past any VM RAM
* budget). The port stays usable after; caller closes it. */
static Value bi_append_port_to_binary_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("append-port-to-binary-file", 2);
check_string(a[0]);
const char *path = AS_STRING(a[0])->data;
ULPort *p = AS_PORT(a[1]);
if (p->kind != PORT_STRING || p->dir != PORT_OUTPUT) {
lisp_error("append-port-to-binary-file: port must be a string output port");
}
FILE *f = fopen(path, "ab");
if (!f) return VAL_FALSE;
size_t wrote = fwrite(p->str_buf, 1, p->str_len, f);
fclose(f);
return wrote == p->str_len ? VAL_VOID : VAL_FALSE;
}
static Value bi_read_binary_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("read-binary-file", 1);
check_string(a[0]);
const char *path = AS_STRING(a[0])->data;
FILE *f = fopen(path, "rb");
if (!f) return VAL_FALSE;
fseek(f, 0, SEEK_END);
long sz = ftell(f);
fseek(f, 0, SEEK_SET);
char *buf = ul_malloc(sz + 1);
if (fread(buf, 1, sz, f) != (size_t)sz) { fclose(f); ul_free(buf); return VAL_FALSE; }
fclose(f);
buf[sz] = 0;
Value r = make_string(buf, sz, false);
ul_free(buf);
return r;
}
/* walk-circuit-ops / op-specs->bytes / count-lumbda-ops
*
* C-tier ports of the three Python primitives at lumbda.py
* _walk_circuit_ops / _op_specs_to_bytes / _count_lumbda_ops. Each
* lifts foxhop ecdsa's emit-ops-bin pipeline out of our Scheme tree-
* walker — same algorithms, native C dispatch.
*
* NO_SLOT representation differs across tiers: Python tier stores the
* literal 18446744073709551615 fixnum (Python big-int). C tier fixnums
* cap at 48 bits, so we use VAL_FALSE as our slot sentinel inside the
* op-spec vector; op-specs->bytes packs 0xFFFFFFFFFFFFFFFF when it
* sees VAL_FALSE. Both tiers produce byte-identical QECCOPS1 output.
*
* Kind enum (matches ecdsa/lumbda/emit-ops-bin.lsp):
* 1 Register, 2 AppendToRegister, 6 X, 7 Z, 8 CX, 9 CZ, 10 Swap,
* 13 CCX, 14 CCZ.
*/
/* Cached symbol interns — populated lazily on first call; symbol
* interning is idempotent so repeated calls cost nothing. */
static Value g_sym_alloc, g_sym_free;
static Value g_sym_x, g_sym_z;
static Value g_sym_cx, g_sym_cz;
static Value g_sym_ccx, g_sym_ccz;
static Value g_sym_swap;
static int g_walk_syms_init = 0;
static void walk_syms_init(void) {
if (g_walk_syms_init) return;
g_sym_alloc = intern("alloc");
g_sym_free = intern("free");
g_sym_x = intern("x");
g_sym_z = intern("z");
g_sym_cx = intern("cx");
g_sym_cz = intern("cz");
g_sym_ccx = intern("ccx");
g_sym_ccz = intern("ccz");
g_sym_swap = intern("swap");
g_walk_syms_init = 1;
}
/* Build a fresh op-spec Vector (7 elements: kind q2 q1 qt ct cc rt).
* Unused slots take VAL_FALSE as sentinel. */
static Value mk_op_spec(int64_t kind, Value q2, Value q1, Value qt,
Value ct, Value cc, Value rt) {
Value items[7];
items[0] = VAL_INT(kind);
items[1] = q2; items[2] = q1; items[3] = qt;
items[4] = ct; items[5] = cc; items[6] = rt;
return make_vector_from(items, 7);
}
/* Layout lookup: hash-table from Symbol → fixnum base.
* Returns the base as int64_t. Caller must ensure name exists. */
static int64_t layout_base(ULHashTable *layout, Value name) {
bool found;
Value v = ht_ref(layout, name, &found);
if (!found) lisp_error("walk-circuit-ops: unknown register");
return as_int(v);
}
/* Append Register + width × AppendToRegister to result list (in
* reverse so we can reverse at end). next_q & reg_id updated as
* declared registers grow the layout. Returns the new next_q. */
static int64_t emit_register_boilerplate(Value *result_head,
Value name, int64_t width,
int64_t next_q,
ULHashTable *layout) {
int64_t base = next_q;
int64_t reg_id = base;
ht_set(layout, name, VAL_INT(base));
/* Register record. */
*result_head = cons(mk_op_spec(1,
VAL_FALSE, VAL_FALSE, VAL_FALSE,
VAL_FALSE, VAL_FALSE,
VAL_INT(reg_id)),
*result_head);
/* width × AppendToRegister. */
for (int64_t i = 0; i < width; i++) {
*result_head = cons(mk_op_spec(2,
VAL_FALSE, VAL_FALSE,
VAL_INT(base + i),
VAL_FALSE, VAL_FALSE,
VAL_INT(reg_id)),
*result_head);
}
return next_q + width;
}
/* Reverse a Scheme list in place via cons rebuild. */
static Value list_reverse(Value lst) {
Value r = VAL_NIL;
while (IS_PAIR(lst)) {
r = cons(CAR(lst), r);
lst = CDR(lst);
}
return r;
}
static Value bi_walk_circuit_ops(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("walk-circuit-ops", 2);
walk_syms_init();
Value registers_lst = a[0];
Value ops_lst = a[1];
Value layout_v = make_hashtable();
ULHashTable *layout = AS_HASHTABLE(layout_v);
int64_t next_q = 0;
Value result_head = VAL_NIL; /* built in reverse */
/* Declared registers first (boilerplate). */
while (IS_PAIR(registers_lst)) {
Value rec = CAR(registers_lst);
/* rec = (name width) */
Value name = CAR(rec);
int64_t width = as_int(CADR(rec));
next_q = emit_register_boilerplate(&result_head, name, width,
next_q, layout);
registers_lst = CDR(registers_lst);
}
/* Walk ops. */
while (IS_PAIR(ops_lst)) {
Value op = CAR(ops_lst);
Value tag = CAR(op);
Value rest = CDR(op);
if (tag == g_sym_ccx) {
Value c1 = CAR(rest);
Value c2 = CAR(CDR(rest));
Value tgt = CAR(CDR(CDR(rest)));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t q2 = layout_base(layout, CAR(c2)) + as_int(CADR(c2));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
result_head = cons(mk_op_spec(13,
VAL_INT(q2), VAL_INT(q1), VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else if (tag == g_sym_cx) {
Value c1 = CAR(rest);
Value tgt = CAR(CDR(rest));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
result_head = cons(mk_op_spec(8,
VAL_FALSE, VAL_INT(q1), VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else if (tag == g_sym_x) {
Value tgt = CAR(rest);
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
result_head = cons(mk_op_spec(6,
VAL_FALSE, VAL_FALSE, VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else if (tag == g_sym_alloc) {
Value name = CAR(rest);
int64_t width = as_int(CADR(rest));
next_q = emit_register_boilerplate(&result_head, name, width,
next_q, layout);
} else if (tag == g_sym_free) {
Value name = CAR(rest);
ht_delete(layout, name);
} else if (tag == g_sym_z) {
Value tgt = CAR(rest);
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
result_head = cons(mk_op_spec(7,
VAL_FALSE, VAL_FALSE, VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else if (tag == g_sym_cz) {
Value c1 = CAR(rest);
Value tgt = CAR(CDR(rest));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
result_head = cons(mk_op_spec(9,
VAL_FALSE, VAL_INT(q1), VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else if (tag == g_sym_swap) {
Value aa = CAR(rest);
Value bb = CAR(CDR(rest));
int64_t q1 = layout_base(layout, CAR(aa)) + as_int(CADR(aa));
int64_t qt = layout_base(layout, CAR(bb)) + as_int(CADR(bb));
result_head = cons(mk_op_spec(10,
VAL_FALSE, VAL_INT(q1), VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else if (tag == g_sym_ccz) {
Value c1 = CAR(rest);
Value c2 = CAR(CDR(rest));
Value tgt = CAR(CDR(CDR(rest)));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t q2 = layout_base(layout, CAR(c2)) + as_int(CADR(c2));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
result_head = cons(mk_op_spec(14,
VAL_INT(q2), VAL_INT(q1), VAL_INT(qt),
VAL_FALSE, VAL_FALSE, VAL_FALSE),
result_head);
} else {
lisp_error("walk-circuit-ops: unknown op tag");
}
ops_lst = CDR(ops_lst);
}
return list_reverse(result_head);
}
/* Pack a single u64 into 8 LE bytes at buf. VAL_FALSE → NO_SLOT
* (0xFFFFFFFFFFFFFFFF). Otherwise the fixnum value as unsigned. */
static void pack_u64_slot(char *buf, Value v) {
uint64_t u;
if (v == VAL_FALSE) {
u = 0xFFFFFFFFFFFFFFFFULL;
} else if (IS_BIGNUM(v)) {
/* Bignum sentinel (e.g. *no-slot* = 2^64-1) — extract low 64
* bits of magnitude. Python tier passes the literal big-int so
* cross-tier emit-stream code stays unchanged. */
Bignum *b = AS_BIGNUM(v);
u = b->n_limbs > 0 ? b->limbs[0] : 0;
if (b->sign < 0) u = ~u + 1;
} else {
u = (uint64_t)as_int(v);
}
buf[0] = (char)(u & 0xFF);
buf[1] = (char)((u >> 8) & 0xFF);
buf[2] = (char)((u >> 16) & 0xFF);
buf[3] = (char)((u >> 24) & 0xFF);
buf[4] = (char)((u >> 32) & 0xFF);
buf[5] = (char)((u >> 40) & 0xFF);
buf[6] = (char)((u >> 48) & 0xFF);
buf[7] = (char)((u >> 56) & 0xFF);
}
static Value bi_op_specs_to_bytes(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("op-specs->bytes", 1);
/* Two-pass: count first to size the buffer exactly. */
size_t count = 0;
{
Value lst = a[0];
while (IS_PAIR(lst)) { count++; lst = CDR(lst); }
}
size_t total = count * 56;
char *buf = (char *)ul_malloc(total + 1);
Value lst = a[0];
size_t pos = 0;
while (IS_PAIR(lst)) {
Value v = CAR(lst);
if (!IS_VECTOR(v)) lisp_error("op-specs->bytes: not a vector");
ULVector *vec = AS_VECTOR(v);
if (vec->len < 7) lisp_error("op-specs->bytes: short vector");
/* u32 kind */
uint32_t kind = (uint32_t)as_int(vec->data[0]);
buf[pos++] = (char)(kind & 0xFF);
buf[pos++] = (char)((kind >> 8) & 0xFF);
buf[pos++] = (char)((kind >> 16) & 0xFF);
buf[pos++] = (char)((kind >> 24) & 0xFF);
/* u32 pad (zero) */
buf[pos++] = 0; buf[pos++] = 0; buf[pos++] = 0; buf[pos++] = 0;
/* 6× u64 slots */
for (int i = 1; i <= 6; i++) {
pack_u64_slot(buf + pos, vec->data[i]);
pos += 8;
}
lst = CDR(lst);
}
buf[pos] = 0;
Value r = make_string(buf, total, false);
ul_free(buf);
return r;
}
static Value bi_count_lumbda_ops(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("count-lumbda-ops", 1);
walk_syms_init();
int64_t tof = 0, cli = 0, tot = 0;
Value lst = a[0];
while (IS_PAIR(lst)) {
Value op = CAR(lst);
Value tag = IS_PAIR(op) ? CAR(op) : op;
tot++;
if (tag == g_sym_ccx) tof++;
else if (tag == g_sym_x || tag == g_sym_cx) cli++;
lst = CDR(lst);
}
Value items[3];
items[0] = VAL_INT(tof);
items[1] = VAL_INT(cli);
items[2] = VAL_INT(tot);
return make_vector_from(items, 3);
}
/* emit-circuit-to-ops-bin-stream — streaming-emit walker that writes
* each 56-byte QECCOPS1 op record directly to a file as it is produced.
* O(1) host memory regardless of n_ops. C-tier port of lumbda.py
* _emit_circuit_to_ops_bin_stream. Byte-identical output across tiers.
*
* Calling shape (matches Python tier):
* (emit-circuit-to-ops-bin-stream out-path registers ops)
* out-path string — destination file
* registers list of (name width) pairs (declared registers)
* ops list of (tag …) op records (lumbda ops, same shape as
* walk-circuit-ops input)
* → returns n_ops written (fixnum)
*
* File format (QECCOPS1):
* magic 8B "QECCOPS1"
* n_ops 8B u64 LE (placeholder zero, patched at tail via fseek)
* body n_ops × 56B (matches op-specs->bytes layout exactly)
*
* Per-op record layout (56 B little-endian):
* u32 kind | u32 pad=0 | u64 q2 | u64 q1 | u64 qt | u64 ct | u64 cc | u64 rt
*
* Kind dispatch & layout mirror bi_walk_circuit_ops (above) — single
* source of truth. NO_SLOT representation: 0xFFFFFFFFFFFFFFFF, written
* directly into u64 slots that the Scheme side did not populate.
*
* Buffering: libc's default fwrite buffer (~4 KB) plus the 56-byte
* records means each disk write covers ~73 ops — same throughput class
* as the Python tier's 8 KiB manual batch. fflush + fclose at the tail
* commit everything before the function returns.
*
* Layout map: ULHashTable Symbol → fixnum base (same as walk-circuit-ops).
* Returning the symbol's qubit base; we never need width after the
* Register/Append boilerplate is emitted, so we store just the base. */
static void pack_op_record(char *buf, uint32_t kind,
uint64_t q2, uint64_t q1, uint64_t qt,
uint64_t ct, uint64_t cc, uint64_t rt) {
/* u32 kind */
buf[0] = (char)(kind & 0xFF);
buf[1] = (char)((kind >> 8) & 0xFF);
buf[2] = (char)((kind >> 16) & 0xFF);
buf[3] = (char)((kind >> 24) & 0xFF);
/* u32 pad */
buf[4] = 0; buf[5] = 0; buf[6] = 0; buf[7] = 0;
/* 6× u64 LE */
uint64_t u[6] = { q2, q1, qt, ct, cc, rt };
for (int i = 0; i < 6; i++) {
size_t off = 8 + i * 8;
uint64_t x = u[i];
buf[off + 0] = (char)(x & 0xFF);
buf[off + 1] = (char)((x >> 8) & 0xFF);
buf[off + 2] = (char)((x >> 16) & 0xFF);
buf[off + 3] = (char)((x >> 24) & 0xFF);
buf[off + 4] = (char)((x >> 32) & 0xFF);
buf[off + 5] = (char)((x >> 40) & 0xFF);
buf[off + 6] = (char)((x >> 48) & 0xFF);
buf[off + 7] = (char)((x >> 56) & 0xFF);
}
}
/* Write one op record to f, bumping count. Returns 0 on success, -1 on
* fwrite failure (caller closes & errors). */
#define NO_SLOT_U64 0xFFFFFFFFFFFFFFFFULL
static int emit_one(FILE *f, uint64_t *count,
uint32_t kind,
uint64_t q2, uint64_t q1, uint64_t qt,
uint64_t ct, uint64_t cc, uint64_t rt) {
char rec[56];
pack_op_record(rec, kind, q2, q1, qt, ct, cc, rt);
if (fwrite(rec, 1, 56, f) != 56) return -1;
(*count)++;
return 0;
}
/* Emit Register + width × AppendToRegister boilerplate.
* Reg-id = base = next_q at time of emit (matches Python tier semantics:
* reg_id = base in _emit_circuit_to_ops_bin_stream::emit_register).
* Updates layout (name → base) and returns new next_q.
* Returns -1 on fwrite failure, 0 on success. */
static int emit_register_stream(FILE *f, uint64_t *count,
ULHashTable *layout,
Value name, int64_t width,
int64_t *next_q) {
int64_t base = *next_q;
uint64_t reg_id = (uint64_t)base;
ht_set(layout, name, VAL_INT(base));
/* Register record. */
if (emit_one(f, count, 1,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64,
NO_SLOT_U64, NO_SLOT_U64, reg_id) < 0) return -1;
/* width × AppendToRegister. */
for (int64_t i = 0; i < width; i++) {
if (emit_one(f, count, 2,
NO_SLOT_U64, NO_SLOT_U64,
(uint64_t)(base + i),
NO_SLOT_U64, NO_SLOT_U64, reg_id) < 0) return -1;
}
*next_q += width;
return 0;
}
static Value bi_emit_circuit_to_ops_bin_stream(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("emit-circuit-to-ops-bin-stream", 3);
check_string(a[0]);
walk_syms_init();
const char *out_path = AS_STRING(a[0])->data;
Value registers_lst = a[1];
Value ops_lst = a[2];
FILE *f = fopen(out_path, "wb");
if (!f) lisp_error("emit-circuit-to-ops-bin-stream: cannot open %s", out_path);
/* Header: magic + zero placeholder for n_ops (patched at tail). */
if (fwrite("QECCOPS1", 1, 8, f) != 8) {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: write magic failed");
}
char zero8[8] = {0,0,0,0,0,0,0,0};
if (fwrite(zero8, 1, 8, f) != 8) {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: write header n_ops placeholder failed");
}
Value layout_v = make_hashtable();
ULHashTable *layout = AS_HASHTABLE(layout_v);
int64_t next_q = 0;
uint64_t count = 0;
int err = 0;
/* Declared registers first (boilerplate before ops). */
while (IS_PAIR(registers_lst)) {
Value rec = CAR(registers_lst);
Value name = CAR(rec);
int64_t width = as_int(CADR(rec));
if (emit_register_stream(f, &count, layout, name, width, &next_q) < 0) {
err = 1; break;
}
registers_lst = CDR(registers_lst);
}
/* Walk ops. */
while (!err && IS_PAIR(ops_lst)) {
Value op = CAR(ops_lst);
Value tag = CAR(op);
Value rest = CDR(op);
if (tag == g_sym_ccx) {
Value c1 = CAR(rest);
Value c2 = CAR(CDR(rest));
Value tgt = CAR(CDR(CDR(rest)));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t q2 = layout_base(layout, CAR(c2)) + as_int(CADR(c2));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
if (emit_one(f, &count, 13,
(uint64_t)q2, (uint64_t)q1, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else if (tag == g_sym_cx) {
Value c1 = CAR(rest);
Value tgt = CAR(CDR(rest));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
if (emit_one(f, &count, 8,
NO_SLOT_U64, (uint64_t)q1, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else if (tag == g_sym_x) {
Value tgt = CAR(rest);
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
if (emit_one(f, &count, 6,
NO_SLOT_U64, NO_SLOT_U64, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else if (tag == g_sym_alloc) {
Value name = CAR(rest);
int64_t width = as_int(CADR(rest));
if (emit_register_stream(f, &count, layout, name, width, &next_q) < 0) err = 1;
} else if (tag == g_sym_free) {
Value name = CAR(rest);
ht_delete(layout, name);
} else if (tag == g_sym_z) {
Value tgt = CAR(rest);
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
if (emit_one(f, &count, 7,
NO_SLOT_U64, NO_SLOT_U64, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else if (tag == g_sym_cz) {
Value c1 = CAR(rest);
Value tgt = CAR(CDR(rest));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
if (emit_one(f, &count, 9,
NO_SLOT_U64, (uint64_t)q1, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else if (tag == g_sym_swap) {
Value aa = CAR(rest);
Value bb = CAR(CDR(rest));
int64_t q1 = layout_base(layout, CAR(aa)) + as_int(CADR(aa));
int64_t qt = layout_base(layout, CAR(bb)) + as_int(CADR(bb));
if (emit_one(f, &count, 10,
NO_SLOT_U64, (uint64_t)q1, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else if (tag == g_sym_ccz) {
Value c1 = CAR(rest);
Value c2 = CAR(CDR(rest));
Value tgt = CAR(CDR(CDR(rest)));
int64_t q1 = layout_base(layout, CAR(c1)) + as_int(CADR(c1));
int64_t q2 = layout_base(layout, CAR(c2)) + as_int(CADR(c2));
int64_t qt = layout_base(layout, CAR(tgt)) + as_int(CADR(tgt));
if (emit_one(f, &count, 14,
(uint64_t)q2, (uint64_t)q1, (uint64_t)qt,
NO_SLOT_U64, NO_SLOT_U64, NO_SLOT_U64) < 0) err = 1;
} else {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: unknown op tag");
}
ops_lst = CDR(ops_lst);
}
if (err) {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: fwrite failed");
}
/* Patch n_ops header. u64 LE at offset 8. */
if (fflush(f) != 0) {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: fflush failed");
}
if (fseek(f, 8, SEEK_SET) != 0) {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: fseek failed");
}
char nbuf[8];
uint64_t nu = count;
nbuf[0] = (char)(nu & 0xFF);
nbuf[1] = (char)((nu >> 8) & 0xFF);
nbuf[2] = (char)((nu >> 16) & 0xFF);
nbuf[3] = (char)((nu >> 24) & 0xFF);
nbuf[4] = (char)((nu >> 32) & 0xFF);
nbuf[5] = (char)((nu >> 40) & 0xFF);
nbuf[6] = (char)((nu >> 48) & 0xFF);
nbuf[7] = (char)((nu >> 56) & 0xFF);
if (fwrite(nbuf, 1, 8, f) != 8) {
fclose(f);
lisp_error("emit-circuit-to-ops-bin-stream: header patch write failed");
}
if (fclose(f) != 0) {
lisp_error("emit-circuit-to-ops-bin-stream: fclose failed");
}
return VAL_INT((int64_t)count);
}
#undef NO_SLOT_U64
/* heap-snapshot / heap-restore: asm-only arena primitives. The asm impl
* has no GC; these let a server rewind its bump allocator between
* requests. Python + C have real GCs — no-ops here so portable .lsp
* code can call them unconditionally. */
static Value bi_heap_snapshot(Value *a, int n, Env *e) {
(void)a; (void)n; (void)e;
return VAL_FALSE;
}
static Value bi_heap_restore(Value *a, int n, Env *e) {
(void)a; (void)n; (void)e;
return VAL_VOID;
}
#include <time.h>
static Value bi_current_time_ms(Value *a, int n, Env *e) {
(void)a; (void)n; (void)e;
struct timespec ts;
clock_gettime(CLOCK_REALTIME, &ts);
int64_t ms = (int64_t)ts.tv_sec * 1000 + ts.tv_nsec / 1000000;
return VAL_INT(ms);
}
static Value bi_read_from_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("read-from-string", 1); check_string(a[0]);
int count = 0;
Value *exprs = read_all(AS_STRING(a[0])->data, &count, false);
Value r = (count > 0) ? exprs[0] : VAL_FALSE;
ul_free(exprs);
return r;
}
static Value bi_open_output_string(Value *a, int n, Env *e) {
(void)e;
return make_string_output_port();
}
static Value bi_get_output_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("get-output-string", 1);
/* Use port's known str_len, not strlen — emitter writes binary
* (op bytes with embedded 0x00). strlen truncates at first null. */
ULPort *p = AS_PORT(a[0]);
if (p->kind != PORT_STRING || p->dir != PORT_OUTPUT) {
return make_string("", 0, false);
}
return make_string(p->str_buf, p->str_len, false);
}
static Value bi_close_port(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("close-port", 1);
ULPort *p = AS_PORT(a[0]);
if (p->fp && p->fp != stdin && p->fp != stdout && p->fp != stderr)
fclose(p->fp);
p->closed = true;
return VAL_VOID;
}
static Value bi_eof_object(Value *a, int n, Env *e) {
(void)e; return VAL_EOF;
}
static Value bi_void(Value *a, int n, Env *e) {
(void)e; return VAL_VOID;
}
static Value bi_current_input_port(Value *a, int n, Env *e) {
(void)e; return make_file_port(stdin, PORT_INPUT);
}
static Value bi_current_output_port(Value *a, int n, Env *e) {
(void)e; return make_file_port(stdout, PORT_OUTPUT);
}
static Value bi_current_error_port(Value *a, int n, Env *e) {
(void)e; return make_file_port(stderr, PORT_OUTPUT);
}
static Value bi_flush_output_port(Value *a, int n, Env *e) {
(void)e;
if (n > 0 && IS_PORT(a[0]) && AS_PORT(a[0])->fp) fflush(AS_PORT(a[0])->fp);
else fflush(stdout);
return VAL_VOID;
}
/* ═══════════════════════════════════════════════════════════════════════════
* File system
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_file_exists(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("file-exists?", 1); check_string(a[0]);
struct stat st;
return VAL_BOOL(stat(AS_STRING(a[0])->data, &st) == 0);
}
static Value bi_current_directory(Value *a, int n, Env *e) {
(void)e;
char buf[4096];
if (!getcwd(buf, sizeof(buf))) return make_string_from_cstr(".");
return make_string_from_cstr(buf);
}
static Value bi_rename_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("rename-file", 2);
check_string(a[0]); check_string(a[1]);
if (rename(AS_STRING(a[0])->data, AS_STRING(a[1])->data) != 0) {
lisp_error("rename-file: %s", strerror(errno));
}
return VAL_VOID;
}
static Value bi_delete_file(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("delete-file", 1);
check_string(a[0]);
if (unlink(AS_STRING(a[0])->data) != 0) {
lisp_error("delete-file: %s", strerror(errno));
}
return VAL_VOID;
}
/* ═══════════════════════════════════════════════════════════════════════════
* System
* ═══════════════════════════════════════════════════════════════════════════ */
static Value bi_exit(Value *a, int n, Env *e) {
(void)e;
exit(n > 0 ? (int)as_number_int(a[0]) : 0);
return VAL_VOID;
}
static Value bi_error(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("error", 1);
char *msg = show(a[0], true);
Value *irr = n > 1 ? a + 1 : NULL;
int nirr = n - 1;
Value obj = make_error_object(msg, irr, nirr);
ErrorObject *eo = AS_ERROR(obj);
char full_msg[MAX_ERROR_MSG];
int off = snprintf(full_msg, sizeof(full_msg), "%s", eo->message);
for (int i = 0; i < nirr && off < MAX_ERROR_MSG - 2; i++) {
char *s = show(irr[i], false);
off += snprintf(full_msg + off, sizeof(full_msg) - off, ": %s", s);
ul_free(s);
}
ul_free(msg);
lisp_error_with_obj(obj, "%s", full_msg);
return VAL_NIL;
}
static Value bi_error_object_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("error-object?", 1);
return VAL_BOOL(IS_ERROR_OBJ(a[0]));
}
static Value bi_error_object_message(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("error-object-message", 1);
if (IS_ERROR_OBJ(a[0])) return make_string_from_cstr(AS_ERROR(a[0])->message);
char *s = show(a[0], true);
Value r = make_string_from_cstr(s);
ul_free(s);
return r;
}
static Value bi_error_object_irritants(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("error-object-irritants", 1);
if (IS_ERROR_OBJ(a[0])) {
ErrorObject *eo = AS_ERROR(a[0]);
return list_to_value(eo->irritants, eo->nirritants);
}
return VAL_NIL;
}
static Value bi_current_time(Value *a, int n, Env *e) {
(void)e;
struct timespec ts;
clock_gettime(CLOCK_REALTIME, &ts);
return make_double(ts.tv_sec + ts.tv_nsec / 1e9);
}
static Value bi_current_jiffy(Value *a, int n, Env *e) {
(void)e;
struct timespec ts;
clock_gettime(CLOCK_MONOTONIC, &ts);
return VAL_INT(ts.tv_sec * 1000 + ts.tv_nsec / 1000000);
}
static Value bi_jiffies_per_second(Value *a, int n, Env *e) {
(void)e; return VAL_INT(1000);
}
static Value bi_command_line(Value *a, int n, Env *e) {
(void)a; (void)n; (void)e;
return VAL_NIL; /* will be set by main */
}
static Value bi_get_environment_variable(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("get-environment-variable", 1); check_string(a[0]);
const char *val = getenv(AS_STRING(a[0])->data);
if (!val) return VAL_FALSE;
return make_string_from_cstr(val);
}
static Value bi_gensym(Value *a, int n, Env *e) {
(void)e;
static int counter = 0;
char buf[32];
snprintf(buf, sizeof(buf), "g%d", counter++);
return intern(buf);
}
static Value bi_make_parameter(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("make-parameter", 1);
/* We store the parameter value in a vector of size 1 */
Value box = make_vector(1, a[0]);
/* If converter provided, apply it */
if (n > 1) {
Value args[1] = {a[0]};
AS_VECTOR(box)->data[0] = call_proc(a[1], args, 1, e);
}
/* Return a closure: 0 args → get, 1 arg → set */
/* We need to create a Scheme closure that captures the box */
/* Use a builtin with captured state via a trick: store box in an env */
Env *closure_env = make_env(e);
env_define(closure_env, intern("__param_box__"), box);
if (n > 1) env_define(closure_env, intern("__param_converter__"), a[1]);
else env_define(closure_env, intern("__param_converter__"), VAL_FALSE);
char src[256];
snprintf(src, sizeof(src),
"(lambda args "
" (if (null? args) "
" (vector-ref __param_box__ 0) "
" (begin (vector-set! __param_box__ 0 "
" (if __param_converter__ (__param_converter__ (car args)) (car args))) "
" (void))))");
int nc;
Value *exprs = read_all(src, &nc, false);
Value proc = leval(exprs[0], closure_env);
ul_free(exprs);
return proc;
}
static Value bi_values(Value *a, int n, Env *e) {
(void)e;
if (n == 1) return a[0];
return make_vector_from(a, n);
}
static Value bi_call_with_values(Value *a, int n, Env *e) {
CHECK_ARITY("call-with-values", 2);
Value r = call_proc(a[0], NULL, 0, e);
if (IS_VECTOR(r)) {
ULVector *v = AS_VECTOR(r);
return call_proc(a[1], v->data, (int)v->len, e);
}
Value args[1] = {r};
return call_proc(a[1], args, 1, e);
}
static Value bi_object_to_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("object->string", 1);
char *s = show(a[0], false);
Value r = make_string_from_cstr(s);
ul_free(s);
return r;
}
static Value bi_display_to_string(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("display-to-string", 1);
char *s = show(a[0], true);
Value r = make_string_from_cstr(s);
ul_free(s);
return r;
}
static Value bi_string_copy(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-copy", 1); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
return make_string(s->data, s->len, true);
}
static Value bi_string_set(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-set!", 3); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
if (!s->mutable) lisp_error("string-set!: immutable string");
int idx = (int)as_number_int(a[1]);
s->data[idx] = (char)AS_CHAR(a[2]);
return VAL_VOID;
}
static Value bi_string_contains(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-contains", 2);
check_string(a[0]); check_string(a[1]);
return VAL_BOOL(strstr(AS_STRING(a[0])->data, AS_STRING(a[1])->data) != NULL);
}
static Value bi_string_join(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("string-join", 1);
Value *items; int ni = value_to_list(a[0], &items);
const char *sep = n > 1 ? AS_STRING(a[1])->data : " ";
size_t seplen = strlen(sep);
size_t total = 0;
for (int i = 0; i < ni; i++) {
check_string(items[i]);
total += AS_STRING(items[i])->len;
if (i > 0) total += seplen;
}
char *buf = (char *)ul_malloc(total + 1);
size_t pos = 0;
for (int i = 0; i < ni; i++) {
if (i > 0) { memcpy(buf + pos, sep, seplen); pos += seplen; }
ULString *s = AS_STRING(items[i]);
memcpy(buf + pos, s->data, s->len);
pos += s->len;
}
buf[pos] = '\0';
ul_free(items);
Value r = make_string(buf, pos, false);
ul_free(buf);
return r;
}
static Value bi_string_split(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("string-split", 1);
check_string(a[0]);
const char *str = AS_STRING(a[0])->data;
const char *sep = n > 1 ? AS_STRING(a[1])->data : " ";
size_t seplen = strlen(sep);
Value result = VAL_NIL;
Value *items = NULL;
int nitems = 0, cap = 16;
items = (Value *)ul_malloc_values(sizeof(Value) * cap);
const char *p = str;
while (*p) {
const char *found = strstr(p, sep);
if (!found) {
if (nitems >= cap) { cap *= 2; items = (Value *)ul_realloc_values(items, sizeof(Value) * cap); }
items[nitems++] = make_string(p, strlen(p), false);
break;
}
if (nitems >= cap) { cap *= 2; items = (Value *)ul_realloc_values(items, sizeof(Value) * cap); }
items[nitems++] = make_string(p, found - p, false);
p = found + seplen;
}
result = list_to_value(items, nitems);
ul_free(items);
return result;
}
/* Record type subtype check — used by define-record-type predicates */
static Value bi_is_subtype_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("__is-subtype?__", 2);
check_string(a[0]); check_string(a[1]);
return VAL_BOOL(is_subtype(AS_STRING(a[0])->data, AS_STRING(a[1])->data));
}
static Value bi_identity(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("identity", 1);
return a[0];
}
static Value bi_string_trim(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-trim", 1); check_string(a[0]);
const char *s = AS_STRING(a[0])->data;
size_t len = AS_STRING(a[0])->len;
while (len > 0 && isspace(s[0])) { s++; len--; }
while (len > 0 && isspace(s[len-1])) { len--; }
return make_string(s, len, false);
}
static Value bi_string_index(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-index", 2); check_string(a[0]); check_string(a[1]);
const char *found = strstr(AS_STRING(a[0])->data, AS_STRING(a[1])->data);
if (!found) return VAL_INT(-1);
return VAL_INT(found - AS_STRING(a[0])->data);
}
static Value bi_string_replace(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("string-replace", 3);
check_string(a[0]); check_string(a[1]); check_string(a[2]);
const char *src = AS_STRING(a[0])->data;
const char *from = AS_STRING(a[1])->data;
const char *to = AS_STRING(a[2])->data;
size_t from_len = strlen(from), to_len = strlen(to);
if (from_len == 0) return a[0];
/* Use strstr (libc-tuned, often Boyer-Moore-Horspool) to skip the
* O(N*k) hand-rolled strncmp-at-every-position sediment. */
char buf[8192];
size_t pos = 0;
const char *cur = src;
const char *hit;
while ((hit = strstr(cur, from)) != NULL) {
size_t chunk = (size_t)(hit - cur);
if (pos + chunk + to_len >= sizeof(buf) - 1) break;
memcpy(buf + pos, cur, chunk); pos += chunk;
memcpy(buf + pos, to, to_len); pos += to_len;
cur = hit + from_len;
}
size_t tail = strlen(cur);
if (pos + tail >= sizeof(buf)) tail = sizeof(buf) - pos - 1;
memcpy(buf + pos, cur, tail); pos += tail;
buf[pos] = '\0';
return make_string_from_cstr(buf);
}
static Value bi_auto_compile(Value *a, int n, Env *e) {
(void)e;
if (n == 0) return VAL_BOOL(g_auto_compile);
g_auto_compile = IS_TRUTHY(a[0]);
return VAL_VOID;
}
static Value bi_compile(Value *a, int n, Env *e) {
CHECK_ARITY("compile", 1);
if (!IS_PROC(a[0])) lisp_error("compile: not a procedure");
CompiledProc *cp = compile_proc(AS_PROC(a[0]), e);
return VAL_PTR(cp);
}
static Value bi_compiled_p(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("compiled?", 1);
return VAL_BOOL(IS_COMPILED_PROC(a[0]));
}
static Value bi_procedure_name(Value *a, int n, Env *e) {
(void)e; CHECK_ARITY("procedure-name", 1);
if (IS_PROC(a[0])) {
const char *name = AS_PROC(a[0])->name;
return name ? make_string_from_cstr(name) : VAL_FALSE;
}
if (IS_COMPILED_PROC(a[0])) {
const char *name = AS_COMPILED_PROC(a[0])->name;
return name ? make_string_from_cstr(name) : VAL_FALSE;
}
return VAL_FALSE;
}
static Value bi_write_string(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("write-string", 1); check_string(a[0]);
ULString *s = AS_STRING(a[0]);
if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) {
port_write_str(AS_PORT(a[1]), s->data, s->len);
} else if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_FILE) {
/* Use fwrite with known s->len — fputs strlen-truncates and
* loses any 0x00 in the payload (breaks binary emit through
* a file port). */
FILE *out = AS_PORT(a[1])->fp;
fwrite(s->data, 1, s->len, out);
} else {
FILE *out = (n > 1 && IS_PORT(a[1])) ? AS_PORT(a[1])->fp : stdout;
fwrite(s->data, 1, s->len, out ? out : stdout);
fflush(out ? out : stdout);
}
return VAL_VOID;
}
static Value bi_write_char(Value *a, int n, Env *e) {
(void)e; CHECK_MIN_ARITY("write-char", 1);
/* Route to string-port buffer when target is a string port — without
* this, write-char ignored string ports and wrote to stdout, breaking
* binary emit through (open-output-string) accumulators. */
if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) {
char ch = (char)AS_CHAR(a[0]);
port_write_str(AS_PORT(a[1]), &ch, 1);
return VAL_VOID;
}
FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout;
fputc(AS_CHAR(a[0]), out ? out : stdout);
/* Per-byte fflush only when writing to stdout for interactive REPL
* feedback. File ports buffer until close (or explicit flush-port)
* — emit-stream calls write-char millions of times per second and
* per-write fflush would tank throughput. */
if (!(n > 1 && IS_PORT(a[1]))) fflush(stdout);
return VAL_VOID;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Prelude — standard macros defined in Scheme
* ═══════════════════════════════════════════════════════════════════════════ */
const char *PRELUDE =
"(define-macro (when test . body)\n"
" `(if ,test (begin ,@body) (void)))\n"
"\n"
"(define-macro (unless test . body)\n"
" `(if ,test (void) (begin ,@body)))\n"
"\n"
"(define-macro (and . args)\n"
" (cond ((null? args) #t)\n"
" ((null? (cdr args)) (car args))\n"
" (else `(if ,(car args) (and ,@(cdr args)) #f))))\n"
"\n"
"(define-macro (or . args)\n"
" (cond ((null? args) #f)\n"
" ((null? (cdr args)) (car args))\n"
" (else (let ((v (gensym)))\n"
" `(let ((,v ,(car args)))\n"
" (if ,v ,v (or ,@(cdr args))))))))\n"
"\n"
"(define-macro (case key . clauses)\n"
" (let ((k (gensym)))\n"
" `(let ((,k ,key))\n"
" (cond ,@(map (lambda (c)\n"
" (if (eq? (car c) 'else)\n"
" c\n"
" `((memv ,k ',(car c)) ,@(cdr c))))\n"
" clauses)))))\n"
"\n"
"(define-macro (while test . body)\n"
" (let ((loop (gensym)))\n"
" `(let ,loop ()\n"
" (when ,test ,@body (,loop)))))\n"
"\n"
"(define-macro (for var lst . body)\n"
" `(for-each (lambda (,var) ,@body) ,lst))\n"
"\n"
"(define (1+ n) (+ n 1))\n"
"(define (1- n) (- n 1))\n"
"(define (-1+ n) (- n 1))\n"
"(define (add1 n) (+ n 1))\n"
"(define (sub1 n) (- n 1))\n"
"\n"
"(define (square x) (* x x))\n"
"(define (cube x) (* x x x))\n"
"\n"
"(define (atom? x) (not (pair? x)))\n"
"\n"
"(define (flatten lst)\n"
" (cond ((null? lst) '())\n"
" ((pair? (car lst)) (append (flatten (car lst)) (flatten (cdr lst))))\n"
" (else (cons (car lst) (flatten (cdr lst))))))\n"
"\n"
"(define (range . args)\n"
" (cond ((= (length args) 1) (iota (car args)))\n"
" ((= (length args) 2) (iota (- (cadr args) (car args)) (car args)))\n"
" ((= (length args) 3) (iota (ceiling (/ (- (cadr args) (car args)) (caddr args)))\n"
" (car args) (caddr args)))\n"
" (else (error \"range: wrong number of args\"))))\n"
"\n"
"(define (char-list->string chars) (apply string chars))\n"
"(define (string-for-each f s) (for-each f (string->list s)))\n"
"(define (string-map f s) (list->string (map f (string->list s))))\n"
"(define (char->string c) (string c))\n"
"(define (boolean->string b) (if b \"#t\" \"#f\"))\n"
"\n"
"(define (caar x) (car (car x)))\n"
"(define (cadr x) (car (cdr x)))\n"
"(define (cdar x) (cdr (car x)))\n"
"(define (cddr x) (cdr (cdr x)))\n"
"(define (caaar x) (car (car (car x))))\n"
"(define (caadr x) (car (car (cdr x))))\n"
"(define (cadar x) (car (cdr (car x))))\n"
"(define (caddr x) (car (cdr (cdr x))))\n"
"(define (cdaar x) (cdr (car (car x))))\n"
"(define (cdadr x) (cdr (car (cdr x))))\n"
"(define (cddar x) (cdr (cdr (car x))))\n"
"(define (cdddr x) (cdr (cdr (cdr x))))\n"
"(define (caaaar x) (car (car (car (car x)))))\n"
"(define (caaadr x) (car (car (car (cdr x)))))\n"
"(define (caaddr x) (car (car (cdr (cdr x)))))\n"
"(define (caddar x) (car (cdr (cdr (car x)))))\n"
"(define (cadddr x) (car (cdr (cdr (cdr x)))))\n"
"\n"
"(define (list* . args)\n"
" (if (null? (cdr args)) (car args)\n"
" (cons (car args) (apply list* (cdr args)))))\n"
"(define cons* list*)\n"
"\n"
"(define (last-pair lst)\n"
" (if (pair? (cdr lst)) (last-pair (cdr lst)) lst))\n"
"\n"
"(define-macro (trace name)\n"
" `(set! ,name (make-traced ,name ',name)))\n"
"\n"
"(define-macro (untrace name)\n"
" `(set! ,name (untrace-proc ',name)))\n"
;
/* ═══════════════════════════════════════════════════════════════════════════
* Build the global environment
* ═══════════════════════════════════════════════════════════════════════════ */
#define DEF(name, fn) env_define(g, intern(name), VAL_BUILTIN(fn))
Env *make_global_env(void) {
Env *g = make_env(NULL);
g->global = g;
/* Arithmetic */
DEF("+", bi_add); DEF("-", bi_sub); DEF("*", bi_mul); DEF("/", bi_div);
DEF("quotient", bi_quotient); DEF("remainder", bi_remainder); DEF("modulo", bi_modulo);
DEF("expt", bi_expt); DEF("abs", bi_abs);
DEF("floor", bi_floor); DEF("ceiling", bi_ceiling); DEF("round", bi_round);
DEF("truncate", bi_truncate);
DEF("sqrt", bi_sqrt); DEF("isqrt", bi_isqrt); DEF("log", bi_log); DEF("exp", bi_exp);
DEF("sin", bi_sin); DEF("cos", bi_cos); DEF("tan", bi_tan);
DEF("asin", bi_asin); DEF("acos", bi_acos); DEF("atan", bi_atan);
DEF("min", bi_min); DEF("max", bi_max);
DEF("gcd", bi_gcd); DEF("lcm", bi_lcm);
DEF("exact", bi_exact); DEF("inexact", bi_inexact);
DEF("exact->inexact", bi_inexact); DEF("inexact->exact", bi_exact);
DEF("numerator", bi_numerator); DEF("denominator", bi_denominator);
DEF("number->string", bi_number_to_string);
DEF("square", bi_square); DEF("exact-integer?", bi_exact_integer_p);
/* Numeric comparison */
DEF("=", bi_num_eq); DEF("<", bi_num_lt); DEF(">", bi_num_gt);
DEF("<=", bi_num_le); DEF(">=", bi_num_ge);
/* Numeric predicates */
DEF("zero?", bi_zero_p); DEF("positive?", bi_positive_p); DEF("negative?", bi_negative_p);
DEF("odd?", bi_odd_p); DEF("even?", bi_even_p);
DEF("nan?", bi_nan_p); DEF("infinite?", bi_infinite_p); DEF("finite?", bi_finite_p);
/* Booleans & equality */
DEF("not", bi_not); DEF("boolean?", bi_boolean_p);
DEF("eq?", bi_eq_p); DEF("eqv?", bi_eqv_p); DEF("equal?", bi_equal_p);
/* Type predicates */
DEF("number?", bi_number_p); DEF("integer?", bi_integer_p);
DEF("real?", bi_real_p); DEF("rational?", bi_rational_p);
DEF("exact?", bi_exact_p); DEF("inexact?", bi_inexact_p);
DEF("pair?", bi_pair_p); DEF("null?", bi_null_p); DEF("list?", bi_list_p);
DEF("symbol?", bi_symbol_p); DEF("string?", bi_string_p);
DEF("char?", bi_char_p); DEF("vector?", bi_vector_p);
DEF("procedure?", bi_procedure_p);
DEF("void?", bi_void_p); DEF("eof-object?", bi_eof_object_p);
DEF("port?", bi_port_p); DEF("input-port?", bi_input_port_p);
DEF("output-port?", bi_output_port_p);
DEF("hash-table?", bi_hash_table_p);
/* Pairs & lists */
DEF("cons", bi_cons); DEF("car", bi_car); DEF("cdr", bi_cdr);
DEF("set-car!", bi_set_car); DEF("set-cdr!", bi_set_cdr);
DEF("list", bi_list); DEF("length", bi_length);
DEF("append", bi_append); DEF("reverse", bi_reverse);
DEF("list-tail", bi_list_tail); DEF("list-ref", bi_list_ref);
DEF("list-set!", bi_list_set); DEF("list-copy", bi_list_copy);
DEF("make-list", bi_make_list); DEF("iota", bi_iota);
DEF("memq", bi_memq); DEF("memv", bi_memv); DEF("member", bi_member);
DEF("assq", bi_assq); DEF("assoc", bi_assoc); DEF("assv", bi_assoc);
/* Higher-order */
DEF("map", bi_map); DEF("for-each", bi_for_each);
DEF("filter", bi_filter);
DEF("fold-left", bi_fold_left); DEF("fold-right", bi_fold_right);
DEF("foldl", bi_fold_left); DEF("foldr", bi_fold_right);
DEF("reduce", bi_fold_left);
DEF("any", bi_any); DEF("every", bi_every);
DEF("find", bi_find); DEF("sort", bi_sort); DEF("count", bi_count);
DEF("apply", bi_apply);
DEF("filter-map", bi_filter); /* simplified */
DEF("identity", bi_identity);
/* Strings */
DEF("make-string", bi_make_string);
DEF("string-length", bi_string_length); DEF("string-ref", bi_string_ref);
DEF("substring", bi_substring); DEF("string-append", bi_string_append);
DEF("string-copy", bi_string_copy); DEF("string-set!", bi_string_set);
DEF("string->list", bi_string_to_list); DEF("list->string", bi_list_to_string);
DEF("string->symbol", bi_string_to_symbol); DEF("symbol->string", bi_symbol_to_string);
DEF("string->number", bi_string_to_number);
DEF("string-upcase", bi_string_upcase); DEF("string-downcase", bi_string_downcase);
DEF("string=?", bi_string_eq); DEF("string<?", bi_string_lt);
DEF("string-contains", bi_string_contains);
DEF("string-join", bi_string_join); DEF("string-split", bi_string_split);
DEF("string-trim", bi_string_trim); DEF("string-index", bi_string_index);
DEF("string-replace", bi_string_replace);
DEF("format", bi_format); DEF("string-format", bi_format);
/* Characters */
DEF("char->integer", bi_char_to_integer); DEF("integer->char", bi_integer_to_char);
DEF("char-alphabetic?", bi_char_alphabetic);
DEF("char-numeric?", bi_char_numeric);
DEF("char-whitespace?", bi_char_whitespace);
DEF("char=?", bi_char_eq);
/* Vectors */
DEF("make-vector", bi_make_vector); DEF("vector", bi_vector);
DEF("vector-length", bi_vector_length);
DEF("vector-ref", bi_vector_ref); DEF("vector-set!", bi_vector_set);
DEF("vector->list", bi_vector_to_list); DEF("list->vector", bi_list_to_vector);
/* Hash tables */
DEF("make-hash-table", bi_make_hash_table);
DEF("make-equal-hash-table", bi_make_hash_table);
DEF("hash-table-set!", bi_hash_table_set);
DEF("hash-table/put!", bi_hash_table_set);
DEF("hash-table-ref", bi_hash_table_ref);
DEF("hash-table-ref/default", bi_hash_table_ref_default);
DEF("hash-table/get", bi_hash_table_ref_default);
DEF("hash-table-delete!", bi_hash_table_delete);
DEF("hash-table-exists?", bi_hash_table_exists);
DEF("hash-table-size", bi_hash_table_size);
DEF("hash-table/count", bi_hash_table_size);
DEF("hash-table-keys", bi_hash_table_keys);
DEF("hash-table-values", bi_hash_table_values);
/* I/O */
DEF("display", bi_display); DEF("write", bi_write);
DEF("newline", bi_newline); DEF("print", bi_print);
DEF("println", bi_print); DEF("writeln", bi_write);
DEF("write-string", bi_write_string); DEF("write-char", bi_write_char);
DEF("read-line", bi_read_line); DEF("read-char", bi_read_char);
DEF("open-input-file", bi_open_input_file);
DEF("open-output-file", bi_open_output_file);
DEF("open-binary-output-file", bi_open_binary_output_file);
DEF("port-set-position!", bi_port_set_position);
DEF("write-file", bi_write_file);
DEF("file->string", bi_file_to_string);
DEF("tcp-listen", bi_tcp_listen);
DEF("tcp-accept", bi_tcp_accept);
DEF("tcp-connect", bi_tcp_connect);
DEF("tcp-recv", bi_tcp_recv);
DEF("tcp-send", bi_tcp_send);
DEF("tcp-close", bi_tcp_close);
DEF("spawn-process-stdio", bi_spawn_process_stdio);
DEF("fork-self", bi_fork_self);
DEF("waitpid-nonblock", bi_waitpid_nonblock);
DEF("exit-immediate", bi_exit_immediate);
DEF("sleep", bi_sleep);
DEF("flush-port", bi_flush_port);
DEF("write-binary-file", bi_write_binary_file);
DEF("append-binary-file", bi_append_binary_file);
DEF("append-port-to-binary-file", bi_append_port_to_binary_file);
DEF("read-binary-file", bi_read_binary_file);
DEF("walk-circuit-ops", bi_walk_circuit_ops);
DEF("op-specs->bytes", bi_op_specs_to_bytes);
DEF("count-lumbda-ops", bi_count_lumbda_ops);
DEF("emit-circuit-to-ops-bin-stream", bi_emit_circuit_to_ops_bin_stream);
DEF("heap-snapshot", bi_heap_snapshot);
DEF("heap-restore", bi_heap_restore);
DEF("current-time-ms", bi_current_time_ms);
DEF("read-from-string", bi_read_from_string);
DEF("open-input-string", bi_open_input_string);
DEF("open-output-string", bi_open_output_string);
DEF("get-output-string", bi_get_output_string);
DEF("close-port", bi_close_port);
DEF("close-input-port", bi_close_port);
DEF("close-output-port", bi_close_port);
DEF("current-input-port", bi_current_input_port);
DEF("current-output-port", bi_current_output_port);
DEF("current-error-port", bi_current_error_port);
DEF("flush-output-port", bi_flush_output_port);
DEF("eof-object", bi_eof_object); DEF("void", bi_void);
/* File system */
DEF("file-exists?", bi_file_exists);
DEF("rename-file", bi_rename_file);
DEF("delete-file", bi_delete_file);
DEF("current-directory", bi_current_directory);
/* System */
DEF("exit", bi_exit); DEF("error", bi_error);
DEF("error-object?", bi_error_object_p);
DEF("error?", bi_error_object_p);
DEF("error-object-message", bi_error_object_message);
DEF("error-object-irritants", bi_error_object_irritants);
DEF("error-message", bi_error_object_message);
DEF("current-time", bi_current_time);
DEF("current-jiffy", bi_current_jiffy);
DEF("jiffies-per-second", bi_jiffies_per_second);
DEF("command-line", bi_command_line);
DEF("get-environment-variable", bi_get_environment_variable);
DEF("gensym", bi_gensym);
DEF("make-parameter", bi_make_parameter);
DEF("values", bi_values);
DEF("call-with-values", bi_call_with_values);
DEF("object->string", bi_object_to_string);
DEF("write-to-string", bi_object_to_string);
DEF("display-to-string", bi_display_to_string);
DEF("raise", bi_error);
DEF("procedure-name", bi_procedure_name);
DEF("auto-compile!", bi_auto_compile);
DEF("compile", bi_compile);
DEF("compiled?", bi_compiled_p);
/* Internal */
DEF("__is-subtype?__", bi_is_subtype_p);
/* Constants */
env_define(g, intern("pi"), make_double(M_PI));
env_define(g, intern("e"), make_double(M_E));
env_define(g, intern("else"), VAL_TRUE);
env_define(g, intern("..."), intern("..."));
env_define(g, intern("*version*"), make_string_from_cstr("1.0.0"));
env_define(g, intern("*name*"), make_string_from_cstr("lumbda"));
/* Portal builtins */
register_portal_builtins(g);
return g;
}
Reference in a new issue View git blame Copy permalink