From: Gerd Möllmann Date: Tue, 18 Oct 2022 16:31:58 +0000 (+0200) Subject: Move more package stuff to Lisp X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9a263a0782b977a072a312aba39ebd8b42fcd5eb;p=emacs.git Move more package stuff to Lisp --- diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el index cc3556fc9d1..42740414013 100644 --- a/lisp/emacs-lisp/pkg.el +++ b/lisp/emacs-lisp/pkg.el @@ -70,7 +70,7 @@ but have common elements %s" key1 key2 common)))) (defun pkg-stringify-name (name kind) (cl-typecase name (string name) - (symbol (symbol-name name)) + (symbol (cl-symbol-name name)) (base-char (char-to-string name)) (t (error "Bogus %s name: %s" kind name)))) @@ -97,9 +97,49 @@ but have common elements %s" key1 key2 common)))) (mapcar (lambda (name) (pkg-find-or-make-package name)) names)) +(defun pkg-package-or-lose (name) + (if (packagep name) + name + (let ((pkg-name (pkg-stringify-name name "package"))) + (or (find-package pkg-name) + (error "No package %s found" name))))) + +(defun pkg--check-name-conflicts (package) + (cl-flet ((check (name) + (when (gethash name *package-registry*) + (error "%s conflicts with existing package" name)))) + (check (package-%name package)) + (dolist (n (package-%nicknames package)) (check n)))) + +(defun pkg--add-to-registry (package) + (pkg--check-name-conflicts package) + (puthash (package-%name package) package *package-registry*) + (mapc (lambda (name) (puthash name package *package-registry*)) + (package-%nicknames package))) + +(defun pkg--remove-from-registry (package) + (remhash (package-%name package) *package-registry*) + (mapc (lambda (name) (remhash name *package-registry*)) + (package-%nicknames package))) + +(defun pkg--package-or-default (package) + (cond ((packagep package) package) + ((null package) *package*) + (t (pkg-package-or-lose package)))) + +(defun pkg--symbol-listify (thing) + (cond ((listp thing) + (dolist (s thing) + (unless (symbolp s) + (error "%s is not a symbol") s)) + thing) + ((symbolp thing) + (list thing)) + (t + (error "%s is neither a symbol nor a list of symbols" thing)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Creating packages +;; Basic stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload @@ -114,9 +154,110 @@ but have common elements %s" key1 key2 common)))) (package-%use-list package) use) package)) +;;;###autoload +(defun package-name (package) + (setq package (pkg-package-or-lose package)) + (package-%name package)) + +;;;###autoload +(defun package-nicknames (package) + (setq package (pkg-package-or-lose package)) + (copy-sequence (package-%nicknames package))) + +;;;###autoload +(defun package-shadowing-symbols (package) + (setq package (pkg-package-or-lose package)) + (copy-sequence (package-%shadowing-symbols package))) + +;;;###autoload +(defun package-use-list (package) + (setq package (pkg-package-or-lose package)) + (copy-sequence (package-%use-list package))) + +;;;###autoload +(defun package-used-by-list (package) + (setq package (pkg-package-or-lose package)) + (let ((used-by nil)) + (maphash (lambda (_n p) + (when (memq package (package-%use-list p)) + (push p used-by))) + *package-registry*) + used-by)) + +;;;###autoload +(defun list-all-packages () + (let ((all nil)) + (maphash (lambda (_name package) + (cl-pushnew package all)) + *package-registry*) + all)) + +;;;###autoload +(defun find-package (package) + (if (packagep package) + package + (let ((name (pkg-stringify-name package "package name"))) + (gethash name *package-registry*)))) + +;;;###autoload +(defun delete-package (package) + (unless (null package) + (setq package (pkg-package-or-lose package)) + (when (or (eq package *emacs-package*) + (eq package *keyword-package*)) + (error "Cannot delete standard package %s" package)) + (pkg--remove-from-registry (package-%name package)) + (setf (package-%name package) nil) + t)) + +;;;###autoload +(defun rename-package (package new-name &optional new-nicknames) + (setq package (pkg-package-or-lose package)) + (unless (package-%name package) + ;; That's what CLHS says, and SBCL does... + (error "Cannot rename deleted package")) + (pkg--remove-from-registry package) + (setf (package-%nicknames package) new-nicknames) + (setf (package-%name package) new-name) + (pkg--add-to-registry package)) + +;;;###autoload +(defun export (symbols &optional package) + (setq package (pkg--package-or-default package)) + (error "not yet implemented")) + +;;;###autoload +(defun unexport (symbols &optional package) + (setq package (pkg--package-or-default package)) + (error "not yet implemented")) +;;;###autoload +(defun import (symbols &optional package) + (let ((package (pkg--package-or-default package)) + (symbols (pkg--symbol-listify symbols))) + (error "not yet implemented")) +;;;###autoload +(defun shadow (symbols &optional package) + (setq package (pkg--package-or-default package)) + (error "not yet implemented")) + +;;;###autoload +(defun shadowing-import (symbols &optional package) + (setq package (pkg--package-or-default package)) + (error "not yet implemented")) + +;;;###autoload +(defun use-package (use package) + (setq package (pkg--package-or-default package)) + (cl-pushnew (package-%use-list package) package)) + +;;;###autoload +(defun unuse-package (unuse package) + (setq package (pkg--package-or-default package)) + (setf (package-%use-list package) + (delq package (package-%use-list package)))) ;; (defun pkg-enter-new-nicknames (package nicknames) ;; (cl-check-type nicknames list) diff --git a/src/lisp.h b/src/lisp.h index 42f35656232..e911e68e760 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2286,6 +2286,7 @@ extern Lisp_Object pkg_intern_maybe_keyword (Lisp_Object name); extern void pkg_break (void); extern void pkg_define_builtin_symbols (void); extern void pkg_map_symbols_c_fn (void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg); +extern Lisp_Object pkg_find_package (Lisp_Object name); /* Return whether a value might be a valid docstring. diff --git a/src/lread.c b/src/lread.c index f322dc43e7b..f3d7b605df9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4294,7 +4294,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) if (*symbol_start == ':') { ++symbol_start; - package = Ffind_package (Qkeyword); + package = Vkeyword_package; eassert (!NILP (package)); } } @@ -4313,7 +4313,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) /* If there is no package with the give name, error. PKG-FIXME is it okay to signal like this here? Is there a better way? */ - package = Ffind_package (pkg_name); + package = pkg_find_package (pkg_name); if (NILP (package)) pkg_error ("unknown package '%s'", read_buffer); diff --git a/src/pkg.c b/src/pkg.c index 600dd3ce5e7..bb6cd5d2c18 100644 --- a/src/pkg.c +++ b/src/pkg.c @@ -100,52 +100,15 @@ h_next (struct h_iter *it) #define FOR_EACH_KEY_VALUE(it, table) \ for (struct h_iter it = h_init (table); h_valid (&it); h_next (&it)) -/* Cons ELT onto *LIST, and return *LIST. */ - -static void -add_to_list (Lisp_Object elt, Lisp_Object *list) -{ - *list = Fcons (elt, *list); -} - -/* Cons ELT onto *LIST, if not already present. Return *LIST. */ - -static void -add_new_to_list (Lisp_Object elt, Lisp_Object *list) -{ - if (NILP (Fmemq (elt, *list))) - add_to_list (elt, 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) +Lisp_Object +pkg_find_package (Lisp_Object name) { - 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); + CHECK_STRING (name); + return Fgethash (name, Vpackage_registry, Qnil); } /* Create and return a new Lisp package object for a package with name @@ -182,32 +145,6 @@ string_from_designator (Lisp_Object 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. */ @@ -233,7 +170,7 @@ package_from_designator (Lisp_Object designator) if (PACKAGEP (designator)) return designator; const Lisp_Object name = string_from_designator (designator); - const Lisp_Object package = Ffind_package (name); + const Lisp_Object package = pkg_find_package (name); return check_package (package); } @@ -249,42 +186,20 @@ package_or_default (Lisp_Object designator) 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); + const Lisp_Object conflict = pkg_find_package (name); if (!NILP (conflict)) return conflict; Lisp_Object tail = nicknames; FOR_EACH_TAIL (tail) { - const Lisp_Object conflict = Ffind_package (XCAR (tail)); + const Lisp_Object conflict = pkg_find_package (XCAR (tail)); if (!NILP (conflict)) return conflict; } @@ -292,25 +207,6 @@ conflicting_package (Lisp_Object name, Lisp_Object nicknames) return Qnil; } -/* Register NAME as a name for PACKAGE in the package registry. */ - -static void -add_to_package_registry (Lisp_Object name, Lisp_Object package) -{ - eassert (STRINGP (name)); - eassert (PACKAGEP (package)); - Fputhash (name, package, Vpackage_registry); -} - -/* Remove NAME as a name for PACKAGE from the package registry. */ - -static void -remove_from_package_registry (Lisp_Object name) -{ - eassert (STRINGP (name)); - Fremhash (name, Vpackage_registry); -} - /* Register package PACKAGE in the package registry, that is, make it known under its name and all its nicknames. */ @@ -318,31 +214,12 @@ 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); - - add_to_package_registry (pkg->name, package); + Fputhash (pkg->name, package, Vpackage_registry); Lisp_Object tail = pkg->nicknames; FOR_EACH_TAIL (tail) - add_to_package_registry (XCAR (tail), package); -} - -/* 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) -{ - remove_from_package_registry (XPACKAGE (package)->name); - Lisp_Object tail = XPACKAGE (package)->nicknames; - FOR_EACH_TAIL (tail) - remove_from_package_registry (XCAR (tail)); + Fputhash (XCAR (tail), package, Vpackage_registry); } - /*********************************************************************** Symbol table ***********************************************************************/ @@ -433,16 +310,6 @@ pkg_add_symbol (Lisp_Object symbol, Lisp_Object package) return add_to_package_symbols (symbol, 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 @@ -834,167 +701,6 @@ DEFUN ("packagep", Fpackagep, Spackagep, 1, 1, 0, doc: 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)->use_list); -} - -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)->use_list))) - add_to_list (it.value, &result); - return result; -} - -DEFUN ("%register-package", Fregister_package, Sregister_package, 1, 1, 0, doc: - /* Register PACKAGE in the package registry. */) - (Lisp_Object package) -{ - CHECK_PACKAGE (package); - register_package (package); - return Qnil; -} - - -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. @@ -1046,92 +752,6 @@ DEFUN ("cl-unintern", Fcl_unintern, Scl_unintern, 1, 2, 0, doc: return pkg_unintern_symbol (symbol, package); } -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_add_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; -} - DEFUN ("pkg-break", Fpkg_read, Spkg_read, 1, 1, 0, doc: /* tbd */) (Lisp_Object stream) @@ -1301,26 +921,9 @@ syms_of_pkg (void) defsubr (&Smake_percent_package); defsubr (&Scl_intern); defsubr (&Scl_unintern); - defsubr (&Sdelete_package); - defsubr (&Sexport); - defsubr (&Sfind_package); defsubr (&Sfind_symbol); - defsubr (&Simport); - defsubr (&Slist_all_packages); - defsubr (&Spackage_name); - defsubr (&Spackage_nicknames); - defsubr (&Spackage_shadowing_symbols); - defsubr (&Spackage_use_list); - defsubr (&Spackage_used_by_list); defsubr (&Spackagep); defsubr (&Spkg_read); - defsubr (&Sregister_package); - defsubr (&Srename_package); - defsubr (&Sshadow); - defsubr (&Sshadowing_import); - defsubr (&Sunexport); - defsubr (&Sunuse_package); - defsubr (&Suse_package); Fmake_variable_buffer_local (Qpackage_prefixes); }