1.0.6.60: add test file that was forgotten from 1.0.6.59

 * clos-interrupts.impure.lisp

diff --git a/tests/clos-interrupts.impure.lisp b/tests/clos-interrupts.impure.lisp
new file mode 100644 (file)
index 0000000..6195449
--- /dev/null
+++ b/tests/clos-interrupts.impure.lisp
@@ -0,0 +1,81 @@
+;;; CLOS interrupt safety tests
+
+;;;; 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-INTERRUPT-TEST"
+  (:use "COMMON-LISP" "SB-EXT"))
+
+(in-package "CLOS-INTERRUPT-TEST")
+
+;;;;; Interrupting applicable method computation and calling the same
+;;;;; GF that was being computed in the interrupt handler must not show
+;;;;; up as metacircle.
+
+;;; KLUDGE: We just want a way to ensure our interrupt happens at a
+;;; bad place.
+;;;
+;;; FIXME: While an invasive hook like this is probably ok for testing
+;;; purposes, it would also be good to have a proper interrupt-stress
+;;; test for CLOS.
+(defmacro define-wrapper (name &key before after)
+  (let ((real (intern (format nil "*REAL-~A*" name)))
+        (our (intern (format nil "OUR-~A" name))))
+    `(progn
+       (defvar ,real #',name)
+       (defun ,our (&rest args)
+         ,@before
+         (multiple-value-prog1
+             (apply ,real args)
+           ,@after))
+       (without-package-locks
+         (setf (fdefinition ',name) #',our)))))
+
+(defgeneric compute-test (x y))
+
+(defvar *interrupting* nil)
+
+(defun interrupt ()
+  (unless *interrupting*
+    (let ((self sb-thread:*current-thread*)
+          (*interrupting* t))
+      ;; Test both interrupting yourself and using another thread
+      ;; for to interrupting.
+      (write-line "interrupt-1")
+      (sb-thread:join-thread (sb-thread:make-thread
+                              (lambda ()
+                                (sb-thread:interrupt-thread
+                                 self
+                                 (lambda ()
+                                   (compute-test 1 2))))))
+      (write-line "interrupt-2")
+      (sb-thread:interrupt-thread self (lambda () (compute-test 1 2))))))
+
+(defvar *interrupted-gfs* nil)
+
+(define-wrapper sb-pcl::compute-applicable-methods-using-types
+    :before ((when (and (eq (car args) #'compute-test)
+                        ;; Check that we are at "bad place"
+                        (assoc (car args) sb-pcl::*cache-miss-values-stack*))
+               (interrupt)
+               (pushnew (car args) *interrupted-gfs*))))
+
+(defmethod compute-test (x y)
+  t)
+(defmethod compute-test ((x fixnum) (y fixnum))
+  'fixnum)
+(defmethod compute-test ((x symbol) (y symbol))
+  'symbol)
+
+(compute-test 1 2)
+
+;;; Check that we actually interrupted something.
+(assert (equal (list #'compute-test) *interrupted-gfs*))

diff --git a/version.lisp-expr b/version.lisp-expr
index 3639f77..308b465 100644 (file)
--- a/version.lisp-expr
+++ b/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.59"
+"1.0.6.60"