From f184e887a6cb09a97cf34feab30eeba4a28a3ae4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 4 Jul 2014 15:52:15 +0200
Subject: [PATCH] build: Support pthread builds without 'pthread_cancel'
 support (Android).

Reported by Sylvain Beucler <beuc@beuc.net>.

* configure.ac: Check for 'pthread_cancel'.
* libguile/threads.c (scm_cancel_thread): Conditionalize on
  !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL.
* test-suite/tests/threads.test (require-cancel-thread): New procedure.
  ("timed joining fails if timeout exceeded", "join-thread returns
  timeoutval on timeout", "cancel succeeds", "handler result passed to
  join", "can cancel self"): Use it.
---
 configure.ac                  |  5 ++++-
 libguile/threads.c            |  7 +++++++
 test-suite/tests/threads.test | 13 ++++++++++++-
 3 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/configure.ac b/configure.ac
index f65d72e21..a323f7093 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1371,8 +1371,11 @@ case "$with_threads" in
     #     pthread_attr_get_np - "np" meaning "non portable" says it
     #         all; specific to FreeBSD
     #     pthread_sigmask - not available on mingw
+    #     pthread_cancel - not available on Android (Bionic libc)
     #
-    AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask)
+    AC_CHECK_FUNCS([pthread_attr_getstack pthread_getattr_np		\
+      pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask	\
+      pthread_cancel])
 
     # On past versions of Solaris, believe 8 through 10 at least, you
     # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };".
diff --git a/libguile/threads.c b/libguile/threads.c
index 15e491990..6ae6818c5 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1156,6 +1156,11 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+/* Some systems, notably Android, lack 'pthread_cancel'.  Don't provide
+   'cancel-thread' on these systems.  */
+
+#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL
+
 SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
 	    (SCM thread),
 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
@@ -1181,6 +1186,8 @@ SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+#endif
+
 SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0,
 	    (SCM thread, SCM proc),
 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 817812051..3b7a3e440 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -1,6 +1,7 @@
 ;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
+;;;;   2014 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -36,6 +37,11 @@
     (equal? '(a b c) '(a b c))
     a))
 
+(define (require-cancel-thread)
+  ;; Skip the test when 'cancel-thread' is unavailable.
+  (unless (defined? 'cancel-thread)
+    (throw 'unresolved)))
+
 (if (provided? 'threads)
     (begin
 
@@ -277,6 +283,7 @@
       (with-test-prefix "join-thread"
 
 	(pass-if "timed joining fails if timeout exceeded"
+          (require-cancel-thread)
 	  (let* ((m (make-mutex))
 		 (c (make-condition-variable))
 		 (t (begin-thread (begin (lock-mutex m)
@@ -286,6 +293,7 @@
 	    (not r)))
 
         (pass-if "join-thread returns timeoutval on timeout"
+          (require-cancel-thread)
           (let* ((m (make-mutex))
 		 (c (make-condition-variable))
 		 (t (begin-thread (begin (lock-mutex m)
@@ -335,6 +343,7 @@
       (with-test-prefix "cancel-thread"
 
         (pass-if "cancel succeeds"
+          (require-cancel-thread)
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (begin (lock-mutex m) 'foo))))
@@ -343,6 +352,7 @@
 	      #t)))
 
 	(pass-if "handler result passed to join"
+          (require-cancel-thread)
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (lock-mutex m))))
@@ -351,6 +361,7 @@
 	      (eq? (join-thread t) 'foo))))
 
 	(pass-if "can cancel self"
+          (require-cancel-thread)
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (begin