Commit 3744fda5 authored by Michael Albinus's avatar Michael Albinus

Provide feature 'threads

* src/thread.c (syms_of_threads): Provide feature "threads".

* test/src/thread-tests.el (top): Declare the functions.
(all): Use (featurep 'threads) check.
parent ef9025f5
...@@ -1068,6 +1068,8 @@ syms_of_threads (void) ...@@ -1068,6 +1068,8 @@ syms_of_threads (void)
staticpro (&last_thread_error); staticpro (&last_thread_error);
last_thread_error = Qnil; last_thread_error = Qnil;
Fprovide (intern_c_string ("threads"), Qnil);
} }
DEFSYM (Qthreadp, "threadp"); DEFSYM (Qthreadp, "threadp");
......
...@@ -19,36 +19,56 @@ ...@@ -19,36 +19,56 @@
;;; Code: ;;; Code:
;; Declare the functions in case Emacs has been configured --without-threads.
(declare-function all-threads "thread.c" ())
(declare-function condition-mutex "thread.c" (cond))
(declare-function condition-name "thread.c" (cond))
(declare-function condition-notify "thread.c" (cond &optional all))
(declare-function condition-wait "thread.c" (cond))
(declare-function current-thread "thread.c" ())
(declare-function make-condition-variable "thread.c" (mutex &optional name))
(declare-function make-mutex "thread.c" (&optional name))
(declare-function make-thread "thread.c" (function &optional name))
(declare-function mutex-lock "thread.c" (mutex))
(declare-function mutex-unlock "thread.c" (mutex))
(declare-function thread--blocker "thread.c" (thread))
(declare-function thread-alive-p "thread.c" (thread))
(declare-function thread-join "thread.c" (thread))
(declare-function thread-last-error "thread.c" ())
(declare-function thread-name "thread.c" (thread))
(declare-function thread-signal "thread.c" (thread error-symbol data))
(declare-function thread-yield "thread.c" ())
(ert-deftest threads-is-one () (ert-deftest threads-is-one ()
"Test for existence of a thread." "Test for existence of a thread."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (current-thread))) (should (current-thread)))
(ert-deftest threads-threadp () (ert-deftest threads-threadp ()
"Test of threadp." "Test of threadp."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (threadp (current-thread)))) (should (threadp (current-thread))))
(ert-deftest threads-type () (ert-deftest threads-type ()
"Test of thread type." "Test of thread type."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (eq (type-of (current-thread)) 'thread))) (should (eq (type-of (current-thread)) 'thread)))
(ert-deftest threads-name () (ert-deftest threads-name ()
"Test for name of a thread." "Test for name of a thread."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(string= "hi bob" (thread-name (make-thread #'ignore "hi bob"))))) (string= "hi bob" (thread-name (make-thread #'ignore "hi bob")))))
(ert-deftest threads-alive () (ert-deftest threads-alive ()
"Test for thread liveness." "Test for thread liveness."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(thread-alive-p (make-thread #'ignore)))) (thread-alive-p (make-thread #'ignore))))
(ert-deftest threads-all-threads () (ert-deftest threads-all-threads ()
"Simple test for all-threads." "Simple test for all-threads."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (listp (all-threads)))) (should (listp (all-threads))))
(defvar threads-test-global nil) (defvar threads-test-global nil)
...@@ -58,7 +78,7 @@ ...@@ -58,7 +78,7 @@
(ert-deftest threads-basic () (ert-deftest threads-basic ()
"Basic thread test." "Basic thread test."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(progn (progn
(setq threads-test-global nil) (setq threads-test-global nil)
...@@ -69,7 +89,7 @@ ...@@ -69,7 +89,7 @@
(ert-deftest threads-join () (ert-deftest threads-join ()
"Test of `thread-join'." "Test of `thread-join'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(progn (progn
(setq threads-test-global nil) (setq threads-test-global nil)
...@@ -80,7 +100,7 @@ ...@@ -80,7 +100,7 @@
(ert-deftest threads-join-self () (ert-deftest threads-join-self ()
"Cannot `thread-join' the current thread." "Cannot `thread-join' the current thread."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should-error (thread-join (current-thread)))) (should-error (thread-join (current-thread))))
(defvar threads-test-binding nil) (defvar threads-test-binding nil)
...@@ -92,7 +112,7 @@ ...@@ -92,7 +112,7 @@
(ert-deftest threads-let-binding () (ert-deftest threads-let-binding ()
"Simple test of threads and let bindings." "Simple test of threads and let bindings."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(progn (progn
(setq threads-test-global nil) (setq threads-test-global nil)
...@@ -104,22 +124,22 @@ ...@@ -104,22 +124,22 @@
(ert-deftest threads-mutexp () (ert-deftest threads-mutexp ()
"Simple test of `mutexp'." "Simple test of `mutexp'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should-not (mutexp 'hi))) (should-not (mutexp 'hi)))
(ert-deftest threads-mutexp-2 () (ert-deftest threads-mutexp-2 ()
"Another simple test of `mutexp'." "Another simple test of `mutexp'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (mutexp (make-mutex)))) (should (mutexp (make-mutex))))
(ert-deftest threads-mutex-type () (ert-deftest threads-mutex-type ()
"type-of mutex." "type-of mutex."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (eq (type-of (make-mutex)) 'mutex))) (should (eq (type-of (make-mutex)) 'mutex)))
(ert-deftest threads-mutex-lock-unlock () (ert-deftest threads-mutex-lock-unlock ()
"Test mutex-lock and unlock." "Test mutex-lock and unlock."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(let ((mx (make-mutex))) (let ((mx (make-mutex)))
(mutex-lock mx) (mutex-lock mx)
...@@ -128,7 +148,7 @@ ...@@ -128,7 +148,7 @@
(ert-deftest threads-mutex-recursive () (ert-deftest threads-mutex-recursive ()
"Test mutex recursion." "Test mutex recursion."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(let ((mx (make-mutex))) (let ((mx (make-mutex)))
(mutex-lock mx) (mutex-lock mx)
...@@ -149,7 +169,7 @@ ...@@ -149,7 +169,7 @@
(ert-deftest threads-mutex-contention () (ert-deftest threads-mutex-contention ()
"Test of mutex contention." "Test of mutex contention."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(progn (progn
(setq threads-mutex (make-mutex)) (setq threads-mutex (make-mutex))
...@@ -170,7 +190,7 @@ ...@@ -170,7 +190,7 @@
(ert-deftest threads-mutex-signal () (ert-deftest threads-mutex-signal ()
"Test signaling a blocked thread." "Test signaling a blocked thread."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(progn (progn
(setq threads-mutex (make-mutex)) (setq threads-mutex (make-mutex))
...@@ -188,7 +208,7 @@ ...@@ -188,7 +208,7 @@
(ert-deftest threads-io-switch () (ert-deftest threads-io-switch ()
"Test that `accept-process-output' causes thread switch." "Test that `accept-process-output' causes thread switch."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(progn (progn
(setq threads-test-global nil) (setq threads-test-global nil)
...@@ -199,36 +219,36 @@ ...@@ -199,36 +219,36 @@
(ert-deftest threads-condvarp () (ert-deftest threads-condvarp ()
"Simple test of `condition-variable-p'." "Simple test of `condition-variable-p'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should-not (condition-variable-p 'hi))) (should-not (condition-variable-p 'hi)))
(ert-deftest threads-condvarp-2 () (ert-deftest threads-condvarp-2 ()
"Another simple test of `condition-variable-p'." "Another simple test of `condition-variable-p'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (condition-variable-p (make-condition-variable (make-mutex))))) (should (condition-variable-p (make-condition-variable (make-mutex)))))
(ert-deftest threads-condvar-type () (ert-deftest threads-condvar-type ()
"type-of condvar" "type-of condvar"
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (eq (type-of (make-condition-variable (make-mutex))) (should (eq (type-of (make-condition-variable (make-mutex)))
'condition-variable))) 'condition-variable)))
(ert-deftest threads-condvar-mutex () (ert-deftest threads-condvar-mutex ()
"Simple test of `condition-mutex'." "Simple test of `condition-mutex'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(let ((m (make-mutex))) (let ((m (make-mutex)))
(eq m (condition-mutex (make-condition-variable m)))))) (eq m (condition-mutex (make-condition-variable m))))))
(ert-deftest threads-condvar-name () (ert-deftest threads-condvar-name ()
"Simple test of `condition-name'." "Simple test of `condition-name'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(eq nil (condition-name (make-condition-variable (make-mutex)))))) (eq nil (condition-name (make-condition-variable (make-mutex))))))
(ert-deftest threads-condvar-name-2 () (ert-deftest threads-condvar-name-2 ()
"Another simple test of `condition-name'." "Another simple test of `condition-name'."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(should (should
(string= "hi bob" (string= "hi bob"
(condition-name (make-condition-variable (make-mutex) (condition-name (make-condition-variable (make-mutex)
...@@ -246,7 +266,7 @@ ...@@ -246,7 +266,7 @@
(ert-deftest thread-errors () (ert-deftest thread-errors ()
"Test what happens when a thread signals an error." "Test what happens when a thread signals an error."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(let (th1 th2) (let (th1 th2)
(setq th1 (make-thread #'call-error "call-error")) (setq th1 (make-thread #'call-error "call-error"))
(should (threadp th1)) (should (threadp th1))
...@@ -259,7 +279,7 @@ ...@@ -259,7 +279,7 @@
(ert-deftest thread-sticky-point () (ert-deftest thread-sticky-point ()
"Test bug #25165 with point movement in cloned buffer." "Test bug #25165 with point movement in cloned buffer."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(with-temp-buffer (with-temp-buffer
(insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit.") (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit.")
(goto-char (point-min)) (goto-char (point-min))
...@@ -270,7 +290,7 @@ ...@@ -270,7 +290,7 @@
(ert-deftest thread-signal-early () (ert-deftest thread-signal-early ()
"Test signaling a thread as soon as it is started by the OS." "Test signaling a thread as soon as it is started by the OS."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(let ((thread (let ((thread
(make-thread #'(lambda () (make-thread #'(lambda ()
(while t (thread-yield)))))) (while t (thread-yield))))))
...@@ -291,7 +311,7 @@ ...@@ -291,7 +311,7 @@
(ert-deftest threads-condvar-wait () (ert-deftest threads-condvar-wait ()
"Test waiting on conditional variable." "Test waiting on conditional variable."
(skip-unless (fboundp 'make-thread)) (skip-unless (featurep 'threads))
(let ((cv-mutex (make-mutex)) (let ((cv-mutex (make-mutex))
new-thread) new-thread)
;; We could have spurious threads from the previous tests still ;; We could have spurious threads from the previous tests still
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment