;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-threads)
  :use-module (ice-9 threads)
  :use-module (test-suite lib))


(if (provided? 'threads)
    (begin

      (with-test-prefix "parallel"
	(pass-if "no forms"
	  (call-with-values
	      (lambda ()
		(parallel))
	    (lambda ()
	      #t)))

	(pass-if "1"
	  (call-with-values
	      (lambda ()
		(parallel 1))
	    (lambda (x)
	      (equal? x 1))))

	(pass-if "1 2"
	  (call-with-values
	      (lambda ()
		(parallel 1 2))
	    (lambda (x y)
	      (and (equal? x 1)
		   (equal? y 2)))))

	(pass-if "1 2 3"
	  (call-with-values
	      (lambda ()
		(parallel 1 2 3))
	    (lambda (x y z)
	      (and (equal? x 1)
		   (equal? y 2)
		   (equal? z 3))))))

      ;;
      ;; n-par-for-each
      ;;

      (with-test-prefix "n-par-for-each"

	(pass-if "0 in limit 10"
	  (n-par-for-each 10 noop '())
	  #t)

	(pass-if "6 in limit 10"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 10 (lambda (n)
				 (vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 1"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 1 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 2"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 2 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 3"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 3 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t)))))

      ;;
      ;; n-for-each-par-map
      ;;

      (with-test-prefix "n-for-each-par-map"

	(pass-if "0 in limit 10"
	  (n-for-each-par-map 10 noop noop '())
	  #t)

	(pass-if "6 in limit 10"
	  (let ((result '()))
	    (n-for-each-par-map 10
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 1"
	  (let ((result '()))
	    (n-for-each-par-map 1
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 2"
	  (let ((result '()))
	    (n-for-each-par-map 2
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 3"
	  (let ((result '()))
	    (n-for-each-par-map 3
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0)))))

      ;;
      ;; thread cancellation
      ;;

      (with-test-prefix "cancel-thread"

        (pass-if "cancel succeeds"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (begin (lock-mutex m) 'foo))))
	      (cancel-thread t)
	      (join-thread t)
	      #t)))

	(pass-if "handler result passed to join"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (lock-mutex m))))
	      (set-thread-cleanup! t (lambda () 'foo))
	      (cancel-thread t)
	      (eq? (join-thread t) 'foo))))

	(pass-if "can cancel self"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (begin
				     (set-thread-cleanup! (current-thread)
							  (lambda () 'foo))
				     (cancel-thread (current-thread))
				     (lock-mutex m)))))
	      (eq? (join-thread t) 'foo))))

	(pass-if "handler supplants final expr"
	  (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread)
							     (lambda () 'bar))
					'foo))))
	    (eq? (join-thread t) 'bar)))

	(pass-if "remove handler by setting false"
	  (let ((m (make-mutex)))
	    (lock-mutex m)
	    (let ((t (begin-thread (lock-mutex m) 'bar)))
	      (set-thread-cleanup! t (lambda () 'foo))
	      (set-thread-cleanup! t #f)
	      (unlock-mutex m)
	      (eq? (join-thread t) 'bar))))

	(pass-if "initial handler is false"
	  (not (thread-cleanup (current-thread)))))))