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

28
src/kernel.sl
View File

@ -16,9 +16,9 @@
(defun fourth (list) (defun fourth (list)
(head (tail (tail (tail list))))) (head (tail (tail (tail list)))))
(defun fifth (list) (defun fifth (list)
(head (tail(tail (tail (tail list)))))) (head (tail (tail (tail (tail list))))))
(defun sixth (list) (defun sixth (list)
(head (tial (tail (tail (tail (tail list))))))) (head (tail (tail (tail (tail (tail list)))))))
(defun seventh (list) (defun seventh (list)
(head (tail (tail (tail (tail (tail (tail list)))))))) (head (tail (tail (tail (tail (tail (tail list))))))))
(defun eight (list) (defun eight (list)
@ -160,9 +160,13 @@
(pred (get name 'type-predicate)) (pred (get name 'type-predicate))
(args (and (pairp type) (tail type)))) (args (and (pairp type) (tail type))))
(unless pred (unless pred
(throw 'void-function-error)) (throw 'type-error))
(apply pred obj args))) (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 any (obj) t)
(define-type-predicate t alias any) (define-type-predicate t alias any)
(define-type-predicate or (obj &rest preds) (define-type-predicate or (obj &rest preds)
@ -196,6 +200,7 @@
(or (not max) (<= obj max)))) (or (not max) (<= obj max))))
(define-type-predicate vector vectorp) (define-type-predicate vector vectorp)
(define-type-predicate function functionp) (define-type-predicate function functionp)
(define-type-predicate callable callablep)
(define-type-predicate hashtable hashtablep) (define-type-predicate hashtable hashtablep)
(define-type-predicate user-pointer user-pointer-p) (define-type-predicate user-pointer user-pointer-p)
(define-type-predicate number (obj &opt min max) (define-type-predicate number (obj &opt min max)
@ -336,3 +341,20 @@
(tail (macroexpand-all (pair 'progn body) (tail (macroexpand-all (pair 'progn body)
macros))))))) macros)))))))
(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))

599
src/lisp.c
View File

@ -3,11 +3,14 @@
// used by static function registering macros // used by static function registering macros
#include "read.h" // IWYU pragma: keep #include "read.h" // IWYU pragma: keep
#include <assert.h>
#include <ctype.h> #include <ctype.h>
#include <stdarg.h> #include <stdarg.h>
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
#define IGNORE() struct __ignored_struct
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = { struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_STRING] = {"string", sizeof("string") - 1}, [TYPE_STRING] = {"string", sizeof("string") - 1},
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 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_FUNCTION] = {"function", sizeof("function") - 1},
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1}, [TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
[TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1}, [TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
[TYPE_PACKAGE] = {"package", sizeof("package") - 1},
}; };
void free_opt_arg_desc(void *obj) { void free_opt_arg_desc(void *obj) {
@ -32,8 +36,9 @@ DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = { LispSymbol _Qnil = {
.type = TYPE_SYMBOL, .type = TYPE_SYMBOL,
.name = &_Qnil_name, .name = &_Qnil_name,
.package = Qnil,
.plist = Qnil, .plist = Qnil,
.function = Qunbound, .function = Qnil,
.value = Qnil, .value = Qnil,
.is_constant = true, .is_constant = true,
}; };
@ -42,8 +47,9 @@ DEF_STATIC_STRING(_Qunbound_name, "unbound");
LispSymbol _Qunbound = { LispSymbol _Qunbound = {
.type = TYPE_SYMBOL, .type = TYPE_SYMBOL,
.name = &_Qunbound_name, .name = &_Qunbound_name,
.package = Qnil,
.plist = Qnil, .plist = Qnil,
.function = Qunbound, .function = Qnil,
.value = Qunbound, .value = Qunbound,
.is_constant = true, .is_constant = true,
}; };
@ -52,8 +58,9 @@ DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = { LispSymbol _Qt = {
.type = TYPE_SYMBOL, .type = TYPE_SYMBOL,
.name = &_Qt_name, .name = &_Qt_name,
.package = Qnil,
.plist = Qnil, .plist = Qnil,
.function = Qunbound, .function = Qnil,
.value = Qt, .value = Qt,
.is_constant = true, .is_constant = true,
}; };
@ -129,10 +136,12 @@ LispVal *sprintf_lisp(const char *format, ...) {
} }
LispVal *make_lisp_symbol(LispVal *name) { LispVal *make_lisp_symbol(LispVal *name) {
CHECK_TYPE(TYPE_STRING, name);
CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL); CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL);
self->name = (LispString *) refcount_ref(name); self->name = (LispString *) refcount_ref(name);
self->package = Qnil;
self->plist = Qnil; self->plist = Qnil;
self->function = Qunbound; self->function = Qnil;
self->value = Qunbound; self->value = Qunbound;
self->is_constant = false; self->is_constant = false;
return LISPVAL(self); return LISPVAL(self);
@ -330,7 +339,7 @@ void set_function_args(LispFunction *func, LispVal *args) {
kns[sn->length + 1] = '\0'; kns[sn->length + 1] = '\0';
LispVal *kn = LispVal *kn =
make_lisp_string(kns, sn->length + 1, false, false); make_lisp_string(kns, sn->length + 1, false, false);
LispVal *keyword = Fintern(kn); LispVal *keyword = Fintern(kn, Qnil, Qnil);
puthash(func->kwargs, keyword, desc); puthash(func->kwargs, keyword, desc);
refcount_unref(keyword); refcount_unref(keyword);
refcount_unref(kn); refcount_unref(kn);
@ -422,6 +431,16 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
return LISPVAL(self); 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)) { DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) {
return make_lisp_hashtable(eq_fn, hash_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 { } else {
LispVal *eq_obj; LispVal *eq_obj;
LispVal *args = const_list(true, 2, v1, v2); LispVal *args = const_list(true, 2, v1, v2);
WITH_CLEANUP_DOUBLE_PTR(args, { WITH_CLEANUP(args, {
eq_obj = Ffuncall(self->eq_fn, args); // eq_obj = Ffuncall(self->eq_fn, args); //
}); });
bool result = !NILP(eq_obj); bool result = !NILP(eq_obj);
@ -513,11 +532,11 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
} else { } else {
LispVal *hash_obj; LispVal *hash_obj;
LispVal *args = const_list(true, 1, key); LispVal *args = const_list(true, 1, key);
WITH_CLEANUP_DOUBLE_PTR(args, { WITH_CLEANUP(args, {
hash_obj = Ffuncall(self->hash_fn, args); // hash_obj = Ffuncall(self->hash_fn, args); //
}); });
uint64_t hash; uint64_t hash;
WITH_CLEANUP_DOUBLE_PTR(hash_obj, { WITH_CLEANUP(hash_obj, {
CHECK_TYPE(TYPE_INTEGER, hash_obj); CHECK_TYPE(TYPE_INTEGER, hash_obj);
hash = ((LispInteger *) hash_obj)->value; hash = ((LispInteger *) hash_obj)->value;
}); });
@ -640,25 +659,330 @@ DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) {
return refcount_ref(remhash(table, 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)) { DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) {
CHECK_TYPE(TYPE_HASHTABLE, table); CHECK_TYPE(TYPE_HASHTABLE, table);
return make_lisp_integer(((LispHashtable *) table)->count); return make_lisp_integer(((LispHashtable *) table)->count);
} }
DEFUN(intern, "intern", (LispVal * name)) { DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table)) {
CHECK_TYPE(TYPE_STRING, name); CHECK_TYPE(TYPE_HASHTABLE, table);
LispVal *cur = gethash(Vobarray, name, Qunbound); 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) { if (cur != Qunbound) {
refcount_unref(real_pkg);
return refcount_ref(cur); 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); 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; 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 *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); refcount_unref(name_obj);
return sym; return sym;
} }
@ -822,6 +1146,8 @@ DEFUN(backtrace, "backtrace", (void) ) {
return head; return head;
} }
IGNORE(); // unconfuse emacs syntax highlighting
DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) { DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) {
Fthrow(Qreturn_frame_error, Fthrow(Qreturn_frame_error,
const_list(false, 2, refcount_ref(name), Feval(value))); const_list(false, 2, refcount_ref(name), Feval(value)));
@ -899,8 +1225,8 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
} }
#pragma GCC diagnostic pop #pragma GCC diagnostic pop
DEF_STATIC_SYMBOL(success, ":success"); DEF_STATIC_SYMBOL(kw_success, "success");
DEF_STATIC_SYMBOL(finally, ":finally"); DEF_STATIC_SYMBOL(kw_finally, "finally");
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal"); DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error"); DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-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(invalid_function_error, "invalid-function-error");
DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error"); DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error");
DEF_STATIC_SYMBOL(return_frame_error, "return-frame-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) { LispVal *predicate_for_type(LispType type) {
switch (type) { switch (type) {
@ -935,12 +1264,17 @@ LispVal *predicate_for_type(LispType type) {
return Qhashtablep; return Qhashtablep;
case TYPE_USER_POINTER: case TYPE_USER_POINTER:
return Quser_pointer_p; return Quser_pointer_p;
case TYPE_PACKAGE:
return Qpackagep;
default: default:
abort(); 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) { static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
switch (TYPEOF(obj)) { switch (TYPEOF(obj)) {
@ -968,10 +1302,10 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
return true; return true;
} }
case TYPE_HASHTABLE: case TYPE_HASHTABLE:
HASHTABLE_FOREACH(key, val, obj, { HASHTABLE_FOREACH(key, val, obj) {
*held = refcount_list_push(*held, key); *held = refcount_list_push(*held, key);
*held = refcount_list_push(*held, val); *held = refcount_list_push(*held, val);
}); }
return true; return true;
case TYPE_FUNCTION: { case TYPE_FUNCTION: {
LispFunction *fn = obj; LispFunction *fn = obj;
@ -989,6 +1323,14 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
} }
return true; 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: default:
abort(); abort();
} }
@ -1031,6 +1373,7 @@ static void free_obj_callback(void *obj, void *ignored) {
case TYPE_PAIR: case TYPE_PAIR:
case TYPE_INTEGER: case TYPE_INTEGER:
case TYPE_FLOAT: case TYPE_FLOAT:
case TYPE_PACKAGE:
// no internal data to free // no internal data to free
break; break;
default: default:
@ -1049,12 +1392,28 @@ void lisp_init(void) {
.free.no_data = lisp_free}); .free.no_data = lisp_free});
refcount_default_context = ctx; 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); package_table = make_lisp_hashtable(Qstrings_equal, Qhash_string);
refcount_init_static(&_Qunbound_name); LispVal *sys_package_name = STATIC_STRING("sys");
REGISTER_SYMBOL(nil); system_package = make_lisp_package(sys_package_name);
REGISTER_SYMBOL(t); 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(opt);
REGISTER_SYMBOL(allow_other_keys); REGISTER_SYMBOL(allow_other_keys);
REGISTER_SYMBOL(key); REGISTER_SYMBOL(key);
@ -1064,8 +1423,8 @@ void lisp_init(void) {
REGISTER_SYMBOL(comma); REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at); REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote); REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL(success); REGISTER_SYMBOL_INTO(kw_success, keyword_package);
REGISTER_SYMBOL(finally); REGISTER_SYMBOL_INTO(kw_finally, keyword_package);
REGISTER_SYMBOL(shutdown_signal); REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(type_error); REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error); REGISTER_SYMBOL(read_error);
@ -1079,6 +1438,9 @@ void lisp_init(void) {
REGISTER_SYMBOL(invalid_function_error); REGISTER_SYMBOL(invalid_function_error);
REGISTER_SYMBOL(no_applicable_method_error); REGISTER_SYMBOL(no_applicable_method_error);
REGISTER_SYMBOL(return_frame_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 // some stuff that musn't be user accesable
REGISTER_SYMBOL_NOINTERN(toplevel); REGISTER_SYMBOL_NOINTERN(toplevel);
@ -1123,6 +1485,7 @@ void lisp_init(void) {
"Set each of a number of variables to their respective values."); "Set each of a number of variables to their respective values.");
REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS."); REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
REGISTER_FUNCTION(symbol_name, "(sym)", ""); REGISTER_FUNCTION(symbol_name, "(sym)", "");
REGISTER_FUNCTION(symbol_package, "(sym)", "");
REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM."); REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM.");
REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist 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(integerp, "(val)", "Return non-nil if VAL is a integer.");
REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float."); 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(vectorp, "(val)", "Return non-nil if VAL is a vector.");
REGISTER_FUNCTION(packagep, "(val)", "Return non-nil if VAL is a package.");
REGISTER_FUNCTION( REGISTER_FUNCTION(
functionp, "(val)", functionp, "(val)",
"Return non-nil if VAL is a non-macro function (includes buitlins)."); "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(plist_rem, "(plist key &opt pred)", "");
REGISTER_FUNCTION(return_from, "(name &opt value)", REGISTER_FUNCTION(return_from, "(name &opt value)",
"Return from the function named NAME and return 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(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) { void lisp_shutdown(void) {
refcount_unref(Vobarray);
garbage_collect(); garbage_collect();
refcount_unref(current_package);
refcount_unref(system_package);
refcount_unref(package_table);
refcount_context_destroy(refcount_default_context); refcount_context_destroy(refcount_default_context);
refcount_default_context = NULL; refcount_default_context = NULL;
} }
@ -1233,6 +1614,11 @@ DEFUN(breakpoint, "breakpoint", (LispVal * id)) {
return Qnil; 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)) { DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol); CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->name); return refcount_ref(((LispSymbol *) symbol)->name);
@ -1242,10 +1628,9 @@ DEFUN(symbol_function, "symbol-function",
(LispVal * symbol, LispVal *resolve)) { (LispVal * symbol, LispVal *resolve)) {
CHECK_TYPE(TYPE_SYMBOL, symbol); CHECK_TYPE(TYPE_SYMBOL, symbol);
if (NILP(resolve)) { if (NILP(resolve)) {
LispVal *fn = ((LispSymbol *) symbol)->function; return refcount_ref(((LispSymbol *) symbol)->function);
return fn == Qunbound ? Qnil : fn;
} }
while (SYMBOLP(symbol) && symbol != Qunbound) { while (SYMBOLP(symbol) && !NILP(symbol)) {
symbol = ((LispSymbol *) symbol)->function; symbol = ((LispSymbol *) symbol)->function;
} }
return refcount_ref(symbol); return refcount_ref(symbol);
@ -1300,7 +1685,9 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
+ !NILP(func->rest_arg)); + !NILP(func->rest_arg));
*nargs = raw_count; *nargs = raw_count;
LispVal **vec = lisp_malloc(sizeof(LispVal *) * 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 = Qnil;
LispVal *rest_end = Qnil; LispVal *rest_end = Qnil;
size_t have_count = 0; 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) { for (size_t i = 0; i < raw_count; ++i) {
if (!vec[i]) { if (!vec[i]) {
vec[i] = Qnil; vec[i] = func->distinguish_unpassed ? Qunbound : Qnil;
} }
} }
return vec; return vec;
@ -1357,9 +1744,7 @@ unknown_key:
too_few: too_few:
refcount_unref(rest); refcount_unref(rest);
for (size_t i = 0; i < raw_count; ++i) { for (size_t i = 0; i < raw_count; ++i) {
if (vec[i]) { refcount_unref(vec[i]);
refcount_unref(vec[i]);
}
} }
lisp_free(vec); lisp_free(vec);
Fthrow(Qargument_error, Fpair(fname, Qnil)); Fthrow(Qargument_error, Fpair(fname, Qnil));
@ -1500,8 +1885,8 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto missing_required; goto missing_required;
} }
#pragma GCC diagnostic push #pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-variable" #pragma GCC diagnostic ignored "-Wunused-but-set-variable"
HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, { HASHTABLE_FOREACH(arg, desc_lv, func->kwargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv); struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
// only check the current function's lexenv and not its parents' // only check the current function's lexenv and not its parents'
if (NILP(gethash(added_kwds, oad->name, Qnil))) { 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); push_to_lexenv(lexenv, oad->pred_var, Qnil);
} }
} }
}); }
#pragma GCC diagnostic pop #pragma GCC diagnostic pop
FOREACH(arg, oargs) { FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg); 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) { 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 *quoted_dest = const_list(false, 2, Qquote, dest);
LispVal *handler = LispVal *handler =
const_list(true, 4, err_var, Qset_for_return, err_var, quoted_dest); 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); fobj = (LispFunction *) refcount_ref(func);
} else if (SYMBOLP(func)) { } else if (SYMBOLP(func)) {
fobj = (LispFunction *) Fsymbol_function(func, Qt); 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 { } else {
Fthrow(Qinvalid_function_error, Fpair(func, Qnil)); Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
} }
void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj); 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)); Fthrow(Qvoid_function_error, const_list(true, 1, func));
} else if (!FUNCTIONP(fobj)) { } else if (!FUNCTIONP(fobj)) {
Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil)); 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); cancel_cleanup(return_cl_handle);
refcount_unref(return_ptr); refcount_unref(return_ptr);
cancel_cleanup(cl_handle); cancel_cleanup(cl_handle);
refcount_unref(fobj);
return retval; return retval;
} }
@ -1641,6 +2030,7 @@ DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
case TYPE_FLOAT: case TYPE_FLOAT:
case TYPE_HASHTABLE: case TYPE_HASHTABLE:
case TYPE_USER_POINTER: case TYPE_USER_POINTER:
case TYPE_PACKAGE:
// the above all are self-evaluating // the above all are self-evaluating
return refcount_ref(form); return refcount_ref(form);
case TYPE_SYMBOL: case TYPE_SYMBOL:
@ -1947,7 +2337,7 @@ static LispVal *filter_body_form(LispVal *form,
fobj = fobj =
(LispFunction *) Fsymbol_function(HEAD(toplevel), Qt); (LispFunction *) Fsymbol_function(HEAD(toplevel), Qt);
} }
if (fobj) { if (fobj && FUNCTIONP(fobj)) {
WITH_CLEANUP(fobj, { WITH_CLEANUP(fobj, {
if (fobj->is_builtin && fobj->is_macro) { if (fobj->is_builtin && fobj->is_macro) {
expand_builtin_macro(fobj, TAIL(toplevel), func, expand_builtin_macro(fobj, TAIL(toplevel), func,
@ -2231,64 +2621,66 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
return refcount_ref(new_func); return refcount_ref(new_func);
} }
// clang-format off
DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) { DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
bool success = false; bool success = false;
LispVal *success_form = Qunbound; LispVal *success_form = Qunbound;
LispVal *finally_form = Qunbound; LispVal *finally_form = Qunbound;
LispVal *retval = Qnil; LispVal *retval = Qnil;
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(Qnil, Qnil, true, { WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
void *cl_handler = register_cleanup(&unref_double_ptr, &success_form); Qnil, Qnil, true,
void *cl_handler2 = register_cleanup(&unref_double_ptr, &finally_form); {
FOREACH(entry, rest) { void *cl_handler =
if (HEAD(entry) == Qsuccess) { register_cleanup(&unref_double_ptr, &success_form);
if (success_form != Qunbound) { void *cl_handler2 =
Fthrow(Qmalformed_lambda_list_error, Qnil); register_cleanup(&unref_double_ptr, &finally_form);
} FOREACH(entry, rest) {
success_form = Fpair(Qprogn, TAIL(entry)); if (HEAD(entry) == Qkw_success) {
} else if (HEAD(entry) == Qfinally) { if (success_form != Qunbound) {
if (finally_form != Qunbound) { Fthrow(Qmalformed_lambda_list_error, Qnil);
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);
} }
}); 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);
cancel_cleanup(cl_handler2); if (finally_form != Qunbound) {
if (finally_form != Qunbound) { the_stack->unwind_form = finally_form;
the_stack->unwind_form = finally_form; }
} retval = Feval(form);
retval = Feval(form); cancel_cleanup(cl_handler);
cancel_cleanup(cl_handler); success = true;
success = true; },
}, { { retval = refcount_ref(stack_return); });
retval = refcount_ref(stack_return);
});
// call this out here so it is not covered by the handlers // call this out here so it is not covered by the handlers
if (success && success_form != Qunbound) { if (success && success_form != Qunbound) {
void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval); void *cl_handler =
WITH_CLEANUP(success_form, { register_cleanup(&refcount_unref_as_callback, retval);
refcount_unref(Feval(success_form)); WITH_CLEANUP(success_form, { refcount_unref(Feval(success_form)); });
});
cancel_cleanup(cl_handler); cancel_cleanup(cl_handler);
} }
return retval; return retval;
} }
// clang-format on
// true if the form was a declare form // true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr) { static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
@ -2473,6 +2865,10 @@ DEFUN(vectorp, "vectorp", (LispVal * val)) {
return LISP_BOOL(VECTORP(val)); return LISP_BOOL(VECTORP(val));
} }
DEFUN(packagep, "packagep", (LispVal * val)) {
return LISP_BOOL(PACKAGEP(val));
}
DEFUN(functionp, "functionp", (LispVal * val)) { DEFUN(functionp, "functionp", (LispVal * val)) {
if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) { if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) {
return Qt; return Qt;
@ -2591,7 +2987,7 @@ DEFMACRO(and, "and", (LispVal * rest)) {
LispVal *retval = Qnil; LispVal *retval = Qnil;
FOREACH(cond, rest) { FOREACH(cond, rest) {
LispVal *nc; LispVal *nc;
WITH_CLEANUP_DOUBLE_PTR(retval, { WITH_CLEANUP(retval, {
nc = Feval(cond); // nc = Feval(cond); //
}); });
if (NILP(nc)) { if (NILP(nc)) {
@ -2619,7 +3015,7 @@ DEFUN(type_of, "type-of", (LispVal * obj)) {
LispVal *name = LispVal *name =
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name, make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
LISP_TYPE_NAMES[obj->type].len, true, true); LISP_TYPE_NAMES[obj->type].len, true, true);
LispVal *sym = Fintern(name); LispVal *sym = Fintern(name, system_package, Qnil);
refcount_unref(name); refcount_unref(name);
return sym; return sym;
} }
@ -2713,6 +3109,18 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
} break; } break;
case TYPE_SYMBOL: { case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) obj; 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); fwrite(sym->name->data, 1, sym->name->length, stream);
} break; } break;
case TYPE_PAIR: { 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>", fprintf(stream, "<user-pointer ptr=%#jx at %#jx>",
(uintmax_t) ptr->data, (uintmax_t) obj); (uintmax_t) ptr->data, (uintmax_t) obj);
} break; } 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: default:
fprintf(stream, "<object type=%ju at %#jx>", fprintf(stream, "<object type=%ju at %#jx>",
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj); (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) { void debug_print_hashtable(FILE *stream, LispVal *table) {
debug_dump(stream, table, true); debug_dump(stream, table, true);
HASHTABLE_FOREACH(key, val, table, { HASHTABLE_FOREACH(key, val, table) {
fprintf(stream, "- "); fprintf(stream, "- ");
debug_dump(stream, key, false); debug_dump(stream, key, false);
fprintf(stream, " = "); fprintf(stream, " = ");
debug_dump(stream, val, true); debug_dump(stream, val, true);
}); }
} }
static bool debug_print_tree_callback(void *obj, const RefcountList *trail, static bool debug_print_tree_callback(void *obj, const RefcountList *trail,

187
src/lisp.h
View File

@ -31,6 +31,7 @@ typedef enum {
TYPE_FUNCTION, TYPE_FUNCTION,
TYPE_HASHTABLE, TYPE_HASHTABLE,
TYPE_USER_POINTER, TYPE_USER_POINTER,
TYPE_PACKAGE,
N_LISP_TYPES, N_LISP_TYPES,
} LispType; } LispType;
@ -60,6 +61,7 @@ typedef struct {
LISP_OBJECT_HEADER; LISP_OBJECT_HEADER;
LispString *name; LispString *name;
LispVal *package;
LispVal *plist; LispVal *plist;
LispVal *function; LispVal *function;
LispVal *value; LispVal *value;
@ -122,7 +124,10 @@ typedef struct {
bool allow_other_keys; bool allow_other_keys;
LispVal *rest_arg; LispVal *rest_arg;
union { union {
lisp_function_ptr_t builtin; struct {
lisp_function_ptr_t builtin;
bool distinguish_unpassed;
};
LispVal *body; LispVal *body;
}; };
@ -159,6 +164,14 @@ typedef struct {
} LispUserPointer; } LispUserPointer;
#define USERPTR(type, obj) ((type *) ((LispUserPointer *) (obj))->data) #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 # // # nil, unbound, and t #
// ####################### // #######################
@ -193,12 +206,17 @@ extern LispSymbol _Qt;
#define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION) #define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION)
#define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE) #define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE)
#define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER) #define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER)
#define PACKAGEP(v) (TYPEOF(v) == TYPE_PACKAGE)
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR) #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) { inline static bool KEYWORDP(LispVal *v) {
return SYMBOLP(v) && ((LispSymbol *) v)->name->length return SYMBOLP(v) && ((LispSymbol *) v)->package == keyword_package;
&& ((LispSymbol *) v)->name->data[0] == ':';
} }
inline static bool LISTP(LispVal *v) { inline static bool LISTP(LispVal *v) {
@ -224,8 +242,9 @@ inline static bool NUMBERP(LispVal *v) {
static LispSymbol _Q##c_name = { \ static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \ .type = TYPE_SYMBOL, \
.name = &_Q##c_name##_symnamestr, \ .name = &_Q##c_name##_symnamestr, \
.package = Qnil, \
.plist = Qnil, \ .plist = Qnil, \
.function = Qunbound, \ .function = Qnil, \
.value = Qunbound, \ .value = Qunbound, \
.is_constant = false, \ .is_constant = false, \
}; \ }; \
@ -234,62 +253,67 @@ inline static bool NUMBERP(LispVal *v) {
LispVal *F##c_name args; \ LispVal *F##c_name args; \
extern LispVal *Q##c_name extern LispVal *Q##c_name
// The args and doc fields are filled when the function is registered // 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) \ #define _INTERNAL_DEFUN_EXTENDED(macrop, du, c_name, lisp_name, c_args, \
static_kw LispVal *F##c_name c_args; \ static_kw) \
DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \ static_kw LispVal *F##c_name c_args; \
static LispSymbol _Q##c_name; \ DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \
static LispFunction _Q##c_name##_function = { \ static LispSymbol _Q##c_name; \
.type = TYPE_FUNCTION, \ static LispFunction _Q##c_name##_function = { \
.is_builtin = true, \ .type = TYPE_FUNCTION, \
.is_macro = macrop, \ .is_builtin = true, \
.builtin = (void (*)(void)) & F##c_name, \ .is_macro = macrop, \
.name = LISPVAL(&_Q##c_name), \ .builtin = (void (*)(void)) & F##c_name, \
.doc = Qnil, \ .distinguish_unpassed = du, \
.args = Qnil, \ .name = LISPVAL(&_Q##c_name), \
.rargs = Qnil, \ .doc = Qnil, \
.oargs = Qnil, \ .args = Qnil, \
.rest_arg = Qnil, \ .rargs = Qnil, \
.kwargs = Qnil, \ .oargs = Qnil, \
.lexenv = Qnil, \ .rest_arg = Qnil, \
}; \ .kwargs = Qnil, \
static LispSymbol _Q##c_name = { \ .lexenv = Qnil, \
.type = TYPE_SYMBOL, \ }; \
.name = &_Q##c_name##_fnnamestr, \ static LispSymbol _Q##c_name = { \
.plist = Qnil, \ .type = TYPE_SYMBOL, \
.value = Qunbound, \ .name = &_Q##c_name##_fnnamestr, \
.function = LISPVAL(&_Q##c_name##_function), \ .package = Qnil, \
.is_constant = false, \ .plist = Qnil, \
}; \ .value = Qunbound, \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \ .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 static_kw LispVal *F##c_name c_args
#define DEFUN(c_name, lisp_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) \ #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) \ #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) \ #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 # // # Loop macros #
// ############### // ###############
#define HASHTABLE_FOREACH(key_var, val_var, table, body) \ #define HASHTABLE_FOREACH(key_var, val_var, table) \
{ \ for (struct { \
LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \ LispHashtable *ht; \
for (size_t __hashtable_foreach_i = 0; \ size_t i; \
__hashtable_foreach_i < __hashtable_foreach_table->table_size; \ } __l = {.ht = (void *) table, .i = 0}; \
++__hashtable_foreach_i) { \ __l.i < __l.ht->table_size; ++__l.i) \
struct HashtableBucket *__hashtable_foreach_cur = \ for (LispVal *__b = (void *) __l.ht->data[__l.i], \
__hashtable_foreach_table->data[__hashtable_foreach_i]; \ *key_var = __b ? ((struct HashtableBucket *) __b)->key \
while (__hashtable_foreach_cur) { \ : NULL, \
LispVal *key_var = __hashtable_foreach_cur->key; \ *val_var = __b ? ((struct HashtableBucket *) __b)->value \
LispVal *val_var = __hashtable_foreach_cur->value; \ : NULL; \
{body}; \ __b; __b = (void *) ((struct HashtableBucket *) __b)->next, \
__hashtable_foreach_cur = __hashtable_foreach_cur->next; \ key_var = __b ? ((struct HashtableBucket *) __b)->key \
} \ : NULL, \
} \ val_var = __b ? ((struct HashtableBucket *) __b)->value \
} : NULL)
#define FOREACH(var, list) \ #define FOREACH(var, list) \
for (LispVal *__foreach_cur = list, *var = HEAD(list); \ for (LispVal *__foreach_cur = list, *var = HEAD(list); \
!NILP(__foreach_cur); \ !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 *)); LispVal *make_user_pointer(void *data, void (*free_func)(void *));
#define ALLOC_USERPTR(type, free_func) \ #define ALLOC_USERPTR(type, free_func) \
(make_user_pointer(lisp_malloc(sizeof(type)), &free_func)) (make_user_pointer(lisp_malloc(sizeof(type)), &free_func))
LispVal *make_lisp_package(LispVal *name);
// ######################## // ########################
// # Utility and internal # // # 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(gethash, (LispVal * table, LispVal *key, LispVal *def));
DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key)); DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
DECLARE_FUNCTION(hash_table_count, (LispVal * table)); DECLARE_FUNCTION(hash_table_count, (LispVal * table));
LispVal *intern(const char *name, size_t length, bool take); DECLARE_FUNCTION(in_package, (LispVal * package));
DECLARE_FUNCTION(intern, (LispVal * name)); DECLARE_FUNCTION(package_name, (LispVal * package));
static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) { 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 *kn = make_lisp_string(name, len, true, true);
LispVal *retval = Fintern(kn); LispVal *retval = Fintern(kn, package, Qnil);
refcount_unref(kn); refcount_unref(kn);
return retval; 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(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail)); 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(return_from, (LispVal * name, LispVal *value));
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
extern LispVal *Qsuccess; extern LispVal *Qkw_success;
extern LispVal *Qfinally; extern LispVal *Qkw_finally;
extern LispVal *Qshutdown_signal; extern LispVal *Qshutdown_signal;
extern LispVal *Qtype_error; extern LispVal *Qtype_error;
extern LispVal *Qread_error; extern LispVal *Qread_error;
@ -519,6 +564,9 @@ extern LispVal *Qargument_error;
extern LispVal *Qinvalid_function_error; extern LispVal *Qinvalid_function_error;
extern LispVal *Qno_applicable_method_error; extern LispVal *Qno_applicable_method_error;
extern LispVal *Qreturn_frame_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); LispVal *predicate_for_type(LispType type);
#define CHECK_TYPE(type, val) \ #define CHECK_TYPE(type, val) \
@ -530,16 +578,17 @@ LispVal *predicate_for_type(LispType type);
Fthrow(Qtype_error, args); \ Fthrow(Qtype_error, args); \
} }
extern LispVal *Vobarray;
#define REGISTER_SYMBOL_NOINTERN(sym) \ #define REGISTER_SYMBOL_NOINTERN(sym) \
{ \ { \
refcount_init_static(Q##sym); \ refcount_init_static(Q##sym); \
refcount_init_static(((LispSymbol *) Q##sym)->name); \ refcount_init_static(((LispSymbol *) Q##sym)->name); \
} }
#define REGISTER_SYMBOL(sym) \ #define REGISTER_SYMBOL_INTO(sym, pkg) \
REGISTER_SYMBOL_NOINTERN(sym) \ REGISTER_SYMBOL_NOINTERN(sym) \
puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##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) \ #define REGISTER_STATIC_FUNCTION(name, args, docstr) \
REGISTER_SYMBOL_NOINTERN(name); \ REGISTER_SYMBOL_NOINTERN(name); \
{ \ { \
@ -547,14 +596,16 @@ extern LispVal *Vobarray;
refcount_init_static(obj); \ refcount_init_static(obj); \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \ ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
LispVal *src = STATIC_STRING(args); \ LispVal *src = STATIC_STRING(args); \
LispVal *a = Fread(src); \ LispVal *a = Fread(src, system_package); \
set_function_args((LispFunction *) (obj), a); \ set_function_args((LispFunction *) (obj), a); \
refcount_unref(src); \ refcount_unref(src); \
refcount_unref(a); \ refcount_unref(a); \
} }
#define REGISTER_FUNCTION(fn, args, docstr) \ #define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_STATIC_FUNCTION(fn, args, docstr); \ REGISTER_STATIC_FUNCTION(fn, args, docstr); \
puthash(Vobarray, LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn); ((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_init(void);
void lisp_shutdown(void); void lisp_shutdown(void);
@ -566,6 +617,7 @@ extern LispVal *Qcomma_at;
DECLARE_FUNCTION(quote, (LispVal * form)); DECLARE_FUNCTION(quote, (LispVal * form));
DECLARE_FUNCTION(breakpoint, (LispVal * id)); DECLARE_FUNCTION(breakpoint, (LispVal * id));
DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
DECLARE_FUNCTION(symbol_name, (LispVal * symbol)); DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
@ -605,6 +657,7 @@ DECLARE_FUNCTION(pairp, (LispVal * val));
DECLARE_FUNCTION(integerp, (LispVal * val)); DECLARE_FUNCTION(integerp, (LispVal * val));
DECLARE_FUNCTION(floatp, (LispVal * val)); DECLARE_FUNCTION(floatp, (LispVal * val));
DECLARE_FUNCTION(vectorp, (LispVal * val)); DECLARE_FUNCTION(vectorp, (LispVal * val));
DECLARE_FUNCTION(packagep, (LispVal * val));
DECLARE_FUNCTION(functionp, (LispVal * val)); DECLARE_FUNCTION(functionp, (LispVal * val));
DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros)); DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros));
DECLARE_FUNCTION(builtinp, (LispVal * val)); DECLARE_FUNCTION(builtinp, (LispVal * val));

16
src/main.c
View File

@ -60,7 +60,7 @@ int main(int argc, const char **argv) {
REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", ""); REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", "");
size_t pos = 0; size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { 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, puthash(the_stack->handlers, Qt,
// simply call the above function // simply call the above function
const_list(true, 3, err_var, Qtoplevel_error_handler, err_var)); const_list(true, 3, err_var, Qtoplevel_error_handler, err_var));
@ -76,15 +76,23 @@ int main(int argc, const char **argv) {
while (true) { while (true) {
LispVal *tv; LispVal *tv;
WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, {
size_t res = size_t res = read_from_buffer(buffer + pos, file_len - pos,
read_from_buffer(buffer + pos, file_len - pos, &tv); current_package, &tv);
if (res == LISP_EOF) { if (res == LISP_EOF) {
break; break;
} }
pos += res; pos += res;
}); });
WITH_CLEANUP(tv, { 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)); //
}
}); });
} }
}); });

124
src/read.c
View File

@ -6,6 +6,7 @@
#include <string.h> #include <string.h>
struct ReadState { struct ReadState {
LispVal *read_pkg;
const char *head; const char *head;
size_t left; size_t left;
size_t off; size_t off;
@ -99,7 +100,10 @@ static LispVal *read_list(struct ReadState *state) {
refcount_unref(list); refcount_unref(list);
UNCLOSED_ERROR(state, "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)) { if (is_dot_symbol(elt)) {
refcount_unref(elt); refcount_unref(elt);
if (NILP(list)) { if (NILP(list)) {
@ -110,7 +114,10 @@ static LispVal *read_list(struct ReadState *state) {
refcount_unref(list); refcount_unref(list);
UNCLOSED_ERROR(state, "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); Fsettail(end, last);
refcount_unref(last); refcount_unref(last);
SKIP_WHITESPACE(state); SKIP_WHITESPACE(state);
@ -283,30 +290,103 @@ static int parse_base(size_t left, const char *c) {
} }
static LispVal *read_symbol(struct ReadState *state) { static LispVal *read_symbol(struct ReadState *state) {
struct ReadState start_state = *state;
bool backslash = false; bool backslash = false;
int c; int c;
char *str = lisp_malloc(1); bool expored_only = true;
str[0] = '\0'; char *pkg_name = NULL;
size_t str_len = 0; 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))) { while (backslash || !is_symbol_end(peekc(state))) {
struct ReadState prev_state = *state;
c = popc(state); c = popc(state);
if (!backslash && c == '\\') { if (!backslash && c == '\\') {
backslash = true; backslash = true;
} else if (!backslash } else if (!backslash
&& (c == '`' || c == ',' || c == '\'' || c == '"')) { && (c == '`' || c == ',' || c == '\'' || c == '"')) {
free(str); free(pkg_name);
READ_ERROR(state, 1, "invalid character for symbol name"); free(sym_name);
} else if (c == '\n') { READ_ERROR(&prev_state, 1, "invalid character for symbol name");
free(str); } else if (backslash && (c == '\n' || c == EOS)) {
READ_ERROR(state, 1, "backslash not escaping anything"); 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 { } else {
str = lisp_realloc(str, ++str_len + 1); sym_name = lisp_realloc(sym_name, ++sym_name_len + 1);
str[str_len - 1] = c; sym_name[sym_name_len - 1] = c;
backslash = false; backslash = false;
} }
} }
str[str_len] = '\0'; sym_name[sym_name_len] = '\0';
return intern(str, str_len, true); 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) { 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 = { struct ReadState state = {
.read_pkg = refcount_unref(package),
.head = text, .head = text,
.left = length, .left = length,
.off = 0, .off = 0,
@ -477,7 +559,9 @@ size_t read_from_buffer(const char *text, size_t length, LispVal **out) {
}; };
LispVal *res = NULL; LispVal *res = NULL;
WITH_PUSH_FRAME(Qnil, Qnil, true, { WITH_PUSH_FRAME(Qnil, Qnil, true, {
res = read_internal(&state); // WITH_CLEANUP(package, {
res = read_internal(&state); //
});
}); });
if (!res) { if (!res) {
*out = Qnil; *out = Qnil;
@ -488,10 +572,11 @@ size_t read_from_buffer(const char *text, size_t length, LispVal **out) {
return state.off; return state.off;
} }
DEFUN(read, "read", (LispVal * source)) { DEFUN(read, "read", (LispVal * source, LispVal *package)) {
LispString *str = (LispString *) source; LispString *str = (LispString *) source;
CHECK_TYPE(TYPE_STRING, source); CHECK_TYPE(TYPE_STRING, source);
struct ReadState state = { struct ReadState state = {
.read_pkg = refcount_ref(package),
.head = str->data, .head = str->data,
.left = str->length, .left = str->length,
.off = 0, .off = 0,
@ -501,7 +586,10 @@ DEFUN(read, "read", (LispVal * source)) {
}; };
LispVal *res = NULL; LispVal *res = NULL;
WITH_PUSH_FRAME(Qnil, Qnil, true, { WITH_PUSH_FRAME(Qnil, Qnil, true, {
res = read_internal(&state); // WITH_CLEANUP(package, {
res = read_internal(&state); //
});
state.read_pkg = Qnil;
}); });
if (!res) { if (!res) {
EOF_ERROR(&state); EOF_ERROR(&state);

5
src/read.h
View File

@ -8,8 +8,9 @@
#define LISP_EOF SIZE_MAX #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 #endif