Add pkg_set_status and Lisp defun for it

diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el
index 6e8dfd01a12fb24b9620e3fbd49c1cecd03e3f06..58dae7dcdc63feb5bac2d59e36bb0c7e05e01413 100644 (file)
--- 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.")
-
 \f
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                               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 fe3199244c5e9d4038ec2b0d2518b7c27505eed8..8570990bebe30ea81a39152d9426eaf5e9b2cf83 100644 (file)
--- 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);
+}
+
 \f
 /***********************************************************************
                            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);