From 5dbc0276d4645adaef8164a755e64df56f06c8bf Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Mon, 22 Sep 2025 04:08:24 -0700 Subject: [PATCH] Work on packages --- src/kernel.sl | 28 ++- src/lisp.c | 599 ++++++++++++++++++++++++++++++++++++++++++-------- src/lisp.h | 187 ++++++++++------ src/main.c | 16 +- src/read.c | 124 +++++++++-- src/read.h | 5 +- 6 files changed, 773 insertions(+), 186 deletions(-) diff --git a/src/kernel.sl b/src/kernel.sl index b232867..0ecd12b 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -16,9 +16,9 @@ (defun fourth (list) (head (tail (tail (tail list))))) (defun fifth (list) - (head (tail(tail (tail (tail list)))))) + (head (tail (tail (tail (tail list)))))) (defun sixth (list) - (head (tial (tail (tail (tail (tail list))))))) + (head (tail (tail (tail (tail (tail list))))))) (defun seventh (list) (head (tail (tail (tail (tail (tail (tail list)))))))) (defun eight (list) @@ -160,9 +160,13 @@ (pred (get name 'type-predicate)) (args (and (pairp type) (tail type)))) (unless pred - (throw 'void-function-error)) + (throw 'type-error)) (apply pred obj args))) +(defun callablep (obj) + (or (functionp obj) + (and (pairp obj) (eq (head obj) 'lambda)))) + (define-type-predicate any (obj) t) (define-type-predicate t alias any) (define-type-predicate or (obj &rest preds) @@ -196,6 +200,7 @@ (or (not max) (<= obj max)))) (define-type-predicate vector vectorp) (define-type-predicate function functionp) +(define-type-predicate callable callablep) (define-type-predicate hashtable hashtablep) (define-type-predicate user-pointer user-pointer-p) (define-type-predicate number (obj &opt min max) @@ -336,3 +341,20 @@ (tail (macroexpand-all (pair 'progn body) macros))))))) (macroexpand-all (pair 'progn body) macros)))) + +(defun import-symbol (symbol &opt target) + (import-package (symbol-package symbol) (list (symbol-name symbol)) target)) + +(defun symbol-accessible-p (symbol &opt package) + "Return non-nil if SYMBOL is accessible from PACKAGE." + (let* ((def '::unbound) + (found (intern-soft (symbol-name symbol) def package t))) + (not (eq found def)))) + +(register-package 'test) + +'test::a +'test::b + +(println (symbol-accessible-p 'b)) +(println (symbol-accessible-p 'b 'test)) diff --git a/src/lisp.c b/src/lisp.c index 41a2b64..39a3fe5 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -3,11 +3,14 @@ // used by static function registering macros #include "read.h" // IWYU pragma: keep +#include #include #include #include #include +#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, "", (uintmax_t) ptr->data, (uintmax_t) obj); } break; + case TYPE_PACKAGE: { + LispPackage *pkg = (LispPackage *) obj; + fprintf(stream, "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, "", (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, diff --git a/src/lisp.h b/src/lisp.h index 7c503a3..f2134fa 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -31,6 +31,7 @@ typedef enum { TYPE_FUNCTION, TYPE_HASHTABLE, TYPE_USER_POINTER, + TYPE_PACKAGE, N_LISP_TYPES, } LispType; @@ -60,6 +61,7 @@ typedef struct { LISP_OBJECT_HEADER; LispString *name; + LispVal *package; LispVal *plist; LispVal *function; LispVal *value; @@ -122,7 +124,10 @@ typedef struct { bool allow_other_keys; LispVal *rest_arg; union { - lisp_function_ptr_t builtin; + struct { + lisp_function_ptr_t builtin; + bool distinguish_unpassed; + }; LispVal *body; }; @@ -159,6 +164,14 @@ typedef struct { } LispUserPointer; #define USERPTR(type, obj) ((type *) ((LispUserPointer *) (obj))->data) +typedef struct { + LISP_OBJECT_HEADER; + LispString *name; + LispVal *obarray; // str -> sym + LispVal *exported_sym_table; // sym -> bool + LispVal *imported; // list of (package . (str -> bool)) +} LispPackage; + // ####################### // # nil, unbound, and t # // ####################### @@ -193,12 +206,17 @@ extern LispSymbol _Qt; #define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION) #define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE) #define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER) +#define PACKAGEP(v) (TYPEOF(v) == TYPE_PACKAGE) #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)->name->length - && ((LispSymbol *) v)->name->data[0] == ':'; + return SYMBOLP(v) && ((LispSymbol *) v)->package == keyword_package; } inline static bool LISTP(LispVal *v) { @@ -224,8 +242,9 @@ inline static bool NUMBERP(LispVal *v) { static LispSymbol _Q##c_name = { \ .type = TYPE_SYMBOL, \ .name = &_Q##c_name##_symnamestr, \ + .package = Qnil, \ .plist = Qnil, \ - .function = Qunbound, \ + .function = Qnil, \ .value = Qunbound, \ .is_constant = false, \ }; \ @@ -234,62 +253,67 @@ inline static bool NUMBERP(LispVal *v) { LispVal *F##c_name args; \ extern LispVal *Q##c_name // The args and doc fields are filled when the function is registered -#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \ - static_kw LispVal *F##c_name c_args; \ - DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \ - static LispSymbol _Q##c_name; \ - static LispFunction _Q##c_name##_function = { \ - .type = TYPE_FUNCTION, \ - .is_builtin = true, \ - .is_macro = macrop, \ - .builtin = (void (*)(void)) & F##c_name, \ - .name = LISPVAL(&_Q##c_name), \ - .doc = Qnil, \ - .args = Qnil, \ - .rargs = Qnil, \ - .oargs = Qnil, \ - .rest_arg = Qnil, \ - .kwargs = Qnil, \ - .lexenv = Qnil, \ - }; \ - static LispSymbol _Q##c_name = { \ - .type = TYPE_SYMBOL, \ - .name = &_Q##c_name##_fnnamestr, \ - .plist = Qnil, \ - .value = Qunbound, \ - .function = LISPVAL(&_Q##c_name##_function), \ - .is_constant = false, \ - }; \ - LispVal *Q##c_name = (LispVal *) &_Q##c_name; \ +#define _INTERNAL_DEFUN_EXTENDED(macrop, du, c_name, lisp_name, c_args, \ + static_kw) \ + static_kw LispVal *F##c_name c_args; \ + DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \ + static LispSymbol _Q##c_name; \ + static LispFunction _Q##c_name##_function = { \ + .type = TYPE_FUNCTION, \ + .is_builtin = true, \ + .is_macro = macrop, \ + .builtin = (void (*)(void)) & F##c_name, \ + .distinguish_unpassed = du, \ + .name = LISPVAL(&_Q##c_name), \ + .doc = Qnil, \ + .args = Qnil, \ + .rargs = Qnil, \ + .oargs = Qnil, \ + .rest_arg = Qnil, \ + .kwargs = Qnil, \ + .lexenv = Qnil, \ + }; \ + static LispSymbol _Q##c_name = { \ + .type = TYPE_SYMBOL, \ + .name = &_Q##c_name##_fnnamestr, \ + .package = Qnil, \ + .plist = Qnil, \ + .value = Qunbound, \ + .function = LISPVAL(&_Q##c_name##_function), \ + .is_constant = false, \ + }; \ + LispVal *Q##c_name = (LispVal *) &_Q##c_name; \ static_kw LispVal *F##c_name c_args #define DEFUN(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args, ) + _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, ) +#define DEFUN_DISTINGUISHED(c_name, lisp_name, c_args) \ + _INTERNAL_DEFUN_EXTENDED(false, true, c_name, lisp_name, c_args, ) #define DEFMACRO(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args, ) + _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, ) #define STATIC_DEFUN(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args, static) + _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, static) #define STATIC_DEFMACRO(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args, static) + _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static) // ############### // # Loop macros # // ############### -#define HASHTABLE_FOREACH(key_var, val_var, table, body) \ - { \ - LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \ - for (size_t __hashtable_foreach_i = 0; \ - __hashtable_foreach_i < __hashtable_foreach_table->table_size; \ - ++__hashtable_foreach_i) { \ - struct HashtableBucket *__hashtable_foreach_cur = \ - __hashtable_foreach_table->data[__hashtable_foreach_i]; \ - while (__hashtable_foreach_cur) { \ - LispVal *key_var = __hashtable_foreach_cur->key; \ - LispVal *val_var = __hashtable_foreach_cur->value; \ - {body}; \ - __hashtable_foreach_cur = __hashtable_foreach_cur->next; \ - } \ - } \ - } +#define HASHTABLE_FOREACH(key_var, val_var, table) \ + for (struct { \ + LispHashtable *ht; \ + size_t i; \ + } __l = {.ht = (void *) table, .i = 0}; \ + __l.i < __l.ht->table_size; ++__l.i) \ + for (LispVal *__b = (void *) __l.ht->data[__l.i], \ + *key_var = __b ? ((struct HashtableBucket *) __b)->key \ + : NULL, \ + *val_var = __b ? ((struct HashtableBucket *) __b)->value \ + : NULL; \ + __b; __b = (void *) ((struct HashtableBucket *) __b)->next, \ + key_var = __b ? ((struct HashtableBucket *) __b)->key \ + : NULL, \ + val_var = __b ? ((struct HashtableBucket *) __b)->value \ + : NULL) #define FOREACH(var, list) \ for (LispVal *__foreach_cur = list, *var = HEAD(list); \ !NILP(__foreach_cur); \ @@ -327,6 +351,7 @@ LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); LispVal *make_user_pointer(void *data, void (*free_func)(void *)); #define ALLOC_USERPTR(type, free_func) \ (make_user_pointer(lisp_malloc(sizeof(type)), &free_func)) +LispVal *make_lisp_package(LispVal *name); // ######################## // # Utility and internal # @@ -343,15 +368,35 @@ 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)); -LispVal *intern(const char *name, size_t length, bool take); -DECLARE_FUNCTION(intern, (LispVal * name)); -static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) { +DECLARE_FUNCTION(in_package, (LispVal * package)); +DECLARE_FUNCTION(package_name, (LispVal * package)); +DECLARE_FUNCTION(mapsymbols, (LispVal * func, LispVal *package)); +DECLARE_FUNCTION(set_current_package, (LispVal * package)); +DECLARE_FUNCTION(current_package, (void) ); +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)); +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)); +static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len, + LispVal *package) { LispVal *kn = make_lisp_string(name, len, true, true); - LispVal *retval = Fintern(kn); + LispVal *retval = Fintern(kn, package, Qnil); refcount_unref(kn); return retval; } -#define INTERN_STATIC(name) (_internal_INTERN_STATIC((name), sizeof(name) - 1)) +#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)); @@ -504,8 +549,8 @@ DECLARE_FUNCTION(backtrace, (void) ); noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); -extern LispVal *Qsuccess; -extern LispVal *Qfinally; +extern LispVal *Qkw_success; +extern LispVal *Qkw_finally; extern LispVal *Qshutdown_signal; extern LispVal *Qtype_error; extern LispVal *Qread_error; @@ -519,6 +564,9 @@ 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) \ @@ -530,16 +578,17 @@ LispVal *predicate_for_type(LispType type); Fthrow(Qtype_error, args); \ } -extern LispVal *Vobarray; - #define REGISTER_SYMBOL_NOINTERN(sym) \ { \ refcount_init_static(Q##sym); \ refcount_init_static(((LispSymbol *) Q##sym)->name); \ } -#define REGISTER_SYMBOL(sym) \ - REGISTER_SYMBOL_NOINTERN(sym) \ - puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); +#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); \ { \ @@ -547,14 +596,16 @@ extern LispVal *Vobarray; refcount_init_static(obj); \ ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ LispVal *src = STATIC_STRING(args); \ - LispVal *a = Fread(src); \ + 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); \ - puthash(Vobarray, LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn); +#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); @@ -566,6 +617,7 @@ 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)); @@ -605,6 +657,7 @@ 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)); diff --git a/src/main.c b/src/main.c index d2c0f91..90fcb55 100644 --- a/src/main.c +++ b/src/main.c @@ -60,7 +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, { - LispVal *err_var = INTERN_STATIC("err-var"); + LispVal *err_var = INTERN_STATIC("err-var", system_package); puthash(the_stack->handlers, Qt, // simply call the above function const_list(true, 3, err_var, Qtoplevel_error_handler, err_var)); @@ -76,15 +76,23 @@ int main(int argc, const char **argv) { while (true) { LispVal *tv; WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { - size_t res = - read_from_buffer(buffer + pos, file_len - pos, &tv); + size_t res = read_from_buffer(buffer + pos, file_len - pos, + current_package, &tv); if (res == LISP_EOF) { break; } pos += res; }); WITH_CLEANUP(tv, { - refcount_unref(Feval(tv)); // + // this is not needed right now as we eval right after reading, + // but it will be later when we read the whole file before + // evaling, so I am testing this here + if (PAIRP(tv) && HEAD(tv) == Qin_package + && list_length(tv) == 2) { + refcount_unref(Fset_current_package(HEAD(TAIL(tv)))); + } else { + refcount_unref(Feval(tv)); // + } }); } }); diff --git a/src/read.c b/src/read.c index 8e97bc9..f3e308a 100644 --- a/src/read.c +++ b/src/read.c @@ -6,6 +6,7 @@ #include struct ReadState { + LispVal *read_pkg; const char *head; size_t left; size_t off; @@ -99,7 +100,10 @@ static LispVal *read_list(struct ReadState *state) { refcount_unref(list); UNCLOSED_ERROR(state, "list"); } - LispVal *elt = read_internal(state); + LispVal *elt = Qnil; + WITH_CLEANUP_IF_THROW(list, { + elt = read_internal(state); // + }); if (is_dot_symbol(elt)) { refcount_unref(elt); if (NILP(list)) { @@ -110,7 +114,10 @@ static LispVal *read_list(struct ReadState *state) { refcount_unref(list); UNCLOSED_ERROR(state, "list"); } - LispVal *last = read_internal(state); + LispVal *last = Qnil; + WITH_CLEANUP_IF_THROW(list, { + last = read_internal(state); // + }); Fsettail(end, last); refcount_unref(last); SKIP_WHITESPACE(state); @@ -283,30 +290,103 @@ static int parse_base(size_t left, const char *c) { } static LispVal *read_symbol(struct ReadState *state) { + struct ReadState start_state = *state; bool backslash = false; int c; - char *str = lisp_malloc(1); - str[0] = '\0'; - size_t str_len = 0; + bool expored_only = true; + char *pkg_name = NULL; + size_t pkg_name_len = 0; + char *sym_name = lisp_malloc(1); + sym_name[0] = '\0'; + size_t sym_name_len = 0; while (backslash || !is_symbol_end(peekc(state))) { + struct ReadState prev_state = *state; c = popc(state); if (!backslash && c == '\\') { backslash = true; } else if (!backslash && (c == '`' || c == ',' || c == '\'' || c == '"')) { - free(str); - READ_ERROR(state, 1, "invalid character for symbol name"); - } else if (c == '\n') { - free(str); - READ_ERROR(state, 1, "backslash not escaping anything"); + free(pkg_name); + free(sym_name); + READ_ERROR(&prev_state, 1, "invalid character for symbol name"); + } else if (backslash && (c == '\n' || c == EOS)) { + free(pkg_name); + free(sym_name); + READ_ERROR(&prev_state, 1, "backslash not escaping anything"); + } else if (!backslash && c == ':') { + if (pkg_name) { + free(pkg_name); + free(sym_name); + READ_ERROR(&prev_state, 1, "invalid character for symbol name"); + } + int n = peekc(state); + if (n == ':') { + popc(state); + expored_only = false; + } + pkg_name = sym_name; + pkg_name_len = sym_name_len; + pkg_name[pkg_name_len] = '\0'; + sym_name = lisp_malloc(1); + sym_name[0] = '\0'; + sym_name_len = 0; } else { - str = lisp_realloc(str, ++str_len + 1); - str[str_len - 1] = c; + sym_name = lisp_realloc(sym_name, ++sym_name_len + 1); + sym_name[sym_name_len - 1] = c; backslash = false; } } - str[str_len] = '\0'; - return intern(str, str_len, true); + sym_name[sym_name_len] = '\0'; + if (pkg_name && !pkg_name_len) { + free(pkg_name); + if (expored_only) { // keyword + return intern(sym_name, sym_name_len, true, keyword_package, false); + } else { // un-exported + LispVal *lisp_name = + make_lisp_string(sym_name, sym_name_len, true, false); + LispVal *sym = make_lisp_symbol(lisp_name); + refcount_unref(lisp_name); + return sym; + } + } else if (pkg_name) { + // take the name string + LispVal *lisp_pkg_name = + make_lisp_string(pkg_name, pkg_name_len, true, false); + LispVal *lisp_sym_name = + make_lisp_string(sym_name, sym_name_len, true, false); + LispVal *pkg = Ffind_package(lisp_pkg_name); + refcount_unref(lisp_pkg_name); + if (NILP(pkg)) { + refcount_unref(lisp_sym_name); + READ_ERROR(&start_state, pkg_name_len, "unknown package"); + } else if (pkg == state->read_pkg) { + refcount_unref(pkg); + LispVal *sym = Fintern(lisp_sym_name, state->read_pkg, Qnil); + refcount_unref(lisp_sym_name); + return sym; + } else if (expored_only) { + LispVal *sym = Fintern_soft(lisp_sym_name, Qunbound, pkg, Qnil); + refcount_unref(lisp_sym_name); + refcount_unref(pkg); + if (sym == Qunbound) { + READ_ERROR(&start_state, sym_name_len + pkg_name_len + 1, + "symbol not present in package"); + } else if (NILP(Fexported_symbol_p(sym))) { + refcount_unref(sym); + READ_ERROR(&start_state, sym_name_len + pkg_name_len + 1, + "symbol not exported"); + } + return sym; + } + LispVal *sym = Fintern(lisp_sym_name, pkg, Qnil); + refcount_unref(lisp_sym_name); + refcount_unref(pkg); + if (expored_only && NILP(Fexported_symbol_p(sym))) { + } + return sym; + } else { + return intern(sym_name, sym_name_len, true, state->read_pkg, true); + } } static LispVal *read_number_or_symbol(struct ReadState *state, int base) { @@ -466,8 +546,10 @@ static LispVal *read_internal(struct ReadState *state) { } } -size_t read_from_buffer(const char *text, size_t length, LispVal **out) { +size_t read_from_buffer(const char *text, size_t length, LispVal *package, + LispVal **out) { struct ReadState state = { + .read_pkg = refcount_unref(package), .head = text, .left = length, .off = 0, @@ -477,7 +559,9 @@ size_t read_from_buffer(const char *text, size_t length, LispVal **out) { }; LispVal *res = NULL; WITH_PUSH_FRAME(Qnil, Qnil, true, { - res = read_internal(&state); // + WITH_CLEANUP(package, { + res = read_internal(&state); // + }); }); if (!res) { *out = Qnil; @@ -488,10 +572,11 @@ size_t read_from_buffer(const char *text, size_t length, LispVal **out) { return state.off; } -DEFUN(read, "read", (LispVal * source)) { +DEFUN(read, "read", (LispVal * source, LispVal *package)) { LispString *str = (LispString *) source; CHECK_TYPE(TYPE_STRING, source); struct ReadState state = { + .read_pkg = refcount_ref(package), .head = str->data, .left = str->length, .off = 0, @@ -501,7 +586,10 @@ DEFUN(read, "read", (LispVal * source)) { }; LispVal *res = NULL; WITH_PUSH_FRAME(Qnil, Qnil, true, { - res = read_internal(&state); // + WITH_CLEANUP(package, { + res = read_internal(&state); // + }); + state.read_pkg = Qnil; }); if (!res) { EOF_ERROR(&state); diff --git a/src/read.h b/src/read.h index f9db116..7efe3fc 100644 --- a/src/read.h +++ b/src/read.h @@ -8,8 +8,9 @@ #define LISP_EOF SIZE_MAX -size_t read_from_buffer(const char *text, size_t length, LispVal **out); +size_t read_from_buffer(const char *text, size_t length, LispVal *package, + LispVal **out); -DECLARE_FUNCTION(read, (LispVal * source)); +DECLARE_FUNCTION(read, (LispVal * source, LispVal *package)); #endif