diff --git a/src/lisp.c b/src/lisp.c index 39a3fe5..56d5e78 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -9,6 +9,7 @@ #include #include +// used to fix up some indentation or syntax highlighting problems #define IGNORE() struct __ignored_struct struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = { @@ -24,14 +25,9 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = { [TYPE_PACKAGE] = {"package", sizeof("package") - 1}, }; -void free_opt_arg_desc(void *obj) { - struct OptArgDesc *oad = obj; - refcount_unref(oad->name); - refcount_unref(oad->default_form); - refcount_unref(oad->pred_var); - lisp_free(oad); -} - +// ####################### +// # nil, unbound, and t # +// ####################### DEF_STATIC_STRING(_Qnil_name, "nil"); LispSymbol _Qnil = { .type = TYPE_SYMBOL, @@ -65,16 +61,30 @@ LispSymbol _Qt = { .is_constant = true, }; +// ########################### +// # Other important symbols # +// ########################### DEF_STATIC_SYMBOL(backquote, "`"); DEF_STATIC_SYMBOL(comma, ","); DEF_STATIC_SYMBOL(comma_at, ",@"); +DEF_STATIC_SYMBOL(opt, "&opt"); +DEF_STATIC_SYMBOL(key, "&key"); +DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys"); +DEF_STATIC_SYMBOL(rest, "&rest"); +DEF_STATIC_SYMBOL(declare, "declare"); +DEF_STATIC_SYMBOL(name, "name"); -struct GCRoot { - struct GCRoot *next; - struct GCRoot *prev; - LispVal *object; -}; +// ############################ +// # Global Package Variables # +// ############################ +LispVal *package_table = Qnil; +LispVal *system_package = Qnil; +LispVal *keyword_package = Qnil; +LispVal *current_package = Qnil; +// ############################# +// # Allocation and references # +// ############################# static size_t bytes_allocated = 0; static size_t last_gc = 0; @@ -101,1181 +111,6 @@ void garbage_collect(void) { refcount_garbage_collect(); } -#define CONSTRUCT_OBJECT(var, Type, TYPE) \ - Type *var = lisp_malloc(sizeof(Type)); \ - refcount_init_obj(var); \ - var->type = TYPE; - -LispVal *make_lisp_string(const char *data, size_t length, bool take, - bool is_static) { - CONSTRUCT_OBJECT(self, LispString, TYPE_STRING); - if (take) { - self->data = (char *) data; - } else { - self->data = lisp_malloc(length + 1); - memcpy(self->data, data, length); - self->data[length] = '\0'; - } - 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) { - CHECK_TYPE(TYPE_STRING, name); - CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL); - self->name = (LispString *) refcount_ref(name); - self->package = Qnil; - self->plist = Qnil; - self->function = Qnil; - self->value = Qunbound; - self->is_constant = false; - return LISPVAL(self); -} - -LispVal *make_lisp_pair(LispVal *head, LispVal *tail) { - CONSTRUCT_OBJECT(self, LispPair, TYPE_PAIR); - 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->value = value; - return LISPVAL(self); -} - -LispVal *make_lisp_float(long double value) { - CONSTRUCT_OBJECT(self, LispFloat, TYPE_FLOAT); - self->value = value; - return LISPVAL(self); -} - -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); -} - -DEF_STATIC_SYMBOL(opt, "&opt"); -DEF_STATIC_SYMBOL(key, "&key"); -DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys"); -DEF_STATIC_SYMBOL(rest, "&rest"); -DEF_STATIC_SYMBOL(declare, "declare"); -DEF_STATIC_SYMBOL(name, "name"); - -static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod, - LispVal *found_args) { - aod->name = Qnil; - aod->default_form = Qnil; - aod->pred_var = Qnil; - if (TYPEOF(ent) == TYPE_SYMBOL) { - if (VALUE_CONSTANTP(ent)) { - return false; - } else if (!NILP(gethash(found_args, ent, Qnil))) { - return false; - } - aod->name = refcount_ref(ent); - aod->pred_var = Qnil; - aod->default_form = Qnil; - return true; - } 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(gethash(found_args, HEAD(ent), Qnil))) { - return false; - } else if (!NILP(end) - && (!NILP(gethash(found_args, HEAD(end), Qnil)) - || VALUE_CONSTANTP(HEAD(end)) - || HEAD(end) == HEAD(ent))) { - return false; - } - 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) { - 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); - - enum { - REQ, - OPT, - KEY, - REST, - MUST_CHANGE, - } mode = REQ; - bool has_opt = false; - bool has_key = false; - bool has_rest = false; - - func->n_req = 0; - func->rargs = Qnil; - func->n_opt = 0; - func->oargs = Qnil; - func->rest_arg = Qnil; - func->kwargs = make_lisp_hashtable(Qnil, Qnil); - func->allow_other_keys = false; - - LispVal *rargs_end = Qnil; - LispVal *oargs_end = Qnil; - - FOREACH(arg, args) { - if (arg == Qopt) { - if (has_opt || mode == REST) { - goto malformed; - } - has_opt = true; - mode = OPT; - } else if (arg == Qkey) { - if (has_key || mode == REST) { - goto malformed; - } - has_key = true; - mode = KEY; - } else if (arg == Qrest) { - if (has_rest) { - goto malformed; - } - has_rest = true; - mode = REST; - } else if (arg == Qallow_other_keys) { - if (func->allow_other_keys || mode != KEY) { - goto malformed; - } - func->allow_other_keys = true; - mode = MUST_CHANGE; - } else { - switch (mode) { - case REQ: - if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg) - || !NILP(gethash(found_args, arg, Qnil))) { - goto malformed; - } - if (NILP(func->rargs)) { - func->rargs = Fpair(arg, Qnil); - rargs_end = func->rargs; - } else { - LispVal *new_end = Fpair(arg, Qnil); - Fsettail(rargs_end, new_end); - refcount_unref(new_end); - rargs_end = new_end; - } - puthash(found_args, arg, Qt); - ++func->n_req; - break; - case OPT: { - LispVal *desc = - ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc); - USERPTR(struct OptArgDesc, desc)->index = 0; - if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc), - found_args)) { - refcount_unref(desc); - goto malformed; - } - if (NILP(func->oargs)) { - func->oargs = Fpair(desc, Qnil); - oargs_end = func->oargs; - } else { - LispVal *new_end = Fpair(desc, Qnil); - Fsettail(oargs_end, new_end); - refcount_unref(new_end); - oargs_end = new_end; - } - refcount_unref(desc); - puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt); - if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) { - puthash(found_args, - USERPTR(struct OptArgDesc, desc)->pred_var, Qt); - } - ++func->n_opt; - } break; - case KEY: { - LispVal *desc = - ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc); - if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc), - found_args)) { - refcount_unref(desc); - goto malformed; - } - USERPTR(struct OptArgDesc, desc)->index = - ((LispHashtable *) func->kwargs)->count; - LispString *sn = - ((LispSymbol *) USERPTR(struct OptArgDesc, desc)->name) - ->name; - char kns[sn->length + 2]; - kns[0] = ':'; - memcpy(kns + 1, sn->data, sn->length); - kns[sn->length + 1] = '\0'; - LispVal *kn = - make_lisp_string(kns, sn->length + 1, false, false); - LispVal *keyword = Fintern(kn, Qnil, Qnil); - puthash(func->kwargs, keyword, desc); - refcount_unref(keyword); - refcount_unref(kn); - refcount_unref(desc); - puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt); - if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) { - puthash(found_args, - USERPTR(struct OptArgDesc, desc)->pred_var, Qt); - } - } break; - case REST: - if (!NILP(func->rest_arg)) { - goto malformed; - } else if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) { - goto malformed; - } else if (!NILP(Fgethash(found_args, arg, Qnil))) { - goto malformed; - } - func->rest_arg = refcount_ref(arg); - mode = MUST_CHANGE; - break; - case MUST_CHANGE: - goto malformed; - } - } - } - refcount_unref(found_args); - // do this last - func->args = refcount_ref(args); - return; -malformed: - 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 *name, LispVal *return_tag, LispVal *args, - LispVal *lexenv, LispVal *body, bool is_macro) { - CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION); - self->is_builtin = false; - self->is_macro = is_macro; - self->args = Qnil; - self->rargs = Qnil; - self->oargs = Qnil; - self->rest_arg = Qnil; - self->kwargs = Qnil; - self->name = Qnil; - self->return_tag = Qnil; - self->lexenv = Qnil; - self->doc = Qnil; - self->body = Qnil; - void *cl = register_cleanup(&refcount_unref_as_callback, self); - set_function_args(self, args); - cancel_cleanup(cl); - - // do these after the potential throw - self->name = refcount_ref(name); - self->return_tag = refcount_ref(return_tag); - 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); -} - -LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) { - CONSTRUCT_OBJECT(self, LispHashtable, TYPE_HASHTABLE); - 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); -} - -LispVal *make_user_pointer(void *data, void (*free_func)(void *)) { - CONSTRUCT_OBJECT(self, LispUserPointer, TYPE_USER_POINTER); - self->data = data; - self->free_func = free_func; - return LISPVAL(self); -} - -LispVal *make_lisp_package(LispVal *name) { - CHECK_TYPE(TYPE_STRING, name); - CONSTRUCT_OBJECT(self, LispPackage, TYPE_PACKAGE); - self->name = refcount_ref(name); - self->obarray = make_lisp_hashtable(Qstrings_equal, Qhash_string); - self->exported_sym_table = make_lisp_hashtable(Qnil, Qnil); - self->imported = Qnil; - return LISPVAL(self); -} - -DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) { - return make_lisp_hashtable(eq_fn, hash_fn); -} - -DEFUN(vector, "vector", (LispVal * elems)) { - struct UnrefListData uld = {.vals = NULL, .len = 0}; - WITH_PUSH_FRAME(Qnil, Qnil, true, { - void *cl_handler = register_cleanup(&unref_free_list_double_ptr, &uld); - FOREACH(elt, elems) { - uld.vals = lisp_realloc(uld.vals, sizeof(LispVal *) * (++uld.len)); - uld.vals[uld.len - 1] = elt; - } - cancel_cleanup(cl_handler); - }); - return make_lisp_vector(uld.vals, uld.len); -} - -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 { - LispVal *eq_obj; - LispVal *args = const_list(true, 2, v1, v2); - WITH_CLEANUP(args, { - eq_obj = Ffuncall(self->eq_fn, args); // - }); - bool result = !NILP(eq_obj); - refcount_unref(eq_obj); - return result; - } -} - -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 and lexenv lookups faster - LispVal *hash_obj = Fhash_string(key); - uint64_t hash = ((LispInteger *) hash_obj)->value; - refcount_unref(hash_obj); - return hash; - } else { - LispVal *hash_obj; - LispVal *args = const_list(true, 1, key); - WITH_CLEANUP(args, { - hash_obj = Ffuncall(self->hash_fn, args); // - }); - uint64_t hash; - WITH_CLEANUP(hash_obj, { - CHECK_TYPE(TYPE_INTEGER, hash_obj); - hash = ((LispInteger *) hash_obj)->value; - }); - return hash; - } -} - -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; -} - -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) { - 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 = 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 - >= LISP_HASHTABLE_GROWTH_THRESHOLD) { - hash_table_rehash(self, - LISP_HASHTABLE_GROWTH_FACTOR * self->table_size); - } - } - return table; -} - -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); - struct HashtableBucket *cur_bucket = - find_hash_table_bucket(self, key, hash); - if (cur_bucket) { - return cur_bucket->value; - } - return def; -} - -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; - refcount_unref(cur_bucket->key); - refcount_unref(cur_bucket->value); - lisp_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; - refcount_unref(cur_bucket->key); - refcount_unref(cur_bucket->value); - lisp_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(remhash, "remhash", (LispVal * table, LispVal *key)) { - return refcount_ref(remhash(table, key)); -} - -static LispVal *normalize_package(LispVal *arg) { - if (STRINGP(arg) || SYMBOLP(arg)) { - LispVal *found = Ffind_package(arg); - if (!PACKAGEP(found)) { - refcount_unref(found); - Fthrow(Qunknown_package_error, const_list(true, 1, arg)); - } - return found; - } else if (PACKAGEP(arg)) { - return refcount_ref(arg); - } else { - Fthrow(Qtype_error, Qnil); - } -} - -DEFUN(set_current_package, "set-current-package", (LispVal * package)) { - LispVal *new = normalize_package(package); - LispVal *old = current_package; - current_package = new; - refcount_unref(old); - return refcount_ref(current_package); -} - -DEFUN(package_name, "package-name", (LispVal * package)) { - CHECK_TYPE(TYPE_PACKAGE, package); - return LISPVAL(((LispPackage *) package)->name); -} - -DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package)) { - LispPackage *pkg; - if (NILP(package)) { - pkg = refcount_ref(current_package); - } else { - pkg = (LispPackage *) normalize_package(package); - } -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wunused-but-set-variable" - WITH_CLEANUP(pkg, { - IGNORE(); - HASHTABLE_FOREACH(name, sym, pkg->obarray) { - LispVal *args = const_list(true, 1, sym); - refcount_unref(Ffuncall(func, args)); - } - }); -#pragma GCC diagnostic pop - return Qnil; -} - -DEFMACRO(in_package, "in-package", (LispVal * package)) { - return Fset_current_package(package); -} - -DEFUN(current_package, "current-package", (void) ) { - return refcount_ref(current_package); -} - -IGNORE(); // unconfuse emacs syntax highlighting - -DEFUN(export_symbol, "export-symbol", (LispVal * symbol)) { - if (SYMBOLP(symbol)) { - LispSymbol *sym = (LispSymbol *) symbol; - LispPackage *pkg = (LispPackage *) sym->package; - puthash(pkg->exported_sym_table, symbol, Qt); - } else if (LISTP(symbol)) { - FOREACH(cur, symbol) { - CHECK_TYPE(TYPE_SYMBOL, cur); - Fexport_symbol(cur); - } - } else { - Fthrow(Qtype_error, - const_list(false, 2, const_list(false, 2, Qlistp, Qsymbolp), - symbol)); - } - return Qnil; -} - -// recursively search all imports of SOURCE, looking for TARGET -static bool check_recursive_import(LispVal *source, LispVal *target) { - FOREACH(entry, ((LispPackage *) source)->imported) { - if (HEAD(entry) == target - || check_recursive_import(HEAD(entry), target)) { - return true; - } - } - return false; -} - -DEFUN_DISTINGUISHED(import_package, "import-package", - (LispVal * source, LispVal *names, LispVal *target)) { - LispPackage *target_pkg; - if (target == Qunbound || NILP(target)) { - target_pkg = refcount_ref(current_package); - } else { - target_pkg = (LispPackage *) normalize_package(target); - } - if (!PACKAGEP(target_pkg)) { - refcount_unref(target_pkg); - Fthrow(Qimport_error, Qnil); - } - if (names == Qunbound) { - names = Qt; // all symbols - } - FOREACH(entry, target_pkg->imported) { - if (HEAD(entry) == source) { - if (names == Qt) { - Fsettail(HEAD(entry), Qt); - } else { - LispVal *imported = TAIL(entry); - // if we have already imported everything, do nothing - if (imported == Qt) { - goto done; - } - FOREACH(name, names) { - if (SYMBOLP(name)) { - name = LISPVAL(((LispSymbol *) name)->name); - } else if (!STRINGP(name)) { - refcount_unref(target_pkg); - CHECK_TYPE(TYPE_STRING, name); - } - puthash(imported, name, Qt); - } - } - goto done; - } - } - // we didn't find any existing imports, so add a new entry - if (check_recursive_import(source, LISPVAL(target_pkg))) { - refcount_unref(target_pkg); - Fthrow(Qimport_error, Qnil); - } - LispVal *lasttail = Qnil; - FOREACH_TAIL(tail, target_pkg->imported) { - if (NILP(TAIL(tail))) { - lasttail = tail; - break; - } - } - if (LISTP(names)) { - LispVal *norm_names = make_lisp_hashtable(Qstrings_equal, Qhash_string); - FOREACH(name, names) { - if (SYMBOLP(name)) { - name = LISPVAL(((LispSymbol *) name)->name); - } else if (!STRINGP(name)) { - refcount_unref(target_pkg); - refcount_unref(norm_names); - CHECK_TYPE(TYPE_STRING, name); - } - puthash(norm_names, name, Qt); - } - names = norm_names; - } - if (NILP(lasttail)) { - target_pkg->imported = const_list(false, 1, Fpair(source, names)); - } else { - Fsettail(lasttail, const_list(false, 1, Fpair(source, names))); - } - refcount_unref(names); -done: - refcount_unref(target_pkg); - return Qnil; -} - -DEFUN(make_package, "make-package", (LispVal * name)) { - if (SYMBOLP(name)) { - name = Fsymbol_name(name); - } else { - name = refcount_ref(name); - } - LispVal *np = make_lisp_package(name); - refcount_unref(name); - return np; -} - -DEFUN(register_package, "register-package", (LispVal * package)) { - if (STRINGP(package)) { - package = make_lisp_package(package); - } else if (SYMBOLP(package)) { - package = make_lisp_package(LISPVAL(((LispSymbol *) package)->name)); - } else { - CHECK_TYPE(TYPE_PACKAGE, package); - package = refcount_ref(package); - } - LispVal *found = Ffind_package(package); - if (!NILP(found)) { - refcount_unref(package); - Fthrow(Qpackage_exists_error, const_list(true, 1, package)); - } - puthash(package_table, LISPVAL(((LispPackage *) package)->name), package); - return package; -} - -DEFUN(find_package, "find-package", (LispVal * name)) { - if (STRINGP(name)) { - return Fgethash(package_table, name, Qnil); - } else if (SYMBOLP(name)) { - return Fgethash(package_table, LISPVAL(((LispSymbol *) name)->name), - Qnil); - } else if (PACKAGEP(name)) { - LispPackage *pkg = (LispPackage *) name; - LispVal *found = Fgethash(package_table, LISPVAL(pkg->name), Qnil); - if (found == LISPVAL(pkg)) { - return found; - } else { - refcount_unref(found); - return Qnil; - } - } else { - Fthrow(Qtype_error, Qnil); - } -} - -LispVal *find_package(const char *name, size_t length) { - LispVal *sobj = make_lisp_string(name, length, false, false); - LispVal *pkg = Ffind_package(sobj); - refcount_unref(sobj); - return pkg; -} - -DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - LispSymbol *sym = (LispSymbol *) symbol; - if (NILP(sym->package)) { - return Qnil; - } - LispPackage *pkg = (LispPackage *) sym->package; - return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil); -} - -DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) { - CHECK_TYPE(TYPE_HASHTABLE, table); - return make_lisp_integer(((LispHashtable *) table)->count); -} - -DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table)) { - CHECK_TYPE(TYPE_HASHTABLE, table); - LispHashtable *orig = (LispHashtable *) table; - CONSTRUCT_OBJECT(copy, LispHashtable, TYPE_HASHTABLE); - copy->table_size = orig->table_size; - copy->data = - lisp_malloc(sizeof(struct HashtableBucket *) * copy->table_size); - memset(copy->data, 0, sizeof(struct HashtableBucket *) * copy->table_size); - copy->count = orig->count; - copy->eq_fn = orig->eq_fn; - copy->hash_fn = orig->hash_fn; - for (size_t i = 0; i < orig->table_size; ++i) { - for (struct HashtableBucket *bucket = orig->data[i]; bucket; - bucket = bucket->next) { - struct HashtableBucket *new_bucket = - lisp_malloc(sizeof(struct HashtableBucket)); - new_bucket->hash = bucket->hash; - new_bucket->key = refcount_ref(bucket->key); - new_bucket->value = refcount_ref(bucket->value); - new_bucket->next = copy->data[i]; - copy->data[i] = new_bucket; - } - } - return LISPVAL(copy); -} - -DEFUN(intern_soft, "intern-soft", - (LispVal * name, LispVal *def, LispVal *package, LispVal *included_too)) { - LispPackage *real_pkg; - if (NILP(package)) { - real_pkg = refcount_ref(current_package); - } else { - real_pkg = (LispPackage *) normalize_package(package); - } - LispVal *cur = gethash(real_pkg->obarray, name, Qunbound); - if (cur != Qunbound) { - refcount_unref(real_pkg); - return refcount_ref(cur); - } - if (!NILP(included_too)) { - FOREACH(entry, real_pkg->imported) { - if (TAIL(entry) != Qt) { - LispVal *sub = HEAD(entry); - LispVal *imported = TAIL(entry); - if (!NILP(gethash(imported, name, Qnil))) { - refcount_unref(real_pkg); - // we import it from this package, so don't keep searching - // if the intern fails - return Fintern_soft(name, def, sub, Qt); - } - // otherwise, keep looking in a different package - } else { - cur = Fintern_soft(name, Qunbound, HEAD(entry), Qt); - if (cur != Qunbound) { - refcount_unref(real_pkg); - return cur; - } - } - } - } - refcount_unref(real_pkg); - return refcount_ref(def); -} - -DEFUN(intern, "intern", - (LispVal * name, LispVal *package, LispVal *included_too)) { - CHECK_TYPE(TYPE_STRING, name); - LispPackage *real_pkg; - if (NILP(package)) { - real_pkg = refcount_ref(current_package); - } else { - real_pkg = (LispPackage *) normalize_package(package); - } - LispVal *cur = Fintern_soft(name, Qunbound, package, included_too); - if (cur != Qunbound) { - return cur; - } - LispVal *sym = make_lisp_symbol(name); - ((LispSymbol *) sym)->package = refcount_ref(real_pkg); - puthash(real_pkg->obarray, name, sym); - refcount_unref(real_pkg); - return sym; -} - -LispVal *intern(const char *name, size_t length, bool take, LispVal *package, - bool included_too) { - if (!NILP(package)) { - CHECK_TYPE(TYPE_PACKAGE, package); - } - LispVal *name_obj = make_lisp_string((char *) name, length, take, false); - LispVal *sym = Fintern(name_obj, package, LISP_BOOL(included_too)); - refcount_unref(name_obj); - return sym; -} - -DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) { - CHECK_TYPE(TYPE_PAIR, pair); - 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); - refcount_unref(((LispPair *) pair)->tail); - ((LispPair *) pair)->tail = refcount_ref(tail); - return Qnil; -} - -size_t list_length(LispVal *obj) { - if (NILP(obj)) { - return 0; - } - CHECK_TYPE(TYPE_PAIR, obj); - size_t length = 0; - LispPair *tortise = (LispPair *) obj; - LispPair *hare = (LispPair *) tortise->tail; - while (!NILP(tortise)) { - if (!LISTP(LISPVAL(tortise))) { - break; - } else if (tortise == hare) { - Fthrow(Qcircular_error, Qnil); - } - ++length; - tortise = (LispPair *) tortise->tail; - if (PAIRP(hare)) { - if (PAIRP(((LispPair *) hare)->tail)) { - hare = (LispPair *) ((LispPair *) hare->tail)->tail; - } else if (NILP(((LispPair *) hare)->tail)) { - hare = (LispPair *) Qnil; - } - } - } - return length; -} - -StackFrame *the_stack = NULL; -LispVal *stack_return = NULL; -DEF_STATIC_SYMBOL(toplevel, "toplevel"); - -void stack_enter(LispVal *name, LispVal *detail, bool inherit) { - StackFrame *frame = lisp_malloc(sizeof(StackFrame)); - frame->name = name; - frame->return_tag = Qnil; - frame->hidden = true; - frame->detail = detail; - frame->lexenv = Qnil; - if (inherit && the_stack) { - frame->lexenv = refcount_ref(the_stack->lexenv); - } - frame->enable_handlers = true; - frame->handlers = make_lisp_hashtable(Qnil, Qnil); - frame->unwind_form = Qnil; - frame->cleanup_handlers = NULL; - - frame->next = the_stack; - the_stack = frame; -} - -void stack_leave(void) { - StackFrame *frame = the_stack; - the_stack = the_stack->next; - refcount_unref(frame->name); - refcount_unref(frame->return_tag); - refcount_unref(frame->detail); - refcount_unref(frame->lexenv); - refcount_unref(frame->handlers); - while (frame->cleanup_handlers) { - frame->cleanup_handlers->fun(frame->cleanup_handlers->data); - struct CleanupHandlerEntry *next = frame->cleanup_handlers->next; - lisp_free(frame->cleanup_handlers); - frame->cleanup_handlers = next; - } - LispVal *unwind_form = frame->unwind_form; - // steal the ref - frame->unwind_form = Qnil; - lisp_free(frame); - if (!NILP(unwind_form)) { - WITH_CLEANUP(unwind_form, { - refcount_unref(Feval(unwind_form)); // - }) - } -} - -void *register_cleanup(lisp_cleanup_func_t fun, void *data) { - struct CleanupHandlerEntry *entry = - lisp_malloc(sizeof(struct CleanupHandlerEntry)); - entry->fun = fun; - entry->data = data; - entry->next = the_stack->cleanup_handlers; - the_stack->cleanup_handlers = entry; - return entry; -} - -void free_double_ptr(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) { - 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; - lisp_free(entry); - } else { - while (entry) { - if (entry->next == handle) { - struct CleanupHandlerEntry *to_free = entry->next; - entry->next = entry->next->next; - lisp_free(to_free); - break; - } - entry = entry->next; - } - } -} - -DEFUN(backtrace, "backtrace", (void) ) { - LispVal *head = Qnil; - LispVal *end = Qnil; - for (StackFrame *frame = the_stack; frame; frame = frame->next) { - if (frame->hidden) { - continue; - } - 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); - refcount_unref(new_end); - end = new_end; - } - } - return head; -} - -IGNORE(); // unconfuse emacs syntax highlighting - -DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) { - Fthrow(Qreturn_frame_error, - const_list(false, 2, refcount_ref(name), Feval(value))); -} - -STATIC_DEFMACRO(internal_real_return, "internal-real-return", - (LispVal * name, LispVal *tag, LispVal *value)) { - for (StackFrame *cur = the_stack; cur; cur = cur->next) { - if (!NILP(cur->return_tag) && cur->enable_handlers - && cur->return_tag == tag) { - Fthrow(cur->return_tag, const_list(false, 1, Feval(value))); - } - } - Fthrow(Qreturn_frame_error, - const_list(false, 2, refcount_ref(name), Feval(value))); -} - -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Winfinite-recursion" -DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { - CHECK_TYPE(TYPE_SYMBOL, signal); - LispVal *error_arg = - const_list(false, 2, Fpair(signal, rest), Fbacktrace()); - while (the_stack) { - if (!the_stack->enable_handlers) { - goto up_frame; - } - LispVal *handler = - gethash(LISPVAL(the_stack->handlers), signal, Qunbound); - if (handler == Qunbound) { - // handler for all exceptions - handler = gethash(LISPVAL(the_stack->handlers), Qt, Qunbound); - } - if (handler != Qunbound) { - the_stack->enable_handlers = false; - LispVal *var = HEAD(handler); - LispVal *form = TAIL(handler); - WITH_PUSH_FRAME(Qnil, Qnil, true, { - if (!NILP(var)) { - // TODO make sure this isn't constant - push_to_lexenv(&the_stack->lexenv, var, error_arg); - } - WITH_CLEANUP(error_arg, { - stack_return = Feval(form); // - }); - }); - longjmp(the_stack->start, STACK_EXIT_THROW); - } - up_frame: { - // steal the form so we can call it after we unwind (in case it - // throws) - LispVal *unwind_form = the_stack->unwind_form; - the_stack->unwind_form = Qnil; - stack_leave(); - if (!NILP(unwind_form)) { - void *cl_handler = - register_cleanup(&refcount_unref_as_callback, error_arg); - WITH_CLEANUP(unwind_form, { - refcount_unref(Feval(unwind_form)); // - }); - cancel_cleanup(cl_handler); - } - } - } - fprintf(stderr, - "ERROR: An exception has propagated past the top of the stack!\n"); - fprintf(stderr, "Type: "); - debug_dump(stderr, signal, true); - fprintf(stderr, "Args: "); - debug_dump(stderr, rest, true); - fprintf(stderr, "Lisp will now exit..."); - // we never used it, so drop it - refcount_unref(error_arg); - abort(); -} -#pragma GCC diagnostic pop - -DEF_STATIC_SYMBOL(kw_success, "success"); -DEF_STATIC_SYMBOL(kw_finally, "finally"); -DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal"); -DEF_STATIC_SYMBOL(type_error, "type-error"); -DEF_STATIC_SYMBOL(read_error, "read-error"); -DEF_STATIC_SYMBOL(unclosed_error, "read-error"); -DEF_STATIC_SYMBOL(eof_error, "eof-error"); -DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error"); -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"); -DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error"); -DEF_STATIC_SYMBOL(package_exists_error, "package-exists-error"); -DEF_STATIC_SYMBOL(import_error, "import-error"); -DEF_STATIC_SYMBOL(unknown_package_error, "unknown-package-error"); - -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; - case TYPE_PACKAGE: - return Qpackagep; - default: - abort(); - } -} - -LispVal *package_table = Qnil; -LispVal *system_package = Qnil; -LispVal *keyword_package = Qnil; -LispVal *current_package = Qnil; - static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) { switch (TYPEOF(obj)) { case TYPE_STRING: @@ -1382,7 +217,200 @@ static void free_obj_callback(void *obj, void *ignored) { lisp_free(obj); } -static DECLARE_FUNCTION(set_for_return, (LispVal * entry, LispVal *dest)); +// ################ +// # Constructors # +// ################ +#define CONSTRUCT_OBJECT(var, Type, TYPE) \ + Type *var = lisp_malloc(sizeof(Type)); \ + refcount_init_obj(var); \ + var->type = TYPE; + +LispVal *make_lisp_string(const char *data, size_t length, bool take, + bool is_static) { + CONSTRUCT_OBJECT(self, LispString, TYPE_STRING); + if (take) { + self->data = (char *) data; + } else { + self->data = lisp_malloc(length + 1); + memcpy(self->data, data, length); + self->data[length] = '\0'; + } + self->length = length; + self->is_static = is_static; + return LISPVAL(self); +} + +LispVal *make_lisp_symbol(LispVal *name) { + CHECK_TYPE(TYPE_STRING, name); + CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL); + self->name = (LispString *) refcount_ref(name); + self->package = Qnil; + self->plist = Qnil; + self->function = Qnil; + self->value = Qunbound; + self->is_constant = false; + return LISPVAL(self); +} + +LispVal *make_lisp_pair(LispVal *head, LispVal *tail) { + CONSTRUCT_OBJECT(self, LispPair, TYPE_PAIR); + 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->value = value; + return LISPVAL(self); +} + +LispVal *make_lisp_float(long double value) { + CONSTRUCT_OBJECT(self, LispFloat, TYPE_FLOAT); + self->value = value; + return LISPVAL(self); +} + +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); +} + +static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod, + LispVal *found_args) { + aod->name = Qnil; + aod->default_form = Qnil; + aod->pred_var = Qnil; + if (TYPEOF(ent) == TYPE_SYMBOL) { + if (VALUE_CONSTANTP(ent)) { + return false; + } else if (!NILP(gethash(found_args, ent, Qnil))) { + return false; + } + aod->name = refcount_ref(ent); + aod->pred_var = Qnil; + aod->default_form = Qnil; + return true; + } 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(gethash(found_args, HEAD(ent), Qnil))) { + return false; + } else if (!NILP(end) + && (!NILP(gethash(found_args, HEAD(end), Qnil)) + || VALUE_CONSTANTP(HEAD(end)) + || HEAD(end) == HEAD(ent))) { + return false; + } + 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; +} + +LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args, + LispVal *lexenv, LispVal *body, bool is_macro) { + CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION); + self->is_builtin = false; + self->is_macro = is_macro; + self->args = Qnil; + self->rargs = Qnil; + self->oargs = Qnil; + self->rest_arg = Qnil; + self->kwargs = Qnil; + self->name = Qnil; + self->return_tag = Qnil; + self->lexenv = Qnil; + self->doc = Qnil; + self->body = Qnil; + void *cl = register_cleanup(&refcount_unref_as_callback, self); + set_function_args(self, args); + cancel_cleanup(cl); + + // do these after the potential throw + self->name = refcount_ref(name); + self->return_tag = refcount_ref(return_tag); + 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); +} + +LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) { + CONSTRUCT_OBJECT(self, LispHashtable, TYPE_HASHTABLE); + 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); +} + +LispVal *make_user_pointer(void *data, void (*free_func)(void *)) { + CONSTRUCT_OBJECT(self, LispUserPointer, TYPE_USER_POINTER); + self->data = data; + self->free_func = free_func; + return LISPVAL(self); +} + +LispVal *make_lisp_package(LispVal *name) { + CHECK_TYPE(TYPE_STRING, name); + CONSTRUCT_OBJECT(self, LispPackage, TYPE_PACKAGE); + self->name = refcount_ref(name); + self->obarray = make_lisp_hashtable(Qstrings_equal, Qhash_string); + self->exported_sym_table = make_lisp_hashtable(Qnil, Qnil); + self->imported = Qnil; + return LISPVAL(self); +} + +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; + case TYPE_PACKAGE: + return Qpackagep; + default: + abort(); + } +} + +// ############################### +// # Initialization and Shutdown # +// ############################### + +static void register_symbols_and_functions(void); void lisp_init(void) { RefcountContext *ctx = refcount_make_context( @@ -1407,170 +435,7 @@ void lisp_init(void) { refcount_unref(kw_package_name); current_package = refcount_ref(system_package); - // don't intern Qunbound! - puthash(((LispPackage *) system_package)->obarray, - LISPVAL(((LispSymbol *) Qnil)->name), Qnil); - ((LispSymbol *) Qnil)->package = refcount_ref(system_package); - puthash(((LispPackage *) system_package)->obarray, - LISPVAL(((LispSymbol *) Qt)->name), Qt); - ((LispSymbol *) Qt)->package = refcount_ref(system_package); - REGISTER_SYMBOL(opt); - REGISTER_SYMBOL(allow_other_keys); - REGISTER_SYMBOL(key); - REGISTER_SYMBOL(rest); - REGISTER_SYMBOL(declare); - REGISTER_SYMBOL(name); - REGISTER_SYMBOL(comma); - REGISTER_SYMBOL(comma_at); - REGISTER_SYMBOL(backquote); - REGISTER_SYMBOL_INTO(kw_success, keyword_package); - REGISTER_SYMBOL_INTO(kw_finally, keyword_package); - REGISTER_SYMBOL(shutdown_signal); - REGISTER_SYMBOL(type_error); - REGISTER_SYMBOL(read_error); - REGISTER_SYMBOL(eof_error); - REGISTER_SYMBOL(unclosed_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_SYMBOL(return_frame_error); - REGISTER_SYMBOL(package_exists_error); - REGISTER_SYMBOL(import_error); - REGISTER_SYMBOL(unknown_package_error); - - // some stuff that musn't be user accesable - REGISTER_SYMBOL_NOINTERN(toplevel); - REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", ""); - REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", ""); - - REGISTER_FUNCTION(make_hashtable, "(&opt hash-fn eq-fn)", ""); - REGISTER_FUNCTION(puthash, "(table key value)", ""); - REGISTER_FUNCTION(gethash, "(table key &opt def)", ""); - REGISTER_FUNCTION(remhash, "(table key)", ""); - REGISTER_FUNCTION(vector, "(&rest elements)", ""); - REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing..."); - 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_name, "(sym)", ""); - REGISTER_FUNCTION(symbol_package, "(sym)", ""); - REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); - REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM."); - REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM."); - REGISTER_FUNCTION(setplist, "(sym plist)", - "Set the plist of SYM to PLIST."); - 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 &opt lexical-macros)", - "Return the form which FORM expands to."); - REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", ""); - REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", ""); - 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(packagep, "(val)", "Return non-nil if VAL is a package."); - REGISTER_FUNCTION( - functionp, "(val)", - "Return non-nil if VAL is a non-macro function (includes buitlins)."); - REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)", - "Return non-nil if VAL is a non-builtin macro."); - REGISTER_FUNCTION(builtinp, "(val)", - "Return non-nil if VAL is a non-macro builtin."); - REGISTER_FUNCTION(special_form_p, "(val)", - "Return non-nil if VAL is a macro-builtin."); - 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(copy_list, "(list)", "Return a shallow copy of LIST."); - REGISTER_FUNCTION(copy_tree, "(tree)", - "Return a deep copy of TREE and all sublists in it."); - 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."); - REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", ""); - REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", ""); - REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", ""); - REGISTER_FUNCTION(return_from, "(name &opt value)", - "Return from the function named NAME and return VALUE."); - REGISTER_FUNCTION(intern, "(name &opt package included-too)", ""); - REGISTER_FUNCTION(intern_soft, "(name &opt default package included-too)", - ""); - REGISTER_FUNCTION(condition_case, "(form &rest handlers)", ""); - REGISTER_FUNCTION(set_current_package, "(package)", ""); - REGISTER_FUNCTION(in_package, "(package)", ""); - REGISTER_FUNCTION(current_package, "()", ""); - REGISTER_FUNCTION(make_package, "(name)", ""); - REGISTER_FUNCTION(register_package, "(package)", ""); - REGISTER_FUNCTION(find_package, "(name)", ""); - REGISTER_FUNCTION(exported_symbol_p, "(symbol)", ""); - REGISTER_FUNCTION(export_symbol, "(symbol)", ""); - REGISTER_FUNCTION(import_package, "(source &opt names target)", ""); - REGISTER_FUNCTION(hash_table_count, "(table)", ""); - REGISTER_FUNCTION(copy_hash_table, "(table)", ""); - REGISTER_FUNCTION(package_name, "(package)", ""); - REGISTER_FUNCTION(mapsymbols, "(func &opt package)", ""); + register_symbols_and_functions(); } void lisp_shutdown(void) { @@ -1584,26 +449,25 @@ void lisp_shutdown(void) { refcount_default_context = NULL; } -static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { - return Fplist_get(lexenv, key, Qunbound, Qnil); +// ############################### +// # General and Misc. Functions # +// ############################### +DEFUN(exit, "exit", (LispVal * code)) { + if (!NILP(code) && !INTEGERP(code)) { + Fthrow(Qtype_error, Qnil); + } + Fthrow(Qshutdown_signal, const_list(true, 1, code)); } -static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { - if (!NILP(lexenv)) { - LispVal *local = find_in_lexenv(lexenv, key); - if (local != Qunbound) { - return local; - } - } - LispVal *sym_val = Fsymbol_value(key); - if (sym_val != Qunbound) { - return sym_val; - } - Fthrow(Qvoid_variable_error, const_list(true, 1, key)); +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 void breakpoint(int64_t id) {} - DEFUN(breakpoint, "breakpoint", (LispVal * id)) { if (NILP(id)) { breakpoint(0); @@ -1614,46 +478,39 @@ DEFUN(breakpoint, "breakpoint", (LispVal * id)) { return Qnil; } -DEFUN(symbol_package, "symbol-package", (LispVal * symbol)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - return refcount_ref(((LispSymbol *) symbol)->package); +DEFUN(not, "not", (LispVal * obj)) { + return NILP(obj) ? Qt : Qnil; } -DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - return refcount_ref(((LispSymbol *) symbol)->name); -} - -DEFUN(symbol_function, "symbol-function", - (LispVal * symbol, LispVal *resolve)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - if (NILP(resolve)) { - return refcount_ref(((LispSymbol *) symbol)->function); +DEFUN(type_of, "type-of", (LispVal * obj)) { + if (obj->type < 0 || obj->type >= N_LISP_TYPES) { + return Qnil; } - while (SYMBOLP(symbol) && !NILP(symbol)) { - symbol = ((LispSymbol *) symbol)->function; - } - return refcount_ref(symbol); + LispVal *name = + make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name, + LISP_TYPE_NAMES[obj->type].len, true, true); + LispVal *sym = Fintern(name, system_package, Qnil); + refcount_unref(name); + return sym; } -DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - return refcount_ref(((LispSymbol *) symbol)->value); +DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) { + return LISP_BOOL(USER_POINTER_P(val)); } -DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - return refcount_ref(((LispSymbol *) symbol)->plist); -} - -DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) { - CHECK_TYPE(TYPE_SYMBOL, symbol); - LispSymbol *real = (LispSymbol *) symbol; - refcount_unref(real->plist); - real->plist = refcount_ref(plist); +DEFUN(print, "print", (LispVal * obj)) { + debug_dump(stdout, obj, false); return Qnil; } +DEFUN(println, "println", (LispVal * obj)) { + debug_dump(stdout, obj, true); + return Qnil; +} + +// ################################## +// # Evaluation and Macro Expansion # +// ################################## static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { LispVal *final_args = Qnil; WITH_PUSH_FRAME(Qnil, Qnil, true, { @@ -2022,6 +879,24 @@ static LispVal *call_function(LispVal *func, LispVal *args, return retval; } +static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { + return Fplist_get(lexenv, key, Qunbound, Qnil); +} + +static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { + if (!NILP(lexenv)) { + LispVal *local = find_in_lexenv(lexenv, key); + if (local != Qunbound) { + return local; + } + } + LispVal *sym_val = Fsymbol_value(key); + if (sym_val != Qunbound) { + return sym_val; + } + Fthrow(Qvoid_variable_error, const_list(true, 1, key)); +} + DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) { switch (TYPEOF(form)) { case TYPE_STRING: @@ -2077,52 +952,48 @@ DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) { return call_function(function, rest, Qnil, false, false); } -DEFUN(copy_tree, "copy-tree", (LispVal * tree)) { - if (NILP(tree)) { - return Qnil; - } - CHECK_TYPE(TYPE_PAIR, tree); - LispPair *tortise = (LispPair *) tree; - LispPair *hare = (LispPair *) tortise->tail; - LispVal *copy = Qnil; - LispVal *copy_end; - WITH_PUSH_FRAME(Qnil, Qnil, true, { - void *cl_handle = register_cleanup(&unref_double_ptr, ©); - while (!NILP(tortise)) { - if (!LISTP(LISPVAL(tortise))) { - break; - } else if (tortise == hare) { - refcount_unref(copy); - Fthrow(Qcircular_error, Qnil); - } - LispVal *elt = tortise->head; - if (PAIRP(elt)) { - elt = Fcopy_tree(elt); - } else { - refcount_ref(elt); - } - if (NILP(copy)) { - copy = Fpair(elt, Qnil); - copy_end = copy; - } else { - LispVal *new_end = Fpair(elt, Qnil); - Fsettail(copy_end, new_end); - refcount_unref(new_end); - copy_end = new_end; - } - refcount_unref(elt); - tortise = (LispPair *) tortise->tail; - if (PAIRP(hare)) { - if (PAIRP(((LispPair *) hare)->tail)) { - hare = (LispPair *) ((LispPair *) hare->tail)->tail; - } else if (NILP(((LispPair *) hare)->tail)) { - hare = (LispPair *) Qnil; - } - } +DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { + LispVal *args = Qnil; + LispVal *end = Qnil; + while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) { + 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; } - cancel_cleanup(cl_handle); + rest = ((LispPair *) rest)->tail; + } + 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 { + 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; + } + } + LispVal *retval; + WITH_CLEANUP_DOUBLE_PTR(args, { + retval = Ffuncall(function, args); // }); - return copy; + return retval; } static LispVal *lookup_lexical_macro(LispVal *name, LispVal *lexical_macros) { @@ -2235,6 +1106,18 @@ static void expand_lambda_list(LispVal *list, } } +STATIC_DEFMACRO(internal_real_return, "internal-real-return", + (LispVal * name, LispVal *tag, LispVal *value)) { + for (StackFrame *cur = the_stack; cur; cur = cur->next) { + if (!NILP(cur->return_tag) && cur->enable_handlers + && cur->return_tag == tag) { + Fthrow(cur->return_tag, const_list(false, 1, Feval(value))); + } + } + Fthrow(Qreturn_frame_error, + const_list(false, 2, refcount_ref(name), Feval(value))); +} + static void expand_builtin_macro(LispFunction *fobj, LispVal *args, LispVal *(*func)(LispVal *body, void *user_data), @@ -2394,83 +1277,13 @@ DEFUN(macroexpand_all, "macroexpand-all", lexical_macros); } -DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { - LispVal *args = Qnil; - LispVal *end = Qnil; - while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) { - 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; - } - rest = ((LispPair *) rest)->tail; - } - 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 { - 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; - } - } - LispVal *retval; - WITH_CLEANUP_DOUBLE_PTR(args, { - retval = Ffuncall(function, args); // - }); - return retval; -} - -DEFUN(head, "head", (LispVal * list)) { - return refcount_ref(HEAD(list)); -} - -DEFUN(tail, "tail", (LispVal * list)) { - return refcount_ref(TAIL(list)); -} - -DEFUN(exit, "exit", (LispVal * code)) { - if (!NILP(code) && !INTEGERP(code)) { - Fthrow(Qtype_error, Qnil); - } - Fthrow(Qshutdown_signal, const_list(true, 1, code)); -} - +// ################# +// # Special Forms # +// ################# DEFMACRO(quote, "'", (LispVal * form)) { return refcount_ref(form); } -DEFUN(print, "print", (LispVal * obj)) { - debug_dump(stdout, obj, false); - return Qnil; -} - -DEFUN(println, "println", (LispVal * obj)) { - debug_dump(stdout, obj, true); - return Qnil; -} - -DEFUN(not, "not", (LispVal * obj)) { - return NILP(obj) ? Qt : Qnil; -} - DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) { LispVal *res = Feval(cond); LispVal *retval = Qnil; @@ -2484,96 +1297,6 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) { return retval; } -DEFUN(num_eq, "=", (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); - } -} - -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_DOUBLE_PTR(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_DOUBLE_PTR(old_out, { - ONE_MATH_OPERAION(-, out, out, arg); // - }); - } - return out; -} - static void set_symbol_in_lexenv(LispVal *key, LispVal *newval, LispVal *lexenv) { LispVal *lexval = Fplist_assoc(lexenv, key, Qnil); @@ -2611,16 +1334,6 @@ DEFMACRO(progn, "progn", (LispVal * forms)) { return retval; } -DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) { - CHECK_TYPE(TYPE_SYMBOL, sym); - LispSymbol *sobj = ((LispSymbol *) sym); - // TODO make sure this is not constant - refcount_ref(new_func); - refcount_unref(sobj->function); - sobj->function = new_func; - return refcount_ref(new_func); -} - DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) { bool success = false; LispVal *success_form = Qunbound; @@ -2837,38 +1550,43 @@ DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) { return Qnil; } -DEFUN(make_symbol, "make-symbol", (LispVal * name)) { - return make_lisp_symbol(name); +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; } -DEFUN(stringp, "stringp", (LispVal * val)) { - return LISP_BOOL(STRINGP(val)); +DEFMACRO(or, "or", (LispVal * rest)) { + FOREACH(cond, rest) { + LispVal *nc = Feval(cond); + if (!NILP(nc)) { + return nc; + } + } + return Qnil; } -DEFUN(symbolp, "symbolp", (LispVal * val)) { - return LISP_BOOL(SYMBOLP(val)); +DEFMACRO(in_package, "in-package", (LispVal * package)) { + return Fset_current_package(package); } -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(packagep, "packagep", (LispVal * val)) { - return LISP_BOOL(PACKAGEP(val)); +DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) { + Fthrow(Qreturn_frame_error, + const_list(false, 2, refcount_ref(name), Feval(value))); } +// ###################### +// # Function Functions # +// ###################### DEFUN(functionp, "functionp", (LispVal * val)) { if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) { return Qt; @@ -2930,30 +1648,227 @@ DEFUN(special_form_p, "special-form-p", (LispVal * val)) { return Qnil; } -DEFUN(hashtablep, "hashtablep", (LispVal * val)) { - return LISP_BOOL(HASHTABLEP(val)); +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; } -DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) { - return LISP_BOOL(USER_POINTER_P(val)); +void free_opt_arg_desc(void *obj) { + struct OptArgDesc *oad = obj; + refcount_unref(oad->name); + refcount_unref(oad->default_form); + refcount_unref(oad->pred_var); + lisp_free(oad); +} + +void set_function_args(LispFunction *func, LispVal *args) { + 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); + + enum { + REQ, + OPT, + KEY, + REST, + MUST_CHANGE, + } mode = REQ; + bool has_opt = false; + bool has_key = false; + bool has_rest = false; + + func->n_req = 0; + func->rargs = Qnil; + func->n_opt = 0; + func->oargs = Qnil; + func->rest_arg = Qnil; + func->kwargs = make_lisp_hashtable(Qnil, Qnil); + func->allow_other_keys = false; + + LispVal *rargs_end = Qnil; + LispVal *oargs_end = Qnil; + + FOREACH(arg, args) { + if (arg == Qopt) { + if (has_opt || mode == REST) { + goto malformed; + } + has_opt = true; + mode = OPT; + } else if (arg == Qkey) { + if (has_key || mode == REST) { + goto malformed; + } + has_key = true; + mode = KEY; + } else if (arg == Qrest) { + if (has_rest) { + goto malformed; + } + has_rest = true; + mode = REST; + } else if (arg == Qallow_other_keys) { + if (func->allow_other_keys || mode != KEY) { + goto malformed; + } + func->allow_other_keys = true; + mode = MUST_CHANGE; + } else { + switch (mode) { + case REQ: + if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg) + || !NILP(gethash(found_args, arg, Qnil))) { + goto malformed; + } + if (NILP(func->rargs)) { + func->rargs = Fpair(arg, Qnil); + rargs_end = func->rargs; + } else { + LispVal *new_end = Fpair(arg, Qnil); + Fsettail(rargs_end, new_end); + refcount_unref(new_end); + rargs_end = new_end; + } + puthash(found_args, arg, Qt); + ++func->n_req; + break; + case OPT: { + LispVal *desc = + ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc); + USERPTR(struct OptArgDesc, desc)->index = 0; + if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc), + found_args)) { + refcount_unref(desc); + goto malformed; + } + if (NILP(func->oargs)) { + func->oargs = Fpair(desc, Qnil); + oargs_end = func->oargs; + } else { + LispVal *new_end = Fpair(desc, Qnil); + Fsettail(oargs_end, new_end); + refcount_unref(new_end); + oargs_end = new_end; + } + refcount_unref(desc); + puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt); + if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) { + puthash(found_args, + USERPTR(struct OptArgDesc, desc)->pred_var, Qt); + } + ++func->n_opt; + } break; + case KEY: { + LispVal *desc = + ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc); + if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc), + found_args)) { + refcount_unref(desc); + goto malformed; + } + USERPTR(struct OptArgDesc, desc)->index = + ((LispHashtable *) func->kwargs)->count; + LispString *sn = + ((LispSymbol *) USERPTR(struct OptArgDesc, desc)->name) + ->name; + char kns[sn->length + 2]; + kns[0] = ':'; + memcpy(kns + 1, sn->data, sn->length); + kns[sn->length + 1] = '\0'; + LispVal *kn = + make_lisp_string(kns, sn->length + 1, false, false); + LispVal *keyword = Fintern(kn, Qnil, Qnil); + puthash(func->kwargs, keyword, desc); + refcount_unref(keyword); + refcount_unref(kn); + refcount_unref(desc); + puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt); + if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) { + puthash(found_args, + USERPTR(struct OptArgDesc, desc)->pred_var, Qt); + } + } break; + case REST: + if (!NILP(func->rest_arg)) { + goto malformed; + } else if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) { + goto malformed; + } else if (!NILP(Fgethash(found_args, arg, Qnil))) { + goto malformed; + } + func->rest_arg = refcount_ref(arg); + mode = MUST_CHANGE; + break; + case MUST_CHANGE: + goto malformed; + } + } + } + refcount_unref(found_args); + // do this last + func->args = refcount_ref(args); + return; +malformed: + 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)); +} + +// ########################### +// # Pair and List Functions # +// ########################### +DEFUN(pairp, "pairp", (LispVal * val)) { + return LISP_BOOL(PAIRP(val)); } DEFUN(atom, "atom", (LispVal * val)) { return LISP_BOOL(ATOM(val)); } +DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) { + return make_lisp_pair(head, tail); +} + +DEFUN(head, "head", (LispVal * list)) { + return refcount_ref(HEAD(list)); +} + +DEFUN(tail, "tail", (LispVal * list)) { + return refcount_ref(TAIL(list)); +} + +DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) { + CHECK_TYPE(TYPE_PAIR, pair); + 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); + refcount_unref(((LispPair *) pair)->tail); + ((LispPair *) pair)->tail = refcount_ref(tail); + return Qnil; +} + +// lists 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)); } @@ -2983,54 +1898,82 @@ DEFUN(copy_list, "copy-list", (LispVal * list)) { return copy; } -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) { +DEFUN(copy_tree, "copy-tree", (LispVal * tree)) { + if (NILP(tree)) { 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, system_package, Qnil); - refcount_unref(name); - return sym; + CHECK_TYPE(TYPE_PAIR, tree); + LispPair *tortise = (LispPair *) tree; + LispPair *hare = (LispPair *) tortise->tail; + LispVal *copy = Qnil; + LispVal *copy_end; + WITH_PUSH_FRAME(Qnil, Qnil, true, { + void *cl_handle = register_cleanup(&unref_double_ptr, ©); + while (!NILP(tortise)) { + if (!LISTP(LISPVAL(tortise))) { + break; + } else if (tortise == hare) { + refcount_unref(copy); + Fthrow(Qcircular_error, Qnil); + } + LispVal *elt = tortise->head; + if (PAIRP(elt)) { + elt = Fcopy_tree(elt); + } else { + refcount_ref(elt); + } + if (NILP(copy)) { + copy = Fpair(elt, Qnil); + copy_end = copy; + } else { + LispVal *new_end = Fpair(elt, Qnil); + Fsettail(copy_end, new_end); + refcount_unref(new_end); + copy_end = new_end; + } + refcount_unref(elt); + tortise = (LispPair *) tortise->tail; + if (PAIRP(hare)) { + if (PAIRP(((LispPair *) hare)->tail)) { + hare = (LispPair *) ((LispPair *) hare->tail)->tail; + } else if (NILP(((LispPair *) hare)->tail)) { + hare = (LispPair *) Qnil; + } + } + } + cancel_cleanup(cl_handle); + }); + return copy; } -DEFUN(function_docstr, "function-docstr", (LispVal * func)) { - if (FUNCTIONP(func)) { - return ((LispFunction *) func)->doc; +size_t list_length(LispVal *obj) { + if (NILP(obj)) { + return 0; } - LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt); - CHECK_TYPE(TYPE_FUNCTION, fobj); - LispVal *retval = refcount_ref(fobj->doc); - refcount_unref(fobj); - return retval; + CHECK_TYPE(TYPE_PAIR, obj); + size_t length = 0; + LispPair *tortise = (LispPair *) obj; + LispPair *hare = (LispPair *) tortise->tail; + while (!NILP(tortise)) { + if (!LISTP(LISPVAL(tortise))) { + break; + } else if (tortise == hare) { + Fthrow(Qcircular_error, Qnil); + } + ++length; + tortise = (LispPair *) tortise->tail; + if (PAIRP(hare)) { + if (PAIRP(((LispPair *) hare)->tail)) { + hare = (LispPair *) ((LispPair *) hare->tail)->tail; + } else if (NILP(((LispPair *) hare)->tail)) { + hare = (LispPair *) Qnil; + } + } + } + return length; } +// plists static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) { if (NILP(pred)) { return !NILP(Feq(v1, v2)); @@ -3098,6 +2041,952 @@ DEFUN(plist_assoc, "plist-assoc", return Qnil; } +// #################### +// # String Functions # +// #################### +DEFUN(stringp, "stringp", (LispVal * val)) { + return LISP_BOOL(STRINGP(val)); +} + +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); +} + +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; +} + +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; +} + +// ##################### +// # Package Functions # +// ##################### +static LispVal *normalize_package(LispVal *arg) { + if (STRINGP(arg) || SYMBOLP(arg)) { + LispVal *found = Ffind_package(arg); + if (!PACKAGEP(found)) { + refcount_unref(found); + Fthrow(Qunknown_package_error, const_list(true, 1, arg)); + } + return found; + } else if (PACKAGEP(arg)) { + return refcount_ref(arg); + } else { + Fthrow(Qtype_error, Qnil); + } +} + +DEFUN(packagep, "packagep", (LispVal * val)) { + return LISP_BOOL(PACKAGEP(val)); +} + +DEFUN(make_package, "make-package", (LispVal * name)) { + if (SYMBOLP(name)) { + name = Fsymbol_name(name); + } else { + name = refcount_ref(name); + } + LispVal *np = make_lisp_package(name); + refcount_unref(name); + return np; +} + +DEFUN(package_name, "package-name", (LispVal * package)) { + CHECK_TYPE(TYPE_PACKAGE, package); + return LISPVAL(((LispPackage *) package)->name); +} + +DEFUN(register_package, "register-package", (LispVal * package)) { + if (STRINGP(package)) { + package = make_lisp_package(package); + } else if (SYMBOLP(package)) { + package = make_lisp_package(LISPVAL(((LispSymbol *) package)->name)); + } else { + CHECK_TYPE(TYPE_PACKAGE, package); + package = refcount_ref(package); + } + LispVal *found = Ffind_package(package); + if (!NILP(found)) { + refcount_unref(package); + Fthrow(Qpackage_exists_error, const_list(true, 1, package)); + } + puthash(package_table, LISPVAL(((LispPackage *) package)->name), package); + return package; +} + +DEFUN(current_package, "current-package", (void) ) { + return refcount_ref(current_package); +} +IGNORE(); // fix indentation + +DEFUN(set_current_package, "set-current-package", (LispVal * package)) { + LispVal *new = normalize_package(package); + LispVal *old = current_package; + current_package = new; + refcount_unref(old); + return refcount_ref(current_package); +} + +DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package)) { + LispPackage *pkg; + if (NILP(package)) { + pkg = refcount_ref(current_package); + } else { + pkg = (LispPackage *) normalize_package(package); + } +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wunused-but-set-variable" + // TODO make hash tables not crash if modified during a loop + WITH_CLEANUP(pkg, { + IGNORE(); + HASHTABLE_FOREACH(name, sym, pkg->obarray) { + LispVal *args = const_list(true, 1, sym); + refcount_unref(Ffuncall(func, args)); + } + }); +#pragma GCC diagnostic pop + return Qnil; +} + +DEFUN(export_symbol, "export-symbol", (LispVal * symbol)) { + if (SYMBOLP(symbol)) { + LispSymbol *sym = (LispSymbol *) symbol; + LispPackage *pkg = (LispPackage *) sym->package; + puthash(pkg->exported_sym_table, symbol, Qt); + } else if (LISTP(symbol)) { + FOREACH(cur, symbol) { + CHECK_TYPE(TYPE_SYMBOL, cur); + Fexport_symbol(cur); + } + } else { + Fthrow(Qtype_error, + const_list(false, 2, const_list(false, 2, Qlistp, Qsymbolp), + symbol)); + } + return Qnil; +} + +// recursively search all imports of SOURCE, looking for TARGET +static bool check_recursive_import(LispVal *source, LispVal *target) { + FOREACH(entry, ((LispPackage *) source)->imported) { + if (HEAD(entry) == target + || check_recursive_import(HEAD(entry), target)) { + return true; + } + } + return false; +} + +DEFUN_DISTINGUISHED(import_package, "import-package", + (LispVal * source, LispVal *names, LispVal *target)) { + LispPackage *target_pkg; + if (target == Qunbound || NILP(target)) { + target_pkg = refcount_ref(current_package); + } else { + target_pkg = (LispPackage *) normalize_package(target); + } + if (!PACKAGEP(target_pkg)) { + refcount_unref(target_pkg); + Fthrow(Qimport_error, Qnil); + } + if (names == Qunbound) { + names = Qt; // all symbols + } + FOREACH(entry, target_pkg->imported) { + if (HEAD(entry) == source) { + if (names == Qt) { + Fsettail(HEAD(entry), Qt); + } else { + LispVal *imported = TAIL(entry); + // if we have already imported everything, do nothing + if (imported == Qt) { + goto done; + } + FOREACH(name, names) { + if (SYMBOLP(name)) { + name = LISPVAL(((LispSymbol *) name)->name); + } else if (!STRINGP(name)) { + refcount_unref(target_pkg); + CHECK_TYPE(TYPE_STRING, name); + } + puthash(imported, name, Qt); + } + } + goto done; + } + } + // we didn't find any existing imports, so add a new entry + if (check_recursive_import(source, LISPVAL(target_pkg))) { + refcount_unref(target_pkg); + Fthrow(Qimport_error, Qnil); + } + LispVal *lasttail = Qnil; + FOREACH_TAIL(tail, target_pkg->imported) { + if (NILP(TAIL(tail))) { + lasttail = tail; + break; + } + } + if (LISTP(names)) { + LispVal *norm_names = make_lisp_hashtable(Qstrings_equal, Qhash_string); + FOREACH(name, names) { + if (SYMBOLP(name)) { + name = LISPVAL(((LispSymbol *) name)->name); + } else if (!STRINGP(name)) { + refcount_unref(target_pkg); + refcount_unref(norm_names); + CHECK_TYPE(TYPE_STRING, name); + } + puthash(norm_names, name, Qt); + } + names = norm_names; + } + if (NILP(lasttail)) { + target_pkg->imported = const_list(false, 1, Fpair(source, names)); + } else { + Fsettail(lasttail, const_list(false, 1, Fpair(source, names))); + } + refcount_unref(names); +done: + refcount_unref(target_pkg); + return Qnil; +} + +DEFUN(find_package, "find-package", (LispVal * name)) { + if (STRINGP(name)) { + return Fgethash(package_table, name, Qnil); + } else if (SYMBOLP(name)) { + return Fgethash(package_table, LISPVAL(((LispSymbol *) name)->name), + Qnil); + } else if (PACKAGEP(name)) { + LispPackage *pkg = (LispPackage *) name; + LispVal *found = Fgethash(package_table, LISPVAL(pkg->name), Qnil); + if (found == LISPVAL(pkg)) { + return found; + } else { + refcount_unref(found); + return Qnil; + } + } else { + Fthrow(Qtype_error, Qnil); + } +} + +LispVal *find_package(const char *name, size_t length) { + LispVal *sobj = make_lisp_string(name, length, false, false); + LispVal *pkg = Ffind_package(sobj); + refcount_unref(sobj); + return pkg; +} + +// #################### +// # Symbol Functions # +// #################### +DEFUN(symbolp, "symbolp", (LispVal * val)) { + return LISP_BOOL(SYMBOLP(val)); +} + +DEFUN(keywordp, "keywordp", (LispVal * val)) { + return LISP_BOOL(KEYWORDP(val)); +} + +DEFUN(make_symbol, "make-symbol", (LispVal * name)) { + return make_lisp_symbol(name); +} + +DEFUN(symbol_package, "symbol-package", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + return refcount_ref(((LispSymbol *) symbol)->package); +} + +DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + return refcount_ref(((LispSymbol *) symbol)->name); +} + +DEFUN(symbol_function, "symbol-function", + (LispVal * symbol, LispVal *resolve)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + if (NILP(resolve)) { + return refcount_ref(((LispSymbol *) symbol)->function); + } + while (SYMBOLP(symbol) && !NILP(symbol)) { + symbol = ((LispSymbol *) symbol)->function; + } + return refcount_ref(symbol); +} + +DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + return refcount_ref(((LispSymbol *) symbol)->value); +} + +DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + return refcount_ref(((LispSymbol *) symbol)->plist); +} + +DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + LispSymbol *real = (LispSymbol *) symbol; + refcount_unref(real->plist); + real->plist = refcount_ref(plist); + return Qnil; +} + +DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) { + CHECK_TYPE(TYPE_SYMBOL, sym); + LispSymbol *sobj = ((LispSymbol *) sym); + // TODO make sure this is not constant + refcount_ref(new_func); + refcount_unref(sobj->function); + sobj->function = new_func; + return refcount_ref(new_func); +} + +DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + LispSymbol *sym = (LispSymbol *) symbol; + if (NILP(sym->package)) { + return Qnil; + } + LispPackage *pkg = (LispPackage *) sym->package; + return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil); +} + +DEFUN(intern_soft, "intern-soft", + (LispVal * name, LispVal *def, LispVal *package, LispVal *included_too)) { + LispPackage *real_pkg; + if (NILP(package)) { + real_pkg = refcount_ref(current_package); + } else { + real_pkg = (LispPackage *) normalize_package(package); + } + LispVal *cur = gethash(real_pkg->obarray, name, Qunbound); + if (cur != Qunbound) { + refcount_unref(real_pkg); + return refcount_ref(cur); + } + if (!NILP(included_too)) { + FOREACH(entry, real_pkg->imported) { + if (TAIL(entry) != Qt) { + LispVal *sub = HEAD(entry); + LispVal *imported = TAIL(entry); + if (!NILP(gethash(imported, name, Qnil))) { + refcount_unref(real_pkg); + // we import it from this package, so don't keep searching + // if the intern fails + return Fintern_soft(name, def, sub, Qt); + } + // otherwise, keep looking in a different package + } else { + cur = Fintern_soft(name, Qunbound, HEAD(entry), Qt); + if (cur != Qunbound) { + refcount_unref(real_pkg); + return cur; + } + } + } + } + refcount_unref(real_pkg); + return refcount_ref(def); +} + +DEFUN(intern, "intern", + (LispVal * name, LispVal *package, LispVal *included_too)) { + CHECK_TYPE(TYPE_STRING, name); + LispPackage *real_pkg; + if (NILP(package)) { + real_pkg = refcount_ref(current_package); + } else { + real_pkg = (LispPackage *) normalize_package(package); + } + LispVal *cur = Fintern_soft(name, Qunbound, package, included_too); + if (cur != Qunbound) { + return cur; + } + LispVal *sym = make_lisp_symbol(name); + ((LispSymbol *) sym)->package = refcount_ref(real_pkg); + puthash(real_pkg->obarray, name, sym); + refcount_unref(real_pkg); + return sym; +} + +LispVal *intern(const char *name, size_t length, bool take, LispVal *package, + bool included_too) { + if (!NILP(package)) { + CHECK_TYPE(TYPE_PACKAGE, package); + } + LispVal *name_obj = make_lisp_string((char *) name, length, take, false); + LispVal *sym = Fintern(name_obj, package, LISP_BOOL(included_too)); + refcount_unref(name_obj); + return sym; +} + +// ####################### +// # Hashtable Functions # +// ####################### +DEFUN(hashtablep, "hashtablep", (LispVal * val)) { + return LISP_BOOL(HASHTABLEP(val)); +} + +DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) { + return make_lisp_hashtable(eq_fn, hash_fn); +} + +DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table)) { + CHECK_TYPE(TYPE_HASHTABLE, table); + LispHashtable *orig = (LispHashtable *) table; + CONSTRUCT_OBJECT(copy, LispHashtable, TYPE_HASHTABLE); + copy->table_size = orig->table_size; + copy->data = + lisp_malloc(sizeof(struct HashtableBucket *) * copy->table_size); + memset(copy->data, 0, sizeof(struct HashtableBucket *) * copy->table_size); + copy->count = orig->count; + copy->eq_fn = orig->eq_fn; + copy->hash_fn = orig->hash_fn; + for (size_t i = 0; i < orig->table_size; ++i) { + for (struct HashtableBucket *bucket = orig->data[i]; bucket; + bucket = bucket->next) { + struct HashtableBucket *new_bucket = + lisp_malloc(sizeof(struct HashtableBucket)); + new_bucket->hash = bucket->hash; + new_bucket->key = refcount_ref(bucket->key); + new_bucket->value = refcount_ref(bucket->value); + new_bucket->next = copy->data[i]; + copy->data[i] = new_bucket; + } + } + return LISPVAL(copy); +} + +DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) { + CHECK_TYPE(TYPE_HASHTABLE, table); + return make_lisp_integer(((LispHashtable *) table)->count); +} + +DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) { + return refcount_ref(puthash(table, key, value)); +} + +DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) { + return refcount_ref(gethash(table, key, def)); +} + +DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) { + return refcount_ref(remhash(table, key)); +} + +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 { + LispVal *eq_obj; + LispVal *args = const_list(true, 2, v1, v2); + WITH_CLEANUP(args, { + eq_obj = Ffuncall(self->eq_fn, args); // + }); + bool result = !NILP(eq_obj); + refcount_unref(eq_obj); + return result; + } +} + +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 and lexenv lookups faster + LispVal *hash_obj = Fhash_string(key); + uint64_t hash = ((LispInteger *) hash_obj)->value; + refcount_unref(hash_obj); + return hash; + } else { + LispVal *hash_obj; + LispVal *args = const_list(true, 1, key); + WITH_CLEANUP(args, { + hash_obj = Ffuncall(self->hash_fn, args); // + }); + uint64_t hash; + WITH_CLEANUP(hash_obj, { + CHECK_TYPE(TYPE_INTEGER, hash_obj); + hash = ((LispInteger *) hash_obj)->value; + }); + return hash; + } +} + +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; +} + +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) { + 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 = 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 + >= LISP_HASHTABLE_GROWTH_THRESHOLD) { + hash_table_rehash(self, + LISP_HASHTABLE_GROWTH_FACTOR * self->table_size); + } + } + return table; +} + +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); + struct HashtableBucket *cur_bucket = + find_hash_table_bucket(self, key, hash); + if (cur_bucket) { + return cur_bucket->value; + } + return 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; + refcount_unref(cur_bucket->key); + refcount_unref(cur_bucket->value); + lisp_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; + refcount_unref(cur_bucket->key); + refcount_unref(cur_bucket->value); + lisp_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; +} + +// ##################### +// # Numeric Functions # +// ##################### +DEFUN(integerp, "integerp", (LispVal * val)) { + return LISP_BOOL(INTEGERP(val)); +} + +DEFUN(floatp, "floatp", (LispVal * val)) { + return LISP_BOOL(FLOATP(val)); +} + +DEFUN(num_eq, "=", (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); + } +} + +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_DOUBLE_PTR(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_DOUBLE_PTR(old_out, { + ONE_MATH_OPERAION(-, out, out, arg); // + }); + } + return out; +} + +// #################### +// # Vector Functions # +// #################### +DEFUN(vectorp, "vectorp", (LispVal * val)) { + return LISP_BOOL(VECTORP(val)); +} + +DEFUN(vector, "vector", (LispVal * elems)) { + struct UnrefListData uld = {.vals = NULL, .len = 0}; + WITH_PUSH_FRAME(Qnil, Qnil, true, { + void *cl_handler = register_cleanup(&unref_free_list_double_ptr, &uld); + FOREACH(elt, elems) { + uld.vals = lisp_realloc(uld.vals, sizeof(LispVal *) * (++uld.len)); + uld.vals[uld.len - 1] = elt; + } + cancel_cleanup(cl_handler); + }); + return make_lisp_vector(uld.vals, uld.len); +} + +// ######################## +// # Lexenv and the Stack # +// ######################## +DEF_STATIC_SYMBOL(kw_success, "success"); +DEF_STATIC_SYMBOL(kw_finally, "finally"); + +DEFUN(backtrace, "backtrace", (void) ) { + LispVal *head = Qnil; + LispVal *end = Qnil; + for (StackFrame *frame = the_stack; frame; frame = frame->next) { + if (frame->hidden) { + continue; + } + 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); + refcount_unref(new_end); + end = new_end; + } + } + return head; +} +IGNORE(); // fix indentation + +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Winfinite-recursion" +DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { + CHECK_TYPE(TYPE_SYMBOL, signal); + LispVal *error_arg = + const_list(false, 2, Fpair(signal, rest), Fbacktrace()); + while (the_stack) { + if (!the_stack->enable_handlers) { + goto up_frame; + } + LispVal *handler = + gethash(LISPVAL(the_stack->handlers), signal, Qunbound); + if (handler == Qunbound) { + // handler for all exceptions + handler = gethash(LISPVAL(the_stack->handlers), Qt, Qunbound); + } + if (handler != Qunbound) { + the_stack->enable_handlers = false; + LispVal *var = HEAD(handler); + LispVal *form = TAIL(handler); + WITH_PUSH_FRAME(Qnil, Qnil, true, { + if (!NILP(var)) { + // TODO make sure this isn't constant + push_to_lexenv(&the_stack->lexenv, var, error_arg); + } + WITH_CLEANUP(error_arg, { + stack_return = Feval(form); // + }); + }); + longjmp(the_stack->start, STACK_EXIT_THROW); + } + up_frame: { + // steal the form so we can call it after we unwind (in case it + // throws) + LispVal *unwind_form = the_stack->unwind_form; + the_stack->unwind_form = Qnil; + stack_leave(); + if (!NILP(unwind_form)) { + void *cl_handler = + register_cleanup(&refcount_unref_as_callback, error_arg); + WITH_CLEANUP(unwind_form, { + refcount_unref(Feval(unwind_form)); // + }); + cancel_cleanup(cl_handler); + } + } + } + fprintf(stderr, + "ERROR: An exception has propagated past the top of the stack!\n"); + fprintf(stderr, "Type: "); + debug_dump(stderr, signal, true); + fprintf(stderr, "Args: "); + debug_dump(stderr, rest, true); + fprintf(stderr, "Lisp will now exit..."); + // we never used it, so drop it + refcount_unref(error_arg); + abort(); +} +#pragma GCC diagnostic pop + +StackFrame *the_stack = NULL; +LispVal *stack_return = NULL; +DEF_STATIC_SYMBOL(toplevel, "toplevel"); + +void stack_enter(LispVal *name, LispVal *detail, bool inherit) { + StackFrame *frame = lisp_malloc(sizeof(StackFrame)); + frame->name = name; + frame->return_tag = Qnil; + frame->hidden = true; + frame->detail = detail; + frame->lexenv = Qnil; + if (inherit && the_stack) { + frame->lexenv = refcount_ref(the_stack->lexenv); + } + frame->enable_handlers = true; + frame->handlers = make_lisp_hashtable(Qnil, Qnil); + frame->unwind_form = Qnil; + frame->cleanup_handlers = NULL; + + frame->next = the_stack; + the_stack = frame; +} + +void stack_leave(void) { + StackFrame *frame = the_stack; + the_stack = the_stack->next; + refcount_unref(frame->name); + refcount_unref(frame->return_tag); + refcount_unref(frame->detail); + refcount_unref(frame->lexenv); + refcount_unref(frame->handlers); + while (frame->cleanup_handlers) { + frame->cleanup_handlers->fun(frame->cleanup_handlers->data); + struct CleanupHandlerEntry *next = frame->cleanup_handlers->next; + lisp_free(frame->cleanup_handlers); + frame->cleanup_handlers = next; + } + LispVal *unwind_form = frame->unwind_form; + // steal the ref + frame->unwind_form = Qnil; + lisp_free(frame); + if (!NILP(unwind_form)) { + WITH_CLEANUP(unwind_form, { + refcount_unref(Feval(unwind_form)); // + }) + } +} + +void *register_cleanup(lisp_cleanup_func_t fun, void *data) { + struct CleanupHandlerEntry *entry = + lisp_malloc(sizeof(struct CleanupHandlerEntry)); + entry->fun = fun; + entry->data = data; + entry->next = the_stack->cleanup_handlers; + the_stack->cleanup_handlers = entry; + return entry; +} + +void free_double_ptr(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) { + 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; + lisp_free(entry); + } else { + while (entry) { + if (entry->next == handle) { + struct CleanupHandlerEntry *to_free = entry->next; + entry->next = entry->next->next; + lisp_free(to_free); + break; + } + entry = entry->next; + } + } +} + +// ######################### +// # Errors and Conditions # +// ######################### +DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal"); +DEF_STATIC_SYMBOL(type_error, "type-error"); +DEF_STATIC_SYMBOL(read_error, "read-error"); +DEF_STATIC_SYMBOL(unclosed_error, "read-error"); +DEF_STATIC_SYMBOL(eof_error, "eof-error"); +DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error"); +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"); +DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error"); +DEF_STATIC_SYMBOL(package_exists_error, "package-exists-error"); +DEF_STATIC_SYMBOL(import_error, "import-error"); +DEF_STATIC_SYMBOL(unknown_package_error, "unknown-package-error"); + +// ################### +// # Debug Functions # +// ################### static void debug_dump_real(FILE *stream, void *obj, bool first) { switch (TYPEOF(obj)) { case TYPE_STRING: { @@ -3231,3 +3120,172 @@ static bool debug_print_tree_callback(void *obj, const RefcountList *trail, void debug_print_tree(FILE *stream, void *obj) { refcount_debug_walk_tree(obj, debug_print_tree_callback, stream); } + +// ################ +// # Registration # +// ################ +static void register_symbols_and_functions(void) { + // don't intern Qunbound! + puthash(((LispPackage *) system_package)->obarray, + LISPVAL(((LispSymbol *) Qnil)->name), Qnil); + ((LispSymbol *) Qnil)->package = refcount_ref(system_package); + puthash(((LispPackage *) system_package)->obarray, + LISPVAL(((LispSymbol *) Qt)->name), Qt); + ((LispSymbol *) Qt)->package = refcount_ref(system_package); + REGISTER_SYMBOL(opt); + REGISTER_SYMBOL(allow_other_keys); + REGISTER_SYMBOL(key); + REGISTER_SYMBOL(rest); + REGISTER_SYMBOL(declare); + REGISTER_SYMBOL(name); + REGISTER_SYMBOL(comma); + REGISTER_SYMBOL(comma_at); + REGISTER_SYMBOL(backquote); + REGISTER_SYMBOL_INTO(kw_success, keyword_package); + REGISTER_SYMBOL_INTO(kw_finally, keyword_package); + REGISTER_SYMBOL(shutdown_signal); + REGISTER_SYMBOL(type_error); + REGISTER_SYMBOL(read_error); + REGISTER_SYMBOL(eof_error); + REGISTER_SYMBOL(unclosed_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_SYMBOL(return_frame_error); + REGISTER_SYMBOL(package_exists_error); + REGISTER_SYMBOL(import_error); + REGISTER_SYMBOL(unknown_package_error); + + // some stuff that musn't be user accesable + REGISTER_SYMBOL_NOINTERN(toplevel); + REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", ""); + REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", ""); + + REGISTER_FUNCTION(make_hashtable, "(&opt hash-fn eq-fn)", ""); + REGISTER_FUNCTION(puthash, "(table key value)", ""); + REGISTER_FUNCTION(gethash, "(table key &opt def)", ""); + REGISTER_FUNCTION(remhash, "(table key)", ""); + REGISTER_FUNCTION(vector, "(&rest elements)", ""); + REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing..."); + 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_name, "(sym)", ""); + REGISTER_FUNCTION(symbol_package, "(sym)", ""); + REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); + REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM."); + REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM."); + REGISTER_FUNCTION(setplist, "(sym plist)", + "Set the plist of SYM to PLIST."); + 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 &opt lexical-macros)", + "Return the form which FORM expands to."); + REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", ""); + REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", ""); + 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(packagep, "(val)", "Return non-nil if VAL is a package."); + REGISTER_FUNCTION( + functionp, "(val)", + "Return non-nil if VAL is a non-macro function (includes buitlins)."); + REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)", + "Return non-nil if VAL is a non-builtin macro."); + REGISTER_FUNCTION(builtinp, "(val)", + "Return non-nil if VAL is a non-macro builtin."); + REGISTER_FUNCTION(special_form_p, "(val)", + "Return non-nil if VAL is a macro-builtin."); + 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(list_length, "(list)", "Return the length of LIST."); + REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST."); + REGISTER_FUNCTION(copy_tree, "(tree)", + "Return a deep copy of TREE and all sublists in it."); + 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."); + REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", ""); + REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", ""); + REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", ""); + REGISTER_FUNCTION(return_from, "(name &opt value)", + "Return from the function named NAME and return VALUE."); + REGISTER_FUNCTION(intern, "(name &opt package included-too)", ""); + REGISTER_FUNCTION(intern_soft, "(name &opt default package included-too)", + ""); + REGISTER_FUNCTION(condition_case, "(form &rest handlers)", ""); + REGISTER_FUNCTION(set_current_package, "(package)", ""); + REGISTER_FUNCTION(in_package, "(package)", ""); + REGISTER_FUNCTION(current_package, "()", ""); + REGISTER_FUNCTION(make_package, "(name)", ""); + REGISTER_FUNCTION(register_package, "(package)", ""); + REGISTER_FUNCTION(find_package, "(name)", ""); + REGISTER_FUNCTION(exported_symbol_p, "(symbol)", ""); + REGISTER_FUNCTION(export_symbol, "(symbol)", ""); + REGISTER_FUNCTION(import_package, "(source &opt names target)", ""); + REGISTER_FUNCTION(hash_table_count, "(table)", ""); + REGISTER_FUNCTION(copy_hash_table, "(table)", ""); + REGISTER_FUNCTION(package_name, "(package)", ""); + REGISTER_FUNCTION(mapsymbols, "(func &opt package)", ""); +} diff --git a/src/lisp.h b/src/lisp.h index f2134fa..3fb9c23 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -48,6 +48,7 @@ extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES]; typedef struct { LISP_OBJECT_HEADER; } LispVal; +#define LISPVAL(obj) ((LispVal *) (obj)) typedef struct { LISP_OBJECT_HEADER; @@ -95,17 +96,7 @@ typedef struct { bool is_static; } LispVector; -struct OptArgDesc { - size_t index; // only for keywords - LispVal *name; - LispVal *default_form; - LispVal *pred_var; -}; - -void free_opt_arg_desc(void *obj); - typedef void (*lisp_function_ptr_t)(void); - typedef struct { LISP_OBJECT_HEADER; @@ -175,8 +166,6 @@ typedef struct { // ####################### // # nil, unbound, and t # // ####################### -#define LISPVAL(obj) ((LispVal *) (obj)) - extern LispSymbol _Qnil; extern LispSymbol _Qunbound; // don't intern! extern LispSymbol _Qt; @@ -187,6 +176,27 @@ extern LispSymbol _Qt; #define LISP_BOOL(v) ((v) ? Qt : Qnil) +// ########################### +// # Other important symbols # +// ########################### +extern LispVal *Qbackquote; +extern LispVal *Qcomma; +extern LispVal *Qcomma_at; +extern LispVal *Qopt; +extern LispVal *Qkey; +extern LispVal *Qallow_other_keys; +extern LispVal *Qrest; +extern LispVal *Qdeclare; +extern LispVal *Qname; + +// ############################ +// # Global Package Variables # +// ############################ +extern LispVal *package_table; +extern LispVal *system_package; +extern LispVal *keyword_package; +extern LispVal *current_package; + // ################### // # Type predicates # // ################### @@ -210,11 +220,6 @@ extern LispSymbol _Qt; #define ATOM(v) (TYPEOF(v) != TYPE_PAIR) -extern LispVal *package_table; -extern LispVal *system_package; -extern LispVal *keyword_package; -extern LispVal *current_package; - inline static bool KEYWORDP(LispVal *v) { return SYMBOLP(v) && ((LispSymbol *) v)->package == keyword_package; } @@ -295,6 +300,36 @@ inline static bool NUMBERP(LispVal *v) { #define STATIC_DEFMACRO(c_name, lisp_name, c_args) \ _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static) +// registration +#define REGISTER_SYMBOL_NOINTERN(sym) \ + { \ + refcount_init_static(Q##sym); \ + refcount_init_static(((LispSymbol *) Q##sym)->name); \ + } +#define REGISTER_SYMBOL_INTO(sym, pkg) \ + REGISTER_SYMBOL_NOINTERN(sym) \ + ((LispSymbol *) Q##sym)->package = refcount_ref(pkg); \ + puthash(((LispPackage *) pkg)->obarray, \ + LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); +#define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package) +#define REGISTER_STATIC_FUNCTION(name, args, docstr) \ + REGISTER_SYMBOL_NOINTERN(name); \ + { \ + LispVal *obj = ((LispSymbol *) Q##name)->function; \ + refcount_init_static(obj); \ + ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ + LispVal *src = STATIC_STRING(args); \ + LispVal *a = Fread(src, system_package); \ + set_function_args((LispFunction *) (obj), a); \ + refcount_unref(src); \ + refcount_unref(a); \ + } +#define REGISTER_FUNCTION(fn, args, docstr) \ + REGISTER_STATIC_FUNCTION(fn, args, docstr); \ + ((LispSymbol *) Q##fn)->package = refcount_ref(system_package); \ + puthash(((LispPackage *) system_package)->obarray, \ + LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn); + // ############### // # Loop macros # // ############### @@ -324,7 +359,6 @@ inline static bool NUMBERP(LispVal *v) { // ############################# // # Allocation and references # // ############################# - #define GC_EVERY_N_BYTES 1024 * 80 void *lisp_malloc(size_t size); void *lisp_realloc(void *old_ptr, size_t size); @@ -338,13 +372,11 @@ void garbage_collect(void); LispVal *make_lisp_string(const char *data, size_t length, bool take, bool is_static); #define STATIC_STRING(s) (make_lisp_string((s), sizeof(s) - 1, true, true)) -LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2); LispVal *make_lisp_symbol(LispVal *name); LispVal *make_lisp_pair(LispVal *head, LispVal *tail); 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 *name, LispVal *return_tag, LispVal *args, LispVal *lexenv, LispVal *body, bool is_macro); LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); @@ -353,41 +385,309 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)); (make_user_pointer(lisp_malloc(sizeof(type)), &free_func)) LispVal *make_lisp_package(LispVal *name); -// ######################## -// # Utility and internal # -// ######################## -bool strings_equal_nocase(const char *s1, const char *s2, size_t n); +LispVal *predicate_for_type(LispType type); -DECLARE_FUNCTION(make_hashtable, (LispVal * hash_fn, LispVal *eq_fn)); -DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail)); -DECLARE_FUNCTION(hash_string, (LispVal * obj)); -DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2)); +// ############################### +// # Initialization and Shutdown # +// ############################### +void lisp_init(void); +void lisp_shutdown(void); + +// ############################### +// # General and Misc. Functions # +// ############################### +noreturn DECLARE_FUNCTION(exit, (LispVal * code)); DECLARE_FUNCTION(id, (LispVal * obj)); DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2)); -DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value)); -DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def)); -DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key)); -DECLARE_FUNCTION(hash_table_count, (LispVal * table)); +DECLARE_FUNCTION(breakpoint, (LispVal * id)); +DECLARE_FUNCTION(not, (LispVal * obj)); +DECLARE_FUNCTION(type_of, (LispVal * val)); +DECLARE_FUNCTION(user_pointer_p, (LispVal * val)); + +DECLARE_FUNCTION(print, (LispVal * obj)); +DECLARE_FUNCTION(println, (LispVal * obj)); + +// ################################## +// # Evaluation and Macro Expansion # +// ################################## +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(macroexpand_1, (LispVal * form, LispVal *lexical_macros)); +DECLARE_FUNCTION(macroexpand_toplevel, + (LispVal * form, LispVal *lexical_macros)); +DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros)); + +// ################# +// # Special Forms # +// ################# +DECLARE_FUNCTION(quote, (LispVal * form)); +DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil)); +DECLARE_FUNCTION(setq, (LispVal * args)); +DECLARE_FUNCTION(progn, (LispVal * forms)); +DECLARE_FUNCTION(condition_case, (LispVal * form, LispVal *rest)); +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(and, (LispVal * rest)); +DECLARE_FUNCTION(or, (LispVal * rest)); DECLARE_FUNCTION(in_package, (LispVal * package)); +noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); + +// ###################### +// # Function Functions # +// ###################### +DECLARE_FUNCTION(functionp, (LispVal * val)); +DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros)); +DECLARE_FUNCTION(builtinp, (LispVal * val)); +DECLARE_FUNCTION(special_form_p, (LispVal * val)); +DECLARE_FUNCTION(function_docstr, (LispVal * func)); + +struct OptArgDesc { + size_t index; // only for keywords + LispVal *name; + LispVal *default_form; + LispVal *pred_var; +}; +void free_opt_arg_desc(void *obj); +void set_function_args(LispFunction *func, LispVal *args); + +// ########################### +// # Pair and List Functions # +// ########################### +DECLARE_FUNCTION(pairp, (LispVal * val)); +DECLARE_FUNCTION(atom, (LispVal * val)); +DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail)); +DECLARE_FUNCTION(head, (LispVal * list)); +DECLARE_FUNCTION(tail, (LispVal * list)); +DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head)); +DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail)); + +// lists +DECLARE_FUNCTION(listp, (LispVal * val)); +DECLARE_FUNCTION(list_length, (LispVal * list)); +DECLARE_FUNCTION(copy_list, (LispVal * list)); +DECLARE_FUNCTION(copy_tree, (LispVal * tree)); +size_t list_length(LispVal *obj); + +// plists +DECLARE_FUNCTION(plist_get, + (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)); +DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value, + LispVal *pred)); +DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred)); +DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred)); + +// #################### +// # String Functions # +// #################### +DECLARE_FUNCTION(stringp, (LispVal * val)); +DECLARE_FUNCTION(hash_string, (LispVal * obj)); +DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2)); +LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2); +bool strings_equal_nocase(const char *s1, const char *s2, size_t n); + +// ##################### +// # Package Functions # +// ##################### +DECLARE_FUNCTION(packagep, (LispVal * val)); +DECLARE_FUNCTION(make_package, (LispVal * name)); DECLARE_FUNCTION(package_name, (LispVal * package)); -DECLARE_FUNCTION(mapsymbols, (LispVal * func, LispVal *package)); -DECLARE_FUNCTION(set_current_package, (LispVal * package)); +DECLARE_FUNCTION(register_package, (LispVal * package)); DECLARE_FUNCTION(current_package, (void) ); +DECLARE_FUNCTION(set_current_package, (LispVal * package)); +DECLARE_FUNCTION(mapsymbols, (LispVal * func, LispVal *package)); DECLARE_FUNCTION(export_symbol, (LispVal * symbol)); DECLARE_FUNCTION(import_package, (LispVal * source, LispVal *names, LispVal *target)); -DECLARE_FUNCTION(make_package, (LispVal * name)); -DECLARE_FUNCTION(register_package, (LispVal * package)); DECLARE_FUNCTION(find_package, (LispVal * name)); +LispVal *find_package(const char *name, size_t length); +#define FIND_PACKAGE_STATIC(name) (find_package(name, sizeof(name))) + +// #################### +// # Symbol Functions # +// #################### +DECLARE_FUNCTION(symbolp, (LispVal * val)); +DECLARE_FUNCTION(keywordp, (LispVal * val)); +DECLARE_FUNCTION(make_symbol, (LispVal * name)); +DECLARE_FUNCTION(symbol_package, (LispVal * symbol)); +DECLARE_FUNCTION(symbol_name, (LispVal * symbol)); +DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); +DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); +DECLARE_FUNCTION(symbol_plist, (LispVal * symbol)); +DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist)); +DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func)); DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol)); DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package, LispVal *included_too)); -LispVal *find_package(const char *name, size_t length); -#define FIND_PACKAGE_STATIC(name) (find_package(name, sizeof(name))) -LispVal *intern(const char *name, size_t length, bool take, LispVal *package, - bool included_too); DECLARE_FUNCTION(intern, (LispVal * name, LispVal *package, LispVal *included_too)); +LispVal *intern(const char *name, size_t length, bool take, LispVal *package, + bool included_too); + +// ####################### +// # Hashtable Functions # +// ####################### +DECLARE_FUNCTION(hashtablep, (LispVal * val)); +DECLARE_FUNCTION(make_hashtable, (LispVal * hash_fn, LispVal *eq_fn)); +DECLARE_FUNCTION(copy_hash_table, (LispVal * table)); +DECLARE_FUNCTION(hash_table_count, (LispVal * table)); +DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value)); +DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def)); +DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key)); + +// Don't ref their return value +LispVal *puthash(LispVal *table, LispVal *key, LispVal *value); +LispVal *gethash(LispVal *table, LispVal *key, LispVal *def); +LispVal *remhash(LispVal *table, LispVal *key); + +// ##################### +// # Numeric Functions # +// ##################### +DECLARE_FUNCTION(integerp, (LispVal * val)); +DECLARE_FUNCTION(floatp, (LispVal * val)); +DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2)); +DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2)); +DECLARE_FUNCTION(add, (LispVal * args)); +DECLARE_FUNCTION(sub, (LispVal * args)); + +// #################### +// # Vector Functions # +// #################### +DECLARE_FUNCTION(vectorp, (LispVal * val)); +DECLARE_FUNCTION(vector, (LispVal * elems)); + +// ######################## +// # Lexenv and the Stack # +// ######################## +// used in condition-case +extern LispVal *Qkw_success; +extern LispVal *Qkw_finally; + +DECLARE_FUNCTION(backtrace, (void) ); +noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); + +typedef void (*lisp_cleanup_func_t)(void *); +struct CleanupHandlerEntry { + struct CleanupHandlerEntry *next; + lisp_cleanup_func_t fun; + void *data; +}; +typedef struct StackFrame { + struct StackFrame *next; + bool hidden; + LispVal *name; + LispVal *return_tag; + LispVal *detail; // function arguments + LispVal *lexenv; // symbol -> value + bool enable_handlers; + LispVal *handlers; // symbol -> (error-var form) + LispVal *unwind_form; + struct CleanupHandlerEntry *cleanup_handlers; + + jmp_buf start; +} StackFrame; + +#define STACK_EXIT_NORMAL 0 +#define STACK_EXIT_THROW 1 + +extern StackFrame *the_stack; +extern LispVal *stack_return; +extern LispVal *Qtoplevel; + +void stack_enter(LispVal *name, LispVal *detail, bool inherit); +void stack_leave(void); +void *register_cleanup(lisp_cleanup_func_t fun, void *data); +void free_double_ptr(void *ptr); +struct UnrefListData { + LispVal **vals; + size_t len; +}; +void unref_free_list_double_ptr(void *ptr); +void unref_double_ptr(void *ptr); +void cancel_cleanup(void *handle); + +// ################ +// # Stack Macros # +// ################ +#define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \ + on_return) \ + stack_enter(name, detail, inherit); \ + { \ + int __with_push_frame_jmpval = setjmp(the_stack->start); \ + if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \ + body \ + } else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \ + on_return; \ + refcount_unref(stack_return); \ + stack_return = NULL; \ + } \ + stack_leave(); \ + } +#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \ + WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, ) +#define WITH_PUSH_FRAME(name, detail, inherit, body) \ + WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \ + body) + +#define WITH_CLEANUP_DOUBLE_PTR(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); \ + } +#define WITH_CLEANUP(var, body) \ + { \ + void *__with_cleanup_cleanup = \ + register_cleanup(&refcount_unref_as_callback, (var)); \ + {body}; \ + cancel_cleanup(__with_cleanup_cleanup); \ + refcount_unref(var); \ + } +#define WITH_CLEANUP_IF_THROW(var, body) \ + { \ + void *__with_cleanup_cleanup = \ + register_cleanup(&refcount_unref_as_callback, (var)); \ + {body}; \ + cancel_cleanup(__with_cleanup_cleanup); \ + } + +// ######################### +// # Errors and Conditions # +// ######################### +extern LispVal *Qshutdown_signal; +extern LispVal *Qtype_error; +extern LispVal *Qread_error; +extern LispVal *Qeof_error; +extern LispVal *Qunclosed_error; +extern LispVal *Qvoid_variable_error; +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; +extern LispVal *Qreturn_frame_error; +extern LispVal *Qpackage_exists_error; +extern LispVal *Qimport_error; +extern LispVal *Qunknown_package_error; + +#define CHECK_TYPE(type, val) \ + if (TYPEOF(val) != type) { \ + LispVal *inner_list = const_list(false, 1, predicate_for_type(type)); \ + LispVal *args = \ + const_list(true, 2, inner_list, Ftype_of(LISPVAL(val))); \ + refcount_unref(inner_list); \ + Fthrow(Qtype_error, args); \ + } + +// ############################ +// # Inline Utility Functions # +// ############################ static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len, LispVal *package) { LispVal *kn = make_lisp_string(name, len, true, true); @@ -398,9 +698,6 @@ static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len, #define INTERN_STATIC(name, package) \ (_internal_INTERN_STATIC((name), sizeof(name) - 1, package)) -DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head)); -DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail)); -size_t list_length(LispVal *obj); static inline LispVal *const_list(bool do_ref, int len, ...) { LispVal *list = Qnil; LispVal *end = Qnil; @@ -455,6 +752,7 @@ static inline LispVal *push_many(LispVal *list, int count, ...) { va_end(args); return new_list; } + static inline void push_to_lexenv(LispVal **lexenv, LispVal *key, LispVal *value) { LispVal *old = *lexenv; @@ -462,244 +760,7 @@ static inline void push_to_lexenv(LispVal **lexenv, LispVal *key, refcount_unref(old); } -typedef void (*lisp_cleanup_func_t)(void *); -struct CleanupHandlerEntry { - struct CleanupHandlerEntry *next; - lisp_cleanup_func_t fun; - void *data; -}; -typedef struct StackFrame { - struct StackFrame *next; - bool hidden; - LispVal *name; - LispVal *return_tag; - LispVal *detail; // function arguments - LispVal *lexenv; // symbol -> value - bool enable_handlers; - LispVal *handlers; // symbol -> (error-var form) - LispVal *unwind_form; - struct CleanupHandlerEntry *cleanup_handlers; - - jmp_buf start; -} StackFrame; - -#define STACK_EXIT_NORMAL 0 -#define STACK_EXIT_THROW 1 - -extern StackFrame *the_stack; -extern LispVal *stack_return; -extern LispVal *Qtoplevel; - -void stack_enter(LispVal *name, LispVal *detail, bool inherit); -void stack_leave(void); -void *register_cleanup(lisp_cleanup_func_t fun, void *data); -void free_double_ptr(void *ptr); -struct UnrefListData { - LispVal **vals; - 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_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \ - on_return) \ - stack_enter(name, detail, inherit); \ - { \ - int __with_push_frame_jmpval = setjmp(the_stack->start); \ - if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \ - body \ - } else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \ - on_return; \ - refcount_unref(stack_return); \ - stack_return = NULL; \ - } \ - stack_leave(); \ - } -#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \ - WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, ) -#define WITH_PUSH_FRAME(name, detail, inherit, body) \ - WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \ - body) - -#define WITH_CLEANUP_DOUBLE_PTR(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); \ - } -#define WITH_CLEANUP(var, body) \ - { \ - void *__with_cleanup_cleanup = \ - register_cleanup(&refcount_unref_as_callback, (var)); \ - {body}; \ - cancel_cleanup(__with_cleanup_cleanup); \ - refcount_unref(var); \ - } -#define WITH_CLEANUP_IF_THROW(var, body) \ - { \ - void *__with_cleanup_cleanup = \ - register_cleanup(&refcount_unref_as_callback, (var)); \ - {body}; \ - cancel_cleanup(__with_cleanup_cleanup); \ - } - -DECLARE_FUNCTION(backtrace, (void) ); -noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); -noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); - -extern LispVal *Qkw_success; -extern LispVal *Qkw_finally; -extern LispVal *Qshutdown_signal; -extern LispVal *Qtype_error; -extern LispVal *Qread_error; -extern LispVal *Qeof_error; -extern LispVal *Qunclosed_error; -extern LispVal *Qvoid_variable_error; -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; -extern LispVal *Qreturn_frame_error; -extern LispVal *Qpackage_exists_error; -extern LispVal *Qunknown_package_error; -extern LispVal *Qimport_error; - -LispVal *predicate_for_type(LispType type); -#define CHECK_TYPE(type, val) \ - if (TYPEOF(val) != type) { \ - LispVal *inner_list = const_list(false, 1, predicate_for_type(type)); \ - LispVal *args = \ - const_list(true, 2, inner_list, Ftype_of(LISPVAL(val))); \ - refcount_unref(inner_list); \ - Fthrow(Qtype_error, args); \ - } - -#define REGISTER_SYMBOL_NOINTERN(sym) \ - { \ - refcount_init_static(Q##sym); \ - refcount_init_static(((LispSymbol *) Q##sym)->name); \ - } -#define REGISTER_SYMBOL_INTO(sym, pkg) \ - REGISTER_SYMBOL_NOINTERN(sym) \ - ((LispSymbol *) Q##sym)->package = refcount_ref(pkg); \ - puthash(((LispPackage *) pkg)->obarray, \ - LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); -#define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package) -#define REGISTER_STATIC_FUNCTION(name, args, docstr) \ - REGISTER_SYMBOL_NOINTERN(name); \ - { \ - LispVal *obj = ((LispSymbol *) Q##name)->function; \ - refcount_init_static(obj); \ - ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ - LispVal *src = STATIC_STRING(args); \ - LispVal *a = Fread(src, system_package); \ - set_function_args((LispFunction *) (obj), a); \ - refcount_unref(src); \ - refcount_unref(a); \ - } -#define REGISTER_FUNCTION(fn, args, docstr) \ - REGISTER_STATIC_FUNCTION(fn, args, docstr); \ - ((LispSymbol *) Q##fn)->package = refcount_ref(system_package); \ - puthash(((LispPackage *) system_package)->obarray, \ - LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn); - -void lisp_init(void); -void lisp_shutdown(void); -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_package, (LispVal * symbol)); -DECLARE_FUNCTION(symbol_name, (LispVal * symbol)); -DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); -DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); -DECLARE_FUNCTION(symbol_plist, (LispVal * symbol)); -DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist)); -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(if, (LispVal * cond, LispVal *t, LispVal *nil)); -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(condition_case, (LispVal * form, LispVal *rest)); -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, LispVal *lexical_macros)); -DECLARE_FUNCTION(macroexpand_toplevel, - (LispVal * form, LispVal *lexical_macros)); -DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros)); -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(packagep, (LispVal * val)); -DECLARE_FUNCTION(functionp, (LispVal * val)); -DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros)); -DECLARE_FUNCTION(builtinp, (LispVal * val)); -DECLARE_FUNCTION(special_form_p, (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(copy_list, (LispVal * list)); -DECLARE_FUNCTION(copy_tree, (LispVal * tree)); -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)); -DECLARE_FUNCTION(plist_get, - (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)); -DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value, - LispVal *pred)); -DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred)); -DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred)); - -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); -void debug_dump_lexenv(FILE *stream, LispVal *lexenv); -extern LispVal *Qopt; -extern LispVal *Qkey; -extern LispVal *Qallow_other_keys; -extern LispVal *Qrest; -extern LispVal *Qdeclare; -extern LispVal *Qname; - -// 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); - +// These are like the internal functions, but they don't ref their return value static inline LispVal *HEAD(LispVal *list) { if (NILP(list)) { return Qnil; @@ -727,4 +788,11 @@ static inline LispVal *TAIL_SAFE(LispVal *list) { return ((LispPair *) list)->tail; } +// ################### +// # Debug Functions # +// ################### +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); + #endif diff --git a/src/main.c b/src/main.c index 90fcb55..29f46d2 100644 --- a/src/main.c +++ b/src/main.c @@ -60,6 +60,7 @@ int main(int argc, const char **argv) { REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", ""); size_t pos = 0; WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { + the_stack->hidden = false; LispVal *err_var = INTERN_STATIC("err-var", system_package); puthash(the_stack->handlers, Qt, // simply call the above function