branch: elpa/slime
commit e20765caf12db8e118bdf7beab7dc5a11da7329e
Author: Stas Boukarev <[email protected]>
Commit: Stas Boukarev <[email protected]>
Lock swank packages.
---
contrib/swank-repl.lisp | 2 +-
packages.lisp | 3 ++-
slime-tests.el | 3 ++-
swank-loader.lisp | 6 +++++-
swank.asd | 4 ++--
swank.lisp | 21 ++++++++++++---------
swank/backend.lisp | 17 +++++++++++++++++
swank/sbcl.lisp | 9 +++++++++
8 files changed, 50 insertions(+), 15 deletions(-)
diff --git a/contrib/swank-repl.lisp b/contrib/swank-repl.lisp
index 49578842f2..c05c4c0bb5 100644
--- a/contrib/swank-repl.lisp
+++ b/contrib/swank-repl.lisp
@@ -347,7 +347,7 @@ dynamic binding."
(defun prefixed-var (prefix variable-symbol)
"(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
(let ((basename (subseq (symbol-name variable-symbol) 1)))
- (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
+ (intern (format nil "*~A-~A" (string prefix) basename) :swank-repl)))
(defvar *standard-output-streams*
'(*standard-output* *error-output* *trace-output*)
diff --git a/packages.lisp b/packages.lisp
index 0ffdb6fa64..175b01f288 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -66,7 +66,8 @@
#:with-lock
#:*slime-interrupts-enabled*
#:with-slime-interrupts
- #:without-slime-interrupts))
+ #:without-slime-interrupts
+ #:with-unlocked-packages))
(swank-loader:define-package #:swank/rpc
(:use #:cl)
diff --git a/slime-tests.el b/slime-tests.el
index f71e9fffab..b0696c919f 100644
--- a/slime-tests.el
+++ b/slime-tests.el
@@ -60,6 +60,7 @@ Exits Emacs when finished. The exit code is the number of
failed tests."
(when noninteractive
(kill-emacs 252)))))
(slime-sync-to-top-level 30)
+ (slime-eval `(swank/backend:unlock-package :swank))
(let* ((selector (if randomize
`(member ,@(slime-shuffle-list
(ert-select-tests (or test-name t) t)))
@@ -1294,7 +1295,7 @@ This test will fail more likely before dispatch caches
are warmed up."
:dont-close nil)))))
(slime-sync-to-top-level 3)
(slime-disconnect)
- (slime-test-expect "Number of connections must remane the same"
+ (slime-test-expect "Number of connections must remain the same"
connection-count
(length slime-net-processes)))
(slime-select-connection old-connection))))
diff --git a/swank-loader.lisp b/swank-loader.lisp
index 5c45302182..c71f0efa9d 100644
--- a/swank-loader.lisp
+++ b/swank-loader.lisp
@@ -313,7 +313,11 @@ If LOAD is true, load the fasl file."
(when (#-clisp probe-file
#+clisp ext:probe-directory
(contrib-dir *source-directory*))
- (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
+ (eval `(pushnew (lambda ()
+ (,(q "swank/backend:with-unlocked-packages")
+ (swank swank/backend)
+ (compile-contribs)))
+ ,(q "swank::*after-init-hook*"))))
(funcall (q "swank::init")))
(defun list-swank-packages ()
diff --git a/swank.asd b/swank.asd
index ff916eb07c..f441597f3c 100644
--- a/swank.asd
+++ b/swank.asd
@@ -28,9 +28,9 @@
(uiop:symbol-call :swank-loader :slime-version-string)
(list
(uiop:symbol-call :swank-loader :contrib-dir
- (symbol-value (intern "*FASL-DIRECTORY*" 'swank-loader)))
+ (symbol-value (find-symbol "*FASL-DIRECTORY*"
'swank-loader)))
(uiop:symbol-call :swank-loader :contrib-dir
- (symbol-value (intern "*SOURCE-DIRECTORY*"
'swank-loader))))))
+ (symbol-value (find-symbol "*SOURCE-DIRECTORY*"
'swank-loader))))))
:components ((:file "swank-loader")
(:file "packages")
(:file "xref" :if-feature :clisp)
diff --git a/swank.lisp b/swank.lisp
index 0b07fbc784..b3c4db02d9 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -2540,14 +2540,15 @@ Record compiler notes signalled as
`compiler-condition's."
(defslimefun swank-require (modules &optional filename)
"Load the module MODULE."
- (dolist (module (ensure-list modules))
- (unless (member (string module) *modules* :test #'string=)
- (catch 'dont-load
- (require module (if filename
- (filename-to-pathname filename)
- (module-filename module)))
- (assert (member (string module) *modules* :test #'string=)
- () "Required module ~s was not provided" module))))
+ (with-unlocked-packages (swank swank/backend)
+ (dolist (module (ensure-list modules))
+ (unless (member (string module) *modules* :test #'string=)
+ (catch 'dont-load
+ (require module (if filename
+ (filename-to-pathname filename)
+ (module-filename module)))
+ (assert (member (string module) *modules* :test #'string=)
+ () "Required module ~s was not provided" module)))))
*modules*)
(defvar *find-module* 'find-module
@@ -3895,7 +3896,9 @@ Collisions are caused because package information is
ignored."
(defun before-init (version load-path)
(pushnew :swank *features*)
(setq *swank-wire-protocol-version* version)
- (setq *load-path* load-path))
+ (setq *load-path* load-path)
+ (loop for x in '(swank swank/backend swank/rpc swank/match swank-mop
swank/gray)
+ do (lock-package x)))
(defun init ()
(run-hook *after-init-hook*))
diff --git a/swank/backend.lisp b/swank/backend.lisp
index 21bb3fde60..3148938d1b 100644
--- a/swank/backend.lisp
+++ b/swank/backend.lisp
@@ -1642,3 +1642,20 @@ Implementations intercept calls to SPEC and call, in
this order:
"Handle interrupts"
(declare (ignore interrupt-handler))
(funcall function))
+
+(definterface lock-package (package)
+ "Lock PACKAGE"
+ (declare (ignore package)))
+
+(definterface unlock-package (package)
+ "Unlock PACKAGE"
+ (declare (ignore package)))
+
+(definterface expand-with-unlocked-packages (packages body)
+ "Lock PACKAGE"
+ (declare (ignore packages))
+ `(progn ,@body))
+
+(defmacro with-unlocked-packages ((&rest packages) &body body)
+ (expand-with-unlocked-packages packages body))
+
diff --git a/swank/sbcl.lisp b/swank/sbcl.lisp
index a45597aa81..ce76e28b98 100644
--- a/swank/sbcl.lisp
+++ b/swank/sbcl.lisp
@@ -2043,3 +2043,12 @@ stack."
(defimplementation call-with-interrupt-handler (interrupt-handler function)
(let ((sb-thread:*interrupt-handler* interrupt-handler))
(funcall function)))
+
+(defimplementation lock-package (package)
+ (sb-ext:lock-package package))
+
+(defimplementation unlock-package (package)
+ (sb-ext:unlock-package package))
+
+(defimplementation expand-with-unlocked-packages (packages body)
+ `(sb-ext:with-unlocked-packages ,packages ,@body))
