1.0.6.40: missed tests from 1.0.6.38

 ...for ADD/REMOVE-METHOD thread safety, that is.

tests/clos-add-remove-method.impure.lisp

@@ -0,0 +1,112 @@
+;;;; testing add/remove-method thread thread safety
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(defpackage "CLOS-ADD/REMOVE-METHOD"
+  (:use "COMMON-LISP" "SB-THREAD"))
+
+(in-package "CLOS-ADD/REMOVE-METHOD")
+
+;;; We make a generic function, add a bunch of method for it, and
+;;; prepare another bunch of method objects for later addition.
+;;;
+;;; Then we run several threads in parallel, removing all the old
+;;; ones and adding all the new ones -- and finally we verify that
+;;; the resulting method set is correct.
+
+(defgeneric foo (x))
+
+(defvar *to-remove-a* nil)
+(defvar *to-remove-b* nil)
+(defvar *to-remove-c* nil)
+(defvar *to-add-d* nil)
+(defvar *to-add-e* nil)
+(defvar *to-add-f* nil)
+
+(defun name (key n)
+  (intern (format nil "FOO-~A-~A" key n)))
+
+(defun names (key)
+  (loop for i from 0 upto 128
+        collect (name key i)))
+
+(defun to-remove (key)
+  (loop for s in (names key)
+        collect
+        `(progn
+           (defclass ,s () ())
+           (defmethod foo ((x ,s))
+             ',s)
+           (push (find-method #'foo nil (list (find-class ',s)) t)
+                 ,(intern (format nil "*TO-REMOVE-~A*" key))))))
+
+(defun to-add (key)
+  (loop for s in (names key)
+        collect
+        `(progn
+           (defclass ,s () ())
+           (push (make-instance
+                  'standard-method
+                  :qualifiers nil
+                  :specializers (list (find-class ',s))
+                  :function (lambda (args next)
+                              (declare (ignore args next))
+                              ',s)
+                  :lambda-list '(x))
+                 ,(intern (format nil "*TO-ADD-~A*" key))))))
+
+(macrolet ((def ()
+             `(progn
+                ,@(to-remove 'a)
+                ,@(to-remove 'b)
+                ,@(to-remove 'c)
+                ,@(to-add 'd)
+                ,@(to-add 'e)
+                ,@(to-add 'f))))
+  (def))
+
+(defvar *run* nil)
+
+(defun remove-methods (list)
+  (loop until *run*)
+  (dolist (method list)
+    (remove-method #'foo method)))
+
+(defun add-methods (list)
+  (loop until *run*)
+  (dolist (method list)
+    (add-method #'foo method)))
+
+#+sb-thread
+(let ((threads (list (make-thread (lambda () (remove-methods *to-remove-a*)))
+                     (make-thread (lambda () (remove-methods *to-remove-b*)))
+                     (make-thread (lambda () (remove-methods *to-remove-c*)))
+                     (make-thread (lambda () (add-methods *to-add-d*)))
+                     (make-thread (lambda () (add-methods *to-add-e*)))
+                     (make-thread (lambda () (add-methods *to-add-f*))))))
+  (setf *run* t)
+  (mapcar #'join-thread threads))
+
+#-sb-thread
+(progn
+  (setf *run* t)
+  (remove-methods *to-remove-a*)
+  (remove-methods *to-remove-b*)
+  (remove-methods *to-remove-c*)
+  (add-methods *to-add-d*)
+  (add-methods *to-add-e*)
+  (add-methods *to-add-f*))
+
+(let ((target (append *to-add-d* *to-add-e* *to-add-f*))
+      (real (sb-mop:generic-function-methods #'foo)))
+  (assert (subsetp target real))
+  (assert (subsetp real target)))

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.6.39"
+"1.0.6.40"