Work on packages

src/kernel.sl

@@ -18,7 +18,7 @@
 (defun fifth (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))

src/lisp.c

@@ -3,11 +3,14 @@
 // used by static function registering macros
 #include "read.h" // IWYU pragma: keep
 
+#include <assert.h>
 #include <ctype.h>
 #include <stdarg.h>
 #include <stdio.h>
 #include <string.h>
 
+#define IGNORE() struct __ignored_struct
+
 struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
     [TYPE_STRING] = {"string", sizeof("string") - 1},
     [TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
@@ -18,6 +21,7 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
     [TYPE_FUNCTION] = {"function", sizeof("function") - 1},
     [TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
     [TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
+    [TYPE_PACKAGE] = {"package", sizeof("package") - 1},
 };
 
 void free_opt_arg_desc(void *obj) {
@@ -32,8 +36,9 @@ DEF_STATIC_STRING(_Qnil_name, "nil");
 LispSymbol _Qnil = {
     .type = TYPE_SYMBOL,
     .name = &_Qnil_name,
+    .package = Qnil,
     .plist = Qnil,
-    .function = Qunbound,
+    .function = Qnil,
     .value = Qnil,
     .is_constant = true,
 };
@@ -42,8 +47,9 @@ DEF_STATIC_STRING(_Qunbound_name, "unbound");
 LispSymbol _Qunbound = {
     .type = TYPE_SYMBOL,
     .name = &_Qunbound_name,
+    .package = Qnil,
     .plist = Qnil,
-    .function = Qunbound,
+    .function = Qnil,
     .value = Qunbound,
     .is_constant = true,
 };
@@ -52,8 +58,9 @@ DEF_STATIC_STRING(_Qt_name, "t");
 LispSymbol _Qt = {
     .type = TYPE_SYMBOL,
     .name = &_Qt_name,
+    .package = Qnil,
     .plist = Qnil,
-    .function = Qunbound,
+    .function = Qnil,
     .value = Qt,
     .is_constant = true,
 };
@@ -129,10 +136,12 @@ LispVal *sprintf_lisp(const char *format, ...) {
 }
 
 LispVal *make_lisp_symbol(LispVal *name) {
+    CHECK_TYPE(TYPE_STRING, name);
     CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL);
     self->name = (LispString *) refcount_ref(name);
+    self->package = Qnil;
     self->plist = Qnil;
-    self->function = Qunbound;
+    self->function = Qnil;
     self->value = Qunbound;
     self->is_constant = false;
     return LISPVAL(self);
@@ -330,7 +339,7 @@ void set_function_args(LispFunction *func, LispVal *args) {
                 kns[sn->length + 1] = '\0';
                 LispVal *kn =
                     make_lisp_string(kns, sn->length + 1, false, false);
-                LispVal *keyword = Fintern(kn);
+                LispVal *keyword = Fintern(kn, Qnil, Qnil);
                 puthash(func->kwargs, keyword, desc);
                 refcount_unref(keyword);
                 refcount_unref(kn);
@@ -422,6 +431,16 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
     return LISPVAL(self);
 }
 
+LispVal *make_lisp_package(LispVal *name) {
+    CHECK_TYPE(TYPE_STRING, name);
+    CONSTRUCT_OBJECT(self, LispPackage, TYPE_PACKAGE);
+    self->name = refcount_ref(name);
+    self->obarray = make_lisp_hashtable(Qstrings_equal, Qhash_string);
+    self->exported_sym_table = make_lisp_hashtable(Qnil, Qnil);
+    self->imported = Qnil;
+    return LISPVAL(self);
+}
+
 DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) {
     return make_lisp_hashtable(eq_fn, hash_fn);
 }
@@ -492,7 +511,7 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
     } else {
         LispVal *eq_obj;
         LispVal *args = const_list(true, 2, v1, v2);
-        WITH_CLEANUP_DOUBLE_PTR(args, {
+        WITH_CLEANUP(args, {
             eq_obj = Ffuncall(self->eq_fn, args); //
         });
         bool result = !NILP(eq_obj);
@@ -513,11 +532,11 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
     } else {
         LispVal *hash_obj;
         LispVal *args = const_list(true, 1, key);
-        WITH_CLEANUP_DOUBLE_PTR(args, {
+        WITH_CLEANUP(args, {
             hash_obj = Ffuncall(self->hash_fn, args); //
         });
         uint64_t hash;
-        WITH_CLEANUP_DOUBLE_PTR(hash_obj, {
+        WITH_CLEANUP(hash_obj, {
             CHECK_TYPE(TYPE_INTEGER, hash_obj);
             hash = ((LispInteger *) hash_obj)->value;
         });
@@ -640,25 +659,330 @@ DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) {
     return refcount_ref(remhash(table, key));
 }
 
+static LispVal *normalize_package(LispVal *arg) {
+    if (STRINGP(arg) || SYMBOLP(arg)) {
+        LispVal *found = Ffind_package(arg);
+        if (!PACKAGEP(found)) {
+            refcount_unref(found);
+            Fthrow(Qunknown_package_error, const_list(true, 1, arg));
+        }
+        return found;
+    } else if (PACKAGEP(arg)) {
+        return refcount_ref(arg);
+    } else {
+        Fthrow(Qtype_error, Qnil);
+    }
+}
+
+DEFUN(set_current_package, "set-current-package", (LispVal * package)) {
+    LispVal *new = normalize_package(package);
+    LispVal *old = current_package;
+    current_package = new;
+    refcount_unref(old);
+    return refcount_ref(current_package);
+}
+
+DEFUN(package_name, "package-name", (LispVal * package)) {
+    CHECK_TYPE(TYPE_PACKAGE, package);
+    return LISPVAL(((LispPackage *) package)->name);
+}
+
+DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package)) {
+    LispPackage *pkg;
+    if (NILP(package)) {
+        pkg = refcount_ref(current_package);
+    } else {
+        pkg = (LispPackage *) normalize_package(package);
+    }
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-but-set-variable"
+    WITH_CLEANUP(pkg, {
+        IGNORE();
+        HASHTABLE_FOREACH(name, sym, pkg->obarray) {
+            LispVal *args = const_list(true, 1, sym);
+            refcount_unref(Ffuncall(func, args));
+        }
+    });
+#pragma GCC diagnostic pop
+    return Qnil;
+}
+
+DEFMACRO(in_package, "in-package", (LispVal * package)) {
+    return Fset_current_package(package);
+}
+
+DEFUN(current_package, "current-package", (void) ) {
+    return refcount_ref(current_package);
+}
+
+IGNORE(); // unconfuse emacs syntax highlighting
+
+DEFUN(export_symbol, "export-symbol", (LispVal * symbol)) {
+    if (SYMBOLP(symbol)) {
+        LispSymbol *sym = (LispSymbol *) symbol;
+        LispPackage *pkg = (LispPackage *) sym->package;
+        puthash(pkg->exported_sym_table, symbol, Qt);
+    } else if (LISTP(symbol)) {
+        FOREACH(cur, symbol) {
+            CHECK_TYPE(TYPE_SYMBOL, cur);
+            Fexport_symbol(cur);
+        }
+    } else {
+        Fthrow(Qtype_error,
+               const_list(false, 2, const_list(false, 2, Qlistp, Qsymbolp),
+                          symbol));
+    }
+    return Qnil;
+}
+
+// recursively search all imports of SOURCE, looking for TARGET
+static bool check_recursive_import(LispVal *source, LispVal *target) {
+    FOREACH(entry, ((LispPackage *) source)->imported) {
+        if (HEAD(entry) == target
+            || check_recursive_import(HEAD(entry), target)) {
+            return true;
+        }
+    }
+    return false;
+}
+
+DEFUN_DISTINGUISHED(import_package, "import-package",
+                    (LispVal * source, LispVal *names, LispVal *target)) {
+    LispPackage *target_pkg;
+    if (target == Qunbound || NILP(target)) {
+        target_pkg = refcount_ref(current_package);
+    } else {
+        target_pkg = (LispPackage *) normalize_package(target);
+    }
+    if (!PACKAGEP(target_pkg)) {
+        refcount_unref(target_pkg);
+        Fthrow(Qimport_error, Qnil);
+    }
+    if (names == Qunbound) {
+        names = Qt; // all symbols
+    }
+    FOREACH(entry, target_pkg->imported) {
+        if (HEAD(entry) == source) {
+            if (names == Qt) {
+                Fsettail(HEAD(entry), Qt);
+            } else {
+                LispVal *imported = TAIL(entry);
+                // if we have already imported everything, do nothing
+                if (imported == Qt) {
+                    goto done;
+                }
+                FOREACH(name, names) {
+                    if (SYMBOLP(name)) {
+                        name = LISPVAL(((LispSymbol *) name)->name);
+                    } else if (!STRINGP(name)) {
+                        refcount_unref(target_pkg);
+                        CHECK_TYPE(TYPE_STRING, name);
+                    }
+                    puthash(imported, name, Qt);
+                }
+            }
+            goto done;
+        }
+    }
+    // we didn't find any existing imports, so add a new entry
+    if (check_recursive_import(source, LISPVAL(target_pkg))) {
+        refcount_unref(target_pkg);
+        Fthrow(Qimport_error, Qnil);
+    }
+    LispVal *lasttail = Qnil;
+    FOREACH_TAIL(tail, target_pkg->imported) {
+        if (NILP(TAIL(tail))) {
+            lasttail = tail;
+            break;
+        }
+    }
+    if (LISTP(names)) {
+        LispVal *norm_names = make_lisp_hashtable(Qstrings_equal, Qhash_string);
+        FOREACH(name, names) {
+            if (SYMBOLP(name)) {
+                name = LISPVAL(((LispSymbol *) name)->name);
+            } else if (!STRINGP(name)) {
+                refcount_unref(target_pkg);
+                refcount_unref(norm_names);
+                CHECK_TYPE(TYPE_STRING, name);
+            }
+            puthash(norm_names, name, Qt);
+        }
+        names = norm_names;
+    }
+    if (NILP(lasttail)) {
+        target_pkg->imported = const_list(false, 1, Fpair(source, names));
+    } else {
+        Fsettail(lasttail, const_list(false, 1, Fpair(source, names)));
+    }
+    refcount_unref(names);
+done:
+    refcount_unref(target_pkg);
+    return Qnil;
+}
+
+DEFUN(make_package, "make-package", (LispVal * name)) {
+    if (SYMBOLP(name)) {
+        name = Fsymbol_name(name);
+    } else {
+        name = refcount_ref(name);
+    }
+    LispVal *np = make_lisp_package(name);
+    refcount_unref(name);
+    return np;
+}
+
+DEFUN(register_package, "register-package", (LispVal * package)) {
+    if (STRINGP(package)) {
+        package = make_lisp_package(package);
+    } else if (SYMBOLP(package)) {
+        package = make_lisp_package(LISPVAL(((LispSymbol *) package)->name));
+    } else {
+        CHECK_TYPE(TYPE_PACKAGE, package);
+        package = refcount_ref(package);
+    }
+    LispVal *found = Ffind_package(package);
+    if (!NILP(found)) {
+        refcount_unref(package);
+        Fthrow(Qpackage_exists_error, const_list(true, 1, package));
+    }
+    puthash(package_table, LISPVAL(((LispPackage *) package)->name), package);
+    return package;
+}
+
+DEFUN(find_package, "find-package", (LispVal * name)) {
+    if (STRINGP(name)) {
+        return Fgethash(package_table, name, Qnil);
+    } else if (SYMBOLP(name)) {
+        return Fgethash(package_table, LISPVAL(((LispSymbol *) name)->name),
+                        Qnil);
+    } else if (PACKAGEP(name)) {
+        LispPackage *pkg = (LispPackage *) name;
+        LispVal *found = Fgethash(package_table, LISPVAL(pkg->name), Qnil);
+        if (found == LISPVAL(pkg)) {
+            return found;
+        } else {
+            refcount_unref(found);
+            return Qnil;
+        }
+    } else {
+        Fthrow(Qtype_error, Qnil);
+    }
+}
+
+LispVal *find_package(const char *name, size_t length) {
+    LispVal *sobj = make_lisp_string(name, length, false, false);
+    LispVal *pkg = Ffind_package(sobj);
+    refcount_unref(sobj);
+    return pkg;
+}
+
+DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol)) {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    LispSymbol *sym = (LispSymbol *) symbol;
+    if (NILP(sym->package)) {
+        return Qnil;
+    }
+    LispPackage *pkg = (LispPackage *) sym->package;
+    return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil);
+}
+
 DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) {
     CHECK_TYPE(TYPE_HASHTABLE, table);
     return make_lisp_integer(((LispHashtable *) table)->count);
 }
 
-DEFUN(intern, "intern", (LispVal * name)) {
+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) {
+        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(kw_success, "success");
-DEF_STATIC_SYMBOL(finally, ":finally");
+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);
+    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(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_INTO(kw_success, keyword_package);
-    REGISTER_SYMBOL(finally);
+    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 refcount_ref(((LispSymbol *) symbol)->function);
-        return fn == Qunbound ? Qnil : fn;
     }
-    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);
+    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,10 +1744,8 @@ unknown_key:
 too_few:
     refcount_unref(rest);
     for (size_t i = 0; i < raw_count; ++i) {
-        if (vec[i]) {
         refcount_unref(vec[i]);
     }
-    }
     lisp_free(vec);
     Fthrow(Qargument_error, Fpair(fname, Qnil));
     return NULL;
