diff --git a/CMakeLists.txt b/CMakeLists.txt index 84e27a9..d10efaf 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,10 +1,23 @@ cmake_minimum_required(VERSION 3.10) set(CMAKE_C_STANDARD 11) -set(CMAKE_EXPORT_COMPILE_COMMANDS TRUE) -project(simple-lisp) +project( + simple-lisp + VERSION 1.0 + LANGUAGES C) -add_compile_options(-Wall -fsanitize=address,leak,undefined) +include(FetchContent) +FetchContent_Declare( + refcount + GIT_REPOSITORY https://git.zander.im/Zander671/refcount.git + GIT_TAG ae7b645b7a4919c20c75f68348347038601229f7) + +FetchContent_MakeAvailable(refcount) + +add_compile_options(-fsanitize=address,leak,undefined) add_link_options(-fsanitize=address,leak,undefined) + add_executable(simple-lisp src/main.c src/lisp.c src/read.c) +target_link_libraries(simple-lisp PUBLIC refcount) +target_compile_options(simple-lisp PRIVATE -Wall -Wpedantic) diff --git a/src/lisp.c b/src/lisp.c index bc88262..7fd3cf9 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -22,16 +22,15 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = { void free_opt_arg_desc(void *obj) { struct OptArgDesc *oad = obj; - lisp_unref(oad->name); - lisp_unref(oad->default_form); - lisp_unref(oad->pred_var); + refcount_unref(oad->name); + refcount_unref(oad->default_form); + refcount_unref(oad->pred_var); lisp_free(oad); } DEF_STATIC_STRING(_Qnil_name, "nil"); LispSymbol _Qnil = { .type = TYPE_SYMBOL, - .ref_count = -1, .name = &_Qnil_name, .plist = Qnil, .function = Qunbound, @@ -42,7 +41,6 @@ LispSymbol _Qnil = { DEF_STATIC_STRING(_Qunbound_name, "unbound"); LispSymbol _Qunbound = { .type = TYPE_SYMBOL, - .ref_count = -1, .name = &_Qunbound_name, .plist = Qnil, .function = Qunbound, @@ -53,7 +51,6 @@ LispSymbol _Qunbound = { DEF_STATIC_STRING(_Qt_name, "t"); LispSymbol _Qt = { .type = TYPE_SYMBOL, - .ref_count = -1, .name = &_Qt_name, .plist = Qnil, .function = Qunbound, @@ -63,6 +60,7 @@ LispSymbol _Qt = { DEF_STATIC_SYMBOL(backquote, "`"); DEF_STATIC_SYMBOL(comma, ","); +DEF_STATIC_SYMBOL(comma_at, ",@"); struct GCRoot { struct GCRoot *next; @@ -70,10 +68,8 @@ struct GCRoot { LispVal *object; }; -static struct GCRoot *gc_roots = NULL; static size_t bytes_allocated = 0; static size_t last_gc = 0; -static bool is_doing_gc; void *lisp_malloc(size_t size) { return lisp_realloc(NULL, size); @@ -83,7 +79,7 @@ void *lisp_realloc(void *old_ptr, size_t size) { if (!size) { return NULL; } - if (!is_doing_gc) { + if (refcount_default_context && !refcount_is_doing_gc()) { bytes_allocated += size; } void *new_ptr = realloc(old_ptr, size); @@ -93,296 +89,15 @@ void *lisp_realloc(void *old_ptr, size_t size) { return new_ptr; } -void *lisp_ref(void *val) { - if (!STATICP(val)) { - ++((LispVal *) val)->ref_count; - } - return val; -} - -static void track_as_gc_root(LispVal *obj) { - if (!obj->gc_root) { - struct GCRoot *nr = lisp_malloc(sizeof(struct GCRoot)); - nr->object = obj; - nr->next = gc_roots; - nr->prev = NULL; - if (gc_roots) { - gc_roots->prev = nr; - } - gc_roots = nr; - obj->gc_root = nr; - } -} - -void *lisp_float_ref(void *val) { - if (LISPVAL(val)->ref_count > 0) { - --LISPVAL(val)->ref_count; - } - return val; -} - -struct ToCheck { - struct ToCheck *next; - LispVal *obj; -}; - -#define CHECK(no) \ - if (!STATICP(no)) { \ - struct ToCheck *new = lisp_malloc(sizeof(struct ToCheck)); \ - new->obj = no; \ - new->next = queue; \ - queue = new; \ - } - -static struct ToCheck *check_object(LispVal *obj, struct ToCheck *queue) { - switch (TYPEOF(obj)) { - case TYPE_INTEGER: - case TYPE_FLOAT: - case TYPE_STRING: - case TYPE_USER_POINTER: - // can't hold references, do nothing - break; - case TYPE_SYMBOL: { - LispSymbol *sym = (LispSymbol *) obj; - CHECK(LISPVAL(sym->name)); - CHECK(LISPVAL(sym->function)); - CHECK(LISPVAL(sym->value)); - CHECK(LISPVAL(sym->plist)); - } break; - case TYPE_PAIR: - CHECK(((LispPair *) obj)->head); - CHECK(((LispPair *) obj)->tail); - break; - case TYPE_VECTOR: { - LispVector *vec = (LispVector *) obj; - for (size_t i = 0; i > vec->length; ++i) { - CHECK(vec->data[i]); - } - } break; - case TYPE_FUNCTION: { - LispFunction *func = (LispFunction *) obj; - CHECK(func->body); - CHECK(func->args); - CHECK(func->doc); - CHECK(func->kwargs); - CHECK(func->oargs); - CHECK(func->rargs); - CHECK(func->lexenv); - CHECK(func->rest_arg); - } break; - case TYPE_HASHTABLE: { - HASHTABLE_FOREACH(key, val, obj, { - CHECK(key); - CHECK(val); - }); - } break; - default: - abort(); - } - return queue; -} - -static void lisp_free_object(LispVal *val, bool is_static) { - struct GCRoot *root = val->gc_root; - if (!STATICP(val) && (root = val->gc_root)) { - if (root->next) { - root->next->prev = root->prev; - } - if (root->prev) { - root->prev->next = root->next; - } else { - gc_roots = gc_roots->next; - if (gc_roots) { - gc_roots->prev = NULL; - } - } - lisp_free(root); - } - switch (TYPEOF(val)) { - case TYPE_INTEGER: - case TYPE_FLOAT: - case TYPE_SYMBOL: - case TYPE_PAIR: - case TYPE_FUNCTION: - break; - case TYPE_STRING: { - LispString *str = (LispString *) val; - if (!str->is_static) { - lisp_free(str->data); - } - } break; - case TYPE_VECTOR: { - LispVector *vec = (LispVector *) val; - lisp_free(vec->data); - } 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) { - struct HashtableBucket *next = cur->next; - lisp_free(cur); - cur = next; - } - } - lisp_free(tbl->data); - } break; - case TYPE_USER_POINTER: { - LispUserPointer *ptr = (LispUserPointer *) val; - if (ptr->free_func) { - ptr->free_func(ptr->data); - } - } break; - default: - abort(); - }; - if (!is_static) { - lisp_free(val); - } -} - -static bool check_gc_root(struct GCRoot *root) { - LispVal *found = make_lisp_hashtable(Qnil, Qnil); - struct ToCheck *queue = NULL; - CHECK(root->object); - size_t num_at_zero = 0; - bool first_pass = true; - while (queue) { - LispVal *obj = queue->obj; - struct ToCheck *next = queue->next; - lisp_free(queue); - queue = next; - LispVal *index = Fgethash(found, obj, Qnil); - if (!NILP(index)) { - if (((LispInteger *) index)->value > 0 - && !--((LispInteger *) index)->value) { - ++num_at_zero; - } - // we already searched this object, don't dereference everything - // again! - continue; - } else { - Fputhash(found, obj, - make_lisp_integer(obj->ref_count - && obj->ref_count - !first_pass)); - } - first_pass = false; - queue = check_object(obj, queue); - } - if (num_at_zero == ((LispHashtable *) found)->count) { - LispHashtable *tbl = (LispHashtable *) found; - for (size_t i = 0; i < tbl->count; ++i) { - for (struct HashtableBucket *bucket = tbl->data[i]; bucket; - bucket = bucket->next) { - lisp_free_object(bucket->key, false); - bucket->key = Qnil; - } - } - } - lisp_unref(found); - return false; -} - -void garbage_collect() { - if (is_doing_gc) { - return; - } - is_doing_gc = true; - struct GCRoot *root = gc_roots; - while (root) { - if (check_gc_root(root)) { - root = gc_roots; - } else { - root = root->next; - } - } - is_doing_gc = false; -} - -struct ToFree { - struct ToFree *next; - LispVal *obj; -}; - -#define FREE(l, no) \ - { \ - struct ToFree *new = lisp_malloc(sizeof(struct ToFree)); \ - new->obj = no; \ - new->next = l; \ - l = new; \ - } - -static struct ToFree *lisp_unref_recursive(LispVal *val) { - struct ToFree *to_free = NULL; - struct ToCheck *queue = NULL; - CHECK(val); - val->ref_count = 0; // prevent double free - FREE(to_free, val); - while (queue) { - LispVal *obj = queue->obj; - struct ToCheck *next = queue->next; - lisp_free(queue); - queue = next; - if (STATICP(obj) || obj->finalizing) { - continue; - } else if (obj->ref_count >= 2) { - --obj->ref_count; - } else { - if (obj->ref_count) { - --obj->ref_count; - // don't check multiple times - FREE(to_free, obj); - } - obj->finalizing = true; - queue = check_object(obj, queue); - } - } - return to_free; -} - -#undef CHECK -#undef FREE - -static void *lisp_unref_extended(void *val, bool even_if_static) { - if (!even_if_static && STATICP(val)) { - return val; - } else if (LISPVAL(val)->ref_count > 1) { - --LISPVAL(val)->ref_count; - if (!is_doing_gc) { - track_as_gc_root(val); - } - if (bytes_allocated - last_gc > GC_EVERY_N_BYTES) { - garbage_collect(); - last_gc = bytes_allocated; - } - return val; - } else { - struct ToFree *to_free = lisp_unref_recursive(val); - while (to_free) { - LispVal *obj = to_free->obj; - struct ToFree *next = to_free->next; - lisp_free(to_free); - to_free = next; - lisp_free_object(obj, false); - } - return Qnil; - } -} - -void *lisp_unref(void *val) { - return lisp_unref_extended(val, false); -} - -void lisp_unref_double_ptr(void **val) { - lisp_unref(*val); +void garbage_collect(void) { + last_gc = bytes_allocated; + refcount_garbage_collect(); } #define CONSTRUCT_OBJECT(var, Type, TYPE) \ Type *var = lisp_malloc(sizeof(Type)); \ - var->type = TYPE; \ - var->ref_count = 0; \ - var->gc_root = NULL; \ - var->finalizing = false; + refcount_init_obj(var); \ + var->type = TYPE; LispVal *make_lisp_string(const char *data, size_t length, bool take, bool is_static) { @@ -415,7 +130,7 @@ LispVal *sprintf_lisp(const char *format, ...) { LispVal *make_lisp_symbol(LispVal *name) { CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL); - self->name = (LispString *) lisp_ref(name); + self->name = (LispString *) refcount_ref(name); self->plist = Qnil; self->function = Qunbound; self->value = Qunbound; @@ -425,15 +140,14 @@ LispVal *make_lisp_symbol(LispVal *name) { LispVal *make_lisp_pair(LispVal *head, LispVal *tail) { CONSTRUCT_OBJECT(self, LispPair, TYPE_PAIR); - self->head = lisp_ref(head); - self->tail = lisp_ref(tail); + self->head = refcount_ref(head); + self->tail = refcount_ref(tail); return LISPVAL(self); } LispVal *make_lisp_integer(intmax_t value) { CONSTRUCT_OBJECT(self, LispInteger, TYPE_INTEGER); self->type = TYPE_INTEGER; - self->ref_count = 0; self->value = value; return LISPVAL(self); } @@ -448,6 +162,7 @@ LispVal *make_lisp_vector(LispVal **data, size_t length) { CONSTRUCT_OBJECT(self, LispVector, TYPE_VECTOR); self->data = data; self->length = length; + self->is_static = false; return LISPVAL(self); } @@ -464,41 +179,41 @@ static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod, if (TYPEOF(ent) == TYPE_SYMBOL) { if (VALUE_CONSTANTP(ent)) { return false; - } else if (!NILP(Fgethash(found_args, ent, Qnil))) { + } else if (!NILP(gethash(found_args, ent, Qnil))) { return false; } - aod->name = lisp_ref(ent); + aod->name = refcount_ref(ent); aod->pred_var = Qnil; aod->default_form = Qnil; return true; - } else if (LISTP(ent) && SYMBOLP(Fhead(ent)) && !VALUE_CONSTANTP(Fhead(ent)) - && LISTP(Ftail(ent))) { - LispVal *end = Ftail(Ftail(ent)); - if (!LISTP(end) || (!SYMBOLP(Fhead(end)) && !NILP(Fhead(end))) - || (!NILP(Fhead(end)) && VALUE_CONSTANTP(Fhead(end)))) { + } else if (LISTP(ent) && SYMBOLP(HEAD(ent)) && !VALUE_CONSTANTP(HEAD(ent)) + && LISTP(TAIL(ent))) { + LispVal *end = TAIL(TAIL(ent)); + if (!LISTP(end) || (!SYMBOLP(HEAD(end)) && !NILP(HEAD(end))) + || (!NILP(HEAD(end)) && VALUE_CONSTANTP(HEAD(end)))) { return false; - } else if (!NILP(Fgethash(found_args, Fhead(ent), Qnil))) { + } else if (!NILP(gethash(found_args, HEAD(ent), Qnil))) { return false; } else if (!NILP(end) - && (!NILP(Fgethash(found_args, Fhead(end), Qnil)) - || VALUE_CONSTANTP(Fhead(end)) - || Fhead(end) == Fhead(ent))) { + && (!NILP(gethash(found_args, HEAD(end), Qnil)) + || VALUE_CONSTANTP(HEAD(end)) + || HEAD(end) == HEAD(ent))) { return false; } - aod->name = lisp_ref(Fhead(ent)); - aod->default_form = lisp_ref(Fhead(Ftail(ent))); - aod->pred_var = lisp_ref(Fhead(end)); + aod->name = refcount_ref(HEAD(ent)); + aod->default_form = refcount_ref(HEAD(TAIL(ent))); + aod->pred_var = refcount_ref(HEAD(end)); return true; } return false; } void set_function_args(LispFunction *func, LispVal *args) { - lisp_unref(func->args); - lisp_unref(func->kwargs); - lisp_unref(func->rargs); - lisp_unref(func->oargs); - lisp_unref(func->rest_arg); + refcount_unref(func->args); + refcount_unref(func->kwargs); + refcount_unref(func->rargs); + refcount_unref(func->oargs); + refcount_unref(func->rest_arg); LispVal *found_args = make_lisp_hashtable(Qnil, Qnil); @@ -518,7 +233,7 @@ void set_function_args(LispFunction *func, LispVal *args) { func->n_opt = 0; func->oargs = Qnil; func->rest_arg = Qnil; - func->kwargs = lisp_ref(make_lisp_hashtable(Qnil, Qnil)); + func->kwargs = make_lisp_hashtable(Qnil, Qnil); func->allow_other_keys = false; LispVal *rargs_end; @@ -553,7 +268,7 @@ void set_function_args(LispFunction *func, LispVal *args) { switch (mode) { case REQ: if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg) - || !NILP(Fgethash(found_args, arg, Qnil))) { + || !NILP(gethash(found_args, arg, Qnil))) { goto malformed; } if (NILP(func->rargs)) { @@ -562,9 +277,10 @@ void set_function_args(LispFunction *func, LispVal *args) { } else { LispVal *new_end = Fpair(arg, Qnil); Fsettail(rargs_end, new_end); + refcount_unref(new_end); rargs_end = new_end; } - Fputhash(found_args, arg, Qt); + puthash(found_args, arg, Qt); ++func->n_req; break; case OPT: { @@ -573,7 +289,7 @@ void set_function_args(LispFunction *func, LispVal *args) { USERPTR(struct OptArgDesc, desc)->index = 0; if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc), found_args)) { - lisp_unref(desc); + refcount_unref(desc); goto malformed; } if (NILP(func->oargs)) { @@ -582,13 +298,13 @@ void set_function_args(LispFunction *func, LispVal *args) { } else { LispVal *new_end = Fpair(desc, Qnil); Fsettail(oargs_end, new_end); + refcount_unref(new_end); oargs_end = new_end; } - Fputhash(found_args, USERPTR(struct OptArgDesc, desc)->name, - Qt); + puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt); if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) { - Fputhash(found_args, - USERPTR(struct OptArgDesc, desc)->pred_var, Qt); + puthash(found_args, + USERPTR(struct OptArgDesc, desc)->pred_var, Qt); } ++func->n_opt; } break; @@ -597,7 +313,7 @@ void set_function_args(LispFunction *func, LispVal *args) { ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc); if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc), found_args)) { - lisp_unref(desc); + refcount_unref(desc); goto malformed; } USERPTR(struct OptArgDesc, desc)->index = 0; @@ -610,14 +326,12 @@ void set_function_args(LispFunction *func, LispVal *args) { kns[sn->length + 1] = '\n'; LispVal *kn = make_lisp_string(kns, sn->length + 1, false, false); - lisp_ref(kn); - Fputhash(func->kwargs, Fintern(kn), desc); - lisp_unref(kn); - Fputhash(found_args, USERPTR(struct OptArgDesc, desc)->name, - Qt); + puthash(func->kwargs, Fintern(kn), desc); + refcount_unref(kn); + puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt); if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) { - Fputhash(found_args, - USERPTR(struct OptArgDesc, desc)->pred_var, Qt); + puthash(found_args, + USERPTR(struct OptArgDesc, desc)->pred_var, Qt); } } break; case REST: @@ -628,7 +342,7 @@ void set_function_args(LispFunction *func, LispVal *args) { } else if (!NILP(Fgethash(found_args, arg, Qnil))) { goto malformed; } - func->rest_arg = lisp_ref(arg); + func->rest_arg = refcount_ref(arg); mode = MUST_CHANGE; break; case MUST_CHANGE: @@ -636,23 +350,21 @@ void set_function_args(LispFunction *func, LispVal *args) { } } } - lisp_ref(func->rargs); - lisp_ref(func->oargs); - lisp_unref(found_args); + refcount_unref(found_args); // do this last - func->args = lisp_ref(args); + func->args = refcount_ref(args); return; malformed: - lisp_unref(func->rargs); - lisp_unref(func->oargs); - lisp_unref(func->rest_arg); - lisp_unref(func->kwargs); - lisp_unref(found_args); + refcount_unref(func->rargs); + refcount_unref(func->oargs); + refcount_unref(func->rest_arg); + refcount_unref(func->kwargs); + refcount_unref(found_args); Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil)); } -LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv, - LispVal *body, bool is_macro) { +LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, + bool is_macro) { CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION); self->is_builtin = false; self->is_macro = is_macro; @@ -666,9 +378,14 @@ LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv, cancel_cleanup(cl); // do these after the potential throw - self->doc = lisp_ref(doc); - self->lexenv = lisp_ref(lexenv); - self->body = lisp_ref(body); + self->lexenv = refcount_ref(lexenv); + if (STRINGP(HEAD(body))) { + self->doc = refcount_ref(HEAD(body)); + self->body = refcount_ref(TAIL(body)); + } else { + self->doc = Qnil; + self->body = refcount_ref(body); + } return LISPVAL(self); } @@ -691,19 +408,6 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)) { 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); } @@ -760,9 +464,8 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) { WITH_CLEANUP(args, { eq_obj = Ffuncall(self->eq_fn, args); // }); - lisp_ref(eq_obj); bool result = !NILP(eq_obj); - lisp_unref(eq_obj); + refcount_unref(eq_obj); return result; } } @@ -774,7 +477,7 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) { // Make obarray and lexenv lookups faster LispVal *hash_obj = Fhash_string(key); uint64_t hash = ((LispInteger *) hash_obj)->value; - UNREF_INPLACE(hash_obj); + refcount_unref(hash_obj); return hash; } else { LispVal *hash_obj; @@ -821,21 +524,22 @@ static void hash_table_rehash(LispHashtable *self, size_t new_size) { self->table_size = new_size; } -DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) { +LispVal *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); + refcount_ref(value); + refcount_unref(cur_bucket->value); + cur_bucket->value = 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); + cur_bucket->key = refcount_ref(key); + cur_bucket->value = refcount_ref(value); self->data[hash % self->table_size] = cur_bucket; ++self->count; if ((double) self->count / self->table_size @@ -847,7 +551,11 @@ DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) { return table; } -DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) { +DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) { + return refcount_ref(puthash(table, key, value)); +} + +LispVal *gethash(LispVal *table, LispVal *key, LispVal *def) { CHECK_TYPE(TYPE_HASHTABLE, table); LispHashtable *self = (LispHashtable *) table; uint64_t hash = hash_table_hash(self, key); @@ -859,16 +567,20 @@ DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) { return def; } -DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) { +DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) { + return refcount_ref(gethash(table, key, def)); +} + +LispVal *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); + refcount_unref(cur_bucket->key); + refcount_unref(cur_bucket->value); + lisp_free(cur_bucket); --self->count; } else { struct HashtableBucket *prev_bucket = cur_bucket; @@ -876,9 +588,9 @@ DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) { 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); + refcount_unref(cur_bucket->key); + refcount_unref(cur_bucket->value); + lisp_free(cur_bucket); --self->count; break; } @@ -893,6 +605,10 @@ DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) { return table; } +DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) { + return refcount_ref(remhash(table, key)); +} + DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) { CHECK_TYPE(TYPE_HASHTABLE, table); return make_lisp_integer(((LispHashtable *) table)->count); @@ -900,34 +616,33 @@ DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) { DEFUN(intern, "intern", (LispVal * name)) { CHECK_TYPE(TYPE_STRING, name); - LispVal *cur = Fgethash(Vobarray, name, Qunbound); + LispVal *cur = gethash(Vobarray, name, Qunbound); if (cur != Qunbound) { - return cur; + return refcount_ref(cur); } LispVal *sym = make_lisp_symbol(name); - Fputhash(Vobarray, name, sym); + puthash(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); + refcount_unref(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); + refcount_unref(((LispPair *) pair)->head); + ((LispPair *) pair)->head = refcount_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); + refcount_unref(((LispPair *) pair)->tail); + ((LispPair *) pair)->tail = refcount_ref(tail); return Qnil; } @@ -964,16 +679,16 @@ DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); void stack_enter(LispVal *name, LispVal *detail, bool inherit) { StackFrame *frame = lisp_malloc(sizeof(StackFrame)); - frame->name = lisp_ref(name); + frame->name = refcount_ref(name); frame->hidden = false; - frame->detail = lisp_ref(detail); - frame->lexenv = lisp_ref(make_lisp_hashtable(Qnil, Qnil)); + frame->detail = refcount_ref(detail); + frame->lexenv = refcount_ref(make_lisp_hashtable(Qnil, Qnil)); if (inherit && the_stack) { - Fputhash(LISPVAL(frame->lexenv), Qparent_lexenv, - LISPVAL(the_stack->lexenv)); + puthash(LISPVAL(frame->lexenv), Qparent_lexenv, + LISPVAL(the_stack->lexenv)); } frame->enable_handlers = true; - frame->handlers = lisp_ref(make_lisp_hashtable(Qnil, Qnil)); + frame->handlers = refcount_ref(make_lisp_hashtable(Qnil, Qnil)); frame->unwind_forms = Qnil; frame->cleanup_handlers = NULL; @@ -984,16 +699,16 @@ void stack_enter(LispVal *name, LispVal *detail, bool inherit) { void stack_leave(void) { StackFrame *frame = the_stack; the_stack = the_stack->next; - lisp_unref(frame->name); - lisp_unref(frame->detail); - lisp_unref(frame->lexenv); - lisp_unref(frame->handlers); + refcount_unref(frame->name); + refcount_unref(frame->detail); + refcount_unref(frame->lexenv); + refcount_unref(frame->handlers); FOREACH(elt, frame->unwind_forms) { WITH_PUSH_FRAME(Qnil, Qnil, false, { - IGNORE_REF(Feval(elt)); // + refcount_unref(Feval(elt)); // }); } - lisp_unref(frame->unwind_forms); + refcount_unref(frame->unwind_forms); while (frame->cleanup_handlers) { frame->cleanup_handlers->fun(frame->cleanup_handlers->data); struct CleanupHandlerEntry *next = frame->cleanup_handlers->next; @@ -1014,28 +729,35 @@ void *register_cleanup(lisp_cleanup_func_t fun, void *data) { } void free_double_ptr(void *ptr) { - free(*(void **) ptr); + lisp_free(*(void **) ptr); } void unref_free_list_double_ptr(void *ptr) { struct UnrefListData *data = ptr; for (size_t i = 0; i < data->len; ++i) { - lisp_unref(data->vals[i]); + refcount_unref(data->vals[i]); } lisp_free(data->vals); } +void unref_double_ptr(void *ptr) { + if (*(void **) ptr) { + refcount_unref(*(void **) ptr); + *(void **) ptr = NULL; + } +} + void cancel_cleanup(void *handle) { struct CleanupHandlerEntry *entry = the_stack->cleanup_handlers; if (entry == handle) { the_stack->cleanup_handlers = entry->next; - free(entry); + lisp_free(entry); } else { while (entry) { if (entry->next == handle) { struct CleanupHandlerEntry *to_free = entry->next; entry->next = entry->next->next; - free(to_free); + lisp_free(to_free); break; } entry = entry->next; @@ -1043,7 +765,7 @@ void cancel_cleanup(void *handle) { } } -DEFUN(backtrace, "backtrace", ()) { +DEFUN(backtrace, "backtrace", (void) ) { LispVal *head = Qnil; LispVal *end; for (StackFrame *frame = the_stack; frame; frame = frame->next) { @@ -1052,10 +774,12 @@ DEFUN(backtrace, "backtrace", ()) { } if (NILP(head)) { head = Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil); + refcount_unref(HEAD(head)); end = head; } else { LispVal *new_end = Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil); + refcount_unref(HEAD(new_end)); Fsettail(end, new_end); end = new_end; } @@ -1073,10 +797,10 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { continue; } LispVal *handler = - Fgethash(LISPVAL(the_stack->handlers), signal, Qunbound); + gethash(LISPVAL(the_stack->handlers), signal, Qunbound); if (handler == Qunbound) { // handler for all exceptions - handler = Fgethash(LISPVAL(the_stack->handlers), Qt, Qunbound); + handler = gethash(LISPVAL(the_stack->handlers), Qt, Qunbound); } if (handler != Qunbound) { the_stack->enable_handlers = false; @@ -1086,17 +810,17 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { the_stack->hidden = true; if (!NILP(var)) { // TODO make sure this isn't constant - Fputhash(the_stack->lexenv, var, error_arg); + puthash(the_stack->lexenv, var, error_arg); } WITH_CLEANUP(error_arg, { - IGNORE_REF(Feval(form)); // + refcount_unref(Feval(form)); // }); }); longjmp(the_stack->start, 1); // return a nonzero value } } // we never used it, so drop it - lisp_unref(error_arg); + refcount_unref(error_arg); fprintf(stderr, "ERROR: An exception has propogated past the top of the stack!\n"); fprintf(stderr, "Type: "); @@ -1117,87 +841,297 @@ DEF_STATIC_SYMBOL(void_function_error, "void-function-error"); DEF_STATIC_SYMBOL(circular_error, "circular-error"); DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error"); DEF_STATIC_SYMBOL(argument_error, "argument-error"); +DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error"); +DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error"); -struct StaticReference *static_references = NULL; - -void add_static_reference(LispVal *obj) { - struct StaticReference *sr = lisp_malloc(sizeof(struct StaticReference)); - sr->next = static_references; - sr->obj = obj; - static_references = sr; +LispVal *predicate_for_type(LispType type) { + switch (type) { + case TYPE_STRING: + return Qstringp; + case TYPE_SYMBOL: + return Qsymbolp; + case TYPE_PAIR: + return Qpairp; + case TYPE_INTEGER: + return Qintegerp; + case TYPE_FLOAT: + return Qfloatp; + case TYPE_VECTOR: + return Qvectorp; + case TYPE_FUNCTION: + return Qfunctionp; + case TYPE_HASHTABLE: + return Qhashtablep; + case TYPE_USER_POINTER: + return Quser_pointer_p; + default: + abort(); + } } LispVal *Vobarray = Qnil; -void lisp_init() { - Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string)); +static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) { + switch (TYPEOF(obj)) { + case TYPE_STRING: + case TYPE_INTEGER: + case TYPE_FLOAT: + case TYPE_USER_POINTER: + // no held refs + return true; + case TYPE_SYMBOL: + *held = refcount_list_push(*held, ((LispSymbol *) obj)->name); + *held = refcount_list_push(*held, ((LispSymbol *) obj)->function); + *held = refcount_list_push(*held, ((LispSymbol *) obj)->plist); + *held = refcount_list_push(*held, ((LispSymbol *) obj)->value); + return true; + case TYPE_PAIR: + *held = refcount_list_push(*held, ((LispPair *) obj)->head); + *held = refcount_list_push(*held, ((LispPair *) obj)->tail); + return true; + case TYPE_VECTOR: { + LispVector *vec = obj; + for (size_t i = 0; i < vec->length; ++i) { + *held = refcount_list_push(*held, vec->data[i]); + } + return true; + } + case TYPE_HASHTABLE: + HASHTABLE_FOREACH(key, val, obj, { + *held = refcount_list_push(*held, key); + *held = refcount_list_push(*held, val); + }); + return true; + case TYPE_FUNCTION: { + LispFunction *fn = obj; + *held = refcount_list_push(*held, fn->args); + *held = refcount_list_push(*held, fn->kwargs); + *held = refcount_list_push(*held, fn->oargs); + *held = refcount_list_push(*held, fn->rargs); + *held = refcount_list_push(*held, fn->lexenv); + *held = refcount_list_push(*held, fn->doc); + if (!fn->is_builtin) { + *held = refcount_list_push(*held, fn->body); + } + return true; + } + default: + abort(); + } +} +static void free_obj_callback(void *obj, void *ignored) { + switch (TYPEOF(obj)) { + case TYPE_STRING: { + LispString *str = obj; + if (!str->is_static) { + lisp_free(str->data); + } + } break; + case TYPE_VECTOR: { + LispVector *vec = obj; + if (!vec->is_static) { + lisp_free(vec->data); + } + } break; + case TYPE_USER_POINTER: { + LispUserPointer *ptr = obj; + if (ptr->free_func) { + ptr->free_func(ptr->data); + } + } break; + case TYPE_HASHTABLE: { + LispHashtable *tbl = obj; + for (size_t i = 0; i < tbl->table_size; ++i) { + struct HashtableBucket *cur = tbl->data[i]; + while (cur) { + struct HashtableBucket *next = cur->next; + lisp_free(cur); + cur = next; + } + } + lisp_free(tbl->data); + } break; + case TYPE_SYMBOL: + case TYPE_PAIR: + case TYPE_INTEGER: + case TYPE_FLOAT: + case TYPE_FUNCTION: + // no internal data to free + break; + default: + abort(); + } + lisp_free(obj); +} + +void lisp_init(void) { + RefcountContext *ctx = refcount_make_context( + offsetof(LispVal, refcount), Qnil, held_refs_callback, + free_obj_callback, NULL, + &(RefcountAllocator) {.malloc.no_data = lisp_malloc, + .free.no_data = lisp_free}); + refcount_default_context = ctx; + + Vobarray = make_lisp_hashtable(Qstrings_equal, Qhash_string); + + refcount_init_static(Qunbound); + refcount_init_static(&_Qunbound_name); REGISTER_SYMBOL(nil); REGISTER_SYMBOL(t); REGISTER_SYMBOL(opt); REGISTER_SYMBOL(allow_other_keys); REGISTER_SYMBOL(key); REGISTER_SYMBOL(rest); + REGISTER_SYMBOL(comma); + REGISTER_SYMBOL(comma_at); + REGISTER_SYMBOL(backquote); + REGISTER_SYMBOL(shutdown_signal); REGISTER_SYMBOL(type_error); + REGISTER_SYMBOL(read_error); + REGISTER_SYMBOL(eof_error); + REGISTER_SYMBOL(void_variable_error); + REGISTER_SYMBOL(void_function_error); + REGISTER_SYMBOL(circular_error); + REGISTER_SYMBOL(malformed_lambda_list_error); + REGISTER_SYMBOL(argument_error); + REGISTER_SYMBOL(invalid_function_error); + REGISTER_SYMBOL(no_applicable_method_error); - REGISTER_FUNCTION(throw, "(signal &rest data)", ""); - REGISTER_FUNCTION(pair, "(head tail)", - "Return a new pair with HEAD and TAIL."); - REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR."); - REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR."); - REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader."); - REGISTER_FUNCTION(exit, "(&opt code)", - "Exit with CODE, defaulting to zero."); - REGISTER_FUNCTION(print, "(obj)", - "Print a human-readable representation of OBJ."); - REGISTER_FUNCTION( - println, "(obj)", - "Print a human-readable representation of OBJ followed by a newline."); - REGISTER_FUNCTION(not, "(obj)", - "Return t if OBJ is nil, otherwise return t."); - REGISTER_FUNCTION(when, "(cond &rest body)", - "Evaluate BODY if COND is non-nil."); - REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS."); - REGISTER_FUNCTION( - if, "(cond then &rest else)", - "Evaluate THEN if COND is non-nil, otherwise evaluate ELSE."); - REGISTER_FUNCTION( - setq, "(var val)", - "Set each of a number of variables to their respective values."); - REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS."); - REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); - REGISTER_FUNCTION(fset, "(sym new-func)", ""); - REGISTER_FUNCTION(defun, "(name args &rest body)", - "Define NAME to be a new function."); - REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR"); - REGISTER_FUNCTION(read, "(source)", - "Read and return the next s-expr from SOURCE."); - REGISTER_FUNCTION(eq, "(obj1 obj2)", - "Return non-nil if OBJ1 and OBJ2 are equal"); + refcount_init_static(Qtoplevel); + refcount_init_static(&_Qtoplevel_name); + refcount_init_static(Qparent_lexenv); + refcount_init_static(&_Qparent_lexenv_name); + + { + refcount_init_static(Qbreakpoint); + refcount_init_static(((LispSymbol *) Qbreakpoint)->name); + puthash(Vobarray, ((LispVal *) (((LispSymbol *) Qbreakpoint)->name)), + Qbreakpoint); + }; + { + refcount_init_static(((LispSymbol *) Qbreakpoint)->function); + ((LispFunction *) (((LispSymbol *) Qbreakpoint)->function))->doc = + (make_lisp_string(("Do nothing..."), sizeof("") - 1, 1, 1)); + LispVal *src = + (make_lisp_string(("(&opt id)"), sizeof("(&opt id)") - 1, 1, 1)); + LispVal *a = Fread(src); + set_function_args( + (LispFunction *) (((LispSymbol *) Qbreakpoint)->function), a); + refcount_unref(src); + refcount_unref(a); + }; + ; + /* REGISTER_FUNCTION(sethead, "(pair newval)", */ + /* "Set the head of PAIR to NEWVAL."); */ + /* REGISTER_FUNCTION(settail, "(pair newval)", */ + /* "Set the tail of PAIR to NEWVAL."); */ + /* REGISTER_FUNCTION(funcall, "(function &rest args)", "") */ + /* REGISTER_FUNCTION(apply, "(function &rest args)", "") */ + /* REGISTER_FUNCTION(throw, "(signal &rest data)", ""); */ + /* REGISTER_FUNCTION(pair, "(head tail)", */ + /* "Return a new pair with HEAD and TAIL."); */ + /* REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR."); */ + /* REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR."); */ + /* REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader."); + */ + /* REGISTER_FUNCTION(exit, "(&opt code)", */ + /* "Exit with CODE, defaulting to zero."); */ + /* REGISTER_FUNCTION(print, "(obj)", */ + /* "Print a human-readable representation of OBJ."); */ + /* REGISTER_FUNCTION( */ + /* println, "(obj)", */ + /* "Print a human-readable representation of OBJ followed by a + * newline."); */ + /* REGISTER_FUNCTION(not, "(obj)", */ + /* "Return t if OBJ is nil, otherwise return t."); */ + /* REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS."); */ + /* REGISTER_FUNCTION(sub, "(&rest nums)", */ + /* "Return (head NUMS) - (apply '+ (tail NUMS))."); */ + /* REGISTER_FUNCTION( */ + /* if, "(cond then &rest else)", */ + /* "Evaluate THEN if COND is non-nil, otherwise evaluate ELSE."); */ + /* REGISTER_FUNCTION( */ + /* setq, "(&rest name-value-pairs)", */ + /* "Set each of a number of variables to their respective values."); */ + /* REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS."); */ + /* REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); */ + /* REGISTER_FUNCTION(fset, "(sym new-func)", ""); */ + /* REGISTER_FUNCTION(defun, "(name args &rest body)", */ + /* "Define NAME to be a new function."); */ + /* REGISTER_FUNCTION(defmacro, "(name args &rest body)", */ + /* "Define NAME to be a new macro."); */ + /* REGISTER_FUNCTION(lambda, "(args &rest body)", "Return a new closure."); + */ + /* REGISTER_FUNCTION(while, "(cond &rest body)", */ + /* "Run BODY until COND returns nil."); */ + /* REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR"); + */ + /* REGISTER_FUNCTION(read, "(source)", */ + /* "Read and return the next s-expr from SOURCE."); */ + /* REGISTER_FUNCTION(eq, "(obj1 obj2)", */ + /* "Return non-nil if OBJ1 and OBJ2 are equal"); */ + /* REGISTER_FUNCTION(make_symbol, "(name)", */ + /* "Return a new un-interned symbol named NAME."); */ + /* REGISTER_FUNCTION(macroexpand_1, "(form)", */ + /* "Return the form which FORM expands to."); */ + /* REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a + * string."); */ + /* REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a + * symbol."); */ + /* REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair."); */ + /* REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a + * integer."); */ + /* REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float."); + */ + /* REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a + * vector."); */ + /* REGISTER_FUNCTION(functionp, "(val)", */ + /* "Return non-nil if VAL is a function."); */ + /* REGISTER_FUNCTION(macrop, "(val)", "Return non-nil if VAL is a macro."); + */ + /* REGISTER_FUNCTION(hashtablep, "(val)", */ + /* "Return non-nil if VAL is a hashtable."); */ + /* REGISTER_FUNCTION(user_pointer_p, "(val)", */ + /* "Return non-nil if VAL is a user pointer."); */ + /* REGISTER_FUNCTION(atom, "(val)", "Return non-nil if VAL is a atom."); */ + /* REGISTER_FUNCTION(listp, "(val)", "Return non-nil if VAL is a list."); */ + /* REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a + * keyword."); */ + /* REGISTER_FUNCTION(numberp, "(val)", "Return non-nil if VAL is a + * number."); */ + /* REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST."); + */ + /* REGISTER_FUNCTION(num_eq, "(n1 n2)", */ + /* "Return non-nil if N1 and N2 are equal numerically.") + */ + /* REGISTER_FUNCTION(num_gt, "(n1 n2)", */ + /* "Return non-nil if N1 is greather than N2.") */ + /* REGISTER_FUNCTION(and, "(&rest args)", */ + /* "Logical and (with short circuit evaluation.)"); */ + /* REGISTER_FUNCTION(or, "(&rest args)", */ + /* "Logical or (with short circuit evaluation.)"); */ + /* REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ."); */ + /* REGISTER_FUNCTION(function_docstr, "(func)", */ + /* "Return the documentation string of FUNC.") */ } -void lisp_shutdown() { - while (static_references) { - struct StaticReference *next = static_references->next; - lisp_unref_extended(static_references->obj, false); - lisp_free(static_references); - static_references = next; - } - - UNREF_INPLACE(Vobarray); +void lisp_shutdown(void) { + refcount_unref(Vobarray); garbage_collect(); -} -void register_static_function(LispVal *func) {} + refcount_context_destroy(refcount_default_context); + refcount_default_context = NULL; +} static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { while (HASHTABLEP(lexenv)) { - LispVal *value = Fgethash(lexenv, key, Qunbound); + LispVal *value = gethash(lexenv, key, Qunbound); if (value != Qunbound) { return value; } - lexenv = Fgethash(lexenv, Qparent_lexenv, Qunbound); + lexenv = gethash(lexenv, Qparent_lexenv, Qunbound); } return Qunbound; } @@ -1213,9 +1147,22 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { if (sym_val != Qunbound) { return sym_val; } + // TODO free args (not just this call, all calls to Fthrow) Fthrow(Qvoid_variable_error, const_list(1, key)); } +static void breakpoint(int64_t id) {} + +DEFUN(breakpoint, "breakpoint", (LispVal * id)) { + if (NILP(id)) { + breakpoint(0); + } else { + CHECK_TYPE(TYPE_INTEGER, id); + breakpoint(((LispInteger *) id)->value); + } + return Qnil; +} + DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve)) { CHECK_TYPE(TYPE_SYMBOL, symbol); @@ -1226,25 +1173,27 @@ DEFUN(symbol_function, "symbol-function", while (SYMBOLP(symbol) && symbol != Qunbound) { symbol = ((LispSymbol *) symbol)->function; } - return symbol; + return refcount_ref(symbol); } DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) { CHECK_TYPE(TYPE_SYMBOL, symbol); - return ((LispSymbol *) symbol)->value; + return refcount_ref(((LispSymbol *) symbol)->value); } static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { LispVal *final_args = Qnil; - void *cl_handle = register_cleanup( - (lisp_cleanup_func_t) &lisp_unref_double_ptr, &final_args); + void *cl_handle = + register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &final_args); LispVal *end; FOREACH(elt, args) { if (NILP(final_args)) { final_args = Fpair(Feval_in_env(elt, lexenv), Qnil); + refcount_unref(HEAD(final_args)); end = final_args; } else { LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil); + refcount_unref(HEAD(new_end)); Fsettail(end, new_end); end = new_end; } @@ -1253,8 +1202,8 @@ static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { return final_args; } -static LispVal **process_builtin_args(LispFunction *func, LispVal *args, - size_t *nargs) { +static LispVal **process_builtin_args(LispVal *fname, LispFunction *func, + LispVal *args, size_t *nargs) { size_t raw_count = (func->n_req + func->n_opt + ((LispHashtable *) func->kwargs)->count + !NILP(func->rest_arg)); @@ -1267,11 +1216,11 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args, LispVal *opt_desc; LispVal *arg = Qnil; // last arg processed while (!NILP(args)) { - arg = Fhead(args); + arg = HEAD(args); if (have_count < func->n_req + func->n_opt) { - vec[have_count++] = lisp_ref(arg); + vec[have_count++] = refcount_ref(arg); } else if (KEYWORDP(arg) - && !NILP(opt_desc = Fhead(Fgethash(func->kwargs, arg, Qnil))) + && !NILP(opt_desc = HEAD(gethash(func->kwargs, arg, Qnil))) && NILP(rest)) { struct OptArgDesc *oad = USERPTR(struct OptArgDesc, opt_desc); if (vec[oad->index]) { @@ -1281,7 +1230,7 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args, if (NILP(args)) { goto key_no_val; } - vec[oad->index] = lisp_ref(Fhead(arg)); + vec[oad->index] = refcount_ref(HEAD(arg)); } else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) { goto unknown_key; } else if (NILP(func->rest_arg)) { @@ -1292,15 +1241,16 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args, } else { LispVal *new_end = Fpair(arg, Qnil); Fsettail(rest_end, new_end); + refcount_unref(new_end); rest_end = new_end; } - args = Ftail(args); + args = TAIL(args); } if (have_count < func->n_req) { goto too_few; } if (!NILP(func->rest_arg)) { - vec[raw_count - 1] = lisp_ref(rest); + vec[raw_count - 1] = refcount_ref(rest); } for (size_t i = 0; i < raw_count; ++i) { if (!vec[i]) { @@ -1314,26 +1264,26 @@ too_many: multikey: unknown_key: too_few: - lisp_unref(rest); + refcount_unref(rest); for (size_t i = 0; i < raw_count; ++i) { if (vec[i]) { - lisp_unref(vec[i]); + refcount_unref(vec[i]); } } lisp_free(vec); - Fthrow(Qargument_error, Qnil); + Fthrow(Qargument_error, Fpair(fname, Qnil)); return NULL; } static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) { size_t nargs; - LispVal **arg_vec = process_builtin_args(func, args, &nargs); + LispVal **arg_vec = process_builtin_args(name, func, args, &nargs); struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs}; void *cl = register_cleanup(&unref_free_list_double_ptr, &cleanup_data); LispVal *retval; switch (nargs) { case 0: - retval = ((LispVal * (*) ()) func->builtin)(); + retval = ((LispVal * (*) (void) ) func->builtin)(); break; case 1: retval = ((LispVal * (*) (LispVal *) ) func->builtin)(arg_vec[0]); @@ -1371,44 +1321,45 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) { abort(); } cancel_cleanup(cl); + refcount_ref(retval); unref_free_list_double_ptr(&cleanup_data); return retval; } -static void process_lisp_args(LispFunction *func, LispVal *args, +static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, LispVal *lexenv) { enum { REQ, OPT, KEY, REST } mode = REQ; LispVal *rargs = func->rargs; LispVal *oargs = func->oargs; while (!NILP(args)) { - LispVal *arg = Fhead(args); + LispVal *arg = HEAD(args); switch (mode) { case REQ: { if (NILP(rargs)) { mode = OPT; continue; // skip increment } - Fputhash(lexenv, Fhead(rargs), arg); - rargs = Ftail(rargs); + puthash(lexenv, HEAD(rargs), arg); + rargs = TAIL(rargs); } break; case OPT: { if (NILP(oargs)) { mode = KEY; continue; // skip increment } - struct OptArgDesc *oad = USERPTR(struct OptArgDesc, Fhead(oargs)); - Fputhash(lexenv, oad->name, arg); + struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs)); + puthash(lexenv, oad->name, arg); if (!NILP(oad->pred_var)) { - Fputhash(lexenv, oad->pred_var, Qt); + puthash(lexenv, oad->pred_var, Qt); } - oargs = Ftail(oargs); + oargs = TAIL(oargs); } break; case KEY: if (!KEYWORDP(arg)) { mode = REST; continue; // skip increment } - LispVal *desc_lv = Fgethash(func->kwargs, arg, Qnil); + LispVal *desc_lv = gethash(func->kwargs, arg, Qnil); if (NILP(desc_lv)) { if (!func->allow_other_keys) { goto unknown_key; @@ -1417,34 +1368,34 @@ static void process_lisp_args(LispFunction *func, LispVal *args, continue; // skip increment } struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv); - args = Ftail(args); + args = TAIL(args); if (NILP(args)) { goto missing_value; } - LispVal *value = Fhead(args); - Fputhash(lexenv, oad->name, value); + LispVal *value = HEAD(args); + puthash(lexenv, oad->name, value); if (!NILP(oad->pred_var)) { - Fputhash(lexenv, oad->pred_var, Qt); + puthash(lexenv, oad->pred_var, Qt); } break; case REST: if (NILP(func->rest_arg)) { if (KEYWORDP(arg)) { - args = Ftail(args); + args = TAIL(args); if (NILP(args)) { goto missing_value; } - args = Ftail(args); + args = TAIL(args); continue; // skip increment } else { goto too_many_args; } } - Fputhash(lexenv, func->rest_arg, args); + puthash(lexenv, func->rest_arg, args); // done processing return; } - args = Ftail(args); + args = TAIL(args); } if (!NILP(rargs)) { goto missing_required; @@ -1455,66 +1406,94 @@ static void process_lisp_args(LispFunction *func, LispVal *args, struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv); // only check the current function's lexenv and not its parents' if (Fgethash(lexenv, oad->name, Qunbound) == Qunbound) { - Fputhash(lexenv, oad->name, Feval(oad->default_form)); + LispVal *eval_res = Feval(oad->default_form); + puthash(lexenv, oad->name, eval_res); + refcount_unref(eval_res); if (!NILP(oad->pred_var)) { - Fputhash(lexenv, oad->pred_var, Qnil); + puthash(lexenv, oad->pred_var, Qnil); } } }); #pragma GCC diagnostic pop FOREACH(arg, oargs) { struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg); - Fputhash(lexenv, oad->name, Feval(oad->default_form)); + LispVal *default_val = Feval(oad->default_form); + puthash(lexenv, oad->name, default_val); + refcount_unref(default_val); if (!NILP(oad->pred_var)) { - Fputhash(lexenv, oad->pred_var, Qnil); + puthash(lexenv, oad->pred_var, Qnil); } } + if (!NILP(func->rest_arg)) { + puthash(lexenv, func->rest_arg, Qnil); + } return; // TODO different messages missing_required: too_many_args: missing_value: unknown_key: - Fthrow(Qargument_error, Qnil); + Fthrow(Qargument_error, Fpair(fname, Qnil)); } static LispVal *call_lisp_function(LispVal *name, LispFunction *func, - LispVal *args) { - Fputhash(the_stack->lexenv, Qparent_lexenv, func->lexenv); - process_lisp_args(func, args, the_stack->lexenv); - // TODO handle macros - return Fprogn(func->body); + LispVal *args, LispVal *args_lexenv) { + puthash(the_stack->lexenv, Qparent_lexenv, func->lexenv); + process_lisp_args(name, func, args, the_stack->lexenv); + if (func->is_macro) { + if (!the_stack->next) { + abort(); + } + LispVal *expansion = Fprogn(func->body); + LispVal *retval = Qnil; + WITH_CLEANUP(expansion, { + // eval in the outer lexenv + retval = Feval_in_env(expansion, args_lexenv); + }); + return retval; + } else { + return Fprogn(func->body); + } } static LispVal *call_function(LispVal *func, LispVal *args, - LispVal *args_lexenv, bool eval_args) { - LispFunction *fobj; + LispVal *args_lexenv, bool eval_args, + bool allow_macro) { + LispFunction *fobj = (LispFunction *) Qnil; if (FUNCTIONP(func)) { - fobj = (LispFunction *) func; - } else { + fobj = (LispFunction *) refcount_ref(func); + } else if (SYMBOLP(func)) { fobj = (LispFunction *) Fsymbol_function(func, Qt); + } else { + Fthrow(Qinvalid_function_error, Fpair(func, Qnil)); } + void *cl_handle = register_cleanup(unref_double_ptr, &fobj); if (LISPVAL(fobj) == Qunbound) { Fthrow(Qvoid_function_error, const_list(1, func)); + } else if (!FUNCTIONP(fobj)) { + Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil)); + } else if (!allow_macro && fobj->is_macro) { + Fthrow(Qtype_error, Qnil); } - CHECK_TYPE(TYPE_FUNCTION, fobj); if (!fobj->is_macro && eval_args) { args = eval_function_args(args, args_lexenv); } - lisp_ref(args); LispVal *retval = Qnil; // builtin macros inherit their parents lexenv - WITH_PUSH_FRAME(func, args, fobj->is_macro && fobj->is_builtin, { - void *cl_handle = register_cleanup( - (lisp_cleanup_func_t) &lisp_unref_double_ptr, &args); + WITH_PUSH_FRAME(func, args, false, { + if (fobj->is_macro && fobj->is_builtin) { + puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv); + } + void *cl_handle = + register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &args); if (fobj->is_builtin) { retval = call_builtin(func, fobj, args); } else { - retval = call_lisp_function(func, fobj, args); + retval = call_lisp_function(func, fobj, args, args_lexenv); } cancel_cleanup(cl_handle); - }) - lisp_unref(args); + }); + cancel_cleanup(cl_handle); return retval; } @@ -1527,24 +1506,26 @@ DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) { case TYPE_HASHTABLE: case TYPE_USER_POINTER: // the above all are self-evaluating - return form; + return refcount_ref(form); case TYPE_SYMBOL: if (KEYWORDP(form)) { - return form; + return refcount_ref(form); } else { + // this refs its return value return symbol_value_in_lexenv(lexenv, form); } case TYPE_VECTOR: { LispVector *vec = (LispVector *) form; LispVal **elts = lisp_malloc(sizeof(LispVal *) * vec->length); for (size_t i = 0; i < vec->length; ++i) { - elts[i] = lisp_ref(Feval_in_env(vec->data[i], lexenv)); + elts[i] = Feval_in_env(vec->data[i], lexenv); } + // does not ref its arguments return make_lisp_vector(elts, vec->length); } case TYPE_PAIR: { LispPair *pair = (LispPair *) form; - return call_function(pair->head, pair->tail, lexenv, true); + return call_function(pair->head, pair->tail, lexenv, true, true); } default: abort(); @@ -1556,7 +1537,29 @@ DEFUN(eval, "eval", (LispVal * form)) { } DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) { - return call_function(function, rest, Qnil, false); + return call_function(function, rest, Qnil, false, false); +} + +DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { + if (PAIRP(form)) { + LispFunction *fobj = (LispFunction *) Fsymbol_function(Fhead(form), Qt); + if (!FUNCTIONP(fobj) || fobj->is_builtin || !fobj->is_macro) { + refcount_unref(fobj); + return refcount_ref(form); + } + LispVal *expansion = Qnil; + WITH_CLEANUP(fobj, { + WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, { + puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv); + process_lisp_args(Fhead(form), fobj, Ftail(form), + the_stack->lexenv); + expansion = Fprogn(fobj->body); + }); + }); + return expansion; + } else { + return refcount_ref(form); + } } DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { @@ -1569,41 +1572,46 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { } else { LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil); Fsettail(end, new_end); + refcount_unref(new_end); end = new_end; } rest = ((LispPair *) rest)->tail; } - if (LISTP(((LispPair *) rest)->head)) { - Fsettail(end, ((LispPair *) rest)->head); + if (LISTP(HEAD(rest))) { + // ensure the list is not circular + refcount_ref(args); + WITH_CLEANUP(args, { + list_length(Fhead(rest)); // + }); + if (NILP(args)) { + args = HEAD(rest); + } else { + Fsettail(end, HEAD(rest)); + } } else { - LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil); - - Fsettail(end, new_end); - end = new_end; + if (NILP(args)) { + args = Fpair(((LispPair *) rest)->head, Qnil); + end = args; + } else { + LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil); + Fsettail(end, new_end); + refcount_unref(new_end); + end = new_end; + } } - lisp_ref(args); - void *cl_handle = - register_cleanup((lisp_cleanup_func_t) &lisp_unref_double_ptr, &args); - LispVal *retval = Ffuncall(function, args); - cancel_cleanup(cl_handle); - lisp_unref(args); + LispVal *retval; + WITH_CLEANUP(args, { + retval = Ffuncall(function, args); // + }); return retval; } DEFUN(head, "head", (LispVal * list)) { - if (NILP(list)) { - return Qnil; - } - CHECK_TYPE(TYPE_PAIR, list); - return ((LispPair *) list)->head; + return refcount_ref(HEAD(list)); } DEFUN(tail, "tail", (LispVal * list)) { - if (NILP(list)) { - return Qnil; - } - CHECK_TYPE(TYPE_PAIR, list); - return ((LispPair *) list)->tail; + return refcount_ref(TAIL(list)); } DEFUN(exit, "exit", (LispVal * code)) { @@ -1614,7 +1622,7 @@ DEFUN(exit, "exit", (LispVal * code)) { } DEFMACRO(quote, "'", (LispVal * form)) { - return form; + return refcount_ref(form); } DEFUN(print, "print", (LispVal * obj)) { @@ -1645,45 +1653,130 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) { return retval; } -DEFMACRO(when, "when", (LispVal * cond, LispVal *t)) { - LispVal *body = Fpair(Qprogn, t); - LispVal *retval = Qnil; - WITH_CLEANUP(body, { - retval = Fif(cond, body, Qnil); // - }); - return retval; -} - -DEFUN(add, "+", (LispVal * n1, LispVal *n2)) { +DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2)) { if (INTEGERP(n1) && INTEGERP(n2)) { - return make_lisp_integer(((LispInteger *) n1)->value - + ((LispInteger *) n2)->value); + return LISP_BOOL(((LispInteger *) n1)->value + == ((LispInteger *) n2)->value); } else if (INTEGERP(n1) && FLOATP(n2)) { - return make_lisp_float(((LispInteger *) n1)->value - + ((LispFloat *) n2)->value); + return LISP_BOOL(((LispInteger *) n1)->value + == ((LispFloat *) n2)->value); } else if (FLOATP(n1) && INTEGERP(n2)) { - return make_lisp_float(((LispFloat *) n1)->value - + ((LispInteger *) n2)->value); + return LISP_BOOL(((LispFloat *) n1)->value + == ((LispInteger *) n2)->value); } else if (FLOATP(n1) && FLOATP(n2)) { - return make_lisp_float(((LispFloat *) n1)->value - + ((LispFloat *) n2)->value); + return LISP_BOOL(((LispFloat *) n1)->value + == ((LispFloat *) n2)->value); } else { Fthrow(Qtype_error, Qnil); } } -DEFMACRO(setq, "setq", (LispVal * name, LispVal *value)) { - CHECK_TYPE(TYPE_SYMBOL, name); - LispSymbol *sym = (LispSymbol *) name; - LispVal *evaled = Feval(value); - lisp_unref(sym->value); - sym->value = lisp_ref(evaled); - return evaled; +DEFUN(num_gt, ">", (LispVal * n1, LispVal *n2)) { + if (INTEGERP(n1) && INTEGERP(n2)) { + return LISP_BOOL(((LispInteger *) n1)->value + > ((LispInteger *) n2)->value); + } else if (INTEGERP(n1) && FLOATP(n2)) { + return LISP_BOOL(((LispInteger *) n1)->value + > ((LispFloat *) n2)->value); + } else if (FLOATP(n1) && INTEGERP(n2)) { + return LISP_BOOL(((LispFloat *) n1)->value + > ((LispInteger *) n2)->value); + } else if (FLOATP(n1) && FLOATP(n2)) { + return LISP_BOOL(((LispFloat *) n1)->value > ((LispFloat *) n2)->value); + } else { + Fthrow(Qtype_error, Qnil); + } +} + +#define ONE_MATH_OPERAION(oper, out, n1, n2) \ + if (INTEGERP(n1) && INTEGERP(n2)) { \ + out = make_lisp_integer( \ + ((LispInteger *) n1)->value oper((LispInteger *) n2)->value); \ + } else if (INTEGERP(n1) && FLOATP(n2)) { \ + out = make_lisp_float( \ + ((LispInteger *) n1)->value oper((LispFloat *) n2)->value); \ + } else if (FLOATP(n1) && INTEGERP(n2)) { \ + out = make_lisp_float( \ + ((LispFloat *) n1)->value oper((LispInteger *) n2)->value); \ + } else if (FLOATP(n1) && FLOATP(n2)) { \ + out = make_lisp_float( \ + ((LispFloat *) n1)->value oper((LispFloat *) n2)->value); \ + } else { \ + Fthrow(Qtype_error, Qnil); \ + } + +static inline LispVal *copy_number(LispVal *v) { + if (FLOATP(v)) { + return make_lisp_float(((LispFloat *) v)->value); + } else if (INTEGERP(v)) { + return make_lisp_integer(((LispInteger *) v)->value); + } else { + abort(); + } +} + +DEFUN(add, "+", (LispVal * args)) { + if (NILP(args)) { + return make_lisp_integer(0); + } + LispVal *out = copy_number(Fhead(args)); + FOREACH(arg, Ftail(args)) { + LispVal *old_out = out; + WITH_CLEANUP(old_out, { + ONE_MATH_OPERAION(+, out, out, arg); // + }); + } + return out; +} + +DEFUN(sub, "-", (LispVal * args)) { + if (NILP(args)) { + return make_lisp_integer(0); + } + LispVal *out = copy_number(Fhead(args)); + FOREACH(arg, Ftail(args)) { + LispVal *old_out = out; + WITH_CLEANUP(old_out, { + ONE_MATH_OPERAION(-, out, out, arg); // + }); + } + return out; +} + +static void set_symbol_in_lexenv(LispVal *key, LispVal *newval, + LispVal *lexenv) { + while (HASHTABLEP(lexenv)) { + if (gethash(lexenv, key, Qunbound) != Qunbound) { + puthash(lexenv, key, newval); + return; + } + lexenv = gethash(lexenv, Qparent_lexenv, Qnil); + } + refcount_ref(newval); + refcount_unref(((LispSymbol *) key)->value); + ((LispSymbol *) key)->value = newval; +} + +DEFMACRO(setq, "setq", (LispVal * args)) { + size_t len = list_length(args); + if (!len || len % 2) { + Fthrow(Qargument_error, Fpair(Qsetq, Qnil)); + } + LispVal *retval = Qnil; + FOREACH_TAIL(tail, args) { + CHECK_TYPE(TYPE_SYMBOL, HEAD(tail)); + LispVal *name = HEAD(tail); + tail = HEAD(tail); + retval = Feval(HEAD(tail)); + set_symbol_in_lexenv(name, retval, the_stack->lexenv); + } + return retval; } DEFMACRO(progn, "progn", (LispVal * forms)) { LispVal *retval = Qnil; FOREACH(form, forms) { + refcount_unref(retval); retval = Feval(form); } return retval; @@ -1693,19 +1786,168 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) { CHECK_TYPE(TYPE_SYMBOL, sym); LispSymbol *sobj = ((LispSymbol *) sym); // TODO make sure this is not constant - lisp_unref(sobj->function); - sobj->function = lisp_ref(new_func); - return new_func; + refcount_ref(new_func); + refcount_unref(sobj->function); + sobj->function = new_func; + return refcount_ref(new_func); } DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) { CHECK_TYPE(TYPE_SYMBOL, name); - LispVal *func = - make_lisp_function(args, Qnil, the_stack->lexenv, body, false); - Ffset(name, func); + LispVal *func = make_lisp_function(args, the_stack->lexenv, body, false); + refcount_unref(Ffset(name, func)); return func; } +DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) { + CHECK_TYPE(TYPE_SYMBOL, name); + LispVal *func = make_lisp_function(args, the_stack->lexenv, body, true); + refcount_unref(Ffset(name, func)); + return func; +} + +DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { + return make_lisp_function(args, the_stack->lexenv, body, false); +} + +DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) { + LispVal *evaled_cond; + while (!NILP(evaled_cond = Feval(cond))) { + refcount_unref(evaled_cond); + refcount_unref(Fprogn(body)); + } + return Qnil; +} + +DEFUN(make_symbol, "make-symbol", (LispVal * name)) { + return make_lisp_symbol(name); +} + +DEFUN(stringp, "stringp", (LispVal * val)) { + return LISP_BOOL(STRINGP(val)); +} + +DEFUN(symbolp, "symbolp", (LispVal * val)) { + return LISP_BOOL(SYMBOLP(val)); +} + +DEFUN(pairp, "pairp", (LispVal * val)) { + return LISP_BOOL(PAIRP(val)); +} + +DEFUN(integerp, "integerp", (LispVal * val)) { + return LISP_BOOL(INTEGERP(val)); +} + +DEFUN(floatp, "floatp", (LispVal * val)) { + return LISP_BOOL(FLOATP(val)); +} + +DEFUN(vectorp, "vectorp", (LispVal * val)) { + return LISP_BOOL(VECTORP(val)); +} + +DEFUN(functionp, "functionp", (LispVal * val)) { + if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) { + return Qt; + } else if (SYMBOLP(val)) { + LispVal *res = Fsymbol_function(val, Qt); + LispVal *retval = + LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_macro); + refcount_unref(res); + return retval; + } + return Qnil; +} + +DEFUN(macrop, "macrop", (LispVal * val)) { + if (FUNCTIONP(val) && ((LispFunction *) val)->is_macro) { + return Qt; + } else if (SYMBOLP(val)) { + LispVal *res = Fsymbol_function(val, Qt); + LispVal *retval = + LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_macro); + refcount_unref(res); + return retval; + } + return Qnil; +} + +DEFUN(hashtablep, "hashtablep", (LispVal * val)) { + return LISP_BOOL(HASHTABLEP(val)); +} + +DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) { + return LISP_BOOL(USER_POINTER_P(val)); +} + +DEFUN(atom, "atom", (LispVal * val)) { + return LISP_BOOL(ATOM(val)); +} + +DEFUN(listp, "listp", (LispVal * val)) { + return LISP_BOOL(LISTP(val)); +} + +DEFUN(keywordp, "keywordp", (LispVal * val)) { + return LISP_BOOL(KEYWORDP(val)); +} + +DEFUN(numberp, "numberp", (LispVal * val)) { + return LISP_BOOL(NUMBERP(val)); +} + +DEFUN(list_length, "list-length", (LispVal * list)) { + return make_lisp_integer(list_length(list)); +} + +DEFMACRO(and, "and", (LispVal * rest)) { + LispVal *retval = Qnil; + FOREACH(cond, rest) { + LispVal *nc; + WITH_CLEANUP(retval, { + nc = Feval(cond); // + }); + if (NILP(nc)) { + return Qnil; + } + retval = nc; + } + return retval; +} + +DEFMACRO(or, "or", (LispVal * rest)) { + FOREACH(cond, rest) { + LispVal *nc = Feval(cond); + if (!NILP(nc)) { + return nc; + } + } + return Qnil; +} + +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); + LispVal *sym = Fintern(name); + return sym; +} + +DEFUN(function_docstr, "function-docstr", (LispVal * func)) { + if (FUNCTIONP(func)) { + return ((LispFunction *) func)->doc; + } + LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt); + CHECK_TYPE(TYPE_FUNCTION, fobj); + LispVal *retval = refcount_ref(fobj->doc); + refcount_unref(fobj); + return retval; +} + static void debug_dump_real(FILE *stream, void *obj, bool first) { switch (TYPEOF(obj)) { case TYPE_STRING: { @@ -1794,3 +2036,19 @@ void debug_print_hashtable(FILE *stream, LispVal *table) { debug_dump(stream, val, true); }); } + +static bool debug_print_tree_callback(void *obj, const RefcountList *trail, + void *stream_raw) { + FILE *stream = stream_raw; + size_t depth = refcount_list_length(trail); + for (size_t i = 0; i < depth; ++i) { + fprintf(stream, " "); + } + fprintf(stream, "- "); + debug_dump(stream, obj, true); + return false; +} + +void debug_print_tree(FILE *stream, void *obj) { + refcount_debug_walk_tree(obj, debug_print_tree_callback, stream); +} diff --git a/src/lisp.h b/src/lisp.h index 2d9d734..a823be9 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1,6 +1,7 @@ #ifndef INCLUDED_LISP_H #define INCLUDED_LISP_H +#include #include #include #include @@ -10,7 +11,7 @@ #include #include -#if __has_attribute(format) +#if defined(__has_attribute) && __has_attribute(format) # define PRINTF_FORMAT(first, second) \ __attribute__((format(printf, first, second))) #else @@ -41,9 +42,7 @@ extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES]; #define LISP_OBJECT_HEADER \ LispType type; \ - void *gc_root; \ - ptrdiff_t ref_count; \ - bool finalizing; + RefcountEntry refcount typedef struct { LISP_OBJECT_HEADER; @@ -91,6 +90,7 @@ typedef struct { LispVal **data; size_t length; + bool is_static; } LispVector; struct OptArgDesc { @@ -102,6 +102,8 @@ struct OptArgDesc { void free_opt_arg_desc(void *obj); +typedef void (*lisp_function_ptr_t)(void); + typedef struct { LISP_OBJECT_HEADER; @@ -118,7 +120,7 @@ typedef struct { bool allow_other_keys; LispVal *rest_arg; union { - void *builtin; + lisp_function_ptr_t builtin; LispVal *body; }; @@ -211,36 +213,33 @@ inline static bool NUMBERP(LispVal *v) { #define DEF_STATIC_STRING(name, value) \ static LispString name = { \ .type = TYPE_STRING, \ - .ref_count = -1, \ .data = value, \ .length = sizeof(value) - 1, \ .is_static = true, \ - }; + } #define DEF_STATIC_SYMBOL(c_name, lisp_name) \ DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ static LispSymbol _Q##c_name = { \ .type = TYPE_SYMBOL, \ - .ref_count = -1, \ .name = &_Q##c_name##_name, \ .plist = Qnil, \ .function = Qunbound, \ .value = Qunbound, \ .is_constant = false, \ }; \ - LispVal *Q##c_name = LISPVAL(&_Q##c_name); + LispVal *Q##c_name = LISPVAL(&_Q##c_name) #define DECLARE_FUNCTION(c_name, args) \ LispVal *F##c_name args; \ - extern LispVal *Q##c_name; + extern LispVal *Q##c_name // The args and doc fields are filled when the function is registered #define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \ LispVal *F##c_name c_args; \ DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ static LispFunction _Q##c_name##_function = { \ .type = TYPE_FUNCTION, \ - .ref_count = -1, \ .is_builtin = true, \ .is_macro = macrop, \ - .builtin = &F##c_name, \ + .builtin = (void (*)(void)) & F##c_name, \ .doc = Qnil, \ .args = Qnil, \ .rargs = Qnil, \ @@ -251,7 +250,6 @@ inline static bool NUMBERP(LispVal *v) { }; \ static LispSymbol _Q##c_name = { \ .type = TYPE_SYMBOL, \ - .ref_count = -1, \ .name = &_Q##c_name##_name, \ .plist = Qnil, \ .value = Qunbound, \ @@ -284,12 +282,12 @@ inline static bool NUMBERP(LispVal *v) { } \ } \ } -#define FOREACH(var, list) \ - for (LispVal *__foreach_cur = list, *var = Fhead(list); \ - !NILP(__foreach_cur); \ - __foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur)) +#define FOREACH(var, list) \ + for (LispVal *__foreach_cur = list, *var = HEAD(list); \ + !NILP(__foreach_cur); \ + __foreach_cur = TAIL(__foreach_cur), var = HEAD(__foreach_cur)) #define FOREACH_TAIL(var, list) \ - for (LispVal *var = list; !NILP(var); var = Ftail(var)) + for (LispVal *var = list; !NILP(var); var = TAIL(var)) // ############################# // # Allocation and references # @@ -300,16 +298,7 @@ void *lisp_malloc(size_t size); void *lisp_realloc(void *old_ptr, size_t size); #define lisp_free free -void *lisp_ref(void *val); -void *lisp_float_ref(void *val); -void garbage_collect(); -void *lisp_unref(void *val); -#define UNREF_INPLACE(variable) \ - { \ - variable = lisp_unref(variable); \ - } -void lisp_unref_double_ptr(void **val); -#define IGNORE_REF(val) (lisp_unref(lisp_ref(val))) +void garbage_collect(void); // ################ // # Constructors # @@ -324,8 +313,8 @@ LispVal *make_lisp_integer(intmax_t value); LispVal *make_lisp_float(long double value); LispVal *make_lisp_vector(LispVal **data, size_t length); void set_function_args(LispFunction *func, LispVal *args); -LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv, - LispVal *body, bool is_macro); +LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, + bool is_macro); LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); LispVal *make_user_pointer(void *data, void (*free_func)(void *)); #define ALLOC_USERPTR(type, free_func) \ @@ -336,7 +325,6 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)); // ######################## bool strings_equal_nocase(const char *s1, const char *s2, size_t n); -DECLARE_FUNCTION(type_of, (LispVal * obj)); DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail)); DECLARE_FUNCTION(hash_string, (LispVal * obj)); DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2)); @@ -349,9 +337,9 @@ DECLARE_FUNCTION(hash_table_count, (LispVal * table)); LispVal *intern(const char *name, size_t length, bool take); DECLARE_FUNCTION(intern, (LispVal * name)); static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) { - LispVal *kn = lisp_ref(make_lisp_string(name, len, true, true)); + LispVal *kn = make_lisp_string(name, len, true, true); LispVal *retval = Fintern(kn); - lisp_unref(kn); + refcount_unref(kn); return retval; } #define INTERN_STATIC(name) (_internal_INTERN_STATIC((name), sizeof(name) - 1)) @@ -372,6 +360,7 @@ static inline LispVal *const_list(int len, ...) { } else { LispVal *new_end = Fpair(elt, Qnil); Fsettail(end, new_end); + refcount_unref(new_end); end = new_end; } } @@ -388,6 +377,7 @@ static inline LispVal *make_list(size_t len, LispVal **vals) { } else { LispVal *new_end = Fpair(vals[i], Qnil); Fsettail(end, new_end); + refcount_unref(new_end); end = new_end; } } @@ -426,6 +416,7 @@ struct UnrefListData { size_t len; }; void unref_free_list_double_ptr(void *ptr); +void unref_double_ptr(void *ptr); void cancel_cleanup(void *handle); #define WITH_PUSH_FRAME(name, detail, inherit, body) \ stack_enter(name, detail, inherit); \ @@ -433,17 +424,16 @@ void cancel_cleanup(void *handle); body \ } \ stack_leave(); -#define WITH_CLEANUP(var, body) \ - lisp_ref(var); \ - { \ - void *__with_cleanup_cleanup = register_cleanup( \ - (lisp_cleanup_func_t) & lisp_unref_double_ptr, &(var)); \ - {body}; \ - cancel_cleanup(__with_cleanup_cleanup); \ - lisp_unref(var); \ +#define WITH_CLEANUP(var, body) \ + { \ + void *__with_cleanup_cleanup = register_cleanup( \ + (lisp_cleanup_func_t) & unref_double_ptr, &(var)); \ + {body}; \ + cancel_cleanup(__with_cleanup_cleanup); \ + refcount_unref(var); \ } -DECLARE_FUNCTION(backtrace, ()); +DECLARE_FUNCTION(backtrace, (void) ); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); extern LispVal *Qshutdown_signal; @@ -455,36 +445,35 @@ extern LispVal *Qvoid_function_error; extern LispVal *Qcircular_error; extern LispVal *Qmalformed_lambda_list_error; extern LispVal *Qargument_error; +extern LispVal *Qinvalid_function_error; +extern LispVal *Qno_applicable_method_error; -#define CHECK_TYPE(type, val) \ - if (TYPEOF(val) != type) { \ - Fthrow(Qtype_error, Qnil); \ +LispVal *predicate_for_type(LispType type); +#define CHECK_TYPE(type, val) \ + if (TYPEOF(val) != type) { \ + LispVal *inner_list = const_list(1, predicate_for_type(type)); \ + LispVal *args = const_list(2, inner_list, Ftype_of(LISPVAL(val))); \ + refcount_unref(inner_list); \ + Fthrow(Qtype_error, args); \ } -struct StaticReference { - struct StaticReference *next; - LispVal *obj; -}; - -extern struct StaticReference *static_references; - -void add_static_reference(LispVal *obj); - extern LispVal *Vobarray; -#define REGISTER_SYMBOL(sym) \ - { \ - Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \ - add_static_reference(Q##sym); \ +#define REGISTER_SYMBOL(sym) \ + { \ + refcount_init_static(Q##sym); \ + refcount_init_static(((LispSymbol *) Q##sym)->name); \ + puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \ } #define REGISTER_STATIC_FUNCTION(obj, args, docstr) \ - ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ { \ + refcount_init_static(obj); \ + ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ LispVal *src = STATIC_STRING(args); \ - lisp_ref(src); \ - set_function_args((LispFunction *) (obj), Fread(src)); \ - lisp_unref(src); \ - add_static_reference(obj); \ + LispVal *a = Fread(src); \ + set_function_args((LispFunction *) (obj), a); \ + refcount_unref(src); \ + refcount_unref(a); \ } #define REGISTER_FUNCTION(fn, args, docstr) \ REGISTER_SYMBOL(fn); \ @@ -496,33 +485,84 @@ void register_static_function(LispVal *func); extern LispVal *Qbackquote; extern LispVal *Qcomma; +extern LispVal *Qcomma_at; DECLARE_FUNCTION(quote, (LispVal * form)); +DECLARE_FUNCTION(breakpoint, (LispVal * id)); DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(eval, (LispVal * form)); DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest)); DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest)); + DECLARE_FUNCTION(head, (LispVal * list)); DECLARE_FUNCTION(tail, (LispVal * list)); + noreturn DECLARE_FUNCTION(exit, (LispVal * code)); DECLARE_FUNCTION(print, (LispVal * obj)); DECLARE_FUNCTION(println, (LispVal * obj)); DECLARE_FUNCTION(not, (LispVal * obj)); -DECLARE_FUNCTION(when, (LispVal * cond, LispVal *t)); DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil)); -DECLARE_FUNCTION(add, (LispVal * n1, LispVal *n2)); -DECLARE_FUNCTION(setq, (LispVal * name, LispVal *value)); +DECLARE_FUNCTION(add, (LispVal * args)); +DECLARE_FUNCTION(sub, (LispVal * args)); +DECLARE_FUNCTION(setq, (LispVal * args)); DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func)); DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body)); +DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body)); +DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); +DECLARE_FUNCTION(while, (LispVal * condition, LispVal *body)); +DECLARE_FUNCTION(make_symbol, (LispVal * name)); +DECLARE_FUNCTION(macroexpand_1, (LispVal * form)); +DECLARE_FUNCTION(stringp, (LispVal * val)); +DECLARE_FUNCTION(symbolp, (LispVal * val)); +DECLARE_FUNCTION(pairp, (LispVal * val)); +DECLARE_FUNCTION(integerp, (LispVal * val)); +DECLARE_FUNCTION(floatp, (LispVal * val)); +DECLARE_FUNCTION(vectorp, (LispVal * val)); +DECLARE_FUNCTION(functionp, (LispVal * val)); +DECLARE_FUNCTION(macrop, (LispVal * val)); +DECLARE_FUNCTION(hashtablep, (LispVal * val)); +DECLARE_FUNCTION(user_pointer_p, (LispVal * val)); +DECLARE_FUNCTION(atom, (LispVal * val)); +DECLARE_FUNCTION(listp, (LispVal * val)); +DECLARE_FUNCTION(keywordp, (LispVal * val)); +DECLARE_FUNCTION(numberp, (LispVal * val)); +DECLARE_FUNCTION(list_length, (LispVal * list)); +DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2)); +DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2)); +DECLARE_FUNCTION(and, (LispVal * rest)); +DECLARE_FUNCTION(or, (LispVal * rest)); +DECLARE_FUNCTION(type_of, (LispVal * val)); +DECLARE_FUNCTION(function_docstr, (LispVal * func)); void debug_dump(FILE *stream, void *obj, bool newline); void debug_print_hashtable(FILE *stream, LispVal *table); +void debug_print_tree(FILE *stream, void *obj); extern LispVal *Qopt; extern LispVal *Qkey; extern LispVal *Qallow_other_keys; extern LispVal *Qrest; +// some internal functions +LispVal *puthash(LispVal *table, LispVal *key, LispVal *value); +LispVal *gethash(LispVal *table, LispVal *key, LispVal *def); +LispVal *remhash(LispVal *table, LispVal *key); + +static inline LispVal *HEAD(LispVal *list) { + if (NILP(list)) { + return Qnil; + } + CHECK_TYPE(TYPE_PAIR, list); + return ((LispPair *) list)->head; +} +static inline LispVal *TAIL(LispVal *list) { + if (NILP(list)) { + return Qnil; + } + CHECK_TYPE(TYPE_PAIR, list); + return ((LispPair *) list)->tail; +} + #endif diff --git a/src/main.c b/src/main.c index eb4391b..554921c 100644 --- a/src/main.c +++ b/src/main.c @@ -6,10 +6,9 @@ static int exit_status = 0; LispVal *Ftoplevel_exit_handler(LispVal *except); static LispFunction _Ftoplevel_exit_handler_function = { .type = TYPE_FUNCTION, - .ref_count = -1, - .is_builtin = 1, - .is_macro = 0, - .builtin = &Ftoplevel_exit_handler, + .is_builtin = true, + .is_macro = false, + .builtin = (lisp_function_ptr_t) &Ftoplevel_exit_handler, .args = Qnil, .kwargs = Qnil, .rargs = Qnil, @@ -20,13 +19,13 @@ static LispFunction _Ftoplevel_exit_handler_function = { #define Ftoplevel_exit_handler_function \ LISPVAL(&_Ftoplevel_exit_handler_function) LispVal *Ftoplevel_exit_handler(LispVal *except) { - LispVal *detail = Ftail(Fhead(except)); - if (NILP(detail) || NILP(Fhead(detail))) { + LispVal *detail = TAIL(HEAD(except)); + if (NILP(detail) || NILP(HEAD(detail))) { exit_status = 0; - } else if (!INTEGERP(Fhead(detail))) { + } else if (!INTEGERP(HEAD(detail))) { exit_status = 1; } else { - exit_status = ((LispInteger *) Fhead(detail))->value; + exit_status = ((LispInteger *) HEAD(detail))->value; } return Qnil; } @@ -34,10 +33,9 @@ LispVal *Ftoplevel_exit_handler(LispVal *except) { LispVal *Ftoplevel_error_handler(LispVal *except); static LispFunction _Ftoplevel_error_handler_function = { .type = TYPE_FUNCTION, - .ref_count = -1, - .is_builtin = 1, - .is_macro = 0, - .builtin = &Ftoplevel_error_handler, + .is_builtin = true, + .is_macro = false, + .builtin = (lisp_function_ptr_t) &Ftoplevel_error_handler, .args = Qnil, .kwargs = Qnil, .lexenv = Qnil, @@ -48,9 +46,9 @@ static LispFunction _Ftoplevel_error_handler_function = { #define Ftoplevel_error_handler_function \ LISPVAL(&_Ftoplevel_error_handler_function) LispVal *Ftoplevel_error_handler(LispVal *except) { - LispVal *type = Fhead(Fhead(except)); - LispVal *detail = Ftail(Fhead(except)); - LispVal *backtrace = Fhead(Ftail(except)); + LispVal *type = HEAD(HEAD(except)); + LispVal *detail = TAIL(HEAD(except)); + LispVal *backtrace = HEAD(TAIL(except)); fprintf(stderr, "Caught signal of type "); debug_dump(stderr, type, true); if (!NILP(detail)) { @@ -69,95 +67,56 @@ LispVal *Ftoplevel_error_handler(LispVal *except) { DEF_STATIC_SYMBOL(toplevel_read, "toplevel-read"); int main(int argc, const char **argv) { - if (argc < 2) { - fprintf(stderr, "No input file!\n"); - return 1; - } - FILE *in = fopen(argv[1], "r"); - if (!in) { - perror("fopen"); - return 1; - } - fseek(in, 0, SEEK_END); - off_t file_len = ftello(in); - rewind(in); - char buffer[file_len]; - fread(buffer, 1, file_len, in); - fclose(in); + /* if (argc < 2) { */ + /* fprintf(stderr, "No input file!\n"); */ + /* return 1; */ + /* } */ + /* FILE *in = fopen(argv[1], "r"); */ + /* if (!in) { */ + /* perror("fopen"); */ + /* return 1; */ + /* } */ + /* fseek(in, 0, SEEK_END); */ + /* off_t file_len = ftello(in); */ + /* rewind(in); */ + /* char buffer[file_len]; */ + /* fread(buffer, 1, file_len, in); */ + /* fclose(in); */ lisp_init(); - REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", ""); - REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", ""); - size_t pos = 0; - // WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { - // the_stack->hidden = true; - // LispVal *err_var = INTERN_STATIC("err-var"); - // Fputhash( - // the_stack->handlers, Qt, - // // simply call the above function - // const_list(3, err_var, Ftoplevel_error_handler_function, - // err_var)); - // Fputhash( - // the_stack->handlers, Qshutdown_signal, - // // simply call the above function - // const_list(3, err_var, Ftoplevel_exit_handler_function, - // err_var)); - // Fputhash(the_stack->handlers, Qeof_error, - // // ignore - // Fpair(Qnil, Qnil)); - // while (pos < file_len) { - // LispVal *tv; - // WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { - // pos += read_from_buffer(buffer + pos, file_len - pos, &tv); - // }); - // WITH_CLEANUP(tv, { - // IGNORE_REF(Feval(tv)); // - // }); - // } - // }); - stack_enter(Qtoplevel, (((LispVal *) (&_Qnil))), 0); - if (_setjmp(the_stack->start) == 0) { - { - the_stack->hidden = 1; - LispVal *err_var = - (_internal_INTERN_STATIC(("err-var"), sizeof("err-var") - 1)); - Fputhash( - the_stack->handlers, (((LispVal *) (&_Qt))), - const_list(3, err_var, - ((LispVal *) (&_Ftoplevel_error_handler_function)), - err_var)); - Fputhash( - the_stack->handlers, Qshutdown_signal, - const_list(3, err_var, - ((LispVal *) (&_Ftoplevel_exit_handler_function)), - err_var)); - Fputhash(the_stack->handlers, Qeof_error, - Fpair((((LispVal *) (&_Qnil))), (((LispVal *) (&_Qnil))))); - while (pos < file_len) { - LispVal *tv; - stack_enter(Qtoplevel_read, (((LispVal *) (&_Qnil))), 0); - if (_setjmp(the_stack->start) == 0) { - { - pos += - read_from_buffer(buffer + pos, file_len - pos, &tv); - } - } - stack_leave(); - ; - lisp_ref(tv); - { - void *__with_cleanup_cleanup = register_cleanup( - (lisp_cleanup_func_t) &lisp_unref_double_ptr, &(tv)); - {{(lisp_unref(lisp_ref(Feval(tv)))); - } - }; - cancel_cleanup(__with_cleanup_cleanup); - lisp_unref(tv); - }; - } -} -} -stack_leave(); -; -lisp_shutdown(); -return exit_status; + /* refcount_init_static(Qtoplevel_read); */ + /* REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", ""); */ + /* REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", ""); */ + /* size_t pos = 0; */ + /* WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { */ + /* the_stack->hidden = true; */ + /* LispVal *err_var = INTERN_STATIC("err-var"); */ + /* puthash( */ + /* the_stack->handlers, Qt, */ + /* // simply call the above function */ + /* const_list(3, err_var, Ftoplevel_error_handler_function, + * err_var)); */ + /* puthash( */ + /* the_stack->handlers, Qshutdown_signal, */ + /* // simply call the above function */ + /* const_list(3, err_var, Ftoplevel_exit_handler_function, + * err_var)); */ + /* LispVal *nil_nil = Fpair(Qnil, Qnil); */ + /* puthash(the_stack->handlers, Qeof_error, */ + /* // ignore */ + /* nil_nil); */ + /* refcount_unref(nil_nil); */ + /* refcount_unref(err_var); */ + /* while (pos < file_len) { */ + /* LispVal *tv; */ + /* WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { */ + /* pos += read_from_buffer(buffer + pos, file_len - pos, &tv); + */ + /* }); */ + /* WITH_CLEANUP(tv, { */ + /* refcount_unref(Feval(tv)); // */ + /* }); */ + /* } */ + /* }); */ + lisp_shutdown(); + return exit_status; } diff --git a/src/read.c b/src/read.c index 7e85701..0dbe876 100644 --- a/src/read.c +++ b/src/read.c @@ -45,9 +45,13 @@ static inline void _internal_read_error(struct ReadState *state, size_t len, if (len > state->left) { len = state->left; } - LispVal *args = const_list( - 4, make_lisp_integer(state->line), make_lisp_integer(state->col), - make_lisp_string(state->head, len, false, false), desc); + LispVal *line = make_lisp_integer(state->line); + LispVal *col = make_lisp_integer(state->col); + LispVal *ctx = make_lisp_string(state->head, len, false, false); + LispVal *args = const_list(4, line, col, ctx, desc); + refcount_unref(line); + refcount_unref(col); + refcount_unref(ctx); WITH_CLEANUP(args, { Fthrow(cause, args); // }); @@ -71,6 +75,14 @@ static bool is_symbol_end(int c) { static LispVal *read_internal(struct ReadState *state); +static bool is_dot_symbol(LispVal *val) { + if (!SYMBOLP(val)) { + return false; + } + LispString *name = ((LispSymbol *) val)->name; + return name->length == 1 && name->data[0] == '.'; +} + static LispVal *read_list(struct ReadState *state) { popc(state); // open ( LispVal *list = Qnil; @@ -79,17 +91,36 @@ static LispVal *read_list(struct ReadState *state) { int c; while ((c = peekc(state)) != ')') { if (c == EOS) { - UNREF_INPLACE(list); + refcount_unref(list); EOF_ERROR(state); - return Qnil; } LispVal *elt = read_internal(state); - if (NILP(list)) { + if (is_dot_symbol(elt)) { + if (NILP(list)) { + READ_ERROR(state, 1, "Dot cannot start a list"); + } + SKIP_WHITESPACE(state); + if (c == EOS) { + refcount_unref(list); + EOF_ERROR(state); + } + LispVal *last = read_internal(state); + Fsettail(end, last); + refcount_unref(last); + SKIP_WHITESPACE(state); + if (peekc(state) != ')') { + refcount_unref(list); + READ_ERROR(state, 1, + "Dot must be second to last element in list."); + } + break; + } else if (NILP(list)) { list = Fpair(elt, Qnil); end = list; } else { LispVal *new_end = Fpair(elt, Qnil); Fsettail(end, new_end); + refcount_unref(new_end); end = new_end; } SKIP_WHITESPACE(state); @@ -108,12 +139,12 @@ static LispVal *read_vector(struct ReadState *state) { if (c == EOS) { EOF_ERROR(state); for (size_t i = 0; i < values_len; ++i) { - lisp_unref(values[i]); + refcount_unref(values[i]); } lisp_free(values); return Qnil; } - LispVal *elt = lisp_ref(read_internal(state)); + LispVal *elt = read_internal(state); values = lisp_realloc(values, sizeof(LispVal *) * ++values_len); values[values_len - 1] = elt; SKIP_WHITESPACE(state); @@ -130,12 +161,12 @@ static LispVal *read_string(struct ReadState *state) { str[0] = '\0'; size_t str_len = 0; while (backslash || peekc(state) != '"') { + c = popc(state); if (c == EOS) { lisp_free(str); EOF_ERROR(state); return Qnil; } - c = popc(state); if (!backslash && c == '\\') { backslash = true; } else if (backslash && c == '\n') { @@ -157,10 +188,10 @@ static LispVal *read_string(struct ReadState *state) { c = '\0'; break; case '"': - c = '"'; + case '\\': + // the same character break; default: - // TODO make this point at the correct thing lisp_free(str); READ_ERROR(state, 1, "unknown escape sequence"); } @@ -169,7 +200,7 @@ static LispVal *read_string(struct ReadState *state) { str[str_len - 1] = c; } } - str[str_len] = '\n'; + str[str_len] = '\0'; popc(state); // close " return make_lisp_string(str, str_len, true, false); } @@ -240,12 +271,33 @@ static int parse_base(size_t left, const char *c) { } static LispVal *read_symbol(struct ReadState *state) { - const char *start = state->head; - // TODO allow escaping characters - while (!is_symbol_end(peekc(state))) { - popc(state); + bool backslash = false; + int c; + char *str = lisp_malloc(1); + str[0] = '\0'; + size_t str_len = 0; + while (backslash || !is_symbol_end(peekc(state))) { + c = popc(state); + if (!backslash && c == '\\') { + backslash = true; + } else if (!backslash + && (c == '`' || c == ',' || c == '\'' || c == '"')) { + free(str); + READ_ERROR(state, 1, "invalid character for symbol name"); + } else if (c == '\n') { + free(str); + READ_ERROR(state, 1, "backslash not escaping anything"); + } else if (c == EOS) { + free(str); + EOF_ERROR(state); + } else { + str = lisp_realloc(str, ++str_len + 1); + str[str_len - 1] = c; + backslash = false; + } } - return intern(start, state->head - start, false); + str[str_len] = '\0'; + return intern(str, str_len, true); } static LispVal *read_number_or_symbol(struct ReadState *state, int base) { @@ -350,7 +402,10 @@ static LispVal *read_internal(struct ReadState *state) { case '\'': { popc(state); // ' LispVal *tail = read_internal(state); - return Fpair(Qquote, Fpair(tail, Qnil)); + LispVal *res = Fpair(Qquote, Fpair(tail, Qnil)); + refcount_unref(tail); + refcount_unref(TAIL(res)); + return res; } // backquote case '`': { @@ -358,16 +413,27 @@ static LispVal *read_internal(struct ReadState *state) { ++state->backquote_level; LispVal *tail = read_internal(state); --state->backquote_level; - return Fpair(Qbackquote, Fpair(tail, Qnil)); + LispVal *res = Fpair(Qbackquote, Fpair(tail, Qnil)); + refcount_unref(tail); + refcount_unref(TAIL(res)); + return res; } // comma case ',': popc(state); // , if (state->backquote_level) { + LispVal *func = Qcomma; + if (peekc(state) == '@') { + popc(state); + func = Qcomma_at; + } --state->backquote_level; LispVal *tail = read_internal(state); ++state->backquote_level; - return Fpair(Qcomma, Fpair(tail, Qnil)); + LispVal *res = Fpair(func, Fpair(tail, Qnil)); + refcount_unref(tail); + refcount_unref(TAIL(res)); + return res; } else { READ_ERROR(state, 1, "comma not inside backquote"); return Qnil; diff --git a/src/read.h b/src/read.h index d75e9c2..5e83ee2 100644 --- a/src/read.h +++ b/src/read.h @@ -5,11 +5,6 @@ #include -typedef enum { - SEVERITY_WARN, - SEVERITY_ERROR, -} ReadErrorSeverity; - size_t read_from_buffer(const char *text, size_t length, LispVal **out); DECLARE_FUNCTION(read, (LispVal * source));