russell@unturf.com
2f342c3be2
Adds tagged bignum support alongside the existing 48-bit fixnum on the C tier. Tag 6 = bignum, heap struct sign-magnitude with u64 little-endian limbs. Reader emits bignums for any literal past the fixnum range; +, -, *, quotient, remainder, modulo, expt, =, <, >, abs, odd?, even?, integer?, exact?, number->string, string->number all promote fixnum → bignum on overflow & demote back when results fit. Boehm GC owns every allocation. Schoolbook O(n²) mul + shift-subtract divmod is sufficient at our 4-limb / 256-bit scale. Before: (expt 2 48) = 0, (expt 2 256) = 0, secp256k1-p = -4294968273. After: all three return their exact arbitrary-precision values, matching Python tier byte-for-byte. Validated: - c/test.c — 85/85 pass (+2 new bignum unit tests). - tests/functional.lsp — 205/205 pass on both C & Python tiers. - tests/bignum-cross-tier.lsp — 33/33 pass byte-identical on both tiers (diff produces no output). - ecdsa/runs/lumbda-sweep-003/c-tier-bignum-probe.lsp — all four assertions now match the Python oracle. - ecdsa Phase B byte-identity sweep inside QEMU guest: n+1=9 p=251 sha256 c668bbe3... — matches Python oracle. n+1=18 p=131071 sha256 8a031f96... — matches Python oracle. n+1=33 p=2³²-5 sha256 0bc56905... — matches Python oracle. Previously the n+1=33 C tier emitted sha256 b024d6d9... (26,078 fewer Toffolis due to silent fixnum wrap). Bignums close that gate. secp256k1 production-width emit (n+1=257) is now structurally unblocked on C tier; downstream agent (#55) drives that next-step on the ecdsa side. Asm tier inherits in a follow-up port.
959 lines
36 KiB
C
959 lines
36 KiB
C
/*
|
|
* types.c — Value types, NaN-boxing, symbol interning, Env, Pair, etc.
|
|
*/
|
|
#include "lumbda.h"
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Error context (thread-local)
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
__thread ErrorContext *g_error_ctx = NULL;
|
|
|
|
void lisp_error(const char *fmt, ...) {
|
|
if (!g_error_ctx) {
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vfprintf(stderr, fmt, ap);
|
|
va_end(ap);
|
|
fprintf(stderr, "\n");
|
|
exit(1);
|
|
}
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vsnprintf(g_error_ctx->message, MAX_ERROR_MSG, fmt, ap);
|
|
va_end(ap);
|
|
g_error_ctx->error_obj = VAL_NIL;
|
|
longjmp(g_error_ctx->jmp, 1);
|
|
}
|
|
|
|
void lisp_error_with_obj(Value obj, const char *fmt, ...) {
|
|
if (!g_error_ctx) {
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vfprintf(stderr, fmt, ap);
|
|
va_end(ap);
|
|
fprintf(stderr, "\n");
|
|
exit(1);
|
|
}
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vsnprintf(g_error_ctx->message, MAX_ERROR_MSG, fmt, ap);
|
|
va_end(ap);
|
|
g_error_ctx->error_obj = obj;
|
|
longjmp(g_error_ctx->jmp, 1);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Value stack
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
void vs_init(ValueStack *s, int cap) {
|
|
s->data = (Value *)ul_malloc(sizeof(Value) * cap);
|
|
s->len = 0;
|
|
s->cap = cap;
|
|
}
|
|
|
|
void vs_push(ValueStack *s, Value v) {
|
|
if (s->len >= s->cap) {
|
|
s->cap = s->cap * 2;
|
|
s->data = (Value *)ul_realloc(s->data, sizeof(Value) * s->cap);
|
|
}
|
|
s->data[s->len++] = v;
|
|
}
|
|
|
|
Value vs_pop(ValueStack *s) {
|
|
if (s->len <= 0) lisp_error("stack underflow");
|
|
return s->data[--s->len];
|
|
}
|
|
|
|
Value vs_peek(ValueStack *s) {
|
|
if (s->len <= 0) lisp_error("stack underflow");
|
|
return s->data[s->len - 1];
|
|
}
|
|
|
|
void vs_clear(ValueStack *s) {
|
|
s->len = 0;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Symbol interning
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
SymbolTable g_symbols = {0};
|
|
|
|
static uint32_t sym_hash(const char *s) {
|
|
uint32_t h = 5381;
|
|
while (*s) { h = ((h << 5) + h) + (unsigned char)*s++; }
|
|
return h;
|
|
}
|
|
|
|
Value intern(const char *name) {
|
|
uint32_t h = sym_hash(name) % SYMBOL_TABLE_SIZE;
|
|
SymbolEntry *e = g_symbols.buckets[h];
|
|
while (e) {
|
|
if (strcmp(e->name, name) == 0) return e->value;
|
|
e = e->next;
|
|
}
|
|
/* New symbol */
|
|
char *copy = ul_strdup(name);
|
|
SymbolEntry *ne = (SymbolEntry *)ul_malloc(sizeof(SymbolEntry));
|
|
ne->name = copy;
|
|
ne->value = VAL_SYM_RAW(copy);
|
|
ne->next = g_symbols.buckets[h];
|
|
g_symbols.buckets[h] = ne;
|
|
return ne->value;
|
|
}
|
|
|
|
const char *sym_name(Value sym) {
|
|
return (const char *)(uintptr_t)GET_PAYLOAD(sym);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Pair
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Pair *make_pair(Value car, Value cdr) {
|
|
Pair *p = (Pair *)ul_malloc(sizeof(Pair));
|
|
p->hdr.type = OBJ_PAIR;
|
|
p->car = car;
|
|
p->cdr = cdr;
|
|
p->line = 0;
|
|
return p;
|
|
}
|
|
|
|
Value cons(Value car, Value cdr) {
|
|
return VAL_PTR(make_pair(car, cdr));
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* String
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Value make_string(const char *s, size_t len, bool mutable) {
|
|
ULString *str = (ULString *)ul_malloc(sizeof(ULString));
|
|
str->hdr.type = mutable ? OBJ_MUTABLE_STRING : OBJ_STRING;
|
|
str->data = (char *)ul_malloc(len + 1);
|
|
memcpy(str->data, s, len);
|
|
str->data[len] = '\0';
|
|
str->len = len;
|
|
str->mutable = mutable;
|
|
return VAL_PTR(str);
|
|
}
|
|
|
|
Value make_string_from_cstr(const char *s) {
|
|
return make_string(s, strlen(s), false);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Vector
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Value make_vector(size_t len, Value fill) {
|
|
ULVector *v = (ULVector *)ul_malloc(sizeof(ULVector));
|
|
v->hdr.type = OBJ_VECTOR;
|
|
v->len = len;
|
|
v->cap = len > 0 ? len : 4;
|
|
v->data = (Value *)ul_malloc(sizeof(Value) * v->cap);
|
|
for (size_t i = 0; i < len; i++) v->data[i] = fill;
|
|
return VAL_PTR(v);
|
|
}
|
|
|
|
Value make_vector_from(Value *items, size_t len) {
|
|
ULVector *v = (ULVector *)ul_malloc(sizeof(ULVector));
|
|
v->hdr.type = OBJ_VECTOR;
|
|
v->len = len;
|
|
v->cap = len > 0 ? len : 4;
|
|
v->data = (Value *)ul_malloc(sizeof(Value) * v->cap);
|
|
memcpy(v->data, items, sizeof(Value) * len);
|
|
return VAL_PTR(v);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Hash table
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
static uint64_t value_hash(Value v);
|
|
|
|
Value make_hashtable(void) {
|
|
ULHashTable *ht = (ULHashTable *)ul_malloc(sizeof(ULHashTable));
|
|
ht->hdr.type = OBJ_HASHTABLE;
|
|
ht->nbuckets = 64;
|
|
ht->count = 0;
|
|
ht->buckets = (HTEntry **)ul_malloc(sizeof(HTEntry *) * ht->nbuckets);
|
|
memset(ht->buckets, 0, sizeof(HTEntry *) * ht->nbuckets);
|
|
return VAL_PTR(ht);
|
|
}
|
|
|
|
static uint64_t value_hash(Value v) {
|
|
if (IS_INT(v)) return (uint64_t)as_int(v) * 2654435761ULL;
|
|
if (IS_SYM(v)) return sym_hash(sym_name(v));
|
|
if (IS_STRING(v)) return sym_hash(AS_STRING(v)->data);
|
|
if (IS_DOUBLE(v)) {
|
|
double d = as_double(v);
|
|
uint64_t bits;
|
|
memcpy(&bits, &d, sizeof(bits));
|
|
return bits * 2654435761ULL;
|
|
}
|
|
if (IS_SPECIAL(v)) return GET_PAYLOAD(v) * 2654435761ULL;
|
|
/* For other types, use the raw bits */
|
|
return v * 2654435761ULL;
|
|
}
|
|
|
|
void ht_set(ULHashTable *ht, Value key, Value val) {
|
|
uint64_t h = value_hash(key) % ht->nbuckets;
|
|
HTEntry *e = ht->buckets[h];
|
|
while (e) {
|
|
if (values_equal(e->key, key)) { e->value = val; return; }
|
|
e = e->next;
|
|
}
|
|
HTEntry *ne = (HTEntry *)ul_malloc(sizeof(HTEntry));
|
|
ne->key = key;
|
|
ne->value = val;
|
|
ne->next = ht->buckets[h];
|
|
ht->buckets[h] = ne;
|
|
ht->count++;
|
|
/* Resize if load factor > 2 */
|
|
if (ht->count > ht->nbuckets * 2) {
|
|
size_t new_nbuckets = ht->nbuckets * 4;
|
|
HTEntry **new_buckets = (HTEntry **)ul_malloc(sizeof(HTEntry *) * new_nbuckets);
|
|
memset(new_buckets, 0, sizeof(HTEntry *) * new_nbuckets);
|
|
for (size_t i = 0; i < ht->nbuckets; i++) {
|
|
HTEntry *cur = ht->buckets[i];
|
|
while (cur) {
|
|
HTEntry *next = cur->next;
|
|
uint64_t nh = value_hash(cur->key) % new_nbuckets;
|
|
cur->next = new_buckets[nh];
|
|
new_buckets[nh] = cur;
|
|
cur = next;
|
|
}
|
|
}
|
|
ul_free(ht->buckets);
|
|
ht->buckets = new_buckets;
|
|
ht->nbuckets = new_nbuckets;
|
|
}
|
|
}
|
|
|
|
Value ht_ref(ULHashTable *ht, Value key, bool *found) {
|
|
uint64_t h = value_hash(key) % ht->nbuckets;
|
|
HTEntry *e = ht->buckets[h];
|
|
while (e) {
|
|
if (values_equal(e->key, key)) { *found = true; return e->value; }
|
|
e = e->next;
|
|
}
|
|
*found = false;
|
|
return VAL_NIL;
|
|
}
|
|
|
|
bool ht_delete(ULHashTable *ht, Value key) {
|
|
uint64_t h = value_hash(key) % ht->nbuckets;
|
|
HTEntry **pp = &ht->buckets[h];
|
|
while (*pp) {
|
|
if (values_equal((*pp)->key, key)) {
|
|
HTEntry *del = *pp;
|
|
*pp = del->next;
|
|
ul_free(del);
|
|
ht->count--;
|
|
return true;
|
|
}
|
|
pp = &(*pp)->next;
|
|
}
|
|
return false;
|
|
}
|
|
|
|
size_t ht_count(ULHashTable *ht) {
|
|
return ht->count;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Rational numbers (simple fraction type)
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
static int64_t gcd64(int64_t a, int64_t b) {
|
|
if (a < 0) a = -a;
|
|
if (b < 0) b = -b;
|
|
while (b) { int64_t t = b; b = a % b; a = t; }
|
|
return a;
|
|
}
|
|
|
|
Value make_rational(int64_t num, int64_t den) {
|
|
Rational *r = (Rational *)ul_malloc(sizeof(Rational));
|
|
r->hdr.type = OBJ_RATIONAL;
|
|
r->num = num;
|
|
r->den = den;
|
|
return NANBOX(TAG_RATIONAL, (uintptr_t)r);
|
|
}
|
|
|
|
Value rational_normalize(int64_t num, int64_t den) {
|
|
if (den == 0) lisp_error("division by zero");
|
|
if (den < 0) { num = -num; den = -den; }
|
|
if (num == 0) return VAL_INT(0);
|
|
int64_t g = gcd64(num, den);
|
|
num /= g; den /= g;
|
|
if (den == 1) return VAL_INT(num);
|
|
return make_rational(num, den);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Number operations
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
double as_number_double(Value v) {
|
|
if (IS_INT(v)) return (double)as_int(v);
|
|
if (IS_DOUBLE(v)) return as_double(v);
|
|
if (IS_RATIONAL(v)) {
|
|
Rational *r = AS_RATIONAL(v);
|
|
return (double)r->num / (double)r->den;
|
|
}
|
|
if (IS_BIGNUM(v)) {
|
|
Bignum *b = AS_BIGNUM(v);
|
|
double d = 0.0;
|
|
for (int32_t i = (int32_t)b->n_limbs - 1; i >= 0; i--)
|
|
d = d * 18446744073709551616.0 + (double)b->limbs[i];
|
|
return b->sign < 0 ? -d : d;
|
|
}
|
|
lisp_error("not a number");
|
|
return 0;
|
|
}
|
|
|
|
int64_t as_number_int(Value v) {
|
|
if (IS_INT(v)) return as_int(v);
|
|
if (IS_DOUBLE(v)) return (int64_t)as_double(v);
|
|
if (IS_RATIONAL(v)) {
|
|
Rational *r = AS_RATIONAL(v);
|
|
return r->num / r->den;
|
|
}
|
|
if (IS_BIGNUM(v)) {
|
|
Bignum *b = AS_BIGNUM(v);
|
|
uint64_t lo = b->n_limbs > 0 ? b->limbs[0] : 0;
|
|
int64_t s = (int64_t)lo;
|
|
return b->sign < 0 ? -s : s;
|
|
}
|
|
lisp_error("not a number");
|
|
return 0;
|
|
}
|
|
|
|
/* Exact arithmetic helpers */
|
|
static void to_rational(Value v, int64_t *num, int64_t *den) {
|
|
if (IS_INT(v)) { *num = as_int(v); *den = 1; }
|
|
else if (IS_RATIONAL(v)) { Rational *r = AS_RATIONAL(v); *num = r->num; *den = r->den; }
|
|
else { *num = 0; *den = 1; } /* shouldn't happen */
|
|
}
|
|
|
|
static bool is_exact(Value v) {
|
|
return IS_INT(v) || IS_RATIONAL(v) || IS_BIGNUM(v);
|
|
}
|
|
|
|
/* Fixnum add/sub/mul that promote on overflow. Result is fixnum or bignum. */
|
|
static Value fixnum_add(int64_t a, int64_t b) {
|
|
int64_t r;
|
|
if (__builtin_add_overflow(a, b, &r) || !FITS_FIXNUM(r))
|
|
return big_add(make_bignum_from_i64(a), make_bignum_from_i64(b));
|
|
return VAL_INT(r);
|
|
}
|
|
static Value fixnum_sub(int64_t a, int64_t b) {
|
|
int64_t r;
|
|
if (__builtin_sub_overflow(a, b, &r) || !FITS_FIXNUM(r))
|
|
return big_sub(make_bignum_from_i64(a), make_bignum_from_i64(b));
|
|
return VAL_INT(r);
|
|
}
|
|
static Value fixnum_mul(int64_t a, int64_t b) {
|
|
int64_t r;
|
|
if (__builtin_mul_overflow(a, b, &r) || !FITS_FIXNUM(r))
|
|
return big_mul(make_bignum_from_i64(a), make_bignum_from_i64(b));
|
|
return VAL_INT(r);
|
|
}
|
|
|
|
Value num_add(Value a, Value b) {
|
|
/* Pure integer path (fixnum or bignum) — never produces a rational. */
|
|
if (IS_INTEGER(a) && IS_INTEGER(b)) {
|
|
if (IS_INT(a) && IS_INT(b)) return fixnum_add(as_int(a), as_int(b));
|
|
return big_add(a, b);
|
|
}
|
|
if (is_exact(a) && is_exact(b)) {
|
|
/* Rational mix — fall back to int64_t numerator/denominator path. */
|
|
int64_t an, ad, bn, bd;
|
|
to_rational(a, &an, &ad);
|
|
to_rational(b, &bn, &bd);
|
|
return rational_normalize(an * bd + bn * ad, ad * bd);
|
|
}
|
|
return make_double(as_number_double(a) + as_number_double(b));
|
|
}
|
|
|
|
Value num_sub(Value a, Value b) {
|
|
if (IS_INTEGER(a) && IS_INTEGER(b)) {
|
|
if (IS_INT(a) && IS_INT(b)) return fixnum_sub(as_int(a), as_int(b));
|
|
return big_sub(a, b);
|
|
}
|
|
if (is_exact(a) && is_exact(b)) {
|
|
int64_t an, ad, bn, bd;
|
|
to_rational(a, &an, &ad);
|
|
to_rational(b, &bn, &bd);
|
|
return rational_normalize(an * bd - bn * ad, ad * bd);
|
|
}
|
|
return make_double(as_number_double(a) - as_number_double(b));
|
|
}
|
|
|
|
Value num_mul(Value a, Value b) {
|
|
if (IS_INTEGER(a) && IS_INTEGER(b)) {
|
|
if (IS_INT(a) && IS_INT(b)) return fixnum_mul(as_int(a), as_int(b));
|
|
return big_mul(a, b);
|
|
}
|
|
if (is_exact(a) && is_exact(b)) {
|
|
int64_t an, ad, bn, bd;
|
|
to_rational(a, &an, &ad);
|
|
to_rational(b, &bn, &bd);
|
|
return rational_normalize(an * bn, ad * bd);
|
|
}
|
|
return make_double(as_number_double(a) * as_number_double(b));
|
|
}
|
|
|
|
Value num_div(Value a, Value b) {
|
|
/* Integer / integer that divides cleanly stays integer (matches Python /
|
|
* Scheme semantics for `/` between exacts when the quotient is exact).
|
|
* For bignum case we treat as exact division (truncating to integer when
|
|
* quotient is exact, else fall back to double for now — secp256k1 ops
|
|
* never use fractional bignum). */
|
|
if (IS_INTEGER(a) && IS_INTEGER(b)) {
|
|
if (big_is_zero(b)) lisp_error("division by zero");
|
|
Value q = big_quotient(a, b);
|
|
Value r = big_remainder(a, b);
|
|
if (big_is_zero(r)) return q;
|
|
/* Inexact fallback. */
|
|
return make_double(as_number_double(a) / as_number_double(b));
|
|
}
|
|
if (is_exact(a) && is_exact(b)) {
|
|
int64_t an, ad, bn, bd;
|
|
to_rational(a, &an, &ad);
|
|
to_rational(b, &bn, &bd);
|
|
if (bn == 0) lisp_error("division by zero");
|
|
return rational_normalize(an * bd, ad * bn);
|
|
}
|
|
double db = as_number_double(b);
|
|
if (db == 0.0) lisp_error("division by zero");
|
|
return make_double(as_number_double(a) / db);
|
|
}
|
|
|
|
Value num_neg(Value a) {
|
|
if (IS_INT(a)) {
|
|
int64_t v = as_int(a);
|
|
return fixnum_sub(0, v); /* handles -FIXNUM_MIN safely */
|
|
}
|
|
if (IS_BIGNUM(a)) return big_neg(a);
|
|
if (IS_RATIONAL(a)) {
|
|
Rational *r = AS_RATIONAL(a);
|
|
return make_rational(-r->num, r->den);
|
|
}
|
|
return make_double(-as_double(a));
|
|
}
|
|
|
|
static int num_cmp(Value a, Value b) {
|
|
if (IS_INTEGER(a) && IS_INTEGER(b)) return big_cmp(a, b);
|
|
if (is_exact(a) && is_exact(b)) {
|
|
int64_t an, ad, bn, bd;
|
|
to_rational(a, &an, &ad);
|
|
to_rational(b, &bn, &bd);
|
|
int64_t lhs = an * bd;
|
|
int64_t rhs = bn * ad;
|
|
if (lhs < rhs) return -1;
|
|
if (lhs > rhs) return 1;
|
|
return 0;
|
|
}
|
|
double da = as_number_double(a), db = as_number_double(b);
|
|
if (da < db) return -1;
|
|
if (da > db) return 1;
|
|
return 0;
|
|
}
|
|
|
|
bool num_eq(Value a, Value b) { return num_cmp(a, b) == 0; }
|
|
bool num_lt(Value a, Value b) { return num_cmp(a, b) < 0; }
|
|
bool num_gt(Value a, Value b) { return num_cmp(a, b) > 0; }
|
|
bool num_le(Value a, Value b) { return num_cmp(a, b) <= 0; }
|
|
bool num_ge(Value a, Value b) { return num_cmp(a, b) >= 0; }
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Environment
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
#define ENV_INIT_BUCKETS 16
|
|
|
|
Env *make_env(Env *parent) {
|
|
Env *e = (Env *)ul_malloc(sizeof(Env));
|
|
e->hdr.type = OBJ_ENV;
|
|
e->nbuckets = ENV_INIT_BUCKETS;
|
|
e->count = 0;
|
|
e->buckets = (EnvBinding **)ul_malloc(sizeof(EnvBinding *) * e->nbuckets);
|
|
memset(e->buckets, 0, sizeof(EnvBinding *) * e->nbuckets);
|
|
e->parent = parent;
|
|
e->global = parent ? parent->global : NULL;
|
|
return e;
|
|
}
|
|
|
|
static uint32_t env_hash_sym(Value sym, size_t nbuckets) {
|
|
/* Symbol payload is a char* pointer — hash the pointer value for speed */
|
|
return (uint32_t)((GET_PAYLOAD(sym) * 2654435761ULL) % nbuckets);
|
|
}
|
|
|
|
void env_define(Env *e, Value sym, Value val) {
|
|
uint32_t h = env_hash_sym(sym, e->nbuckets);
|
|
/* Check if already defined */
|
|
EnvBinding *b = e->buckets[h];
|
|
while (b) {
|
|
if (b->sym == sym) { b->val = val; return; }
|
|
b = b->next;
|
|
}
|
|
/* New binding */
|
|
EnvBinding *nb = (EnvBinding *)ul_malloc(sizeof(EnvBinding));
|
|
nb->sym = sym;
|
|
nb->val = val;
|
|
nb->next = e->buckets[h];
|
|
e->buckets[h] = nb;
|
|
e->count++;
|
|
/* Resize if needed */
|
|
if (e->count > e->nbuckets * 2) {
|
|
size_t new_nb = e->nbuckets * 4;
|
|
EnvBinding **new_bk = (EnvBinding **)ul_malloc(sizeof(EnvBinding *) * new_nb);
|
|
memset(new_bk, 0, sizeof(EnvBinding *) * new_nb);
|
|
for (size_t i = 0; i < e->nbuckets; i++) {
|
|
EnvBinding *cur = e->buckets[i];
|
|
while (cur) {
|
|
EnvBinding *next = cur->next;
|
|
uint32_t nh = env_hash_sym(cur->sym, new_nb);
|
|
cur->next = new_bk[nh];
|
|
new_bk[nh] = cur;
|
|
cur = next;
|
|
}
|
|
}
|
|
ul_free(e->buckets);
|
|
e->buckets = new_bk;
|
|
e->nbuckets = new_nb;
|
|
}
|
|
}
|
|
|
|
static EnvBinding *env_find_local(Env *e, Value sym) {
|
|
uint32_t h = env_hash_sym(sym, e->nbuckets);
|
|
EnvBinding *b = e->buckets[h];
|
|
while (b) {
|
|
if (b->sym == sym) return b;
|
|
b = b->next;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
Value env_lookup(Env *e, Value sym) {
|
|
/* Walk the lexical parent chain — covers locals, nested lets, and
|
|
* the global env at the top. An earlier "global shortcut" jumped
|
|
* straight to e->global after missing in the local frame, which
|
|
* broke lexical scoping whenever a parent scope shadowed a global
|
|
* (e.g. (let ((s 100)) (let ((m 0)) s)) with (define s 4) returned
|
|
* 4 instead of 100). Walking parents end-to-end is correct and
|
|
* still O(scope-depth) — bounded by code structure, not runtime. */
|
|
Env *cur = e;
|
|
while (cur) {
|
|
EnvBinding *b = env_find_local(cur, sym);
|
|
if (b) return b->val;
|
|
cur = cur->parent;
|
|
}
|
|
lisp_error("undefined: %s", sym_name(sym));
|
|
return VAL_NIL; /* unreachable */
|
|
}
|
|
|
|
bool env_set(Env *e, Value sym, Value val) {
|
|
Env *cur = e;
|
|
while (cur) {
|
|
EnvBinding *b = env_find_local(cur, sym);
|
|
if (b) { b->val = val; return true; }
|
|
cur = cur->parent;
|
|
}
|
|
lisp_error("set! undefined: %s", sym_name(sym));
|
|
return false;
|
|
}
|
|
|
|
Env *env_child(Env *parent, Value *params, int nparams, Value rest_param,
|
|
Value *args, int nargs) {
|
|
if (nargs < nparams) {
|
|
lisp_error("arity: need %d, got %d", nparams, nargs);
|
|
}
|
|
if (IS_NIL(rest_param) && nargs > nparams) {
|
|
lisp_error("arity: need %d, got %d", nparams, nargs);
|
|
}
|
|
Env *c = make_env(parent);
|
|
for (int i = 0; i < nparams; i++) {
|
|
env_define(c, params[i], args[i]);
|
|
}
|
|
if (!IS_NIL(rest_param)) {
|
|
/* Build rest list */
|
|
Value rest = VAL_NIL;
|
|
for (int i = nargs - 1; i >= nparams; i--) {
|
|
rest = cons(args[i], rest);
|
|
}
|
|
env_define(c, rest_param, rest);
|
|
}
|
|
return c;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Full continuation support
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
__thread ContTrampoline *g_cont_trampoline = NULL;
|
|
__thread FullCont *g_cont_invoked = NULL;
|
|
__thread Value g_cont_invoked_val = 0;
|
|
|
|
VMFrame *deep_copy_frames(VMFrame *frames, int nframes) {
|
|
if (nframes == 0) return NULL;
|
|
VMFrame *copy = (VMFrame *)ul_malloc(sizeof(VMFrame) * nframes);
|
|
for (int i = 0; i < nframes; i++) {
|
|
copy[i].instrs = frames[i].instrs;
|
|
copy[i].ip = frames[i].ip;
|
|
copy[i].n_instrs = frames[i].n_instrs;
|
|
copy[i].env = deep_copy_env(frames[i].env);
|
|
copy[i].stack_len = frames[i].stack_len;
|
|
copy[i].stack_cap = frames[i].stack_cap;
|
|
copy[i].stack = (Value *)ul_malloc(sizeof(Value) * copy[i].stack_cap);
|
|
memcpy(copy[i].stack, frames[i].stack, sizeof(Value) * frames[i].stack_len);
|
|
}
|
|
return copy;
|
|
}
|
|
|
|
FullCont *make_full_cont(VMFrame *frames, int nframes, Value *stack, int stack_len,
|
|
int ip, Instruction *instrs, int n_instrs, Env *env, void *vm_id) {
|
|
FullCont *c = (FullCont *)ul_malloc(sizeof(FullCont));
|
|
c->hdr.type = OBJ_CONTINUATION;
|
|
c->frames = deep_copy_frames(frames, nframes);
|
|
c->nframes = nframes;
|
|
c->stack = (Value *)ul_malloc(sizeof(Value) * (stack_len > 0 ? stack_len : 4));
|
|
memcpy(c->stack, stack, sizeof(Value) * stack_len);
|
|
c->stack_len = stack_len;
|
|
c->ip = ip;
|
|
c->instrs = instrs;
|
|
c->n_instrs = n_instrs;
|
|
c->env = deep_copy_env(env);
|
|
c->vm_id = vm_id;
|
|
return c;
|
|
}
|
|
|
|
/* Deep copy env chain (for multi-shot continuations) */
|
|
Env *deep_copy_env(Env *env) {
|
|
if (!env) return NULL;
|
|
if (env->global == env) return env; /* don't copy global */
|
|
Env *ne = (Env *)ul_malloc(sizeof(Env));
|
|
ne->hdr.type = OBJ_ENV;
|
|
ne->nbuckets = env->nbuckets;
|
|
ne->count = env->count;
|
|
ne->buckets = (EnvBinding **)ul_malloc(sizeof(EnvBinding *) * ne->nbuckets);
|
|
memset(ne->buckets, 0, sizeof(EnvBinding *) * ne->nbuckets);
|
|
for (size_t i = 0; i < env->nbuckets; i++) {
|
|
EnvBinding *src = env->buckets[i];
|
|
EnvBinding **dst = &ne->buckets[i];
|
|
while (src) {
|
|
EnvBinding *nb = (EnvBinding *)ul_malloc(sizeof(EnvBinding));
|
|
nb->sym = src->sym;
|
|
nb->val = src->val;
|
|
nb->next = NULL;
|
|
*dst = nb;
|
|
dst = &nb->next;
|
|
src = src->next;
|
|
}
|
|
}
|
|
ne->global = env->global;
|
|
ne->parent = deep_copy_env(env->parent);
|
|
return ne;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Procedure
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Proc *make_proc(Value *params, int nparams, Value rest,
|
|
ExprList body, Env *env, const char *name) {
|
|
Proc *p = (Proc *)ul_malloc(sizeof(Proc));
|
|
p->hdr.type = OBJ_PROC;
|
|
p->params = (Value *)ul_malloc(sizeof(Value) * nparams);
|
|
memcpy(p->params, params, sizeof(Value) * nparams);
|
|
p->nparams = nparams;
|
|
p->rest = rest;
|
|
p->body.exprs = (Value *)ul_malloc(sizeof(Value) * body.count);
|
|
memcpy(p->body.exprs, body.exprs, sizeof(Value) * body.count);
|
|
p->body.count = body.count;
|
|
p->env = env;
|
|
p->name = name ? ul_strdup(name) : NULL;
|
|
p->has_defs = has_internal_defines(body);
|
|
p->jit_block = NULL;
|
|
return p;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Macro
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Value make_macro(Value transformer) {
|
|
ULMacro *m = (ULMacro *)ul_malloc(sizeof(ULMacro));
|
|
m->hdr.type = OBJ_MACRO;
|
|
m->transformer = transformer;
|
|
return VAL_PTR(m);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Error object
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Value make_error_object(const char *msg, Value *irritants, int nirr) {
|
|
ErrorObject *e = (ErrorObject *)ul_malloc(sizeof(ErrorObject));
|
|
e->hdr.type = OBJ_ERROR;
|
|
e->message = ul_strdup(msg);
|
|
e->nirritants = nirr;
|
|
if (nirr > 0) {
|
|
e->irritants = (Value *)ul_malloc(sizeof(Value) * nirr);
|
|
memcpy(e->irritants, irritants, sizeof(Value) * nirr);
|
|
} else {
|
|
e->irritants = NULL;
|
|
}
|
|
return VAL_PTR(e);
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Port
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Value make_file_port(FILE *fp, PortDir dir) {
|
|
ULPort *p = (ULPort *)ul_malloc(sizeof(ULPort));
|
|
p->hdr.type = OBJ_PORT;
|
|
p->dir = dir;
|
|
p->kind = PORT_FILE;
|
|
p->fp = fp;
|
|
p->str_buf = NULL;
|
|
p->str_len = 0;
|
|
p->str_pos = 0;
|
|
p->str_cap = 0;
|
|
p->closed = false;
|
|
return VAL_PTR(p);
|
|
}
|
|
|
|
Value make_string_input_port(const char *s, size_t len) {
|
|
ULPort *p = (ULPort *)ul_malloc(sizeof(ULPort));
|
|
p->hdr.type = OBJ_PORT;
|
|
p->dir = PORT_INPUT;
|
|
p->kind = PORT_STRING;
|
|
p->fp = NULL;
|
|
p->str_buf = (char *)ul_malloc(len + 1);
|
|
memcpy(p->str_buf, s, len);
|
|
p->str_buf[len] = '\0';
|
|
p->str_len = len;
|
|
p->str_pos = 0;
|
|
p->str_cap = len + 1;
|
|
p->closed = false;
|
|
return VAL_PTR(p);
|
|
}
|
|
|
|
Value make_string_output_port(void) {
|
|
ULPort *p = (ULPort *)ul_malloc(sizeof(ULPort));
|
|
p->hdr.type = OBJ_PORT;
|
|
p->dir = PORT_OUTPUT;
|
|
p->kind = PORT_STRING;
|
|
p->fp = NULL;
|
|
p->str_cap = 256;
|
|
p->str_buf = (char *)ul_malloc(p->str_cap);
|
|
p->str_buf[0] = '\0';
|
|
p->str_len = 0;
|
|
p->str_pos = 0;
|
|
p->closed = false;
|
|
return VAL_PTR(p);
|
|
}
|
|
|
|
void port_write_char(ULPort *p, int ch) {
|
|
if (p->kind == PORT_FILE) {
|
|
fputc(ch, p->fp);
|
|
} else {
|
|
if (p->str_len + 1 >= p->str_cap) {
|
|
p->str_cap *= 2;
|
|
p->str_buf = (char *)ul_realloc(p->str_buf, p->str_cap);
|
|
}
|
|
p->str_buf[p->str_len++] = (char)ch;
|
|
p->str_buf[p->str_len] = '\0';
|
|
}
|
|
}
|
|
|
|
void port_write_str(ULPort *p, const char *s, size_t len) {
|
|
if (p->kind == PORT_FILE) {
|
|
fwrite(s, 1, len, p->fp);
|
|
} else {
|
|
while (p->str_len + len + 1 > p->str_cap) {
|
|
p->str_cap *= 2;
|
|
p->str_buf = (char *)ul_realloc(p->str_buf, p->str_cap);
|
|
}
|
|
memcpy(p->str_buf + p->str_len, s, len);
|
|
p->str_len += len;
|
|
p->str_buf[p->str_len] = '\0';
|
|
}
|
|
}
|
|
|
|
int port_read_char(ULPort *p) {
|
|
if (p->kind == PORT_FILE) {
|
|
return fgetc(p->fp);
|
|
} else {
|
|
if (p->str_pos >= p->str_len) return EOF;
|
|
return (unsigned char)p->str_buf[p->str_pos++];
|
|
}
|
|
}
|
|
|
|
int port_peek_char(ULPort *p) {
|
|
if (p->kind == PORT_FILE) {
|
|
int c = fgetc(p->fp);
|
|
if (c != EOF) ungetc(c, p->fp);
|
|
return c;
|
|
} else {
|
|
if (p->str_pos >= p->str_len) return EOF;
|
|
return (unsigned char)p->str_buf[p->str_pos];
|
|
}
|
|
}
|
|
|
|
char *port_read_line(ULPort *p) {
|
|
if (p->kind == PORT_FILE) {
|
|
char buf[4096];
|
|
if (!fgets(buf, sizeof(buf), p->fp)) return NULL;
|
|
size_t len = strlen(buf);
|
|
if (len > 0 && buf[len-1] == '\n') buf[--len] = '\0';
|
|
return ul_strdup(buf);
|
|
} else {
|
|
if (p->str_pos >= p->str_len) return NULL;
|
|
size_t start = p->str_pos;
|
|
while (p->str_pos < p->str_len && p->str_buf[p->str_pos] != '\n')
|
|
p->str_pos++;
|
|
size_t len = p->str_pos - start;
|
|
if (p->str_pos < p->str_len) p->str_pos++; /* skip \n */
|
|
char *result = (char *)ul_malloc(len + 1);
|
|
memcpy(result, p->str_buf + start, len);
|
|
result[len] = '\0';
|
|
return result;
|
|
}
|
|
}
|
|
|
|
char *port_get_output_string(ULPort *p) {
|
|
if (p->kind != PORT_STRING || p->dir != PORT_OUTPUT) return ul_strdup("");
|
|
char *result = (char *)ul_malloc(p->str_len + 1);
|
|
memcpy(result, p->str_buf, p->str_len);
|
|
result[p->str_len] = '\0';
|
|
return result;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Record type registry
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
RecordType *g_record_types = NULL;
|
|
|
|
RecordType *find_record_type(const char *name) {
|
|
RecordType *rt = g_record_types;
|
|
while (rt) {
|
|
if (strcmp(rt->name, name) == 0) return rt;
|
|
rt = rt->next;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
void register_record_type(const char *name, char **fields, int nfields, const char *parent) {
|
|
RecordType *rt = (RecordType *)ul_malloc(sizeof(RecordType));
|
|
rt->name = ul_strdup(name);
|
|
rt->fields = (char **)ul_malloc(sizeof(char *) * nfields);
|
|
for (int i = 0; i < nfields; i++) rt->fields[i] = ul_strdup(fields[i]);
|
|
rt->nfields = nfields;
|
|
rt->parent = parent ? ul_strdup(parent) : NULL;
|
|
rt->next = g_record_types;
|
|
g_record_types = rt;
|
|
}
|
|
|
|
bool is_subtype(const char *child, const char *ancestor) {
|
|
if (strcmp(child, ancestor) == 0) return true;
|
|
RecordType *rt = find_record_type(child);
|
|
while (rt && rt->parent) {
|
|
if (strcmp(rt->parent, ancestor) == 0) return true;
|
|
rt = find_record_type(rt->parent);
|
|
}
|
|
return false;
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Module registry
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Module *g_modules = NULL;
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Common interned symbols
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
Value SYM_QUOTE, SYM_IF, SYM_COND, SYM_AND, SYM_OR;
|
|
Value SYM_WHEN, SYM_UNLESS, SYM_BEGIN, SYM_DEFINE, SYM_SET;
|
|
Value SYM_LAMBDA, SYM_LAMBDA_UC, SYM_LET, SYM_LET_STAR, SYM_LETREC;
|
|
Value SYM_LETREC_STAR, SYM_DO, SYM_QUASIQUOTE, SYM_UNQUOTE;
|
|
Value SYM_UNQUOTE_SPLICING, SYM_DEFINE_MACRO, SYM_DEFMACRO;
|
|
Value SYM_DEFINE_SYNTAX, SYM_LET_SYNTAX, SYM_LETREC_SYNTAX;
|
|
Value SYM_SYNTAX_RULES, SYM_VALUES, SYM_CALL_WITH_VALUES;
|
|
Value SYM_CALL_CC, SYM_CALL_CC2, SYM_APPLY, SYM_EVAL;
|
|
Value SYM_ERROR, SYM_DEFINE_RECORD_TYPE, SYM_MODULE, SYM_IMPORT;
|
|
Value SYM_LOAD, SYM_INCLUDE, SYM_PARAMETERIZE, SYM_DYNAMIC_WIND;
|
|
Value SYM_WITH_EXCEPTION_HANDLER, SYM_GUARD, SYM_DEFINE_VALUES;
|
|
Value SYM_LET_VALUES, SYM_LET_STAR_VALUES, SYM_CASE;
|
|
Value SYM_ELSE, SYM_ARROW, SYM_DOT, SYM_ELLIPSIS, SYM_UNDERSCORE;
|
|
Value SYM_EXPORT;
|
|
|
|
void init_symbols(void) {
|
|
SYM_QUOTE = intern("quote");
|
|
SYM_IF = intern("if");
|
|
SYM_COND = intern("cond");
|
|
SYM_AND = intern("and");
|
|
SYM_OR = intern("or");
|
|
SYM_WHEN = intern("when");
|
|
SYM_UNLESS = intern("unless");
|
|
SYM_BEGIN = intern("begin");
|
|
SYM_DEFINE = intern("define");
|
|
SYM_SET = intern("set!");
|
|
SYM_LAMBDA = intern("lambda");
|
|
SYM_LAMBDA_UC = intern("λ");
|
|
SYM_LET = intern("let");
|
|
SYM_LET_STAR = intern("let*");
|
|
SYM_LETREC = intern("letrec");
|
|
SYM_LETREC_STAR = intern("letrec*");
|
|
SYM_DO = intern("do");
|
|
SYM_QUASIQUOTE = intern("quasiquote");
|
|
SYM_UNQUOTE = intern("unquote");
|
|
SYM_UNQUOTE_SPLICING = intern("unquote-splicing");
|
|
SYM_DEFINE_MACRO = intern("define-macro");
|
|
SYM_DEFMACRO = intern("defmacro");
|
|
SYM_DEFINE_SYNTAX = intern("define-syntax");
|
|
SYM_LET_SYNTAX = intern("let-syntax");
|
|
SYM_LETREC_SYNTAX = intern("letrec-syntax");
|
|
SYM_SYNTAX_RULES = intern("syntax-rules");
|
|
SYM_VALUES = intern("values");
|
|
SYM_CALL_WITH_VALUES = intern("call-with-values");
|
|
SYM_CALL_CC = intern("call/cc");
|
|
SYM_CALL_CC2 = intern("call-with-current-continuation");
|
|
SYM_APPLY = intern("apply");
|
|
SYM_EVAL = intern("eval");
|
|
SYM_ERROR = intern("error");
|
|
SYM_DEFINE_RECORD_TYPE = intern("define-record-type");
|
|
SYM_MODULE = intern("module");
|
|
SYM_IMPORT = intern("import");
|
|
SYM_LOAD = intern("load");
|
|
SYM_INCLUDE = intern("include");
|
|
SYM_PARAMETERIZE = intern("parameterize");
|
|
SYM_DYNAMIC_WIND = intern("dynamic-wind");
|
|
SYM_WITH_EXCEPTION_HANDLER = intern("with-exception-handler");
|
|
SYM_GUARD = intern("guard");
|
|
SYM_DEFINE_VALUES = intern("define-values");
|
|
SYM_LET_VALUES = intern("let-values");
|
|
SYM_LET_STAR_VALUES = intern("let*-values");
|
|
SYM_CASE = intern("case");
|
|
SYM_ELSE = intern("else");
|
|
SYM_ARROW = intern("=>");
|
|
SYM_DOT = intern(".");
|
|
SYM_ELLIPSIS = intern("...");
|
|
SYM_UNDERSCORE = intern("_");
|
|
SYM_EXPORT = intern("export");
|
|
}
|
|
|
|
/* ═══════════════════════════════════════════════════════════════════════════
|
|
* Global state
|
|
* ═══════════════════════════════════════════════════════════════════════════ */
|
|
|
|
bool g_auto_compile = false;
|