1 ;;;; testing add/remove-method thread thread safety
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (defpackage "CLOS-ADD/REMOVE-METHOD"
15 (:use "COMMON-LISP" "SB-THREAD"))
17 (in-package "CLOS-ADD/REMOVE-METHOD")
19 ;;; We make a generic function, add a bunch of method for it, and
20 ;;; prepare another bunch of method objects for later addition.
22 ;;; Then we run several threads in parallel, removing all the old
23 ;;; ones and adding all the new ones -- and finally we verify that
24 ;;; the resulting method set is correct.
28 (defvar *to-remove-a* nil)
29 (defvar *to-remove-b* nil)
30 (defvar *to-remove-c* nil)
31 (defvar *to-add-d* nil)
32 (defvar *to-add-e* nil)
33 (defvar *to-add-f* nil)
36 (intern (format nil "FOO-~A-~A" key n)))
39 (loop for i from 0 upto 128
40 collect (name key i)))
42 (defun to-remove (key)
43 (loop for s in (names key)
47 (defmethod foo ((x ,s))
49 (push (find-method #'foo nil (list (find-class ',s)) t)
50 ,(intern (format nil "*TO-REMOVE-~A*" key))))))
53 (loop for s in (names key)
60 :specializers (list (find-class ',s))
61 :function (lambda (args next)
62 (declare (ignore args next))
65 ,(intern (format nil "*TO-ADD-~A*" key))))))
79 (defun remove-methods (list)
80 (loop until *run* do (sb-thread:thread-yield))
82 (remove-method #'foo method)))
84 (defun add-methods (list)
85 (loop until *run* do (sb-thread:thread-yield))
87 (add-method #'foo method)))
90 (let ((threads (list (make-thread (lambda () (remove-methods *to-remove-a*)))
91 (make-thread (lambda () (remove-methods *to-remove-b*)))
92 (make-thread (lambda () (remove-methods *to-remove-c*)))
93 (make-thread (lambda () (add-methods *to-add-d*)))
94 (make-thread (lambda () (add-methods *to-add-e*)))
95 (make-thread (lambda () (add-methods *to-add-f*))))))
97 (mapcar #'join-thread threads))
102 (remove-methods *to-remove-a*)
103 (remove-methods *to-remove-b*)
104 (remove-methods *to-remove-c*)
105 (add-methods *to-add-d*)
106 (add-methods *to-add-e*)
107 (add-methods *to-add-f*))
109 (let ((target (append *to-add-d* *to-add-e* *to-add-f*))
110 (real (sb-mop:generic-function-methods #'foo)))
111 (assert (subsetp target real))
112 (assert (subsetp real target)))