Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Work on packages

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-22 04:08:24 -07:00
parent 96c4d9eecb
commit 5dbc0276d4
6 changed files with 773 additions and 186 deletions
Download Patch File Download Diff File Expand all files Collapse all files

599
src/lisp.c
View File

@ -3,11 +3,14 @@
// used by static function registering macros
#include "read.h" // IWYU pragma: keep
#include <assert.h>
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <string.h>
#define IGNORE() struct __ignored_struct
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_STRING] = {"string", sizeof("string") - 1},
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
@ -18,6 +21,7 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_FUNCTION] = {"function", sizeof("function") - 1},
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
[TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
[TYPE_PACKAGE] = {"package", sizeof("package") - 1},
};
void free_opt_arg_desc(void *obj) {
@ -32,8 +36,9 @@ DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = {
.type = TYPE_SYMBOL,
.name = &_Qnil_name,
.package = Qnil,
.plist = Qnil,
.function = Qunbound,
.function = Qnil,
.value = Qnil,
.is_constant = true,
};
@ -42,8 +47,9 @@ DEF_STATIC_STRING(_Qunbound_name, "unbound");
LispSymbol _Qunbound = {
.type = TYPE_SYMBOL,
.name = &_Qunbound_name,
.package = Qnil,
.plist = Qnil,
.function = Qunbound,
.function = Qnil,
.value = Qunbound,
.is_constant = true,
};
@ -52,8 +58,9 @@ DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = {
.type = TYPE_SYMBOL,
.name = &_Qt_name,
.package = Qnil,
.plist = Qnil,
.function = Qunbound,
.function = Qnil,
.value = Qt,
.is_constant = true,
};
@ -129,10 +136,12 @@ LispVal *sprintf_lisp(const char *format, ...) {
}
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 = Qunbound;
self->function = Qnil;
self->value = Qunbound;
self->is_constant = false;
return LISPVAL(self);
@ -330,7 +339,7 @@ void set_function_args(LispFunction *func, LispVal *args) {
kns[sn->length + 1] = '\0';
LispVal *kn =
make_lisp_string(kns, sn->length + 1, false, false);
LispVal *keyword = Fintern(kn);
LispVal *keyword = Fintern(kn, Qnil, Qnil);
puthash(func->kwargs, keyword, desc);
refcount_unref(keyword);
refcount_unref(kn);
@ -422,6 +431,16 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
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);
}
@ -492,7 +511,7 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
} else {
LispVal *eq_obj;
LispVal *args = const_list(true, 2, v1, v2);
WITH_CLEANUP_DOUBLE_PTR(args, {
WITH_CLEANUP(args, {
eq_obj = Ffuncall(self->eq_fn, args); //
});
bool result = !NILP(eq_obj);
@ -513,11 +532,11 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
} else {
LispVal *hash_obj;
LispVal *args = const_list(true, 1, key);
WITH_CLEANUP_DOUBLE_PTR(args, {
WITH_CLEANUP(args, {
hash_obj = Ffuncall(self->hash_fn, args); //
});
uint64_t hash;
WITH_CLEANUP_DOUBLE_PTR(hash_obj, {
WITH_CLEANUP(hash_obj, {
CHECK_TYPE(TYPE_INTEGER, hash_obj);
hash = ((LispInteger *) hash_obj)->value;
});
@ -640,25 +659,330 @@ 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(intern, "intern", (LispVal * name)) {
CHECK_TYPE(TYPE_STRING, name);
LispVal *cur = gethash(Vobarray, name, Qunbound);
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);
puthash(Vobarray, name, sym);
((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 *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);
LispVal *sym = Fintern(name_obj, package, LISP_BOOL(included_too));
refcount_unref(name_obj);
return sym;
}
@ -822,6 +1146,8 @@ DEFUN(backtrace, "backtrace", (void) ) {
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)));
@ -899,8 +1225,8 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
}
#pragma GCC diagnostic pop
DEF_STATIC_SYMBOL(success, ":success");
DEF_STATIC_SYMBOL(finally, ":finally");
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");
@ -914,6 +1240,9 @@ 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) {
@ -935,12 +1264,17 @@ LispVal *predicate_for_type(LispType type) {
return Qhashtablep;
case TYPE_USER_POINTER:
return Quser_pointer_p;
case TYPE_PACKAGE:
return Qpackagep;
default:
abort();
}
}
LispVal *Vobarray = Qnil;
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)) {
@ -968,10 +1302,10 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
return true;
}
case TYPE_HASHTABLE:
HASHTABLE_FOREACH(key, val, obj, {
HASHTABLE_FOREACH(key, val, obj) {
*held = refcount_list_push(*held, key);
*held = refcount_list_push(*held, val);
});
}
return true;
case TYPE_FUNCTION: {
LispFunction *fn = obj;
@ -989,6 +1323,14 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
}
return true;
}
case TYPE_PACKAGE: {
LispPackage *pkg = obj;
*held = refcount_list_push(*held, pkg->name);
*held = refcount_list_push(*held, pkg->imported);
*held = refcount_list_push(*held, pkg->obarray);
*held = refcount_list_push(*held, pkg->exported_sym_table);
return true;
}
default:
abort();
}
@ -1031,6 +1373,7 @@ static void free_obj_callback(void *obj, void *ignored) {
case TYPE_PAIR:
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_PACKAGE:
// no internal data to free
break;
default:
@ -1049,12 +1392,28 @@ void lisp_init(void) {
.free.no_data = lisp_free});
refcount_default_context = ctx;
Vobarray = make_lisp_hashtable(Qstrings_equal, Qhash_string);
REGISTER_SYMBOL_NOINTERN(unbound);
REGISTER_SYMBOL_NOINTERN(nil);
REGISTER_SYMBOL_NOINTERN(t);
refcount_init_static(Qunbound);
refcount_init_static(&_Qunbound_name);
REGISTER_SYMBOL(nil);
REGISTER_SYMBOL(t);
package_table = make_lisp_hashtable(Qstrings_equal, Qhash_string);
LispVal *sys_package_name = STATIC_STRING("sys");
system_package = make_lisp_package(sys_package_name);
refcount_unref(Fregister_package(system_package));
refcount_unref(sys_package_name);
LispVal *kw_package_name = STATIC_STRING("kw");
keyword_package = make_lisp_package(kw_package_name);
refcount_unref(Fregister_package(keyword_package));
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);
@ -1064,8 +1423,8 @@ void lisp_init(void) {
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL(success);
REGISTER_SYMBOL(finally);
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);
@ -1079,6 +1438,9 @@ void lisp_init(void) {
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);
@ -1123,6 +1485,7 @@ void lisp_init(void) {
"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.");
@ -1153,6 +1516,7 @@ void lisp_init(void) {
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).");
@ -1190,15 +1554,32 @@ void lisp_init(void) {
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)", "");
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)", "");
}
void lisp_shutdown(void) {
refcount_unref(Vobarray);
garbage_collect();
refcount_unref(current_package);
refcount_unref(system_package);
refcount_unref(package_table);
refcount_context_destroy(refcount_default_context);
refcount_default_context = NULL;
}
@ -1233,6 +1614,11 @@ 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(symbol_name, "symbol-name", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->name);
@ -1242,10 +1628,9 @@ DEFUN(symbol_function, "symbol-function",
(LispVal * symbol, LispVal *resolve)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (NILP(resolve)) {
LispVal *fn = ((LispSymbol *) symbol)->function;
return fn == Qunbound ? Qnil : fn;
return refcount_ref(((LispSymbol *) symbol)->function);
}
while (SYMBOLP(symbol) && symbol != Qunbound) {
while (SYMBOLP(symbol) && !NILP(symbol)) {
symbol = ((LispSymbol *) symbol)->function;
}
return refcount_ref(symbol);
@ -1300,7 +1685,9 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
+ !NILP(func->rest_arg));
*nargs = raw_count;
LispVal **vec = lisp_malloc(sizeof(LispVal *) * raw_count);
memset(vec, 0, sizeof(LispVal *) * raw_count);
if (raw_count) {
memset(vec, 0, sizeof(LispVal *) * raw_count);
}
LispVal *rest = Qnil;
LispVal *rest_end = Qnil;
size_t have_count = 0;
@ -1345,7 +1732,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
}
for (size_t i = 0; i < raw_count; ++i) {
if (!vec[i]) {
vec[i] = Qnil;
vec[i] = func->distinguish_unpassed ? Qunbound : Qnil;
}
}
return vec;
@ -1357,9 +1744,7 @@ unknown_key:
too_few:
refcount_unref(rest);
for (size_t i = 0; i < raw_count; ++i) {
if (vec[i]) {
refcount_unref(vec[i]);
}
refcount_unref(vec[i]);
}
lisp_free(vec);
Fthrow(Qargument_error, Fpair(fname, Qnil));
@ -1500,8 +1885,8 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto missing_required;
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-variable"
HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, {
#pragma GCC diagnostic ignored "-Wunused-but-set-variable"
HASHTABLE_FOREACH(arg, desc_lv, func->kwargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
// only check the current function's lexenv and not its parents'
if (NILP(gethash(added_kwds, oad->name, Qnil))) {
@ -1512,7 +1897,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
push_to_lexenv(lexenv, oad->pred_var, Qnil);
}
}
});
}
#pragma GCC diagnostic pop
FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
@ -1571,7 +1956,7 @@ STATIC_DEFUN(set_for_return, "set-for-return",
}
static inline void setup_return_handler(LispVal *tag, LispVal *dest) {
LispVal *err_var = INTERN_STATIC("e");
LispVal *err_var = INTERN_STATIC("e", system_package);
LispVal *quoted_dest = const_list(false, 2, Qquote, dest);
LispVal *handler =
const_list(true, 4, err_var, Qset_for_return, err_var, quoted_dest);
@ -1588,11 +1973,14 @@ static LispVal *call_function(LispVal *func, LispVal *args,
fobj = (LispFunction *) refcount_ref(func);
} else if (SYMBOLP(func)) {
fobj = (LispFunction *) Fsymbol_function(func, Qt);
} else if (PAIRP(func) && HEAD(func) == Qlambda) {
fobj = (LispFunction *) Feval_in_env(func, args_lexenv);
assert(FUNCTIONP(fobj));
} else {
Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
}
void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
if (LISPVAL(fobj) == Qunbound) {
if (NILP(fobj)) {
Fthrow(Qvoid_function_error, const_list(true, 1, func));
} else if (!FUNCTIONP(fobj)) {
Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil));
@ -1630,6 +2018,7 @@ static LispVal *call_function(LispVal *func, LispVal *args,
cancel_cleanup(return_cl_handle);
refcount_unref(return_ptr);
cancel_cleanup(cl_handle);
refcount_unref(fobj);
return retval;
}
@ -1641,6 +2030,7 @@ DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
case TYPE_FLOAT:
case TYPE_HASHTABLE:
case TYPE_USER_POINTER:
case TYPE_PACKAGE:
// the above all are self-evaluating
return refcount_ref(form);
case TYPE_SYMBOL:
@ -1947,7 +2337,7 @@ static LispVal *filter_body_form(LispVal *form,
fobj =
(LispFunction *) Fsymbol_function(HEAD(toplevel), Qt);
}
if (fobj) {
if (fobj && FUNCTIONP(fobj)) {
WITH_CLEANUP(fobj, {
if (fobj->is_builtin && fobj->is_macro) {
expand_builtin_macro(fobj, TAIL(toplevel), func,
@ -2231,64 +2621,66 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
return refcount_ref(new_func);
}
// clang-format off
DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
bool success = false;
LispVal *success_form = Qunbound;
LispVal *finally_form = Qunbound;
LispVal *retval = Qnil;
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(Qnil, Qnil, true, {
void *cl_handler = register_cleanup(&unref_double_ptr, &success_form);
void *cl_handler2 = register_cleanup(&unref_double_ptr, &finally_form);
FOREACH(entry, rest) {
if (HEAD(entry) == Qsuccess) {
if (success_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
success_form = Fpair(Qprogn, TAIL(entry));
} else if (HEAD(entry) == Qfinally) {
if (finally_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
finally_form = Fpair(Qprogn, TAIL(entry));
} else {
LispVal *var = HEAD(HEAD(entry)); LispVal *types = HEAD(TAIL(HEAD(entry)));
if (!PAIRP(types)) {
types = const_list(true, 1, types);
} else {
types = refcount_ref(types);
}
WITH_CLEANUP(types, {
FOREACH(type, types) {
LispVal *handler = push_many(TAIL(entry), 2,
Qprogn, var);
puthash(the_stack->handlers, type, handler);
refcount_unref(handler);
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
Qnil, Qnil, true,
{
void *cl_handler =
register_cleanup(&unref_double_ptr, &success_form);
void *cl_handler2 =
register_cleanup(&unref_double_ptr, &finally_form);
FOREACH(entry, rest) {
if (HEAD(entry) == Qkw_success) {
if (success_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
});
success_form = Fpair(Qprogn, TAIL(entry));
} else if (HEAD(entry) == Qkw_finally) {
if (finally_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
finally_form = Fpair(Qprogn, TAIL(entry));
} else {
LispVal *var = HEAD(HEAD(entry));
LispVal *types = HEAD(TAIL(HEAD(entry)));
if (!PAIRP(types)) {
types = const_list(true, 1, types);
} else {
types = refcount_ref(types);
}
WITH_CLEANUP(types, {
IGNORE(); // unconfuse clang-format
FOREACH(type, types) {
LispVal *handler =
push_many(TAIL(entry), 2, Qprogn, var);
puthash(the_stack->handlers, type, handler);
refcount_unref(handler);
}
});
}
}
}
cancel_cleanup(cl_handler2);
if (finally_form != Qunbound) {
the_stack->unwind_form = finally_form;
}
retval = Feval(form);
cancel_cleanup(cl_handler);
success = true;
}, {
retval = refcount_ref(stack_return);
});
cancel_cleanup(cl_handler2);
if (finally_form != Qunbound) {
the_stack->unwind_form = finally_form;
}
retval = Feval(form);
cancel_cleanup(cl_handler);
success = true;
},
{ retval = refcount_ref(stack_return); });
// call this out here so it is not covered by the handlers
if (success && success_form != Qunbound) {
void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval);
WITH_CLEANUP(success_form, {
refcount_unref(Feval(success_form));
});
void *cl_handler =
register_cleanup(&refcount_unref_as_callback, retval);
WITH_CLEANUP(success_form, { refcount_unref(Feval(success_form)); });
cancel_cleanup(cl_handler);
}
return retval;
}
// clang-format on
// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
@ -2473,6 +2865,10 @@ DEFUN(vectorp, "vectorp", (LispVal * val)) {
return LISP_BOOL(VECTORP(val));
}
DEFUN(packagep, "packagep", (LispVal * val)) {
return LISP_BOOL(PACKAGEP(val));
}
DEFUN(functionp, "functionp", (LispVal * val)) {
if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) {
return Qt;
@ -2591,7 +2987,7 @@ DEFMACRO(and, "and", (LispVal * rest)) {
LispVal *retval = Qnil;
FOREACH(cond, rest) {
LispVal *nc;
WITH_CLEANUP_DOUBLE_PTR(retval, {
WITH_CLEANUP(retval, {
nc = Feval(cond); //
});
if (NILP(nc)) {
@ -2619,7 +3015,7 @@ DEFUN(type_of, "type-of", (LispVal * obj)) {
LispVal *name =
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
LISP_TYPE_NAMES[obj->type].len, true, true);
LispVal *sym = Fintern(name);
LispVal *sym = Fintern(name, system_package, Qnil);
refcount_unref(name);
return sym;
}
@ -2713,6 +3109,18 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
} break;
case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) obj;
if (KEYWORDP(obj)) {
fputc(':', stream);
} else if (NILP(sym->package)) {
fprintf(stream, "::");
} else if (sym->package != current_package) {
LispPackage *pkg = (LispPackage *) sym->package;
fwrite(pkg->name->data, 1, pkg->name->length, stream);
fputc(':', stream);
if (NILP(Fexported_symbol_p(obj))) {
fputc(':', stream);
}
}
fwrite(sym->name->data, 1, sym->name->length, stream);
} break;
case TYPE_PAIR: {
@ -2777,6 +3185,13 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
fprintf(stream, "<user-pointer ptr=%#jx at %#jx>",
(uintmax_t) ptr->data, (uintmax_t) obj);
} break;
case TYPE_PACKAGE: {
LispPackage *pkg = (LispPackage *) obj;
fprintf(stream, "<package ");
fwrite(pkg->name->data, 1, pkg->name->length, stream);
fprintf(stream, " obarray-size=%zu at %#jx>",
((LispHashtable *) pkg->obarray)->count, (uintmax_t) obj);
} break;
default:
fprintf(stream, "<object type=%ju at %#jx>",
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
@ -2793,12 +3208,12 @@ void debug_dump(FILE *stream, void *obj, bool newline) {
void debug_print_hashtable(FILE *stream, LispVal *table) {
debug_dump(stream, table, true);
HASHTABLE_FOREACH(key, val, table, {
HASHTABLE_FOREACH(key, val, table) {
fprintf(stream, "- ");
debug_dump(stream, key, false);
fprintf(stream, " = ");
debug_dump(stream, val, true);
});
}
}
static bool debug_print_tree_callback(void *obj, const RefcountList *trail,