diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index ad220e2b8..ee8884573 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -204,6 +204,15 @@ the resulting COMPARE-AND-SWAP expansions." (setq lambda-list (cons env lambda-list)) (push `(declare (ignore ,env)) body)))) `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((package (symbol-package ',accessor))) + (when (and package + (ext:package-locked-p package) + (null si:*ignore-package-locks*)) + (si:signal-simple-error 'package-error + "Ignore lock and proceed." + "Attempt to define CAS accessor ~S in locked package." + '(,accessor) + :package package))) (si:put-sysprop ',accessor 'CAS-EXPANDER #'(ext::lambda-block ,accessor ,lambda-list ,@body)) ',accessor)) @@ -227,6 +236,15 @@ the resulting COMPARE-AND-SWAP expansions." (defun remcas (symbol) "Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of (FMAKUNBOUND (SETF SYMBOL))" + (let ((package (symbol-package symbol))) + (when (and package + (ext:package-locked-p package) + (null si:*ignore-package-locks*)) + (si:signal-simple-error 'package-error + "Ignore lock and proceed." + "Attempt to define CAS accessor ~S in locked package." + (list symbol) + :package package))) (si:rem-sysprop symbol 'cas-expander)) #+threads diff --git a/src/tests/normal-tests/multiprocessing.lsp b/src/tests/normal-tests/multiprocessing.lsp index 41b5d15aa..d405daa80 100644 --- a/src/tests/normal-tests/multiprocessing.lsp +++ b/src/tests/normal-tests/multiprocessing.lsp @@ -723,3 +723,15 @@ creating stray processes." (is (eql (cdr *obj*) :cdr)) (mp:remcas 'foo) (signals error (eval `(mp:compare-and-swap (foo *obj*) :car :cdr))))) + +;;; Date: 2019-02-07 +;;; From: Daniel KochmaƄski +;;; Description: +;;; +;;; Verifies that CAS modifications honor the package locks. +;;; +(test cas-locked-package + (signals package-error (mp:defcas cl:car (lambda (obj old new) nil))) + (signals package-error (mp:remcas 'cl:car)) + (finishes (mp:defcas cor (lambda (obj old new) nil))) + (finishes (mp:remcas 'cor)))