engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
lumbda/c/builtins.c
russell@unturf.com 6e9d3ea52f isqrt: add integer square root builtin to all three impls 
Semantics: (isqrt n) → floor(sqrt(n)). Negative argument errors.
Matches Python 3.8+ math.isqrt and R7RS exact-integer-sqrt contract.

- Python: wraps math.isqrt via lambda registration
- C: hand-rolled bit-by-bit algorithm in bi_isqrt (O(log n), no FPU)
- asm: new BI_ISQRT=109, bit-by-bit algorithm in integer registers
       (%r8/%r9/%r10). Negative input → stderr + exit(1) like other
       errors. GC builtin constants bumped to 110-114.

Tests:
- tests/functional.lsp: 7 shared tests (0, 1, perfect squares, floor
  cases, large values). Python + C now 196 each (was 189).
- asm/test.sh: 5 asm-local tests. asm suite now 142 (was 137).

MOAD: all three implementations O(log n), no O(N²) hazards.
2026-04-20 08:50:24 -04:00

1953 lines
71 KiB
C
Raw Blame History

/*
* 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);
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);
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);
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);
if (IS_INT(a[0]) && IS_INT(a[1]) && as_int(a[1]) >= 0) {
int64_t base = as_int(a[0]), exp = as_int(a[1]);
int64_t result = 1;
for (int64_t i = 0; i < exp; i++) result *= base;
return VAL_INT(result);
}
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]); return VAL_INT(v < 0 ? -v : v); }
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]);
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_INT(a[0]) && (as_int(a[0]) % 2 != 0))
NUM_PRED(even_p, IS_INT(a[0]) && (as_int(a[0]) % 2 == 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_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_RATIONAL(a[0]) || (IS_DOUBLE(a[0]) && isfinite(as_double(a[0]))))
TYPE_PRED(exact_p, IS_INT(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(sizeof(Value) * min_len);
Value *call_args = (Value *)ul_malloc(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(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(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(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");
return VAL_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;
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);
}
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));
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;
}
/* 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);
char *s = port_get_output_string(AS_PORT(a[0]));
Value r = make_string_from_cstr(s);
ul_free(s);
return r;
}
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);
}
/* ═══════════════════════════════════════════════════════════════════════════
* 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(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(items, sizeof(Value) * cap); }
items[nitems++] = make_string(p, strlen(p), false);
break;
}
if (nitems >= cap) { cap *= 2; items = (Value *)ul_realloc(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]);
FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout;
if (n > 1 && IS_PORT(a[1]) && AS_PORT(a[1])->kind == PORT_STRING) {
ULString *s = AS_STRING(a[0]);
port_write_str(AS_PORT(a[1]), s->data, s->len);
} else {
fputs(AS_STRING(a[0])->data, 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);
FILE *out = n > 1 && IS_PORT(a[1]) ? AS_PORT(a[1])->fp : stdout;
fputc(AS_CHAR(a[0]), out ? out : stdout);
fflush(out ? out : 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("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("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("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