scratch/pkg ec637f1d0b8 2/2: More package lock stuff

[Gerd Moellmann]

branch: scratch/pkg
commit ec637f1d0b82a6c5faccd99311730bea5dd1536b
Author: Gerd Moellmann <gerd.moellmann@gmail.com>
Commit: Gerd Moellmann <gerd.moellmann@gmail.com>

    More package lock stuff
    
    * lisp/emacs-lisp/pkg.el (pkg--internal-symbols,
      pkg--external-symbols): New functions.
    (without-package-locks, with-unlocked-packages): New macros.
    (rename-package): Check package locks.
    * src/pkg.c (pkg_check_package_lock): New.
    (pkg_intern_symbol1): Use it.
    (init_pkg_once, syms_of_pkg): New var enable-packge-locks.
---
 lisp/emacs-lisp/pkg.el | 28 +++++++++++++++++++++++++++-
 src/pkg.c              | 16 ++++++++++++++--
 2 files changed, 41 insertions(+), 3 deletions(-)

diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el
index 494cf0eb437..6962421f61e 100644
--- a/lisp/emacs-lisp/pkg.el
+++ b/lisp/emacs-lisp/pkg.el
@@ -45,6 +45,11 @@
 ;;                               Helpers
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(defun pkg--check-package-lock (package)
+  (when (and (package-locked-p package)
+             enable-package-locks)
+    (error "Package %s is locked" (package-name package))))
+
 (defun pkg--check-disjoint (&rest args)
   "Check whether all given arguments specify disjoint sets of symbols.
 Each argument is of the form (:key . set)."
@@ -179,7 +184,7 @@ BUFFER must be either a buffer object or the name of an 
existing buffer."
                      (if (bufferp buffer)
                          buffer
                        (get-buffer buffer))))
-
+
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                                  Macros
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -255,6 +260,26 @@ normally, or else if an explcit return occurs the value it 
transfers."
          ,var
         ,result-form))))
 
+(defun pkg--internal-symbols (package)
+  (let (syms)
+    (do-symbols (sym (pkg--package-or-lose package))
+      (when (eq (symbol-package sym) *emacs-user-package*)
+        (push sym syms)))
+    syms))
+
+(defun pkg--external-symbols (package)
+  (let (syms)
+    (do-external-symbols (sym (pkg--package-or-lose package))
+      (when (eq (symbol-package sym) *emacs-user-package*)
+        (push sym syms)))
+    syms))
+
+(cl-defmacro without-package-locks (&body body)
+  `(let ((enable-package-locks nil))
+     (progn ,@body)))
+
+(cl-defmacro with-unlocked-packages ((&rest _packages) &body body)
+  )
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                        Basic stuff
@@ -452,6 +477,7 @@ Value is the renamed package object."
         (new-name (pkg--stringify-name new-name "package name"))
         (new-nicknames (pkg--stringify-names new-nicknames
                                              "package nickname")))
+    (pkg--check-package-lock package)
     (unless (package-%name package)
       (error "Package is deleted"))
     (pkg--remove-from-registry package)
diff --git a/src/pkg.c b/src/pkg.c
index d39f71c7e1a..110f7b08856 100644
--- a/src/pkg.c
+++ b/src/pkg.c
@@ -286,6 +286,14 @@ pkg_remove_symbol (Lisp_Object symbol, Lisp_Object package)
   Fremhash (symbol, PACKAGE_SYMBOLS (package));
 }
 
+static void
+pkg_check_package_lock (Lisp_Object package)
+{
+  if (!NILP (Venable_package_locks))
+    if (!NILP (XPACKAGE (package)->lock))
+      error ("Package %s is locked", SDATA (XPACKAGE (package)->name));
+}
+
 /* Intern a symbol with name NAME to PACKAGE.  If a symbol with name
    NAME is already accessible in PACKAGE, return that symbol.
 
@@ -315,8 +323,7 @@ pkg_intern_symbol1 (const Lisp_Object name, Lisp_Object 
package,
     symbol = existing_symbol;
   else
     {
-      if (!NILP (XPACKAGE (package)->lock))
-       error ("Package %s is locked", SDATA (XPACKAGE (package)->name));
+      pkg_check_package_lock (package);
       symbol = Fmake_symbol (name);
     }
 
@@ -988,6 +995,9 @@ init_pkg_once (void)
   staticpro (&Vsymbol_packages);
   Vsymbol_packages = Qnil;
 
+  staticpro (&Venable_package_locks);
+  Venable_package_locks = Qt;
+
   pkg_define_builtin_symbols ();
 }
 
@@ -1033,6 +1043,8 @@ syms_of_pkg (void)
   DEFVAR_LISP_NOPRO ("symbol-packages", Vsymbol_packages,
                     doc: /* */);
   Fmake_variable_buffer_local (Qsymbol_packages);
+  DEFVAR_LISP_NOPRO ("enable-package-locks", Venable_package_locks,
+                    doc: /* */);
 
   Fprovide (Qsymbol_packages, Qnil);
 }