Really restore clisp cross-compilation.
[sbcl.git] / tests / clos-add-remove-method.impure.lisp
1 ;;;; testing add/remove-method thread thread safety
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (defpackage "CLOS-ADD/REMOVE-METHOD"
15   (:use "COMMON-LISP" "SB-THREAD"))
16
17 (in-package "CLOS-ADD/REMOVE-METHOD")
18
19 ;;; We make a generic function, add a bunch of method for it, and
20 ;;; prepare another bunch of method objects for later addition.
21 ;;;
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.
25
26 (defgeneric foo (x))
27
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)
34
35 (defun name (key n)
36   (intern (format nil "FOO-~A-~A" key n)))
37
38 (defun names (key)
39   (loop for i from 0 upto 128
40         collect (name key i)))
41
42 (defun to-remove (key)
43   (loop for s in (names key)
44         collect
45         `(progn
46            (defclass ,s () ())
47            (defmethod foo ((x ,s))
48              ',s)
49            (push (find-method #'foo nil (list (find-class ',s)) t)
50                  ,(intern (format nil "*TO-REMOVE-~A*" key))))))
51
52 (defun to-add (key)
53   (loop for s in (names key)
54         collect
55         `(progn
56            (defclass ,s () ())
57            (push (make-instance
58                   'standard-method
59                   :qualifiers nil
60                   :specializers (list (find-class ',s))
61                   :function (lambda (args next)
62                               (declare (ignore args next))
63                               ',s)
64                   :lambda-list '(x))
65                  ,(intern (format nil "*TO-ADD-~A*" key))))))
66
67 (macrolet ((def ()
68              `(progn
69                 ,@(to-remove 'a)
70                 ,@(to-remove 'b)
71                 ,@(to-remove 'c)
72                 ,@(to-add 'd)
73                 ,@(to-add 'e)
74                 ,@(to-add 'f))))
75   (def))
76
77 (defvar *run* nil)
78
79 (defun remove-methods (list)
80   (loop until *run* do (sb-thread:thread-yield))
81   (dolist (method list)
82     (remove-method #'foo method)))
83
84 (defun add-methods (list)
85   (loop until *run* do (sb-thread:thread-yield))
86   (dolist (method list)
87     (add-method #'foo method)))
88
89 #+sb-thread
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*))))))
96   (setf *run* t)
97   (mapcar #'join-thread threads))
98
99 #-sb-thread
100 (progn
101   (setf *run* t)
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*))
108
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)))