lumbda/c/types.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;
    }
    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;
    }
    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);
}

Value num_add(Value a, Value 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_sub(Value a, Value 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_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) {
    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)) return VAL_INT(-as_int(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_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) {
    /* Check local first */
    EnvBinding *b = env_find_local(e, sym);
    if (b) return b->val;
    /* Check global shortcut */
    if (e->global && e->global != e) {
        b = env_find_local(e->global, sym);
        if (b) return b->val;
    }
    /* Walk parent chain */
    Env *cur = e->parent;
    while (cur) {
        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;