[Sbcl-commits] CVS: sbcl/tests clos-interrupts.impure.lisp, NONE, 1.1

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv22669/tests

Added Files:
	clos-interrupts.impure.lisp 
Log Message:
1.0.6.60: add test file that was forgotten from 1.0.6.59

 * clos-interrupts.impure.lisp


--- NEW FILE: clos-interrupts.impure.lisp ---
;;; 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*))