Commit 38f5dea0 authored by Daniel Kochmański's avatar Daniel Kochmański

cas: ensure that package locks are honored

parent 13a42249
......@@ -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
......
......@@ -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)))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment