Initial commit
This commit is contained in:
552
src/lisp.c
Normal file
552
src/lisp.c
Normal file
@ -0,0 +1,552 @@
|
||||
#include "lisp.h"
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdarg.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
|
||||
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
|
||||
[TYPE_NULL] = {"null", sizeof("null") - 1},
|
||||
[TYPE_STRING] = {"string", sizeof("string") - 1},
|
||||
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
|
||||
[TYPE_PAIR] = {"pair", sizeof("pair") - 1},
|
||||
[TYPE_INTEGER] = {"integer", sizeof("integer") - 1},
|
||||
[TYPE_FLOAT] = {"float", sizeof("float") - 1},
|
||||
[TYPE_VECTOR] = {"vector", sizeof("vector") - 1},
|
||||
[TYPE_FUNCTION] = {"function", sizeof("function") - 1},
|
||||
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
|
||||
};
|
||||
|
||||
LispVal _Qnil = {
|
||||
.type = TYPE_NULL,
|
||||
.ref_count = -1,
|
||||
};
|
||||
|
||||
DEF_STATIC_STRING(_Qunbound_name, "unbound");
|
||||
LispSymbol _Qunbound = {
|
||||
.type = TYPE_SYMBOL,
|
||||
.ref_count = -1,
|
||||
.name = &_Qunbound_name,
|
||||
.plist = Qnil,
|
||||
.function = Qunbound,
|
||||
.value = Qunbound,
|
||||
};
|
||||
|
||||
DEF_STATIC_STRING(_Qt_name, "t");
|
||||
LispSymbol _Qt = {
|
||||
.type = TYPE_SYMBOL,
|
||||
.ref_count = -1,
|
||||
.name = &_Qt_name,
|
||||
.plist = Qnil,
|
||||
.function = Qunbound,
|
||||
.value = Qunbound,
|
||||
};
|
||||
|
||||
DEF_STATIC_SYMBOL(quote, "'");
|
||||
DEF_STATIC_SYMBOL(backquote, "`");
|
||||
DEF_STATIC_SYMBOL(comma, ",");
|
||||
|
||||
void _internal_lisp_delete_object(LispVal *val) {
|
||||
switch (TYPEOF(val)) {
|
||||
case TYPE_NULL:
|
||||
case TYPE_INTEGER:
|
||||
case TYPE_FLOAT:
|
||||
lisp_free(val);
|
||||
break;
|
||||
case TYPE_STRING: {
|
||||
LispString *str = (LispString *) val;
|
||||
if (!str->is_static) {
|
||||
lisp_free(str->data);
|
||||
}
|
||||
lisp_free(val);
|
||||
} break;
|
||||
case TYPE_SYMBOL: {
|
||||
LispSymbol *sym = (LispSymbol *) val;
|
||||
lisp_unref(sym->name);
|
||||
lisp_unref(sym->plist);
|
||||
lisp_unref(sym->function);
|
||||
lisp_unref(sym->value);
|
||||
lisp_free(val);
|
||||
} break;
|
||||
case TYPE_PAIR:
|
||||
lisp_unref(((LispPair *) val)->head);
|
||||
lisp_unref(((LispPair *) val)->tail);
|
||||
lisp_free(val);
|
||||
break;
|
||||
case TYPE_VECTOR: {
|
||||
LispVector *vec = (LispVector *) val;
|
||||
for (size_t i = 0; i < vec->length; ++i) {
|
||||
lisp_unref(vec->data[i]);
|
||||
}
|
||||
lisp_free(vec->data);
|
||||
lisp_free(val);
|
||||
} break;
|
||||
case TYPE_FUNCTION:
|
||||
// TODO handle
|
||||
break;
|
||||
case TYPE_HASHTABLE: {
|
||||
LispHashtable *tbl = (LispHashtable *) val;
|
||||
for (size_t i = 0; i < tbl->table_size; ++i) {
|
||||
struct HashtableBucket *cur = tbl->data[i];
|
||||
while (cur) {
|
||||
lisp_unref(cur->key);
|
||||
lisp_unref(cur->value);
|
||||
struct HashtableBucket *next = cur->next;
|
||||
lisp_free(cur);
|
||||
cur = next;
|
||||
}
|
||||
}
|
||||
lisp_free(tbl->data);
|
||||
lisp_unref(tbl->eq_fn);
|
||||
lisp_unref(tbl->hash_fn);
|
||||
lisp_free(val);
|
||||
} break;
|
||||
default:
|
||||
abort();
|
||||
};
|
||||
}
|
||||
|
||||
void *lisp_malloc(size_t size) {
|
||||
return lisp_realloc(NULL, size);
|
||||
}
|
||||
|
||||
void *lisp_realloc(void *old_ptr, size_t size) {
|
||||
if (!size) {
|
||||
return NULL;
|
||||
}
|
||||
void *new_ptr = realloc(old_ptr, size);
|
||||
if (!new_ptr) {
|
||||
abort();
|
||||
}
|
||||
return new_ptr;
|
||||
}
|
||||
|
||||
char *lisp_strdup(const char *str) {
|
||||
size_t len = strlen(str);
|
||||
char *new_str = lisp_malloc(len + 1);
|
||||
memcpy(new_str, str, len + 1);
|
||||
return new_str;
|
||||
}
|
||||
|
||||
LispVal *make_lisp_string(const char *data, size_t length, bool take,
|
||||
bool is_static) {
|
||||
LispString *self = lisp_malloc(sizeof(LispString));
|
||||
self->type = TYPE_STRING;
|
||||
self->ref_count = 0;
|
||||
if (take) {
|
||||
self->data = (char *) data;
|
||||
} else {
|
||||
self->data = lisp_strdup(data);
|
||||
}
|
||||
self->length = length;
|
||||
self->is_static = is_static;
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
LispVal *sprintf_lisp(const char *format, ...) {
|
||||
va_list args;
|
||||
va_start(args, format);
|
||||
va_list args_measure;
|
||||
va_copy(args_measure, args);
|
||||
int size = vsnprintf(NULL, 0, format, args_measure) + 1;
|
||||
va_end(args_measure);
|
||||
char *buffer = lisp_malloc(size);
|
||||
vsnprintf(buffer, size, format, args);
|
||||
LispVal *obj = make_lisp_string(buffer, size, true, false);
|
||||
va_end(args);
|
||||
return obj;
|
||||
}
|
||||
|
||||
LispVal *make_lisp_symbol(LispVal *name) {
|
||||
LispSymbol *self = lisp_malloc(sizeof(LispSymbol));
|
||||
self->type = TYPE_SYMBOL;
|
||||
self->ref_count = 0;
|
||||
self->name = (LispString *) lisp_ref(name);
|
||||
self->plist = Qnil;
|
||||
self->function = Qunbound;
|
||||
self->value = Qunbound;
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
LispVal *make_lisp_pair(LispVal *head, LispVal *tail) {
|
||||
LispPair *self = lisp_malloc(sizeof(LispPair));
|
||||
self->type = TYPE_PAIR;
|
||||
self->ref_count = 0;
|
||||
self->head = lisp_ref(head);
|
||||
self->tail = lisp_ref(tail);
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
LispVal *make_lisp_integer(intmax_t value) {
|
||||
LispInteger *self = lisp_malloc(sizeof(LispInteger));
|
||||
self->type = TYPE_INTEGER;
|
||||
self->ref_count = 0;
|
||||
self->value = value;
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
LispVal *make_lisp_float(long double value) {
|
||||
LispFloat *self = lisp_malloc(sizeof(LispFloat));
|
||||
self->type = TYPE_FLOAT;
|
||||
self->ref_count = 0;
|
||||
self->value = value;
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
LispVal *make_lisp_vector(LispVal **data, size_t length) {
|
||||
LispVector *self = lisp_malloc(sizeof(LispVector));
|
||||
self->type = TYPE_VECTOR;
|
||||
self->ref_count = 0;
|
||||
self->data = data;
|
||||
self->length = length;
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
|
||||
LispHashtable *self = lisp_malloc(sizeof(LispHashtable));
|
||||
self->type = TYPE_HASHTABLE;
|
||||
self->ref_count = 0;
|
||||
self->table_size = LISP_HASHTABLE_INITIAL_SIZE;
|
||||
self->data =
|
||||
lisp_malloc(sizeof(struct HashtableBucket *) * self->table_size);
|
||||
memset(self->data, 0, sizeof(struct HashtableBucket *) * self->table_size);
|
||||
self->count = 0;
|
||||
self->eq_fn = eq_fn;
|
||||
self->hash_fn = hash_fn;
|
||||
return LISPVAL(self);
|
||||
}
|
||||
|
||||
DEFUN(type_of, "type-of", (LispVal * obj)) {
|
||||
if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
|
||||
return Qnil;
|
||||
}
|
||||
LispVal *name =
|
||||
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
|
||||
LISP_TYPE_NAMES[obj->type].len, true, true);
|
||||
lisp_ref(name);
|
||||
LispVal *sym = Fintern(name);
|
||||
UNREF_INPLACE(name);
|
||||
return sym;
|
||||
}
|
||||
|
||||
DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) {
|
||||
return make_lisp_pair(head, tail);
|
||||
}
|
||||
|
||||
DEFUN(hash_string, "hash-string", (LispVal * obj)) {
|
||||
CHECK_TYPE(TYPE_STRING, obj);
|
||||
const char *str = ((LispString *) obj)->data;
|
||||
uint64_t hash = 5381;
|
||||
int c;
|
||||
while ((c = *(str++))) {
|
||||
hash = ((hash << 5) + hash) + c;
|
||||
}
|
||||
return make_lisp_integer(hash);
|
||||
}
|
||||
|
||||
DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2)) {
|
||||
CHECK_TYPE(TYPE_STRING, obj1);
|
||||
CHECK_TYPE(TYPE_STRING, obj2);
|
||||
LispString *str1 = (LispString *) obj1;
|
||||
LispString *str2 = (LispString *) obj2;
|
||||
if (str1->length != str2->length) {
|
||||
return Qnil;
|
||||
}
|
||||
return LISP_BOOL(memcmp(str1->data, str2->data, str1->length) == 0);
|
||||
}
|
||||
|
||||
bool strings_equal_nocase(const char *s1, const char *s2, size_t n) {
|
||||
for (size_t i = 0; i < n; ++i) {
|
||||
if (!s1[i] || !s2[i]) {
|
||||
return !s1[i] && !s2[i];
|
||||
} else if (tolower(s1[i]) != tolower(s2[i])) {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
DEFUN(id, "id", (LispVal * obj)) {
|
||||
return make_lisp_integer((int64_t) obj);
|
||||
}
|
||||
|
||||
DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2)) {
|
||||
return LISP_BOOL(obj1 == obj2);
|
||||
}
|
||||
|
||||
static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
|
||||
if (NILP(self->eq_fn)) {
|
||||
return v1 == v2;
|
||||
} else if (self->eq_fn == Qstrings_equal) {
|
||||
return !NILP(Fstrings_equal(v1, v2));
|
||||
} else {
|
||||
// TODO call the function
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
|
||||
if (NILP(self->hash_fn)) {
|
||||
return (uint64_t) key;
|
||||
} else if (self->hash_fn == Qhash_string) {
|
||||
// Make obarray lookups faster
|
||||
LispVal *hash_obj = Fhash_string(key);
|
||||
uint64_t hash = ((LispInteger *) hash_obj)->value;
|
||||
UNREF_INPLACE(hash_obj);
|
||||
return hash;
|
||||
} else {
|
||||
// TODO call the hash function
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
static struct HashtableBucket *
|
||||
find_hash_table_bucket(LispHashtable *self, LispVal *key, uint64_t hash) {
|
||||
struct HashtableBucket *cur = self->data[hash % self->table_size];
|
||||
while (cur) {
|
||||
if (hash_table_eq(self, key, cur->key)) {
|
||||
return cur;
|
||||
}
|
||||
cur = cur->next;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static void hash_table_rehash(LispHashtable *self, size_t new_size) {
|
||||
struct HashtableBucket **new_data =
|
||||
lisp_malloc(sizeof(struct HashtableBucket *) * new_size);
|
||||
memset(new_data, 0, sizeof(struct HashtableBucket *) * new_size);
|
||||
for (size_t i = 0; i < self->table_size; ++i) {
|
||||
struct HashtableBucket *cur = self->data[i];
|
||||
while (cur) {
|
||||
struct HashtableBucket *next = cur->next;
|
||||
cur->next = new_data[cur->hash % new_size];
|
||||
new_data[cur->hash % new_size] = cur;
|
||||
cur = next;
|
||||
}
|
||||
}
|
||||
free(self->data);
|
||||
self->data = new_data;
|
||||
self->table_size = new_size;
|
||||
}
|
||||
|
||||
DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) {
|
||||
CHECK_TYPE(TYPE_HASHTABLE, table);
|
||||
LispHashtable *self = (LispHashtable *) table;
|
||||
uint64_t hash = hash_table_hash(self, key);
|
||||
struct HashtableBucket *cur_bucket =
|
||||
find_hash_table_bucket(self, key, hash);
|
||||
if (cur_bucket) {
|
||||
UNREF_INPLACE(cur_bucket->value);
|
||||
cur_bucket->value = lisp_ref(value);
|
||||
} else {
|
||||
cur_bucket = lisp_malloc(sizeof(struct HashtableBucket));
|
||||
cur_bucket->next = self->data[hash % self->table_size];
|
||||
cur_bucket->hash = hash;
|
||||
cur_bucket->key = lisp_ref(key);
|
||||
cur_bucket->value = lisp_ref(value);
|
||||
self->data[hash % self->table_size] = cur_bucket;
|
||||
++self->count;
|
||||
if ((double) self->count / self->table_size
|
||||
>= LISP_HASHTABLE_GROWTH_THRESHOLD) {
|
||||
hash_table_rehash(self,
|
||||
LISP_HASHTABLE_GROWTH_FACTOR * self->table_size);
|
||||
}
|
||||
}
|
||||
return table;
|
||||
}
|
||||
|
||||
DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) {
|
||||
CHECK_TYPE(TYPE_HASHTABLE, table);
|
||||
LispHashtable *self = (LispHashtable *) table;
|
||||
uint64_t hash = hash_table_hash(self, key);
|
||||
struct HashtableBucket *cur_bucket =
|
||||
find_hash_table_bucket(self, key, hash);
|
||||
if (cur_bucket) {
|
||||
return cur_bucket->value;
|
||||
}
|
||||
return def;
|
||||
}
|
||||
|
||||
DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) {
|
||||
CHECK_TYPE(TYPE_HASHTABLE, table);
|
||||
LispHashtable *self = (LispHashtable *) table;
|
||||
uint64_t hash = hash_table_hash(self, key);
|
||||
struct HashtableBucket *cur_bucket = self->data[hash % self->table_size];
|
||||
if (cur_bucket && hash_table_eq(self, cur_bucket->key, key)) {
|
||||
self->data[hash % self->table_size] = cur_bucket->next;
|
||||
UNREF_INPLACE(cur_bucket->key);
|
||||
UNREF_INPLACE(cur_bucket->value);
|
||||
free(cur_bucket);
|
||||
--self->count;
|
||||
} else {
|
||||
struct HashtableBucket *prev_bucket = cur_bucket;
|
||||
cur_bucket = cur_bucket->next;
|
||||
while (cur_bucket) {
|
||||
if (hash_table_eq(self, cur_bucket->key, key)) {
|
||||
prev_bucket->next = cur_bucket->next;
|
||||
UNREF_INPLACE(cur_bucket->key);
|
||||
UNREF_INPLACE(cur_bucket->value);
|
||||
free(cur_bucket);
|
||||
--self->count;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
if ((double) self->count / self->table_size
|
||||
<= LISP_HASHTABLE_SHRINK_THRESHOLD
|
||||
&& self->table_size > LISP_HASHTABLE_INITIAL_SIZE) {
|
||||
hash_table_rehash(self,
|
||||
self->table_size / LISP_HASHTABLE_GROWTH_FACTOR);
|
||||
}
|
||||
return table;
|
||||
}
|
||||
|
||||
DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) {
|
||||
CHECK_TYPE(TYPE_HASHTABLE, table);
|
||||
return make_lisp_integer(((LispHashtable *) table)->count);
|
||||
}
|
||||
|
||||
DEFUN(intern, "intern", (LispVal * name)) {
|
||||
CHECK_TYPE(TYPE_STRING, name);
|
||||
LispVal *cur = Fgethash(Vobarray, name, Qunbound);
|
||||
if (cur != Qunbound) {
|
||||
return cur;
|
||||
}
|
||||
LispVal *sym = make_lisp_symbol(name);
|
||||
Fputhash(Vobarray, name, sym);
|
||||
return sym;
|
||||
}
|
||||
|
||||
LispVal *intern(const char *name, size_t length, bool take) {
|
||||
LispVal *name_obj = make_lisp_string((char *) name, length, take, false);
|
||||
lisp_ref(name_obj);
|
||||
LispVal *sym = Fintern(name_obj);
|
||||
UNREF_INPLACE(name_obj);
|
||||
return sym;
|
||||
}
|
||||
|
||||
DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) {
|
||||
CHECK_TYPE(TYPE_PAIR, pair);
|
||||
UNREF_INPLACE(((LispPair *) pair)->head);
|
||||
((LispPair *) pair)->head = lisp_ref(head);
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) {
|
||||
CHECK_TYPE(TYPE_PAIR, pair);
|
||||
UNREF_INPLACE(((LispPair *) pair)->tail);
|
||||
((LispPair *) pair)->tail = lisp_ref(tail);
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
|
||||
if (!SYMBOLP(signal)) {
|
||||
printf("Attempt to throw non-symbol value!\n");
|
||||
} else {
|
||||
LispSymbol *sym = (LispSymbol *) signal;
|
||||
printf("Throw %*s! Data: ", (int) sym->name->length, sym->name->data);
|
||||
debug_dump(stdout, rest, true);
|
||||
}
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEF_STATIC_SYMBOL(type_error, "type-error");
|
||||
DEF_STATIC_SYMBOL(read_error, "read-error");
|
||||
|
||||
LispVal *Vobarray = Qnil;
|
||||
|
||||
void lisp_init() {
|
||||
Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string));
|
||||
}
|
||||
|
||||
void lisp_shutdown() {
|
||||
UNREF_INPLACE(Vobarray);
|
||||
}
|
||||
|
||||
static void debug_dump_real(FILE *stream, void *obj, bool first) {
|
||||
switch (TYPEOF(obj)) {
|
||||
case TYPE_NULL:
|
||||
fprintf(stream, "nil");
|
||||
break;
|
||||
case TYPE_STRING: {
|
||||
LispString *str = (LispString *) obj;
|
||||
// TODO actually quote
|
||||
fputc('"', stream);
|
||||
fwrite(str->data, 1, str->length, stream);
|
||||
fputc('"', stream);
|
||||
} break;
|
||||
case TYPE_SYMBOL: {
|
||||
LispSymbol *sym = (LispSymbol *) obj;
|
||||
fwrite(sym->name->data, 1, sym->name->length, stream);
|
||||
} break;
|
||||
case TYPE_PAIR: {
|
||||
LispPair *pair = (LispPair *) obj;
|
||||
if (first) {
|
||||
fputc('(', stream);
|
||||
} else {
|
||||
fputc(' ', stream);
|
||||
}
|
||||
debug_dump_real(stream, pair->head, true);
|
||||
if (NILP(pair->tail)) {
|
||||
fputc(')', stream);
|
||||
} else if (PAIRP(pair->tail)) {
|
||||
debug_dump_real(stream, pair->tail, false);
|
||||
} else {
|
||||
fprintf(stream, " . ");
|
||||
debug_dump_real(stream, pair->tail, false);
|
||||
fputc(')', stream);
|
||||
}
|
||||
} break;
|
||||
case TYPE_INTEGER:
|
||||
fprintf(stream, "%jd", ((LispInteger *) obj)->value);
|
||||
break;
|
||||
case TYPE_FLOAT:
|
||||
fprintf(stream, "%Lf", ((LispFloat *) obj)->value);
|
||||
break;
|
||||
case TYPE_VECTOR: {
|
||||
LispVector *vec = (LispVector *) obj;
|
||||
fputc('[', stream);
|
||||
for (size_t i = 0; i < vec->length; ++i) {
|
||||
if (i) {
|
||||
fputc(' ', stream);
|
||||
}
|
||||
debug_dump_real(stream, vec->data[i], true);
|
||||
}
|
||||
fputc(']', stream);
|
||||
} break;
|
||||
case TYPE_FUNCTION:
|
||||
if (((LispFunction *) obj)->builtin) {
|
||||
fprintf(stream, "<builtin at %#jx>", (uintmax_t) obj);
|
||||
} else {
|
||||
fprintf(stream, "<function at %#jx>", (uintmax_t) obj);
|
||||
}
|
||||
break;
|
||||
case TYPE_HASHTABLE: {
|
||||
LispHashtable *tbl = (LispHashtable *) obj;
|
||||
fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
|
||||
tbl->table_size, tbl->count, (uintmax_t) obj);
|
||||
} break;
|
||||
default:
|
||||
fprintf(stream, "<object type=%ju at %#jx>",
|
||||
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
void debug_dump(FILE *stream, void *obj, bool newline) {
|
||||
debug_dump_real(stream, obj, true);
|
||||
if (newline) {
|
||||
fputc('\n', stream);
|
||||
}
|
||||
}
|
||||
|
||||
void debug_print_hashtable(FILE *stream, LispVal *table) {
|
||||
debug_dump(stream, table, true);
|
||||
HASHTABLE_FOREACH(key, val, table, {
|
||||
fprintf(stream, "- ");
|
||||
debug_dump(stream, key, false);
|
||||
fprintf(stream, " = ");
|
||||
debug_dump(stream, val, true);
|
||||
});
|
||||
}
|
||||
Reference in New Issue
Block a user