From: Gerd Möllmann Date: Wed, 5 Oct 2022 14:15:20 +0000 (+0200) Subject: Basic functionality for packages X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=54a08db92b432cba4d4e92fec86c4f294b9191ed;p=emacs.git 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. --- diff --git a/etc/emacs_lldb.py b/etc/emacs_lldb.py index a2329e6ea4f..15efcec057e 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 1f941874ea8..5f6ebbb67e4 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 419c5e558b4..034d82e3ea0 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 221a6f58835..5fda374f1f6 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 43e81b912c6..1fa83751b33 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 22e66d3653d..ac8594d8a15 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 9710dbef8d2..f8267eea151 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 dfa4d9afb51..c458d0d51e9 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 903298f17d2..d7102b4298b 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 00000000000..52fde88da8a --- /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 + +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 . */ + +/* 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 +#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 1c96ec14b86..063aef28f4a 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 ("#name, printcharfun); + print_c_string ("\">", printcharfun); + } + else + print_c_string ("#", 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 00000000000..1cfea6a6320 --- /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 . + +;;; 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))