pkg 54a08db92b 01/76: Basic functionality for packages

[Gerd Moellmann]

branch: pkg
commit 54a08db92b432cba4d4e92fec86c4f294b9191ed
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>

    Basic functionality for packages
    
    Lisp packages exist and can be dumped and loaded.  Two standard
    packages "emacs" and "keyword".  Some package functions and variables
    of CLHS.
    
    Symbols have a package slot.  Built-in symbols before loaodup get
    packages emacs or keyword.
    
    Dumping and loading.
    
    Some tests.
    
    * src/pkg.c: New file for Lisp packages.
    * src/Makefile.in (base_obj): Add pkg.c.
    * test/src/pkg-tests.el: New file.
    * src/lisp.h: Add Lisp_Package.
    * etc/emacs_lldb.py: Add Lisp_Package.
    * src/data.c (Ftype_of): Handle packages.
    (syms_of_data): Add Qpackage.
    * src/emacs.c (main): Initialize pkg.c, fix built-in symbols.
    * src/fns.c (check_hash_table, get_key_arg): Make externally visible.
    * src/pdumper.c (dump_vectorlike): Handle packages.
    * src/print.c: Print packages, print symbols with packages.
---
 etc/emacs_lldb.py     |   1 +
 src/Makefile.in       |   2 +-
 src/alloc.c           |   5 +
 src/data.c            |  11 +
 src/emacs.c           |   6 +
 src/fns.c             |   4 +-
 src/lisp.h            |  84 +++++
 src/lread.c           |   3 +
 src/pdumper.c         |   3 +
 src/pkg.c             | 901 ++++++++++++++++++++++++++++++++++++++++++++++++++
 src/print.c           |  43 +++
 test/src/pkg-tests.el | 153 +++++++++
 12 files changed, 1213 insertions(+), 3 deletions(-)

diff --git a/etc/emacs_lldb.py b/etc/emacs_lldb.py
index a2329e6ea4..15efcec057 100644
--- a/etc/emacs_lldb.py
+++ b/etc/emacs_lldb.py
@@ -59,6 +59,7 @@ class Lisp_Object:
         "PVEC_TERMINAL": "struct terminal",
         "PVEC_WINDOW_CONFIGURATION": "struct save_window_data",
         "PVEC_SUBR": "struct Lisp_Subr",
+        "PVEC_PACKAGE": "struct Lisp_Package",
         "PVEC_OTHER": "void",
         "PVEC_XWIDGET": "void",
         "PVEC_XWIDGET_VIEW": "void",
diff --git a/src/Makefile.in b/src/Makefile.in
index 1f941874ea..5f6ebbb67e 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -436,7 +436,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o 
$(XMENU_OBJ) window.o \
        alloc.o pdumper.o data.o doc.o editfns.o callint.o \
        eval.o floatfns.o fns.o sort.o font.o print.o lread.o $(MODULES_OBJ) \
        syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \
-       process.o gnutls.o callproc.o \
+       pkg.o process.o gnutls.o callproc.o \
        region-cache.o sound.o timefns.o atimer.o \
        doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \
        $(XWIDGETS_OBJ) \
diff --git a/src/alloc.c b/src/alloc.c
index 419c5e558b..034d82e3ea 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3625,12 +3625,14 @@ init_symbol (Lisp_Object val, Lisp_Object name)
   p->u.s.redirect = SYMBOL_PLAINVAL;
   SET_SYMBOL_VAL (p, Qunbound);
   set_symbol_function (val, Qnil);
+  set_symbol_package (val, Qnil);
   set_symbol_next (val, NULL);
   p->u.s.gcmarkbit = false;
   p->u.s.interned = SYMBOL_UNINTERNED;
   p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE;
   p->u.s.declared_special = false;
   p->u.s.pinned = false;
+  p->u.s.external = false;
 }
 
 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
@@ -4641,6 +4643,7 @@ live_symbol_holding (struct mem_node *m, void *p)
          || off == offsetof (struct Lisp_Symbol, u.s.name)
          || off == offsetof (struct Lisp_Symbol, u.s.val)
          || off == offsetof (struct Lisp_Symbol, u.s.function)
+         || off == offsetof (struct Lisp_Symbol, u.s.package)
          || off == offsetof (struct Lisp_Symbol, u.s.plist)
          || off == offsetof (struct Lisp_Symbol, u.s.next))
        {
@@ -6947,6 +6950,8 @@ process_mark_stack (ptrdiff_t base_sp)
            /* Attempt to catch bogus objects.  */
            eassert (valid_lisp_object_p (ptr->u.s.function));
            mark_stack_push_value (ptr->u.s.function);
+           eassert (valid_lisp_object_p (ptr->u.s.package));
+           mark_stack_push_value (ptr->u.s.package);
            mark_stack_push_value (ptr->u.s.plist);
            switch (ptr->u.s.redirect)
              {
diff --git a/src/data.c b/src/data.c
index 221a6f5883..5fda374f1f 100644
--- a/src/data.c
+++ b/src/data.c
@@ -225,6 +225,7 @@ for example, (type-of 1) returns `integer'.  */)
         case PVEC_PROCESS: return Qprocess;
         case PVEC_WINDOW: return Qwindow;
         case PVEC_SUBR: return Qsubr;
+        case PVEC_PACKAGE: return Qpackage;
         case PVEC_COMPILED: return Qcompiled_function;
         case PVEC_BUFFER: return Qbuffer;
         case PVEC_CHAR_TABLE: return Qchar_table;
@@ -777,6 +778,14 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
   return name;
 }
 
+DEFUN ("symbol-package", Fsymbol_package, Ssymbol_package, 1, 1, 0,
+       doc: /* Return SYMBOL's package, a package or nil.  */)
+  (Lisp_Object symbol)
+{
+  CHECK_SYMBOL (symbol);
+  return SYMBOL_PACKAGE (symbol);
+}
+
 DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
        doc: /* Extract, if need be, the bare symbol from SYM, a symbol.  */)
   (register Lisp_Object sym)
@@ -4254,6 +4263,7 @@ syms_of_data (void)
   DEFSYM (Qprocess, "process");
   DEFSYM (Qwindow, "window");
   DEFSYM (Qsubr, "subr");
+  DEFSYM (Qpackage, "package");
   DEFSYM (Qcompiled_function, "compiled-function");
   DEFSYM (Qbuffer, "buffer");
   DEFSYM (Qframe, "frame");
@@ -4328,6 +4338,7 @@ syms_of_data (void)
   defsubr (&Sindirect_function);
   defsubr (&Ssymbol_plist);
   defsubr (&Ssymbol_name);
+  defsubr (&Ssymbol_package);
   defsubr (&Sbare_symbol);
   defsubr (&Ssymbol_with_pos_pos);
   defsubr (&Sremove_pos_from_symbol);
diff --git a/src/emacs.c b/src/emacs.c
index 43e81b912c..1fa83751b3 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1878,6 +1878,7 @@ Using an Emacs configured with --with-x-toolkit=lucid 
does not have this problem
   if (!initialized)
     {
       init_alloc_once ();
+      init_pkg_once ();
       init_pdumper_once ();
       init_obarray_once ();
       init_eval_once ();
@@ -1907,6 +1908,8 @@ Using an Emacs configured with --with-x-toolkit=lucid 
does not have this problem
       /* Called before syms_of_fileio, because it sets up Qerror_condition.  */
       syms_of_data ();
       syms_of_fns ();  /* Before syms_of_charset which uses hash tables.  */
+      syms_of_pkg ();
+
       syms_of_fileio ();
       /* Before syms_of_coding to initialize Vgc_cons_threshold.  */
       syms_of_alloc ();
@@ -1925,6 +1928,7 @@ Using an Emacs configured with --with-x-toolkit=lucid 
does not have this problem
     }
 
   init_alloc ();
+  init_pkg ();
   init_bignum ();
   init_threads ();
   init_eval ();
@@ -2456,6 +2460,8 @@ Using an Emacs configured with --with-x-toolkit=lucid 
does not have this problem
   init_window ();
   init_font ();
 
+  fix_symbol_packages ();
+
   if (!initialized)
     {
       char *file;
diff --git a/src/fns.c b/src/fns.c
index 22e66d3653..ac8594d8a1 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -4161,7 +4161,7 @@ set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t 
idx, ptrdiff_t val)
 /* If OBJ is a Lisp hash table, return a pointer to its struct
    Lisp_Hash_Table.  Otherwise, signal an error.  */
 
-static struct Lisp_Hash_Table *
+struct Lisp_Hash_Table *
 check_hash_table (Lisp_Object obj)
 {
   CHECK_HASH_TABLE (obj);
@@ -4189,7 +4189,7 @@ next_almost_prime (EMACS_INT n)
    0.  This function is used to extract a keyword/argument pair from
    a DEFUN parameter list.  */
 
-static ptrdiff_t
+ptrdiff_t
 get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
 {
   ptrdiff_t i;
diff --git a/src/lisp.h b/src/lisp.h
index 9710dbef8d..f8267eea15 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -863,6 +863,9 @@ struct Lisp_Symbol
       /* True if pointed to from purespace and hence can't be GC'd.  */
       bool_bf pinned : 1;
 
+      /* True if external symbol in its home package.  */
+      bool_bf external : 1;
+
       /* The symbol's name, as a Lisp string.  */
       Lisp_Object name;
 
@@ -881,6 +884,9 @@ struct Lisp_Symbol
       /* The symbol's property list.  */
       Lisp_Object plist;
 
+      /* The symbol's package, or nil.  */
+      Lisp_Object package;
+
       /* Next symbol in obarray bucket, if the symbol is interned.  */
       struct Lisp_Symbol *next;
     } s;
@@ -1054,6 +1060,7 @@ enum pvec_type
   PVEC_TERMINAL,
   PVEC_WINDOW_CONFIGURATION,
   PVEC_SUBR,
+  PVEC_PACKAGE,
   PVEC_OTHER,            /* Should never be visible to Elisp code.  */
   PVEC_XWIDGET,
   PVEC_XWIDGET_VIEW,
@@ -1402,6 +1409,7 @@ dead_object (void)
 #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW))
 #define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL))
 #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR))
+#define XSETPACKAGE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PACKAGE))
 #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER))
 #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
 #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
@@ -2197,6 +2205,62 @@ XSUBR (Lisp_Object a)
   return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s;
 }
 
+
+/************************************************************************
+                               Packages
+************************************************************************/
+
+struct Lisp_Package
+{
+  union vectorlike_header header;
+
+  /* The package name, a string.  */
+  Lisp_Object name;
+
+  /* Package nicknames as List of strings.  */
+  Lisp_Object nicknames;
+
+  /* List of package objects for the packages used by this
+     package.  */
+  Lisp_Object used_packages;
+
+  /* List of shadowing symbols.  */
+  Lisp_Object shadowing_symbols;
+
+  /* Hash table mapping symbol names to symbols present in the
+     package.  */
+  Lisp_Object symbols;
+
+} GCALIGNED_STRUCT;
+
+union Aligned_Lisp_Package
+{
+  struct Lisp_Package s;
+  GCALIGNED_UNION_MEMBER
+};
+
+verify (GCALIGNED (union Aligned_Lisp_Package));
+
+INLINE bool
+PACKAGEP (Lisp_Object a)
+{
+  return PSEUDOVECTORP (a, PVEC_PACKAGE);
+}
+
+INLINE struct Lisp_Package *
+XPACKAGE (Lisp_Object a)
+{
+  eassert (PACKAGEP (a));
+  return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Package)->s;
+}
+
+extern void init_pkg_once (void);
+extern void init_pkg (void);
+extern void syms_of_pkg (void);
+extern void fix_symbol_packages (void);
+extern Lisp_Object pkg_insert_new_symbol (Lisp_Object symbol, Lisp_Object 
package);
+
+
 /* Return whether a value might be a valid docstring.
    Used to distinguish the presence of non-docstring in the docstring slot,
    as in the case of OClosures.  */
@@ -2322,6 +2386,18 @@ SYMBOL_NAME (Lisp_Object sym)
   return XSYMBOL (sym)->u.s.name;
 }
 
+INLINE Lisp_Object
+SYMBOL_PACKAGE (Lisp_Object sym)
+{
+  return XSYMBOL (sym)->u.s.package;
+}
+
+INLINE bool
+SYMBOL_EXTERNAL_P (Lisp_Object sym)
+{
+  return XSYMBOL (sym)->u.s.external;
+}
+
 /* Value is true if SYM is an interned symbol.  */
 
 INLINE bool
@@ -3774,6 +3850,12 @@ set_symbol_function (Lisp_Object sym, Lisp_Object 
function)
   XSYMBOL (sym)->u.s.function = function;
 }
 
+INLINE void
+set_symbol_package (Lisp_Object sym, Lisp_Object package)
+{
+  XSYMBOL (sym)->u.s.package = package;
+}
+
 INLINE void
 set_symbol_plist (Lisp_Object sym, Lisp_Object plist)
 {
@@ -4004,6 +4086,8 @@ extern void init_syntax_once (void);
 extern void syms_of_syntax (void);
 
 /* Defined in fns.c.  */
+extern struct Lisp_Hash_Table *check_hash_table (Lisp_Object);
+extern ptrdiff_t get_key_arg (Lisp_Object, ptrdiff_t, Lisp_Object *, char *);
 enum { NEXT_ALMOST_PRIME_LIMIT = 11 };
 extern ptrdiff_t list_length (Lisp_Object);
 extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST;
diff --git a/src/lread.c b/src/lread.c
index dfa4d9afb5..c458d0d51e 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -4649,7 +4649,10 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, 
Lisp_Object index)
         in lexically bound elisp signal an error, as documented.  */
       XSYMBOL (sym)->u.s.declared_special = true;
       SET_SYMBOL_VAL (XSYMBOL (sym), sym);
+      pkg_insert_new_symbol (sym, Vkeyword_package);
     }
+  else
+      pkg_insert_new_symbol (sym, Vearmuffs_package);
 
   ptr = aref_addr (obarray, XFIXNUM (index));
   set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL);
diff --git a/src/pdumper.c b/src/pdumper.c
index 903298f17d..d7102b4298 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -2450,6 +2450,7 @@ dump_symbol (struct dump_context *ctx,
   DUMP_FIELD_COPY (&out, symbol, u.s.interned);
   DUMP_FIELD_COPY (&out, symbol, u.s.declared_special);
   DUMP_FIELD_COPY (&out, symbol, u.s.pinned);
+  DUMP_FIELD_COPY (&out, symbol, u.s.external);
   dump_field_lv (ctx, &out, symbol, &symbol->u.s.name, WEIGHT_STRONG);
   switch (symbol->u.s.redirect)
     {
@@ -2472,6 +2473,7 @@ dump_symbol (struct dump_context *ctx,
       emacs_abort ();
     }
   dump_field_lv (ctx, &out, symbol, &symbol->u.s.function, WEIGHT_NORMAL);
+  dump_field_lv (ctx, &out, symbol, &symbol->u.s.package, WEIGHT_NORMAL);
   dump_field_lv (ctx, &out, symbol, &symbol->u.s.plist, WEIGHT_NORMAL);
   dump_field_lv_rawptr (ctx, &out, symbol, &symbol->u.s.next, Lisp_Symbol,
                         WEIGHT_STRONG);
@@ -2975,6 +2977,7 @@ dump_vectorlike (struct dump_context *ctx,
     case PVEC_CHAR_TABLE:
     case PVEC_SUB_CHAR_TABLE:
     case PVEC_RECORD:
+    case PVEC_PACKAGE:
       offset = dump_vectorlike_generic (ctx, &v->header);
       break;
     case PVEC_BOOL_VECTOR:
diff --git a/src/pkg.c b/src/pkg.c
new file mode 100644
index 0000000000..52fde88da8
--- /dev/null
+++ b/src/pkg.c
@@ -0,0 +1,901 @@
+/* Common Lisp style packages.
+   Copyright (C) 2022 Free Software Foundation, Inc.
+
+Author: Gerd Möllmann <gerd@gnu.org>
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
+
+/* Lisp packages patterned after CMUCL, which implements CLHS plus
+   extensions.  The extensions are currently not implemented.
+
+   Useful features that could be added:
+   package locks
+   hierarchical packages
+   package-local nicknames  */
+
+#include <config.h>
+#include "lisp.h"
+#include "character.h"
+
+/* True after fix_symbol_packages has run.  */
+static bool symbols_fixed_p = false;
+
+/***********************************************************************
+                           Useless tools
+ ***********************************************************************/
+
+/* Iterator for hash tables.  */
+
+struct h_iterator
+{
+  /* Hash table being iterated over.  */
+  struct Lisp_Hash_Table *h;
+
+  /* Current index in key/value vector of H.  */
+  ptrdiff_t i;
+
+  /* Key and value at I, or nil.  */
+  Lisp_Object key, value;
+};
+
+/* Return a freshly initialized iterator for iterating over hash table
+   TABLE.  */
+
+static struct h_iterator
+h_init (Lisp_Object table)
+{
+  struct Lisp_Hash_Table *h = check_hash_table (table);
+  struct h_iterator it = {.h = h, .i = 0, .key = Qnil, .value = Qnil};
+  return it;
+}
+
+/* Value is true if iterator IT is on a valid poisition.  If it is,
+   IT.key and IT.value are set to key and value at that position.  */
+
+static bool
+h_valid (struct h_iterator *it)
+{
+  for (; it->i < HASH_TABLE_SIZE (it->h); ++it->i)
+    if (!EQ (HASH_KEY (it->h, it->i), Qunbound))
+      {
+       it->key = HASH_KEY (it->h, it->i);
+       it->value = HASH_VALUE (it->h, it->i);
+       return true;
+      }
+  return false;
+}
+
+/* Advance to next element.  */
+
+static void
+h_next (struct h_iterator *it)
+{
+  ++it->i;
+}
+
+/* Macrology.  IT is a variable name that is bound to an iterator over
+   hash table TABLE for the duration of the loop.  */
+
+#define FOR_EACH_KEY_VALUE(it, table) \
+  for (struct h_iterator it = h_init (table); h_valid (&it); h_next (&it))
+
+/* Cons ELT onto *LIST, and return *LIST.  */
+
+static Lisp_Object
+add_to_list (Lisp_Object elt, Lisp_Object *list)
+{
+  return *list = Fcons (elt, *list);
+}
+
+/* Cons ELT onto *LIST, if not already present.  Return *LIST.  */
+
+static Lisp_Object
+add_new_to_list (Lisp_Object elt, Lisp_Object *list)
+{
+  if (NILP (Fmemq (elt, *list)))
+    add_to_list (elt, list);
+  return *list;
+}
+
+/***********************************************************************
+                              Helpers
+ ***********************************************************************/
+
+/* If THING is nil, return nil.  If THING is symbol, return a list of
+   length 1 containing THING: Otherwise, THING must be a list.  Check
+   that each element of the list is a symbol, and return a new list
+   containing all elements of THING, with duplicates removed.  */
+
+static Lisp_Object
+symbols_to_list (Lisp_Object thing)
+{
+  if (NILP (thing))
+    return Qnil;
+  if (SYMBOLP (thing))
+    return list1 (thing);
+  if (CONSP (thing))
+    {
+      Lisp_Object result = Qnil;
+      Lisp_Object tail = thing;
+      FOR_EACH_TAIL (tail)
+       {
+         Lisp_Object symbol = XCAR (tail);
+         CHECK_SYMBOL (symbol);
+         add_new_to_list (symbol, &result);
+         return result;
+       }
+    }
+  signal_error ("Not a list of symbols", thing);
+}
+
+/* Create and return a new Lisp package object for a package with name
+   NAME, a string.
+
+   What are the contents of the symbol hash table?  Mapping symbol
+   names to entries of which form?  Can there be more than one
+   symbol-name for different symbols */
+
+static Lisp_Object
+make_package (Lisp_Object name)
+{
+  eassert (STRINGP (name));
+  struct Lisp_Package *pkg
+    = ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Package, symbols, 
PVEC_PACKAGE);
+  pkg->name = name;
+  pkg->symbols = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize, make_fixnum 
(1024));
+  Lisp_Object package;
+  XSETPACKAGE (package, pkg);
+  return package;
+}
+
+/* Return a string for DESIGNATOR.  If DESIGNATOR is a symbol, return
+   the symbol's name.  If DESIGNATOR is a string, return that string.
+   If DESIGNATOR is a character, return a string that contains only
+   that character.  If it is neither, signal an error.  */
+
+static Lisp_Object
+string_from_designator (Lisp_Object designator)
+{
+  if (SYMBOLP (designator))
+    return Fsymbol_name (designator);
+  if (STRINGP (designator))
+    return designator;
+  if (CHARACTERP (designator))
+    return Fchar_to_string (designator);
+  signal_error ("Not a string designator", designator);
+}
+
+/* Return a list of strings for a list of string designators
+   DESIGNATORS.  If DESIGNATORS is nil, return nil.  if DESIGNATORS is
+   a list, return a new list of strings for the designators with order
+   being preserved, and duplicates removed.  Signal an error if
+   DESIGNATORS is neither nil nor a cons.  */
+
+static Lisp_Object
+string_list_from_designators (Lisp_Object designators)
+{
+  if (CONSP (designators))
+    {
+      Lisp_Object result = Qnil;
+      Lisp_Object tail = designators;
+      FOR_EACH_TAIL (tail)
+       {
+         const Lisp_Object name = string_from_designator (XCAR (tail));
+         if (NILP (Fmember (name, result)))
+           result = Fcons (name, result);
+       }
+      return Fnreverse (result);
+    }
+  else if (NILP (designators))
+    return Qnil;
+  signal_error ("Not a list of strings designators", designators);
+}
+
+/* Valiue is PACKAGE, if it is a package, otherwise signal an
+   error.  */
+
+static Lisp_Object
+check_package (Lisp_Object package)
+{
+  if (PACKAGEP (package))
+    return package;
+  signal_error ("Not a package", package);
+}
+
+/* Return a package for a package designator DESIGNATOR.  If
+   DESIGNATOR is a package, return that package.  Otherwise,
+   DESIGNATOR must a string designator for a registered package.
+   Signal an error in the designator case if the package is not
+   registered.  */
+
+static Lisp_Object
+package_from_designator (Lisp_Object designator)
+{
+  /* FIXME? Not signaling here if DESIGNATOR is not registered is odd,
+     but I think that's what CLHS says.  */
+  if (PACKAGEP (designator))
+    return designator;
+  const Lisp_Object name = string_from_designator (designator);
+  const Lisp_Object package = Ffind_package (name);
+  return check_package (package);
+}
+
+/* Value is the package designated by DESIGNATOR, or the value of
+   "*package*" if DESIGNATOR is nil.  Signal an error if DESIGNATOR is
+   not a registered package, or *package* is not.  */
+
+static Lisp_Object
+package_or_default (Lisp_Object designator)
+{
+  if (NILP (designator))
+    return check_package (Vearmuffs_package);
+  return package_from_designator (designator);
+}
+
+/* Convert a list of package designators to a list of packages.
+   Order is preserved, and duplicates are removed.  */
+
+static Lisp_Object
+package_list_from_designators (Lisp_Object designators)
+{
+  if (NILP (designators))
+    return Qnil;
+  if (CONSP (designators))
+    {
+      Lisp_Object result = Qnil;
+      Lisp_Object tail = designators;
+      FOR_EACH_TAIL (tail)
+       {
+         Lisp_Object package = package_from_designator (XCAR (tail));
+         add_new_to_list (package, &result);
+       }
+      return Fnreverse (result);
+    }
+  signal_error ("Not a package designator list", designators);
+}
+
+/* Check for conflicts of NAME and NICKNAMES with registered packages.
+   Value is the conflicting package or nil.  */
+
+static Lisp_Object
+conflicting_package (Lisp_Object name, Lisp_Object nicknames)
+{
+  const Lisp_Object conflict = Ffind_package (name);
+  if (!NILP (conflict))
+    return conflict;
+
+  Lisp_Object tail = nicknames;
+  FOR_EACH_TAIL (tail)
+    {
+      const Lisp_Object conflict = Ffind_package (XCAR (tail));
+      if (!NILP (conflict))
+       return conflict;
+    }
+
+  return Qnil;
+}
+
+/* Register package PACKAGE in the package registry, that is, make it
+   known under its name and all its nicknames.  */
+
+static void
+register_package (Lisp_Object package)
+{
+  const struct Lisp_Package *pkg = XPACKAGE (package);
+
+  const Lisp_Object conflict = conflicting_package (pkg->name, pkg->nicknames);
+  if (!NILP (conflict))
+    signal_error ("Package name conflict", conflict);
+
+  Fputhash (pkg->name, package, Vpackage_registry);
+  Lisp_Object tail = pkg->nicknames;
+  FOR_EACH_TAIL (tail)
+    Fputhash (XCAR (tail), package, Vpackage_registry);
+}
+
+/* Remove PACKAGE fromt the package registry, that is, remove its name
+   all its nicknames. Note that we intentionally don't remove the
+   package from used_packages of other packages.  */
+
+static void
+unregister_package (Lisp_Object package)
+{
+  Lisp_Object tail = XPACKAGE (package)->nicknames;
+  FOR_EACH_TAIL (tail)
+    Fremhash (XCAR (tail), Vpackage_registry);
+  Fremhash (XPACKAGE (package)->name, Vpackage_registry);
+}
+
+
+/***********************************************************************
+                             Symbol table
+ ***********************************************************************/
+
+/* Find a symbol with name NAME in PACKAGE or one of the packages it
+   inherits from.  Value is nil if no symbol is found.  SEEN is a list
+   of packages that have already been checked, to prevent infinte
+   recursion.  */
+
+static Lisp_Object
+lookup_symbol1 (Lisp_Object name, Lisp_Object package, Lisp_Object seen)
+{
+  const struct Lisp_Package *pkg = XPACKAGE (package);
+  Lisp_Object symbol = Fgethash (name, pkg->symbols, Qnil);
+  if (NILP (symbol))
+    {
+      Lisp_Object tail = pkg->used_packages;
+      FOR_EACH_TAIL (tail)
+       {
+         const Lisp_Object used_package = XCAR (tail);
+         if (NILP (Fmemq (used_package, seen)))
+           {
+             seen = Fcons (used_package, seen);
+             symbol = lookup_symbol1 (name, used_package, seen);
+             if (!NILP (symbol))
+               break;
+           }
+       }
+    }
+
+  return symbol;
+}
+
+static Lisp_Object
+lookup_symbol (Lisp_Object name, Lisp_Object package)
+{
+  return lookup_symbol1(name, package, Qnil);
+}
+
+/* Add a new SYMBOL to package PACKAGE.  Value is SYMBOL.  The symbol
+   is made external if PACKAGE is the keyword package.  Otherwise it
+   is internal.  */
+
+Lisp_Object
+pkg_insert_new_symbol (Lisp_Object symbol, Lisp_Object package)
+{
+  if (symbols_fixed_p)
+    {
+      eassert (NILP (SYMBOL_PACKAGE (symbol)));
+      XSYMBOL (symbol)->u.s.package = package;
+      XSYMBOL (symbol)->u.s.external = EQ (package, Vkeyword_package);
+      Fputhash (SYMBOL_NAME (symbol), symbol, XPACKAGE (package)->symbols);
+    }
+  return symbol;
+}
+
+/* Add a symbol with name NAME to PACKAGE.  If a symbol with name NAME
+   is already accessible in PACKAGE, return that symbol.  Otherwise,
+   add a new symbol to PACKAGE.  Value is the symbol found or newly
+   inserted.  */
+
+static Lisp_Object
+pkg_intern_symbol (Lisp_Object name, Lisp_Object package)
+{
+  Lisp_Object found = lookup_symbol (name, package);
+  if (!NILP (found))
+    return found;
+  return pkg_insert_new_symbol (Fmake_symbol (name), package);
+}
+
+/* Add SYMBOL to PACKAGE's shadowing symbols, if not already
+   present.  */
+
+static void
+add_shadowing_symbol (Lisp_Object symbol, Lisp_Object package)
+{
+  struct Lisp_Package *pkg = XPACKAGE (package);
+  add_new_to_list (symbol, &pkg->shadowing_symbols);
+}
+
+/* Remvoe SYMBOL from the shadowing list of PACKAGE.  */
+
+static void
+remove_shadowing_symbol (Lisp_Object symbol, Lisp_Object package)
+{
+  struct Lisp_Package *pkg = XPACKAGE (package);
+  pkg->shadowing_symbols = Fdelq (symbol, pkg->shadowing_symbols);
+}
+
+/* Return a list (SYMBOL STATUS) where STATUS is a symbol describing
+   the status of SYMBOL relative to PACKAGE (internal, external,
+   inherted).  This is kind of a poor man's substitude for multiple
+   values.  */
+
+static Lisp_Object
+symbol_and_status (Lisp_Object symbol, Lisp_Object package)
+{
+  if (NILP (symbol))
+    return Qnil;
+  if (EQ (SYMBOL_PACKAGE (symbol), package))
+    return list2 (symbol, SYMBOL_EXTERNAL_P (symbol) ? QCexternal : 
QCinternal);
+  return list2 (symbol, QCinherited);
+}
+
+
+/***********************************************************************
+                           Lisp functions
+ ***********************************************************************/
+
+DEFUN ("packagep", Fpackagep, Spackagep, 1, 1, 0, doc:
+       /* Value is non-nil if PACKAGE is a package object. */)
+  (Lisp_Object package)
+{
+  return PACKAGEP (package) ? Qt : Qnil;
+}
+
+DEFUN ("package-name", Fpackage_name, Spackage_name, 1, 1, 0, doc:
+       /* Value is the name of package PACKAGE.  */)
+  (Lisp_Object package)
+{
+  package = package_from_designator (package);
+  return XPACKAGE (package)->name;
+}
+
+DEFUN ("package-nicknames", Fpackage_nicknames,
+       Spackage_nicknames, 1, 1, 0, doc:
+       /* Valus is the package nicknames of package PACKAGE.  */)
+  (Lisp_Object package)
+{
+  package = package_from_designator (package);
+  return Fcopy_sequence (XPACKAGE (package)->nicknames);
+}
+
+DEFUN ("package-shadowing-symbols", Fpackage_shadowing_symbols,
+       Spackage_shadowing_symbols, 1, 1, 0, doc:
+       /* tbd.  */)
+  (Lisp_Object package)
+{
+  package = package_from_designator (package);
+  return Fcopy_sequence (XPACKAGE (package)->shadowing_symbols);
+}
+
+DEFUN ("package-use-list", Fpackage_use_list, Spackage_use_list, 1, 1, 0, doc:
+       /* tbd.  */)
+  (Lisp_Object package)
+{
+  package = package_from_designator (package);
+  return Fcopy_sequence (XPACKAGE (package)->used_packages);
+}
+
+DEFUN ("package-used-by-list", Fpackage_used_by_list, Spackage_used_by_list,
+       1, 1, 0, doc:
+       /* tbd.  */)
+  (Lisp_Object package)
+{
+  package = package_from_designator (package);
+  Lisp_Object result = Qnil;
+  FOR_EACH_KEY_VALUE (it, Vpackage_registry)
+    if (!NILP (Fmemq (package, XPACKAGE (it.value)->used_packages)))
+      add_to_list (it.value, &result);
+  return result;
+}
+
+DEFUN ("make-package", Fmake_package, Smake_package, 0, MANY, 0,
+       doc: /* Value is a new package with name NAME.
+
+NAME must be a string designator.
+
+Additional arguments are specified as keyword/argument pairs.  The
+following keyword arguments are defined:
+
+:nicknames NICKNAMES is a list of additional names which may be used
+to refer to the new package.
+
+:use USE specifies a list of zero or more packages the external
+symbols of which are to be inherited by the new package. See the
+function 'use-package'.
+
+usage: (make-package NAME &rest KEYWORD-ARGS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  if (nargs <= 0)
+    signal_error ("make-package: no package name", Qnil);
+
+  /* Determine the package's name as a string.  A package with the
+     same name or nickname must not be known yet.  */
+  const Lisp_Object name = string_from_designator (args[0]);
+  ++args;
+  --nargs;
+
+  /* The vector `used' is used to keep track of arguments that have
+     been consumed below.  */
+  USE_SAFE_ALLOCA;
+  char *used_args = SAFE_ALLOCA (nargs * sizeof *used_args);
+  memset (used_args, 0, nargs * sizeof *used_args);
+
+  /* Check for :USE.  Argument must be a list of package designators
+     for known packages.  */
+  const ptrdiff_t use_index = get_key_arg (QCuse, nargs, args, used_args);
+  const Lisp_Object use_designators = use_index ? args[use_index] : Qnil;
+  const Lisp_Object used_packages = package_list_from_designators 
(use_designators);
+
+  /* Check for :NICKNAMES.  Argument must be a list of string
+     designators.  Note that we don't check if the package name
+     appears also as a nickname, because SBCL also doesn't.  */
+  const ptrdiff_t nicknames_index = get_key_arg (QCnicknames, nargs, args, 
used_args);
+  const Lisp_Object nickname_designators = nicknames_index ? 
args[nicknames_index] : Qnil;
+  const Lisp_Object nicknames = string_list_from_designators 
(nickname_designators);
+
+  /* Now, all args should have been used up, or there's a problem.  */
+  for (ptrdiff_t i = 0; i < nargs; ++i)
+    if (!used_args[i])
+      signal_error ("make-package: invalid argument", args[i]);
+
+  const Lisp_Object package = make_package (name);
+  XPACKAGE (package)->nicknames = nicknames;
+  XPACKAGE (package)->used_packages = used_packages;
+  register_package (package);
+
+  SAFE_FREE ();
+  return package;
+}
+
+DEFUN ("list-all-packages", Flist_all_packages, Slist_all_packages, 0, 0, 0, 
doc:
+       /* Return a list of all registered packages.  */)
+  (void)
+{
+  Lisp_Object result = Qnil;
+  FOR_EACH_KEY_VALUE (it, Vpackage_registry)
+    result = Fcons (it.value, result);
+  return result;
+}
+
+DEFUN ("find-package", Ffind_package, Sfind_package, 1, 1, 0, doc:
+       /* Find the package with name or nickname NAME.
+
+If NAME is a package object, return that.  Otherwise, NAME must be a
+string designator.
+
+Value is nil if no such package exists.  */)
+  (Lisp_Object name)
+{
+  if (PACKAGEP (name))
+    return name;
+  name = string_from_designator (name);
+  return Fgethash (name, Vpackage_registry, Qnil);
+}
+
+DEFUN ("delete-package", Fdelete_package, Sdelete_package, 1, 1, 0, doc:
+       /* Delete package PACKAGE.
+
+If the operation is successful, delete-package returns t, otherwise
+nil.  The effect of delete-package is that the name and nicknames of
+PACKAGE cease to be recognized package names.  The package object is
+still a package (i.e., packagep is true of it) but package-name
+returns nil.
+
+The consequences of deleting the EMACS package or the KEYWORD package
+are undefined.  The consequences of invoking any other package
+operation on package once it has been deleted are unspecified. In
+particular, the consequences of invoking find-symbol, intern and other
+functions that look for a symbol name in a package are unspecified if
+they are called with *package* bound to the deleted package or with
+the deleted package as an argument.
+
+If package is a package object that has already been deleted,
+delete-package immediately returns nil.
+
+After this operation completes, the home package of any symbol whose
+home package had previously been package is
+implementation-dependent. Except for this, symbols accessible in
+package are not modified in any other way; symbols whose home package
+is not package remain unchanged.  */)
+  (Lisp_Object package)
+{
+  /* Deleting an already deleted package.  */
+  if (NILP (XPACKAGE (package)->name))
+    return Qnil;
+
+  package = package_from_designator (package);
+
+  /* Don't allow deleting the standard packages.  */
+  if (EQ (package, Vemacs_package) || EQ (package, Vkeyword_package))
+    signal_error ("Cannot delete standard package", package);
+
+  unregister_package (package);
+  XPACKAGE (package)->name = Qnil;
+  return Qt;
+}
+
+DEFUN ("rename-package", Frename_package, Srename_package, 2, 3, 0, doc:
+       /* Replace the name and nicknames of package.
+
+PACKAGE must be a package designator.
+
+NEW-NAME is the new name for the package.
+
+Optional NEW-NICKNAMES replaces the nicknames of the package.  Note
+that omitting NEW-NICKNAMES removes all nicknames.
+
+The consequences are undefined if NEW-NAME or any NEW-NICKNAMES
+conflicts with any existing package names.
+
+Value is the package object after renaming.  */)
+  (Lisp_Object package, Lisp_Object new_name, Lisp_Object new_nicknames)
+{
+  package = package_from_designator (package);
+
+  /* Don't rename deleted package, which is what CLHS says, and SBCL
+     does.  */
+  if (NILP (XPACKAGE (package)->name))
+    signal_error ("Cannot rename deleted package", package);
+
+  /* Don't change anything if register would fail.  */
+  new_name = string_from_designator (new_name);
+  new_nicknames = string_list_from_designators (new_nicknames);
+  const Lisp_Object conflict = conflicting_package (new_name, new_nicknames);
+  if (!NILP (conflict))
+    signal_error("Package name conflict", conflict);
+
+  unregister_package (package);
+  XPACKAGE (package)->name = new_name;
+  XPACKAGE (package)->nicknames = new_nicknames;
+  register_package (package);
+  return package;
+}
+
+DEFUN ("find-symbol", Ffind_symbol, Sfind_symbol, 1, 2, 0, doc:
+       /* Find symbol with name NAME in PACKAGE.
+If PACKAGE is omitted, use the current package.
+
+Value is nil if no symbol is found.
+
+Otherwise, value is a list (SYMBOL STATUS), where SYMBOL is the
+symbol that was found, and STATUS is one of the following:
+
+`internal' if SYMBOL is present in PACKAGE as an internal symbol.
+
+`external' if SYMBOL is present in PACKAGE as an external symbol.
+
+`inherited' if SYMBOL is inherited via `use-package'. */)
+  (Lisp_Object name, Lisp_Object package)
+{
+  CHECK_STRING (name);
+  package = package_or_default (package);
+  Lisp_Object symbol = lookup_symbol (name, package);
+  return symbol_and_status (symbol, package);
+}
+
+/* FIXME: Make this somehow compatible with Emacs' intern?  */
+
+DEFUN ("cl-intern", Fcl_intern, Scl_intern, 1, 2, 0, doc:
+       /* Enter a symbol with name NAME into PACKAGE.
+
+If PACKAGE is omitted, use the current package.
+
+Value is a list (SYMBOL STATUS).
+
+If a symbol with name NAME is already accessible, SYMBOL is that
+symbol, and STATUS is it's status in the package.
+
+Otherwise, a new SYMBOL is created, whose status 'external' if
+package is the keyword package, or 'internal' if not.  */)
+  (Lisp_Object name, Lisp_Object package)
+{
+  CHECK_STRING (name);
+  package = package_or_default (package);
+  Lisp_Object symbol = pkg_intern_symbol (name, package);
+  return symbol_and_status (symbol, package);
+}
+
+DEFUN ("cl-unintern", Fcl_unintern, Scl_unintern, 1, 2, 0, doc:
+       /* tbd */)
+  (Lisp_Object symbolname, Lisp_Object package)
+{
+  return Qnil;
+}
+
+DEFUN ("export", Fexport, Sexport, 1, 2, 0, doc: /* tbd  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  return Qt;
+}
+
+DEFUN ("unexport", Funexport, Sunexport, 1, 2, 0, doc: /* tbd  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  return Qt;
+}
+
+DEFUN ("import", Fimport, Simport, 1, 2, 0, doc: /* tbd  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  return Qt;
+}
+
+DEFUN ("shadow", Fshadow, Sshadow, 1, 2, 0, doc:
+       /* Make an internal symbol in PACKAGE with the same name as
+  each of the specified SYMBOLS, adding the new symbols to the
+  package-shadowing-symbols.  If a symbol with the given name is
+  already present in PACKAGE, then the existing symbol is placed in
+  the shadowing symbols list if it is not already present.  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  package = package_or_default (package);
+  Lisp_Object tail = symbols_to_list (symbols);
+  FOR_EACH_TAIL (tail)
+    {
+      const Lisp_Object name = string_from_designator (XCAR (tail));
+      const Lisp_Object found = Ffind_symbol (name, package);
+      Lisp_Object symbol = NILP (found) ? Qnil : XCAR (found);
+      if (NILP (symbol) || EQ (XCAR (XCDR (found)), QCinherited))
+       {
+         symbol = Fmake_symbol (name);
+         pkg_insert_new_symbol (symbol, package);
+       }
+      add_shadowing_symbol (symbol, package);
+    }
+  return Qt;
+}
+
+DEFUN ("shadowing-import", Fshadowing_import, Sshadowing_import, 1, 2, 0,
+       doc: /* Import SYMBOLS into PACKAGE, disregarding any name conflict.
+  If a symbol of the same name is present, then it is uninterned.  The
+  symbols are added to the 'package-shadowing-symbols'.  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  package = package_or_default (package);
+  Lisp_Object tail = symbols_to_list (symbols);
+  FOR_EACH_TAIL (tail)
+    {
+      const Lisp_Object import = XCAR (tail);
+      const Lisp_Object found = Ffind_symbol (SYMBOL_NAME (import), package);
+      const Lisp_Object symbol = NILP (found) ? Qnil : XCAR (found);
+      const Lisp_Object status = NILP (found) ? Qnil : XCAR (XCDR (found));
+
+      if (!EQ (import, symbol))
+       {
+         /* Inintern if symbol with the same name is found.  */
+         if (EQ (status, QCinternal) || EQ (status, QCexternal))
+           {
+             remove_shadowing_symbol (symbol, package);
+             Fcl_unintern (symbol, package);
+           }
+       }
+      add_shadowing_symbol (import, package);
+    }
+  return Qt;
+}
+
+DEFUN ("use-package", Fuse_package, Suse_package, 1, 2, 0,
+       doc: /* tbd  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  return Qt;
+}
+
+DEFUN ("unuse-package", Funuse_package, Sunuse_package, 1, 2, 0,
+       doc: /* tbd  */)
+  (Lisp_Object symbols, Lisp_Object package)
+{
+  return Qt;
+}
+
+
+/***********************************************************************
+                           Initialization
+ ***********************************************************************/
+
+/* Loop over all known, interned symbols, and fix their packages.  */
+
+void
+fix_symbol_packages (void)
+{
+  if (symbols_fixed_p)
+    return;
+  symbols_fixed_p = true;
+
+  for (size_t i = 0; i < ASIZE (Vobarray); ++i)
+    {
+      Lisp_Object bucket = AREF (Vobarray, i);
+      if (SYMBOLP (bucket))
+       for (struct Lisp_Symbol *sym = XSYMBOL (bucket); sym; sym = 
sym->u.s.next)
+         /* Probably not, let's see wht I do, so just in case... */
+         if (!PACKAGEP (sym->u.s.package))
+           {
+#if 0
+             /* Fix symbol names of keywordsby removing the leading colon.  */
+             Lisp_Object name = sym->u.s.name;
+             struct Lisp_String *s = XSTRING (name);
+             if (s->u.s.size_byte == -2 && s->u.s.size > 0 && *s->u.s.data == 
':')
+               {
+                 ++s->u.s.data;
+                 --s->u.s.size;
+               }
+#endif
+
+             const Lisp_Object package = *SDATA (sym->u.s.name) == ':'
+               ? Vkeyword_package : Vemacs_package;
+             Lisp_Object symbol;
+             XSETSYMBOL (symbol, sym);
+             pkg_insert_new_symbol (symbol, package);
+           }
+    }
+}
+
+/* Called very early, after init_alloc_once and init_obarray_once.
+   Not called when starting a dumped Emacs.  */
+
+void
+init_pkg_once (void)
+{
+}
+
+/* Not called when starting a dumped Emacs.  */
+
+void
+syms_of_pkg (void)
+{
+  defsubr (&Scl_intern);
+  defsubr (&Scl_unintern);
+  defsubr (&Sdelete_package);
+  defsubr (&Sexport);
+  defsubr (&Sfind_package);
+  defsubr (&Sfind_symbol);
+  defsubr (&Simport);
+  defsubr (&Slist_all_packages);
+  defsubr (&Smake_package);
+  defsubr (&Spackage_name);
+  defsubr (&Spackage_nicknames);
+  defsubr (&Spackage_shadowing_symbols);
+  defsubr (&Spackage_use_list);
+  defsubr (&Spackage_used_by_list);
+  defsubr (&Spackagep);
+  defsubr (&Srename_package);
+  defsubr (&Sshadow);
+  defsubr (&Sshadowing_import);
+  defsubr (&Sunexport);
+  defsubr (&Sunuse_package);
+  defsubr (&Suse_package);
+
+  DEFSYM (QCexternal, ":external");
+  DEFSYM (QCinherited, ":inherited");
+  DEFSYM (QCinternal, ":internal");
+  DEFSYM (QCnicknames, ":nicknames");
+  DEFSYM (QCuse, ":use");
+
+  DEFSYM (Qearmuffs_package, "*package*");
+  DEFSYM (Qemacs_package, "emacs-package");
+  DEFSYM (Qkeyword_package, "keyword-package");
+  DEFSYM (Qpackage_registry, "package-registry");
+
+  DEFSYM (Qkeyword, "keyword");
+  DEFSYM (Qpackage, "package");
+
+  DEFVAR_LISP ("package-registry", Vpackage_registry,
+              doc: "A map of names to packages.");
+  Vpackage_registry = CALLN (Fmake_hash_table, QCtest, Qequal);
+
+  DEFVAR_LISP ("emacs-package", Vemacs_package, doc: "The emacs package.");
+  Vemacs_package = CALLN (Fmake_package, Qemacs);
+  make_symbol_constant (Qemacs_package);
+
+  DEFVAR_LISP ("keyword-package", Vkeyword_package, doc: "The keyword 
package.");
+  Vkeyword_package = CALLN (Fmake_package, Qkeyword,
+                           QCnicknames, list1 (intern_c_string ("")));
+  make_symbol_constant (Qkeyword_package);
+
+  DEFVAR_LISP ("*package*", Vearmuffs_package, doc: "The current package.");
+  Vearmuffs_package = Vemacs_package;
+  XSYMBOL (Qearmuffs_package)->u.s.declared_special = true;
+}
+
+/* Called when starting a dumped Emacs.  */
+
+void
+init_pkg (void)
+{
+}
diff --git a/src/print.c b/src/print.c
index 1c96ec14b8..063aef28f4 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1803,6 +1803,17 @@ print_vectorlike (Lisp_Object obj, Lisp_Object 
printcharfun, bool escapeflag,
       printchar ('>', printcharfun);
       break;
 
+    case PVEC_PACKAGE:
+      if (STRINGP (XPACKAGE (obj)->name))
+       {
+         print_c_string ("#<package \"", printcharfun);
+         print_string (XPACKAGE (obj)->name, printcharfun);
+         print_c_string ("\">", printcharfun);
+       }
+      else
+       print_c_string ("#<deleted package>", printcharfun);
+      break;
+
     case PVEC_XWIDGET:
 #ifdef HAVE_XWIDGETS
       {
@@ -2371,6 +2382,38 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, 
bool escapeflag)
            break;
          }
 
+       /* Package prefix, maybe.  */
+       const Lisp_Object package = SYMBOL_PACKAGE (obj);
+       if (NILP (package) || EQ (package, Vearmuffs_package))
+         {
+           /* Nothing to do for uninterned symbols, or symbols in
+              their home package.  */
+         }
+       else if (EQ (package, Vkeyword_package))
+         {
+           /* FIXME: If symbol names of keywords didn't include the
+              colon, we'd have to print it here.  */
+           // print_c_string (":", printcharfun);
+         }
+       else
+         {
+           const Lisp_Object found
+             = Ffind_symbol (SYMBOL_NAME (obj), Vearmuffs_package);
+           if (!NILP (found) && EQ (XCAR (found), obj))
+             {
+               /* Don't print qualification if accessible in current
+                  package.  */
+             }
+           else
+             {
+               print_object (XPACKAGE (package)->name, printcharfun, false);
+               if (SYMBOL_EXTERNAL_P (obj))
+                 print_c_string (":", printcharfun);
+               else
+                 print_c_string ("::", printcharfun);
+             }
+         }
+
        ptrdiff_t i = 0;
        for (ptrdiff_t i_byte = 0; i_byte < size_byte; )
          {
diff --git a/test/src/pkg-tests.el b/test/src/pkg-tests.el
new file mode 100644
index 0000000000..1cfea6a632
--- /dev/null
+++ b/test/src/pkg-tests.el
@@ -0,0 +1,153 @@
+;;; pkg-tests.el --- tests for src/pkg.c  -*- lexical-binding:t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+(require 'cl-lib)
+
+(defmacro with-packages (packages &rest body)
+  (declare (indent 1))
+  (let (vars shoulds makes deletions)
+    (dolist (p packages)
+      (let ((name (if (consp p) (cl-first p) p))
+            (options (if (consp p) (cl-rest p))))
+        (push `(,name nil) vars)
+        (push `(should (not (find-package ',name))) shoulds)
+        (push `(setq ,name (make-package ',name ,@options)) makes)
+        (push `(when (packagep ,name) (delete-package ,name)) deletions)))
+    `(let (,@vars)
+       ,@(nreverse shoulds)
+       (unwind-protect
+          (progn ,@(nreverse makes) ,@body)
+        ,@(nreverse deletions)))))
+
+(ert-deftest pkg-tests-make-package-invalid ()
+  (should-error (make-package))
+  (should-error (make-package 1.0))
+  (should-error (make-package "x" :hansi 1))
+  (should-error (make-package "x" :nicknames))
+  (should-error (make-package "x" :nicknames 1))
+  (should-error (make-package "x" :use))
+  (should-error (make-package "x" :use 1)))
+
+(ert-deftest pkg-tests-standard-packages ()
+  (should (packagep (find-package "emacs")))
+  (should (packagep (find-package "keyword")))
+  (should (member "" (package-nicknames (find-package "keyword")))))
+
+(ert-deftest pkg-tests-make-package-nicknames ()
+  (with-packages ((x :nicknames '(x z)))
+    ;; Package name allowed in nicknames.
+    (should (equal (package-nicknames x) '("x" "z"))))
+  (with-packages ((x :nicknames '(y y z)))
+    ;; Duplicates removed, order-preserving.
+    (should (equal (package-nicknames x) '("y" "z")))))
+
+(ert-deftest pkg-tests-package-use-list ()
+  (should nil))
+
+(ert-deftest pkg-tests-package-used-by-list ()
+  (should nil))
+
+(ert-deftest pkg-tests-package-shadowing-symbols ()
+  (should nil))
+
+(ert-deftest pkg-tests-list-all-packages ()
+  (with-packages (x y z)
+    (let ((all (list-all-packages)))
+      (should (member x all))
+      (should (member y all))
+      (should (member z all)))))
+
+(ert-deftest pkg-tests-package-find-package ()
+  (with-packages (x)
+    (should-error (find-package 1.0))
+    (should (eq (find-package 'x) x))
+    (should (eq (find-package "x") x))
+    (should (eq (find-package ?x) x))
+    (should (not (find-package "X"))))
+  (with-packages ((x :nicknames '("y" "z")))
+    (should (eq (find-package 'y) (find-package 'x)))
+    (should (eq (find-package 'z) (find-package 'x)))))
+
+(ert-deftest pkg-tests-delete-package ()
+  (with-packages (x)
+    (should (delete-package x))
+    (should (null (delete-package x)))
+    (should (null (package-name x)))
+    (should (not (find-package 'x))))
+  (with-packages (x)
+    (should (delete-package "x"))
+    (should-error (delete-package "x")))
+  (let ((original (list-all-packages)))
+    (with-packages ((x :nicknames '(y)))
+      (should (delete-package x))
+      (should (null (delete-package x)))
+      (should (not (find-package 'x)))
+      (should (not (find-package 'y))))))
+
+(ert-deftest pkg-tests-rename-package ()
+  (with-packages (x y)
+    (should (eq x (rename-package x 'a '(b))))
+    (should (not (find-package 'x)))
+    (should (eq (find-package 'a) x))
+    (should (eq (find-package 'b) x))
+    ;; Can't rename to an existing name or nickname.
+    (should-error (rename-package y 'a))
+    (should-error (rename-package y 'c :nicknames '("b")))
+    ;; Original package name and nicknames are unchanged.
+    (should (equal (package-name x) "a"))
+    (should (equal (package-nicknames x) '("b")))
+    ;; Can't rename deleted package.
+    (should (delete-package x))
+    (should-error (rename-package x 'd))))
+
+(ert-deftest pkg-tests-find-symbol ()
+  (should nil))
+
+(ert-deftest pkg-tests-cl-intern ()
+  (should nil))
+
+(ert-deftest pkg-tests-cl-unintern ()
+  (should nil))
+
+(ert-deftest pkg-tests-export ()
+  (should nil))
+
+(ert-deftest pkg-tests-unexport ()
+  (should nil))
+
+(ert-deftest pkg-tests-import ()
+  (should nil))
+
+(ert-deftest pkg-tests-shadow ()
+  (should nil))
+
+(ert-deftest pkg-tests-shadowing-import ()
+  (should nil))
+
+(ert-deftest pkg-tests-shadowing-use-package ()
+  (should nil))
+
+(ert-deftest pkg-tests-shadowing-unuse-package ()
+  (should nil))