@@ -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"
+#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);
         // 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,37 +2621,42 @@ 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, {
+    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);
+        {
+            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 (HEAD(entry) == Qkw_success) {
                     if (success_form != Qunbound) {
                         Fthrow(Qmalformed_lambda_list_error, Qnil);
                     }
                     success_form = Fpair(Qprogn, TAIL(entry));
-            } else if (HEAD(entry) == Qfinally) {
+                } 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)));
+                    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,
+                            LispVal *handler =
-                                                     Qprogn, var);
+                                push_many(TAIL(entry), 2, Qprogn, var);
                             puthash(the_stack->handlers, type, handler);
                             refcount_unref(handler);
                         }
@@ -2275,20 +2670,17 @@ DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
             retval = Feval(form);
             cancel_cleanup(cl_handler);
             success = true;
-    }, {
+        },
-        retval = refcount_ref(stack_return);
+        { 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);
+        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);
     }
     return retval;
 }
-// clang-format on
 
 // true if the form was a declare form
 static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
@@ -2473,6 +2865,10 @@ DEFUN(vectorp, "vectorp", (LispVal * val)) {
     return LISP_BOOL(VECTORP(val));
 }
 
+DEFUN(packagep, "packagep", (LispVal * val)) {
+    return LISP_BOOL(PACKAGEP(val));
+}
+
 DEFUN(functionp, "functionp", (LispVal * val)) {
     if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) {
         return Qt;
@@ -2591,7 +2987,7 @@ DEFMACRO(and, "and", (LispVal * rest)) {
     LispVal *retval = Qnil;
     FOREACH(cond, rest) {
         LispVal *nc;
-        WITH_CLEANUP_DOUBLE_PTR(retval, {
+        WITH_CLEANUP(retval, {
             nc = Feval(cond); //
         });
         if (NILP(nc)) {
@@ -2619,7 +3015,7 @@ DEFUN(type_of, "type-of", (LispVal * obj)) {
     LispVal *name =
         make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
                          LISP_TYPE_NAMES[obj->type].len, true, true);
-    LispVal *sym = Fintern(name);
+    LispVal *sym = Fintern(name, system_package, Qnil);
     refcount_unref(name);
     return sym;
 }
@@ -2713,6 +3109,18 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
     } break;
     case TYPE_SYMBOL: {
         LispSymbol *sym = (LispSymbol *) obj;
+        if (KEYWORDP(obj)) {
+            fputc(':', stream);
+        } else if (NILP(sym->package)) {
+            fprintf(stream, "::");
+        } else if (sym->package != current_package) {
+            LispPackage *pkg = (LispPackage *) sym->package;
+            fwrite(pkg->name->data, 1, pkg->name->length, stream);
+            fputc(':', stream);
+            if (NILP(Fexported_symbol_p(obj))) {
+                fputc(':', stream);
+            }
+        }
         fwrite(sym->name->data, 1, sym->name->length, stream);
     } break;
     case TYPE_PAIR: {
@@ -2777,6 +3185,13 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
         fprintf(stream, "<user-pointer ptr=%#jx at %#jx>",
                 (uintmax_t) ptr->data, (uintmax_t) obj);
     } break;
+    case TYPE_PACKAGE: {
+        LispPackage *pkg = (LispPackage *) obj;
+        fprintf(stream, "<package ");
+        fwrite(pkg->name->data, 1, pkg->name->length, stream);
+        fprintf(stream, " obarray-size=%zu at %#jx>",
+                ((LispHashtable *) pkg->obarray)->count, (uintmax_t) obj);
+    } break;
     default:
         fprintf(stream, "<object type=%ju at %#jx>",
                 (uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
@@ -2793,12 +3208,12 @@ void debug_dump(FILE *stream, void *obj, bool newline) {
 
 void debug_print_hashtable(FILE *stream, LispVal *table) {
     debug_dump(stream, table, true);
-    HASHTABLE_FOREACH(key, val, table, {
+    HASHTABLE_FOREACH(key, val, table) {
         fprintf(stream, "- ");
         debug_dump(stream, key, false);
         fprintf(stream, " = ");
         debug_dump(stream, val, true);
-    });
+    }
 }
 
 static bool debug_print_tree_callback(void *obj, const RefcountList *trail,

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 {
+        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
+    return SYMBOLP(v) && ((LispSymbol *) v)->package == keyword_package;
-           && ((LispSymbol *) v)->name->data[0] == ':';
 }
 
 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,7 +253,8 @@ 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) \
+#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;                                       \
@@ -243,6 +263,7 @@ inline static bool NUMBERP(LispVal *v) {
         .is_builtin = true,                                             \
         .is_macro = macrop,                                             \
         .builtin = (void (*)(void)) & F##c_name,                        \
+        .distinguish_unpassed = du,                                     \
         .name = LISPVAL(&_Q##c_name),                                   \
         .doc = Qnil,                                                    \
         .args = Qnil,                                                   \
@@ -255,6 +276,7 @@ inline static bool NUMBERP(LispVal *v) {
     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),                    \
@@ -263,33 +285,35 @@ inline static bool NUMBERP(LispVal *v) {
     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)                    \
+#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)                                 \
     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(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 *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 *Qkw_success;
-extern LispVal *Qfinally;
+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)      \
+#define REGISTER_SYMBOL_INTO(sym, pkg)                    \
     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)           \
     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);
+    ((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));

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 =
+                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) {
                     break;
                 }
                 pos += res;
             });
             WITH_CLEANUP(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)); //
+                }
             });
         }
     });

src/read.c

@@ -6,6 +6,7 @@
 #include <string.h>
 
 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);
+    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))) {
+        struct ReadState prev_state = *state;
         c = popc(state);
         if (!backslash && c == '\\') {
             backslash = true;
         } else if (!backslash
                    && (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 {
-            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;
         }
     }
-    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) {
@@ -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,8 +559,10 @@ size_t read_from_buffer(const char *text, size_t length, LispVal **out) {
     };
     LispVal *res = NULL;
     WITH_PUSH_FRAME(Qnil, Qnil, true, {
+        WITH_CLEANUP(package, {
             res = read_internal(&state); //
         });
+    });
     if (!res) {
         *out = Qnil;
         return LISP_EOF;
@@ -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,8 +586,11 @@ DEFUN(read, "read", (LispVal * source)) {
     };
     LispVal *res = NULL;
     WITH_PUSH_FRAME(Qnil, Qnil, true, {
+        WITH_CLEANUP(package, {
             res = read_internal(&state); //
         });
+        state.read_pkg = Qnil;
+    });
     if (!res) {
         EOF_ERROR(&state);
     } else {

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