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.

diff --git a/NEWS b/NEWS
index 4e2611d..e10971e 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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))))