-(require :sb-queue)
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was written at
+;;;; Carnegie Mellon University and released into the public domain. The
+;;;; software is in the public domain and is provided with absolutely no
+;;;; warranty. See the COPYING and CREDITS files for more information.
(defpackage :sb-queue-test
- (:use :cl :sb-thread :sb-queue)
+ (:use :cl :sb-thread :sb-queue :sb-rt)
(:export))
(in-package :sb-queue-test)
-(let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
- (enqueue 4 q)
- (assert (eq 'test-q (queue-name q)))
- (multiple-value-bind (v ok) (dequeue q)
- (assert (eql 1 v))
- (assert (eq t ok)))
- (assert (equal (list-queue-contents q) (list 2 3 4))))
+(deftest queue.1
+ (let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
+ (enqueue 4 q)
+ (values (queue-name q)
+ (multiple-value-list (dequeue q))
+ (list-queue-contents q)))
+ test-q
+ (1 t)
+ (2 3 4))
-(assert (equal (list nil nil) (multiple-value-list (dequeue (make-queue)))))
+(deftest queue.2
+ (dequeue (make-queue))
+ nil
+ nil)
-(assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil))))))
+(deftest queue.3
+ (dequeue (make-queue :initial-contents '(nil)))
+ nil
+ t)
-(let ((x (make-instance 'structure-object))
- (y (make-queue)))
- (assert (not (typep x 'queue)))
- (assert (not (queuep x)))
- (assert (typep y 'queue))
- (assert (queuep y)))
+(deftest queue.4
+ (let ((x (make-instance 'structure-object))
+ (y (make-queue)))
+ ;; I wonder why I thought this needs testing?
+ (values (typep x 'queue)
+ (queuep x)
+ (typep y 'queue)
+ (queuep y)))
+ nil nil t t)
-(let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
- (assert (= 5 (queue-count q)))
- (enqueue 'foo q)
- (assert (= 6 (queue-count q)))
- (dequeue q)
- (assert (= 5 (queue-count q)))
- (dequeue q)
- (assert (= 4 (queue-count q)))
- (dequeue q)
- (assert (= 3 (queue-count q)))
- (dequeue q)
- (assert (= 2 (queue-count q)))
- (dequeue q)
- (assert (= 1 (queue-count q)))
- (assert (not (queue-empty-p q)))
- (dequeue q)
- (assert (= 0 (queue-count q)))
- (assert (queue-empty-p q))
- (dequeue q)
- (assert (= 0 (queue-count q)))
- (assert (queue-empty-p q)))
+(deftest queue.5
+ (let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
+ (values (= 5 (queue-count q))
+ (enqueue 'foo q)
+ (= 6 (queue-count q))
+ (dequeue q)
+ (= 5 (queue-count q))
+ (dequeue q)
+ (= 4 (queue-count q))
+ (dequeue q)
+ (= 3 (queue-count q))
+ (dequeue q)
+ (= 2 (queue-count q))
+ (dequeue q)
+ (= 1 (queue-count q))
+ (not (queue-empty-p q))
+ (dequeue q)
+ (= 0 (queue-count q))
+ (queue-empty-p q)
+ (dequeue q)
+ (= 0 (queue-count q))
+ (queue-empty-p q)))
+ t
+ foo
+ t
+ 1
+ t
+ 2
+ t
+ 3
+ t
+ 4
+ t
+ 5
+ t
+ t
+ foo
+ t
+ t
+ nil
+ t
+ t)
#+sb-thread
-(let* ((q (make-queue))
- (w (make-semaphore))
- (r (make-semaphore))
- (n 100000)
- (schedulers (list
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :a i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :b i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :c i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :d i) q)))))))
- (loop repeat 4 do (wait-on-semaphore r))
- (signal-semaphore w 4)
- (mapc #'join-thread schedulers)
- (let (a b c d)
- (loop
- (multiple-value-bind (item ok) (dequeue q)
- (cond (item
- (assert ok)
- (case (car item)
- (:a (push (cdr item) a))
- (:b (push (cdr item) b))
- (:c (push (cdr item) c))
- (:d (push (cdr item) d))))
- (t
- (assert (not ok))
- (return)))))
- (labels ((check-list (list)
- (when list
- (if (cdr list)
- (when (= (first list) (1- (second list)))
- (check-list (cdr list)))
- (= (first list) (1- n))))))
- (assert (eq t (check-list (nreverse a))))
- (assert (eq t (check-list (nreverse b))))
- (assert (eq t (check-list (nreverse c))))
- (assert (eq t (check-list (nreverse d)))))))
+(deftest queue.t.1
+ (let* ((q (make-queue))
+ (w (make-semaphore))
+ (r (make-semaphore))
+ (n 100000)
+ (schedulers (list
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :a i) q))))
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :b i) q))))
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :c i) q))))
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :d i) q)))))))
+ (loop repeat 4 do (wait-on-semaphore r))
+ (signal-semaphore w 4)
+ (mapc #'join-thread schedulers)
+ (let (a b c d)
+ (loop
+ (multiple-value-bind (item ok) (dequeue q)
+ (cond (item
+ (assert ok)
+ (case (car item)
+ (:a (push (cdr item) a))
+ (:b (push (cdr item) b))
+ (:c (push (cdr item) c))
+ (:d (push (cdr item) d))))
+ (t
+ (assert (not ok))
+ (return)))))
+ (labels ((check-list (list)
+ (when list
+ (if (cdr list)
+ (when (= (first list) (1- (second list)))
+ (check-list (cdr list)))
+ (= (first list) (1- n))))))
+ (values (check-list (nreverse a))
+ (check-list (nreverse b))
+ (check-list (nreverse c))
+ (check-list (nreverse d))))))
+ t
+ t
+ t
+ t)
#+sb-thread
-(let ((q (make-queue))
+(deftest queue.t.2
+ (let ((q (make-queue))
(w (make-semaphore))
(r (make-semaphore)))
(dotimes (i 1000000)
(make-thread #'dq))))
(loop repeat 4 do (wait-on-semaphore r))
(signal-semaphore w 4)
- (mapcar (lambda (th)
- (assert (eq t (join-thread th))))
- deschedulers))))
+ (mapcar #'join-thread deschedulers))))
+ (t t t t))
#+sb-thread
-(let* ((q (make-queue))
- (w (make-semaphore))
- (r (make-semaphore))
- (n 100000)
- (schedulers (list
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :a i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :b i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :c i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :d i) q)))))))
- (flet ((dq ()
- (let ((a -1)
- (ac 0)
- (b -1)
- (bc 0)
- (c -1)
- (cc 0)
- (d -1)
- (dc 0))
- (signal-semaphore r)
- (wait-on-semaphore w)
- (loop (multiple-value-bind (item ok) (dequeue q)
- (cond (item
- (let ((n (cdr item)))
- (macrolet ((test (name c)
- `(if (< ,name n)
- (progn
- (setf ,name n)
- (incf ,c))
- (return nil))))
- (ecase (car item)
- (:a (test a ac))
- (:b (test b bc))
- (:c (test c cc))
- (:d (test d dc))))))
- (t
- (assert (not ok))
- (unless (or (some #'thread-alive-p schedulers)
- (not (queue-empty-p q)))
- (return (list a ac b bc c cc d dc))))))))))
- (let ((deschedulers (list
- (make-thread #'dq)
- (make-thread #'dq)
- (make-thread #'dq)
- (make-thread #'dq))))
- (loop repeat 8 do (wait-on-semaphore r))
- (signal-semaphore w 8)
- (let ((a -1)
- (ac 0)
- (b -1)
- (bc 0)
- (c -1)
- (cc 0)
- (d -1)
- (dc 0))
- (mapc (lambda (th)
- (let ((results (join-thread th)))
- (when results
- (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
- (setf a (max ta a)
- b (max tb b)
- c (max tc c)
- d (max td d))
- (incf ac tac)
- (incf bc tbc)
- (incf cc tcc)
- (incf dc tdc)))))
- deschedulers)
- (assert (and (= n ac (1+ a))
- (= n bc (1+ b))
- (= n cc (1+ c))
- (= n dc (1+ d))))))))
-
-;;;; Unix success convention for exit codes
-(sb-ext:quit :unix-status 0)
+(deftest queue.t.3
+ (let* ((q (make-queue))
+ (w (make-semaphore))
+ (r (make-semaphore))
+ (n 100000)
+ (schedulers (list
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :a i) q))))
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :b i) q))))
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :c i) q))))
+ (make-thread (lambda ()
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (dotimes (i n)
+ (enqueue (cons :d i) q)))))))
+ (flet ((dq ()
+ (let ((a -1)
+ (ac 0)
+ (b -1)
+ (bc 0)
+ (c -1)
+ (cc 0)
+ (d -1)
+ (dc 0))
+ (signal-semaphore r)
+ (wait-on-semaphore w)
+ (loop (multiple-value-bind (item ok) (dequeue q)
+ (cond (item
+ (let ((n (cdr item)))
+ (macrolet ((test (name c)
+ `(if (< ,name n)
+ (progn
+ (setf ,name n)
+ (incf ,c))
+ (return nil))))
+ (ecase (car item)
+ (:a (test a ac))
+ (:b (test b bc))
+ (:c (test c cc))
+ (:d (test d dc))))))
+ (t
+ (assert (not ok))
+ (unless (or (some #'thread-alive-p schedulers)
+ (not (queue-empty-p q)))
+ (return (list a ac b bc c cc d dc))))))))))
+ (let ((deschedulers (list
+ (make-thread #'dq)
+ (make-thread #'dq)
+ (make-thread #'dq)
+ (make-thread #'dq))))
+ (loop repeat 8 do (wait-on-semaphore r))
+ (signal-semaphore w 8)
+ (let ((a -1)
+ (ac 0)
+ (b -1)
+ (bc 0)
+ (c -1)
+ (cc 0)
+ (d -1)
+ (dc 0))
+ (mapc (lambda (th)
+ (let ((results (join-thread th)))
+ (when results
+ (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
+ (setf a (max ta a)
+ b (max tb b)
+ c (max tc c)
+ d (max td d))
+ (incf ac tac)
+ (incf bc tbc)
+ (incf cc tcc)
+ (incf dc tdc)))))
+ deschedulers)
+ (and (= n ac (1+ a))
+ (= n bc (1+ b))
+ (= n cc (1+ c))
+ (= n dc (1+ d)))))))
+ t)
projects / sbcl.git / blobdiff