contrib/sb-queue/test-queue.lisp

   1 (require :sb-queue)
   2
   3 (defpackage :sb-queue-test
   4   (:use :cl :sb-thread :sb-queue)
   5   (:export))
   6
   7 (in-package :sb-queue-test)
   8
   9 (let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
  10   (enqueue 4 q)
  11   (assert (eq 'test-q (queue-name q)))
  12   (multiple-value-bind (v ok) (dequeue q)
  13     (assert (eql 1 v))
  14     (assert (eq t ok)))
  15   (assert (equal (list-queue-contents q) (list 2 3 4))))
  16
  17 (assert (equal (list nil nil) (multiple-value-list (dequeue (make-queue)))))
  18
  19 (assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil))))))
  20
  21 (let ((x (make-instance 'structure-object))
  22           (y (make-queue)))
  23   (assert (not (typep x 'queue)))
  24   (assert (not (queuep x)))
  25   (assert (typep y 'queue))
  26   (assert (queuep y)))
  27
  28 (let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
  29   (assert (= 5 (queue-count q)))
  30   (enqueue 'foo q)
  31   (assert (= 6 (queue-count q)))
  32   (dequeue q)
  33   (assert (= 5 (queue-count q)))
  34   (dequeue q)
  35   (assert (= 4 (queue-count q)))
  36   (dequeue q)
  37   (assert (= 3 (queue-count q)))
  38   (dequeue q)
  39   (assert (= 2 (queue-count q)))
  40   (dequeue q)
  41   (assert (= 1 (queue-count q)))
  42   (assert (not (queue-empty-p q)))
  43   (dequeue q)
  44   (assert (= 0 (queue-count q)))
  45   (assert (queue-empty-p q))
  46   (dequeue q)
  47   (assert (= 0 (queue-count q)))
  48   (assert (queue-empty-p q)))
  49
  50 #+sb-thread
  51 (let* ((q (make-queue))
  52        (w (make-semaphore))
  53        (r (make-semaphore))
  54        (n 100000)
  55        (schedulers (list
  56                     (make-thread (lambda ()
  57                                    (signal-semaphore r)
  58                                    (wait-on-semaphore w)
  59                                    (dotimes (i n)
  60                                      (enqueue (cons :a i) q))))
  61                     (make-thread (lambda ()
  62                                    (signal-semaphore r)
  63                                    (wait-on-semaphore w)
  64                                    (dotimes (i n)
  65                                      (enqueue (cons :b i) q))))
  66                     (make-thread (lambda ()
  67                                    (signal-semaphore r)
  68                                    (wait-on-semaphore w)
  69                                    (dotimes (i n)
  70                                      (enqueue (cons :c i) q))))
  71                     (make-thread (lambda ()
  72                                    (signal-semaphore r)
  73                                    (wait-on-semaphore w)
  74                                    (dotimes (i n)
  75                                      (enqueue (cons :d i) q)))))))
  76   (loop repeat 4 do (wait-on-semaphore r))
  77   (signal-semaphore w 4)
  78   (mapc #'join-thread schedulers)
  79   (let (a b c d)
  80     (loop
  81       (multiple-value-bind (item ok) (dequeue q)
  82         (cond (item
  83                (assert ok)
  84                (case (car item)
  85                  (:a (push (cdr item) a))
  86                  (:b (push (cdr item) b))
  87                  (:c (push (cdr item) c))
  88                  (:d (push (cdr item) d))))
  89               (t
  90                (assert (not ok))
  91                (return)))))
  92     (labels ((check-list (list)
  93                (when list
  94                  (if (cdr list)
  95                      (when (= (first list) (1- (second list)))
  96                        (check-list (cdr list)))
  97                      (= (first list) (1- n))))))
  98       (assert (eq t (check-list (nreverse a))))
  99       (assert (eq t (check-list (nreverse b))))
 100       (assert (eq t (check-list (nreverse c))))
 101       (assert (eq t (check-list (nreverse d)))))))
 102
 103 #+sb-thread
 104 (let ((q (make-queue))
 105           (w (make-semaphore))
 106           (r (make-semaphore)))
 107       (dotimes (i 1000000)
 108         (enqueue i q))
 109       (flet ((dq ()
 110                (signal-semaphore r)
 111                (wait-on-semaphore w)
 112                (let ((last -1))
 113                  (loop
 114                    (multiple-value-bind (x ok) (dequeue q)
 115                      (cond (x
 116                             (if (and (> x last) ok)
 117                                 (setf last x)
 118                                 (return (list last x ok))))
 119                            (t
 120                             (if (not ok)
 121                                 (return t)
 122                                 (return (list last x ok))))))))))
 123         (let ((deschedulers
 124                (list (make-thread #'dq)
 125                      (make-thread #'dq)
 126                      (make-thread #'dq)
 127                      (make-thread #'dq))))
 128           (loop repeat 4 do (wait-on-semaphore r))
 129           (signal-semaphore w 4)
 130           (mapcar (lambda (th)
 131                     (assert (eq t (join-thread th))))
 132                   deschedulers))))
 133
 134 #+sb-thread
 135 (let* ((q (make-queue))
 136        (w (make-semaphore))
 137        (r (make-semaphore))
 138        (n 100000)
 139        (schedulers (list
 140                     (make-thread (lambda ()
 141                                    (signal-semaphore r)
 142                                    (wait-on-semaphore w)
 143                                    (dotimes (i n)
 144                                      (enqueue (cons :a i) q))))
 145                     (make-thread (lambda ()
 146                                    (signal-semaphore r)
 147                                    (wait-on-semaphore w)
 148                                    (dotimes (i n)
 149                                      (enqueue (cons :b i) q))))
 150                     (make-thread (lambda ()
 151                                    (signal-semaphore r)
 152                                    (wait-on-semaphore w)
 153                                    (dotimes (i n)
 154                                      (enqueue (cons :c i) q))))
 155                     (make-thread (lambda ()
 156                                    (signal-semaphore r)
 157                                    (wait-on-semaphore w)
 158                                    (dotimes (i n)
 159                                      (enqueue (cons :d i) q)))))))
 160   (flet ((dq ()
 161            (let ((a -1)
 162                  (ac 0)
 163                  (b -1)
 164                  (bc 0)
 165                  (c -1)
 166                  (cc 0)
 167                  (d -1)
 168                  (dc 0))
 169              (signal-semaphore r)
 170              (wait-on-semaphore w)
 171              (loop (multiple-value-bind (item ok) (dequeue q)
 172                      (cond (item
 173                             (let ((n (cdr item)))
 174                               (macrolet ((test (name c)
 175                                            `(if (< ,name n)
 176                                                 (progn
 177                                                   (setf ,name n)
 178                                                   (incf ,c))
 179                                                 (return nil))))
 180                                 (ecase (car item)
 181                                   (:a (test a ac))
 182                                   (:b (test b bc))
 183                                   (:c (test c cc))
 184                                   (:d (test d dc))))))
 185                            (t
 186                             (assert (not ok))
 187                             (unless (or (some #'thread-alive-p schedulers)
 188                                         (not (queue-empty-p q)))
 189                               (return (list a ac b bc c cc d dc))))))))))
 190     (let ((deschedulers (list
 191                          (make-thread #'dq)
 192                          (make-thread #'dq)
 193                          (make-thread #'dq)
 194                          (make-thread #'dq))))
 195       (loop repeat 8 do (wait-on-semaphore r))
 196       (signal-semaphore w 8)
 197       (let ((a -1)
 198             (ac 0)
 199             (b -1)
 200             (bc 0)
 201             (c -1)
 202             (cc 0)
 203             (d -1)
 204             (dc 0))
 205         (mapc (lambda (th)
 206                 (let ((results (join-thread th)))
 207                   (when results
 208                     (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
 209                       (setf a (max ta a)
 210                             b (max tb b)
 211                             c (max tc c)
 212                             d (max td d))
 213                       (incf ac tac)
 214                       (incf bc tbc)
 215                       (incf cc tcc)
 216                       (incf dc tdc)))))
 217               deschedulers)
 218         (assert (and (= n ac (1+ a))
 219                      (= n bc (1+ b))
 220                      (= n cc (1+ c))
 221                      (= n dc (1+ d))))))))
 222
 223 ;;;; Unix success convention for exit codes
 224 (sb-ext:quit :unix-status 0)