From 0a3d799b59df15a7fcd680182f88feda8704f261 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Fri, 10 Jun 2011 21:52:52 -0400 Subject: [PATCH] MAKE-THREAD accepts :ARGUMENTS to pass to the thread function The additional keyword argument should be a lsit designator Based on a patch by Roman Marynchak. Fixes lp#727384. --- NEWS | 2 ++ src/code/target-thread.lisp | 17 +++++++++++++---- tests/threads.pure.lisp | 25 +++++++++++++++++++++++++ 3 files changed, 40 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index 4e2611d..e10971e 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes relative to sbcl-1.0.49: * enhancement: location of user or system initialization file can now easily be customized for saved cores. See: SB-EXT:*USERINIT-PATHNAME-FUNCTION* and SB-EXT:*SYSINIT-PATHNAME-FUNCTION*. + * enhancement: SB-EXT:MAKE-THREAD accepts an argument list designator for + the thunk, as a keyword argument, :arguments. * bug fix: bound derivation for floating point operations is now more careful about rounding possibly closing open bounds. (lp#793771) * bug fix: SB-POSIX:SYSCALL-ERROR's argument is now optional. (accidental diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 89c5111..18bec35 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1073,17 +1073,26 @@ have the foreground next." ;;;; The beef -(defun make-thread (function &key name) +(defun make-thread (function &key name arguments) #!+sb-doc - "Create a new thread of NAME that runs FUNCTION. When the function + "Create a new thread of NAME that runs FUNCTION with the argument +list designator provided (defaults to no argument). When the function returns the thread exits. The return values of FUNCTION are kept around and can be retrieved by JOIN-THREAD." - #!-sb-thread (declare (ignore function name)) + #!-sb-thread (declare (ignore function name arguments)) #!-sb-thread (error "Not supported in unithread builds.") + #!+sb-thread (assert (or (atom arguments) + (null (cdr (last arguments)))) + (arguments) + "Argument passed to ~S, ~S, is an improper list." + 'make-thread arguments) #!+sb-thread (let* ((thread (%make-thread :name name)) (setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) (initial-function (named-lambda initial-thread-function () ;; In time we'll move some of the binding presently done in C @@ -1144,7 +1153,7 @@ around and can be retrieved by JOIN-THREAD." (setf (thread-result thread) (cons t (multiple-value-list - (funcall real-function)))) + (apply real-function arguments)))) ;; Try to block deferrables. An ;; interrupt may unwind it, but for a ;; normal exit it prevents interrupt diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 983ace8..ce0df2d 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -481,3 +481,28 @@ (sb-thread:thread-deadlock () :deadlock)))) (assert (eq :ok (join-thread t1))))) + +#+sb-thread +(with-test (:name :pass-arguments-to-thread) + (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2)))))) + +#+sb-thread +(with-test (:name :pass-atom-to-thread) + (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2))))) + +#+sb-thread +(with-test (:name :pass-nil-to-thread) + (assert (= 1 (join-thread (make-thread #'* :arguments '()))))) + +#+sb-thread +(with-test (:name :pass-nothing-to-thread) + (assert (= 1 (join-thread (make-thread #'*))))) + +#+sb-thread +(with-test (:name :pass-improper-list-to-thread) + (multiple-value-bind (value error) + (ignore-errors (make-thread #'+ :arguments '(1 . 1))) + (when value + (join-thread value)) + (assert (and (null value) + error)))) -- 1.7.10.4