Sat Dec 27 19:15:11 CST 2008 Stephen Compall * test *default-special-bindings* Sat Dec 27 19:14:26 CST 2008 Stephen Compall * use creating-thread binding of *default-special-bindings* when making threads Sat Dec 27 17:39:15 CST 2008 Stephen Compall * Change *default-special-bindings* semantics and implement for all Lisps diff -rN -u old-bordeaux-threads/src/allegro.lisp new-bordeaux-threads/src/allegro.lisp --- old-bordeaux-threads/src/allegro.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/allegro.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -12,7 +12,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (mp:process-run-function name function)) + (mp:process-run-function name (binding-default-specials function))) (defun current-thread () mp:*current-process*) diff -rN -u old-bordeaux-threads/src/armedbear.lisp new-bordeaux-threads/src/armedbear.lisp --- old-bordeaux-threads/src/armedbear.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/armedbear.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -12,7 +12,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (ext:make-thread function :name name)) + (ext:make-thread (binding-default-specials function) :name name)) (defun current-thread () (ext:current-thread)) diff -rN -u old-bordeaux-threads/src/bordeaux-threads.lisp new-bordeaux-threads/src/bordeaux-threads.lisp --- old-bordeaux-threads/src/bordeaux-threads.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/bordeaux-threads.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -96,9 +96,18 @@ ;;; See default-implementations.lisp for MAKE-THREAD. +(defun binding-default-specials (thunk) + "Return a thunk that binds `*default-special-bindings*' and calls +THUNK." + (let ((specials *default-special-bindings*)) + (lambda () + (progv (mapcar #'car specials) + (mapcar (lambda (assoc) (funcall (cdr assoc))) specials) + (funcall thunk))))) + (defvar *default-special-bindings* '() "This variable holds an alist associating special variable symbols - with forms to evaluate for binding values. Special variables named + with thunks to call for binding values. Special variables named in this list will be locally bound in the new thread before it begins executing user code. diff -rN -u old-bordeaux-threads/src/cmu.lisp new-bordeaux-threads/src/cmu.lisp --- old-bordeaux-threads/src/cmu.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/cmu.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -10,7 +10,7 @@ (defun make-thread (function &rest keys &key name) (declare (ignore name)) - (apply #'mp:make-process function keys)) + (apply #'mp:make-process (binding-default-specials function) keys)) (defun current-thread () mp:*current-process*) diff -rN -u old-bordeaux-threads/src/corman.lisp new-bordeaux-threads/src/corman.lisp --- old-bordeaux-threads/src/corman.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/corman.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -10,7 +10,7 @@ (defun make-thread (function &key name) (declare (ignore name)) - (threads:create-thread function)) + (threads:create-thread (binding-default-specials function))) (defun current-thread () threads:*current-thread*) diff -rN -u old-bordeaux-threads/src/ecl.lisp new-bordeaux-threads/src/ecl.lisp --- old-bordeaux-threads/src/ecl.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/ecl.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -12,7 +12,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (mp:process-run-function (or name "") function)) + (mp:process-run-function (or name "") (binding-default-specials function))) (defun current-thread () mp::*current-process*) diff -rN -u old-bordeaux-threads/src/lispworks.lisp new-bordeaux-threads/src/lispworks.lisp --- old-bordeaux-threads/src/lispworks.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/lispworks.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -14,7 +14,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (mp:process-run-function name nil function)) + (mp:process-run-function name nil (binding-default-specials function))) (defun current-thread () mp:*current-process*) diff -rN -u old-bordeaux-threads/src/mcl.lisp new-bordeaux-threads/src/mcl.lisp --- old-bordeaux-threads/src/mcl.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/mcl.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -9,7 +9,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (ccl:process-run-function name function)) + (ccl:process-run-function name (binding-default-specials function))) (defun current-thread () ccl:*current-thread*) diff -rN -u old-bordeaux-threads/src/openmcl.lisp new-bordeaux-threads/src/openmcl.lisp --- old-bordeaux-threads/src/openmcl.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/openmcl.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -12,7 +12,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (ccl:process-run-function name function)) + (ccl:process-run-function name (binding-default-specials function))) (defun current-thread () ccl:*current-process*) diff -rN -u old-bordeaux-threads/src/sbcl.lisp new-bordeaux-threads/src/sbcl.lisp --- old-bordeaux-threads/src/sbcl.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/sbcl.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -12,7 +12,7 @@ ;;; Thread Creation (defun make-thread (function &key name) - (sb-thread:make-thread function :name name)) + (sb-thread:make-thread (binding-default-specials function) :name name)) (defun current-thread () sb-thread:*current-thread*) diff -rN -u old-bordeaux-threads/src/scl.lisp new-bordeaux-threads/src/scl.lisp --- old-bordeaux-threads/src/scl.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/src/scl.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -7,7 +7,8 @@ (in-package #:bordeaux-threads) (defun make-thread (function &key name) - (thread:thread-create function :name (or name "Anonymous"))) + (thread:thread-create (binding-default-specials function) + :name (or name "Anonymous"))) (defun current-thread () thread:*thread*) diff -rN -u old-bordeaux-threads/test/bordeaux-threads-test.lisp new-bordeaux-threads/test/bordeaux-threads-test.lisp --- old-bordeaux-threads/test/bordeaux-threads-test.lisp 2008-12-27 20:31:22.000000000 -0600 +++ new-bordeaux-threads/test/bordeaux-threads-test.lisp 2008-12-27 20:31:22.000000000 -0600 @@ -30,6 +30,34 @@ (ensure (acquire-lock lock nil)) (release-lock lock)) +(defun set-equal (set-a set-b) + (and (null (set-difference set-a set-b)) + (null (set-difference set-b set-a)))) + +(addtest default-special-bindings + (locally (declare (special *a* *c*)) + (let* ((the-as 50) (the-bs 150) (*b* 42) + some-a some-b some-other-a some-other-b + (*default-special-bindings* + (list* (cons '*a* (lambda () (incf the-as))) + (cons '*b* (lambda () (incf the-bs))) + *default-special-bindings*)) + (threads (list (make-thread + (lambda () + (setf some-a *a* some-b *b*))) + (make-thread + (lambda () + (setf some-other-a *a* + some-other-b *b*)))))) + (declare (special *b*)) + (thread-yield) + (ensure (not (boundp '*a*))) + (loop while (some #'thread-alive-p threads) + do (thread-yield)) + (ensure-same (list some-a some-other-a) '(51 52) :test set-equal) + (ensure-same (list some-b some-other-b) '(151 152) :test set-equal) + (ensure (not (boundp '*a*)))))) + (defparameter *shared* 0) (defparameter *lock* (make-lock))