Merge branch 'master' of git://repo.or.cz/sbcl
[sbcl/attila.git] / tests / clos-interrupts.impure.lisp
blob8935ab749b377b0929725f4e243f87b0a857ff2c
1 ;;; CLOS interrupt safety tests
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.
14 (defpackage "CLOS-INTERRUPT-TEST"
15 (:use "COMMON-LISP" "SB-EXT"))
17 (in-package "CLOS-INTERRUPT-TEST")
19 ;;;;; Interrupting applicable method computation and calling the same
20 ;;;;; GF that was being computed in the interrupt handler must not show
21 ;;;;; up as metacircle.
23 ;;; KLUDGE: We just want a way to ensure our interrupt happens at a
24 ;;; bad place.
25 ;;;
26 ;;; FIXME: While an invasive hook like this is probably ok for testing
27 ;;; purposes, it would also be good to have a proper interrupt-stress
28 ;;; test for CLOS.
29 (defmacro define-wrapper (name &key before after)
30 (let ((real (intern (format nil "*REAL-~A*" name)))
31 (our (intern (format nil "OUR-~A" name))))
32 `(progn
33 (defvar ,real #',name)
34 (defun ,our (&rest args)
35 ,@before
36 (multiple-value-prog1
37 (apply ,real args)
38 ,@after))
39 (without-package-locks
40 (setf (fdefinition ',name) #',our)))))
42 (defgeneric compute-test (x y))
44 (defvar *interrupting* nil)
46 (defun interrupt ()
47 (unless *interrupting*
48 (let ((self sb-thread:*current-thread*)
49 (*interrupting* t))
50 ;; Test both interrupting yourself and using another thread
51 ;; for to interrupting.
52 #+sb-thread
53 (progn
54 (write-line "/interrupt-other")
55 (sb-thread:join-thread (sb-thread:make-thread
56 (lambda ()
57 (sb-thread:interrupt-thread
58 self
59 (lambda ()
60 (compute-test 1 2)))))))
61 (write-line "/interrupt-self")
62 (sb-thread:interrupt-thread self (lambda () (compute-test 1 2))))))
64 (defvar *interrupted-gfs* nil)
66 (define-wrapper sb-pcl::compute-applicable-methods-using-types
67 :before ((when (and (eq (car args) #'compute-test)
68 ;; Check that we are at "bad place"
69 (assoc (car args) sb-pcl::*cache-miss-values-stack*))
70 (interrupt)
71 (pushnew (car args) *interrupted-gfs*))))
73 (defmethod compute-test (x y)
75 (defmethod compute-test ((x fixnum) (y fixnum))
76 'fixnum)
77 (defmethod compute-test ((x symbol) (y symbol))
78 'symbol)
80 (compute-test 1 2)
82 ;;; Check that we actually interrupted something.
83 (assert (equal (list #'compute-test) *interrupted-gfs*))