[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
pkg cc6095482b 73/76: Add pkg_set_status and Lisp defun for it
From: |
Gerd Moellmann |
Subject: |
pkg cc6095482b 73/76: Add pkg_set_status and Lisp defun for it |
Date: |
Fri, 21 Oct 2022 00:16:20 -0400 (EDT) |
branch: pkg
commit cc6095482b5cdb1d96e379c19a488eb31b251e44
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>
Add pkg_set_status and Lisp defun for it
---
lisp/emacs-lisp/pkg.el | 204 +++++++++++++++++++++++++++++++++++--------------
src/pkg.c | 34 +++++++--
2 files changed, 176 insertions(+), 62 deletions(-)
diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el
index 6e8dfd01a1..58dae7dcdc 100644
--- a/lisp/emacs-lisp/pkg.el
+++ b/lisp/emacs-lisp/pkg.el
@@ -45,9 +45,6 @@
(gv-define-simple-setter package-%nicknames package-%set-nicknames)
(gv-define-simple-setter package-%use-list package-%set-use-list)
-(defvar *default-package-use-list* nil
- "List of packages to use when defpackage is used without :use.")
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpers
@@ -83,6 +80,17 @@ but have common elements %s" key1 key2 common))))
(defun pkg-find-package (name)
(gethash name *package-registry* nil))
+(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))))
+
(defun pkg-find-or-make-package (name)
(if (packagep name)
(progn
@@ -118,6 +126,7 @@ but have common elements %s" key1 key2 common))))
(package-%nicknames package)))
(defun pkg--remove-from-registry (package)
+ "Remove PACKAGE from the package registry."
(remhash (package-%name package) *package-registry*)
(mapc (lambda (name) (remhash name *package-registry*))
(package-%nicknames package)))
@@ -156,37 +165,32 @@ but have common elements %s" key1 key2 common))))
;;;###autoload
(defun package-name (package)
- (setq package (pkg-package-or-lose package))
- (package-%name package))
+ (package-%name (pkg-package-or-lose package)))
;;;###autoload
(defun package-nicknames (package)
- (setq package (pkg-package-or-lose package))
- (copy-sequence (package-%nicknames package)))
+ (package-%nicknames (pkg-package-or-lose package)))
;;;###autoload
(defun package-shadowing-symbols (package)
- (setq package (pkg-package-or-lose package))
- (copy-sequence (package-%shadowing-symbols package)))
+ (package-%shadowing-symbols (pkg-package-or-lose package)))
;;;###autoload
(defun package-use-list (package)
- (setq package (pkg-package-or-lose package))
- (copy-sequence (package-%use-list package)))
+ (package-%use-list (pkg-package-or-lose 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*)
+ (let ((package (pkg-package-or-lose package))
+ ((used-by ())))
+ (dolist (p (list-all-packages))
+ (when (memq package (package-%use-list p))
+ (cl-pushnew p used-by)))
used-by))
;;;###autoload
(defun list-all-packages ()
- (let ((all nil))
+ (let ((all ()))
(maphash (lambda (_name package)
(cl-pushnew package all))
*package-registry*)
@@ -201,29 +205,113 @@ but have common elements %s" key1 key2 common))))
;;;###autoload
(defun delete-package (package)
- (unless (null package)
- (setq package (pkg-package-or-lose package))
+ (if (and (packagep package)
+ (null (package-name package)))
+ nil
+ (let ((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))
+ (error "Cannot delete standard package"))
+ (pkg--remove-from-registry package)
(setf (package-%name package) nil)
- t))
+ 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))
+ (let ((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)))
+
+
+;;; Here...
;;;###autoload
-(defun export (_symbols &optional package)
- (setq package (pkg--package-or-default package))
+(defun export (symbols &optional package)
+ "tbd"
+ (let ((symbols (pkg--symbol-listify symbols))
+ (package (pkg--package-or-default package))
+ (syms ()))
+ (let ((syms ()))
+ ;; Ignore any symbols that are already external.
+ (dolist (sym symbols)
+ (cl-multiple-value-bind (_s status)
+ (find-symbol (cl-symbol-name sym) package)
+ (unless (or (eq :external status)
+ (memq (sym syms)))
+ (push sym syms))))
+
+ ;; Find symbols and packages with conflicts.
+ (let ((used-by (package-used-by-list package))
+ (cpackages ())
+ (cset ()))
+ (dolist (sym syms)
+ (let ((name (cl-symbol-name sym)))
+ (dolist (p used-by)
+ (cl-multiple-value-bind (s w)
+ (find-symbol name p)
+ (when (and w (not (eq s sym))
+ (not (member s (package-%shadowing-symbols p))))
+ (pushnew sym cset)
+ (pushnew p cpackages))))))
+
+ (when cset
+ (restart-case
+ (error
+ 'simple-package-error
+ :package package
+ :format-control
+ (intl:gettext "Exporting these symbols from the ~A package:~%~S~%~
+ results in name conflicts with these packages:~%~{~A ~}")
+ :format-arguments
+ (list (package-%name package) cset
+ (mapcar #'package-%name cpackages)))
+ (unintern-conflicting-symbols ()
+ :report (lambda (stream)
+ (write-string (intl:gettext "Unintern conflicting
symbols.") stream))
+ (dolist (p cpackages)
+ (dolist (sym cset)
+ (moby-unintern sym p))))
+ (skip-exporting-these-symbols ()
+ :report (lambda (stream)
+ (write-string (intl:gettext "Skip exporting conflicting
symbols.") stream))
+ (setq syms (nset-difference syms cset))))))
+ ;;
+ ;; Check that all symbols are accessible. If not, ask to import them.
+ (let ((missing ())
+ (imports ()))
+ (dolist (sym syms)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (cond ((not (and w (eq s sym))) (push sym missing))
+ ((eq w :inherited) (push sym imports)))))
+ (when missing
+ (with-simple-restart
+ (continue (intl:gettext "Import these symbols into the ~A package.")
+ (package-%name package))
+ (error 'simple-package-error
+ :package package
+ :format-control
+ (intl:gettext "These symbols are not accessible in the ~A
package:~%~S")
+ :format-arguments
+ (list (package-%name package) missing)))
+ (import missing package))
+ (import imports package))
+ ;;
+ ;; And now, three pages later, we export the suckers.
+ (let ((internal (package-internal-symbols package))
+ (external (package-external-symbols package)))
+ (dolist (sym syms)
+ (nuke-symbol internal (symbol-name sym))
+ (add-symbol external sym)))
+ t))
+
+
+
+
(error "not yet implemented"))
;;;###autoload
@@ -259,7 +347,11 @@ but have common elements %s" key1 key2 common))))
(setf (package-%use-list package)
(delq package (package-%use-list package))))
-;; (defun pkg-enter-new-nicknames (package nicknames)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; defpackage
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (defun pkg--enter-new-nicknames (package nicknames)
;; (cl-check-type nicknames list)
;; (dolist (n nicknames)
;; (let* ((n (pkg-package-namify n))
@@ -276,19 +368,18 @@ but have common elements %s" key1 key2 common))))
;; n (package-name found)))))))
;; (defun pkg-defpackage (name nicknames size shadows shadowing-imports
-;; use imports interns exports doc-string)
-;; (let ((package (or (find-package name)
-;; (progn
-;; (when (eq use :default)
-;; (setf use *default-package-use-list*))
-;; (make-package name
-;; :use nil
-;; :size (or size 10))))))
+;; use imports interns exports doc-string)
+;; (let ((package (find-package name)))
+;; (unless package
+;; (setq package (make-package name :use nil :size (or size 10))))
;; (unless (string= (package-name package) name)
-;; (error "%s is a nick-name for the package %s" name (package-name
name)))
-;; (pkg-enter-new-nicknames package nicknames)
+;; (error "%s is a nickname for the package %s"
+;; name (package-name package)))
+
+;; Nicknames
+;; (pkg--enter-new-nicknames package nicknames)
-;; ;; Shadows and Shadowing-imports.
+;; Shadows and Shadowing-imports.
;; (let ((old-shadows (package-%shadowing-symbols package)))
;; (shadow shadows package)
;; (dolist (sym-name shadows)
@@ -303,18 +394,17 @@ but have common elements %s" key1 key2 common))))
;; (warn "%s also shadows the following symbols: %s"
;; name old-shadows)))
-;; ;; Use
-;; (unless (eq use :default)
-;; (let ((old-use-list (package-use-list package))
-;; (new-use-list (mapcar #'package-or-lose use)))
-;; (use-package (cl-set-difference new-use-list old-use-list) package)
-;; (let ((laterize (cl-set-difference old-use-list new-use-list)))
-;; (when laterize
-;; (unuse-package laterize package)
+;; Use
+;; (let ((old-use-list (package-use-list package))
+;; (new-use-list (mapcar #'package-or-lose use)))
+;; (use-package (cl-set-difference new-use-list old-use-list) package)
+;; (let ((laterize (cl-set-difference old-use-list new-use-list)))
+;; (when laterize
+;; (unuse-package laterize package)
;; (warn "%s previously used the following packages: %s"
-;; name laterize)))))
+;; name laterize))))
-;; ;; Import and Intern.
+;; Import and Intern.
;; (dolist (sym-name interns)
;; (intern sym-name package))
;; (dolist (imports-from imports)
@@ -323,7 +413,7 @@ but have common elements %s" key1 key2 common))))
;; (import (list (find-or-make-symbol sym-name other-package))
;; package))))
-;; ;; Exports.
+;; Exports.
;; (let ((old-exports nil)
;; (exports (mapcar (lambda (sym-name) (intern sym-name package))
exports)))
;; (do-external-symbols (sym package)
@@ -333,7 +423,7 @@ but have common elements %s" key1 key2 common))))
;; (when diff
;; (warn "%s also exports the following symbols: %s" name diff))))
-;; ;; Documentation
+;; Documentation
;; (setf (package-doc-string package) doc-string)
;; package))
diff --git a/src/pkg.c b/src/pkg.c
index fe3199244c..8570990beb 100644
--- a/src/pkg.c
+++ b/src/pkg.c
@@ -483,6 +483,23 @@ pkg_keywordp (Lisp_Object obj)
return SYMBOLP (obj) && EQ (SYMBOL_PACKAGE (obj), Vkeyword_package);
}
+static Lisp_Object
+pkg_set_status (Lisp_Object symbol, Lisp_Object package, Lisp_Object status)
+{
+ CHECK_SYMBOL (symbol);
+ CHECK_PACKAGE (package);
+ if (!EQ (status, QCinternal) && !EQ (status, QCexternal))
+ pkg_error ("Invalid symbol status %s", status);
+
+ struct Lisp_Hash_Table *h = XHASH_TABLE (PACKAGE_SYMBOLS (package));
+ ptrdiff_t i = hash_lookup (h, SYMBOL_NAME (symbol), NULL);
+ eassert (i >= 0);
+ ASET (h->key_and_value, 2 * i + 1, status);
+ return Qnil;
+}
+
+
+
/***********************************************************************
Traditional Emacs intern stuff
***********************************************************************/
@@ -817,6 +834,13 @@ DEFUN ("package-%symbols", Fpackage_percent_symbols,
return XPACKAGE (package)->symbols;
}
+DEFUN ("package-%set-status", Fpackage_percent_set_status,
+ Spackage_percent_set_status, 3, 3, 0, doc: /* Internal use only. */)
+ (Lisp_Object symbol, Lisp_Object package, Lisp_Object status)
+{
+ return pkg_set_status (symbol, package, status);
+}
+
/***********************************************************************
Initialization
@@ -889,20 +913,20 @@ syms_of_pkg (void)
doc: /* */);
Fmake_variable_buffer_local (Qpackage_prefixes);
+ defsubr (&Scl_intern);
+ defsubr (&Scl_unintern);
+ defsubr (&Sfind_symbol);
+ defsubr (&Smake_percent_package);
defsubr (&Spackage_percent_name);
defsubr (&Spackage_percent_nicknames);
defsubr (&Spackage_percent_set_name);
defsubr (&Spackage_percent_set_nicknames);
defsubr (&Spackage_percent_set_shadowing_symbols);
+ defsubr (&Spackage_percent_set_status);
defsubr (&Spackage_percent_set_use_list);
defsubr (&Spackage_percent_shadowing_symbols);
defsubr (&Spackage_percent_symbols);
defsubr (&Spackage_percent_use_list);
-
- defsubr (&Smake_percent_package);
- defsubr (&Scl_intern);
- defsubr (&Scl_unintern);
- defsubr (&Sfind_symbol);
defsubr (&Spackagep);
defsubr (&Spkg_read);
- pkg a3f99fde48 22/76: Remove Lisp_Symbol::next pointer, (continued)
- pkg a3f99fde48 22/76: Remove Lisp_Symbol::next pointer, Gerd Moellmann, 2022/10/21
- pkg 2518bc249c 39/76: Fix printing symbols, Gerd Moellmann, 2022/10/21
- pkg bbb2609103 40/76: Recognize vectors as obarrays, Gerd Moellmann, 2022/10/21
- pkg 76d59f8a03 60/76: Fix missing ')', Gerd Moellmann, 2022/10/21
- pkg 73b617eaa9 64/76: Change package symbol table layout, Gerd Moellmann, 2022/10/21
- pkg 0976c09890 37/76: Fix printing of confusing symbol names, Gerd Moellmann, 2022/10/21
- pkg aaf12c12b6 32/76: Some scribbling, Gerd Moellmann, 2022/10/21
- pkg 963de7cafe 35/76: More scribbling, Gerd Moellmann, 2022/10/21
- pkg 90c070fec6 59/76: Restore obarray.el to return vectors, Gerd Moellmann, 2022/10/21
- pkg 74da61ff09 74/76: Remove a call to pkg_break, Gerd Moellmann, 2022/10/21
- pkg cc6095482b 73/76: Add pkg_set_status and Lisp defun for it,
Gerd Moellmann <=
- pkg 7acb6c5ca1 68/76: Intrdduce pkg_find_symbol, Gerd Moellmann, 2022/10/21
- pkg 55cef2c78c 69/76: Some cleanup in pkg.c and lisp.h, Gerd Moellmann, 2022/10/21
- pkg df1e4c1e51 34/76: Allow intern with ":xyz" again, Gerd Moellmann, 2022/10/21
- pkg 513f5a0b90 21/76: Remove obarrays, Gerd Moellmann, 2022/10/21
- pkg 051a17f540 63/76: Fix some warnings, Gerd Moellmann, 2022/10/21
- pkg 0f4b419fa3 65/76: Remove unused function prototype from lisp.h, Gerd Moellmann, 2022/10/21
- pkg adf7b760f2 12/76: More symbol reading, Gerd Moellmann, 2022/10/21
- pkg e2b79c2c5a 14/76: Revert the escaping of symbol names in lisp files, Gerd Moellmann, 2022/10/21
- pkg 4d4690f8cf 75/76: Handle keywords in image specs, Gerd Moellmann, 2022/10/21
- pkg f45b266d0e 03/76: Don't use symbols that look package-qualified, Gerd Moellmann, 2022/10/21