shithub: femtolisp

ref: 1a611fb29238402d52afca4b4f3c779c434afe84
dir: /table.c/

#include "llt.h"
#include "flisp.h"
#include "equalhash.h"
#include "cvalues.h"
#include "types.h"
#include "print.h"
#include "table.h"

static void
print_htable(value_t v, ios_t *f)
{
	htable_t *h = (htable_t*)cv_data(ptr(v));
	size_t i;
	int first = 1;
	fl_print_str("#table(", f);
	for(i = 0; i < h->size; i += 2){
		if(h->table[i+1] != HT_NOTFOUND){
			if(!first)
				fl_print_str("  ", f);
			fl_print_child(f, (value_t)h->table[i]);
			fl_print_chr(' ', f);
			fl_print_child(f, (value_t)h->table[i+1]);
			first = 0;
		}
	}
	fl_print_chr(')', f);
}

static void
print_traverse_htable(value_t self)
{
	htable_t *h = (htable_t*)cv_data(ptr(self));
	size_t i;
	for(i = 0; i < h->size; i += 2){
		if(h->table[i+1] != HT_NOTFOUND){
			print_traverse((value_t)h->table[i]);
			print_traverse((value_t)h->table[i+1]);
		}
	}
}

static void
free_htable(value_t self)
{
	htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self));
	htable_free(h);
}

static void
relocate_htable(value_t oldv, value_t newv)
{
	htable_t *oldh = (htable_t*)cv_data(ptr(oldv));
	htable_t *h = (htable_t*)cv_data(ptr(newv));
	if(oldh->table == &oldh->_space[0])
		h->table = &h->_space[0];
	size_t i;
	for(i = 0; i < h->size; i++){
		if(h->table[i] != HT_NOTFOUND)
			h->table[i] = (void*)relocate_lispvalue((value_t)h->table[i]);
	}
}

static cvtable_t table_vtable = {
	print_htable,
	relocate_htable,
	free_htable,
	print_traverse_htable,
};

static int
ishashtable(value_t v)
{
	return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == FL(tabletype);
}

BUILTIN("table?", tablep)
{
	argcount(nargs, 1);
	return ishashtable(args[0]) ? FL(t) : FL(f);
}

static htable_t *
totable(value_t v)
{
	if(!ishashtable(v))
		type_error("table", v);
	return (htable_t*)cv_data((cvalue_t*)ptr(v));
}

BUILTIN("table", table)
{
	size_t cnt = (size_t)nargs;
	if(cnt & 1)
		lerrorf(FL(ArgError), "arguments must come in pairs");
	value_t nt;
	// prevent small tables from being added to finalizer list
	if(cnt <= HT_N_INLINE)
		nt = cvalue_nofinalizer(FL(tabletype), sizeof(htable_t));
	else
		nt = cvalue(FL(tabletype), 2*sizeof(void*));
	htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt));
	htable_new(h, cnt/2);
	int i;
	value_t k = FL(Nil), arg;
	FOR_ARGS(i, 0, arg, args){
		if(i & 1)
			equalhash_put(h, (void*)k, (void*)arg);
		else
			k = arg;
	}
	if(cnt <= HT_N_INLINE && h->table != &h->_space[0]){
		cvalue_t *cv = ptr(nt);
		add_finalizer(cv);
		cv->len = 2*sizeof(void*);
	}
	return nt;
}

// (put! table key value)
BUILTIN("put!", put)
{
	argcount(nargs, 3);
	htable_t *h = totable(args[0]);
	void **table0 = h->table;
	equalhash_put(h, (void*)args[1], (void*)args[2]);
	// register finalizer if we outgrew inline space
	if(table0 == &h->_space[0] && h->table != &h->_space[0]){
		cvalue_t *cv = ptr(args[0]);
		add_finalizer(cv);
		cv->len = 2*sizeof(void*);
	}
	return args[0];
}

static void
key_error(value_t key)
{
	lerrorf(fl_list2(FL(KeyError), key), "key not found");
}

// (get table key [default])
BUILTIN("get", get)
{
	if(nargs != 3)
		argcount(nargs, 2);
	htable_t *h = totable(args[0]);
	value_t v = (value_t)equalhash_get(h, (void*)args[1]);
	if(v == (value_t)HT_NOTFOUND){
		if(nargs == 3)
			return args[2];
		key_error(args[1]);
	}
	return v;
}

// (has? table key)
BUILTIN("has?", has)
{
	argcount(nargs, 2);
	htable_t *h = totable(args[0]);
	return equalhash_has(h, (void*)args[1]) ? FL(t) : FL(f);
}

// (del! table key)
BUILTIN("del!", del)
{
	argcount(nargs, 2);
	htable_t *h = totable(args[0]);
	if(!equalhash_remove(h, (void*)args[1]))
		key_error(args[1]);
	return args[0];
}

BUILTIN("table-foldl", table_foldl)
{
	argcount(nargs, 3);
	value_t f = args[0], zero = args[1], t = args[2];
	htable_t *h = totable(t);
	size_t i, n = h->size;
	void **table = h->table;
	fl_gc_handle(&f);
	fl_gc_handle(&zero);
	fl_gc_handle(&t);
	for(i = 0; i < n; i += 2){
		if(table[i+1] != HT_NOTFOUND){
			zero = fl_applyn(3, f, (value_t)table[i], (value_t)table[i+1], zero);
			// reload pointer
			h = (htable_t*)cv_data(ptr(t));
			if(h->size != n)
				lerrorf(FL(EnumerationError), "table modified");
			table = h->table;
		}
	}
	fl_free_gc_handles(3);
	return zero;
}

void
table_init(void)
{
	FL(tablesym) = symbol("table");
	FL(tabletype) = define_opaque_type(FL(tablesym), sizeof(htable_t), &table_vtable, nil);
}