Commit 9632467a authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Added com.informatimago.clext.queue.

parent 257c3171
......@@ -57,11 +57,14 @@ specifications, like GRAY or other portability libraries.
:depends-on ("com.informatimago.clext.association"
"com.informatimago.clext.character-sets"
#+(or ccl clisp sbcl cmu) "com.informatimago.clext.closer-weak"
#+(or ccl clisp sbcl cmu) "com.informatimago.clext.pipe")
#+(or ccl clisp sbcl cmu) "com.informatimago.clext.pipe"
"com.informatimago.clext.queue")
:components ()
#+adsf3 :in-order-to #+adsf3 ((asdf:test-op (asdf:test-op "com.informatimago.clext.test")
(asdf:test-op "com.informatimago.clext.association.test")
(asdf:test-op "com.informatimago.clext.pipe.test")))
#+adsf3 :in-order-to
#+adsf3 ((asdf:test-op (asdf:test-op "com.informatimago.clext.test")
(asdf:test-op "com.informatimago.clext.association.test")
(asdf:test-op "com.informatimago.clext.pipe.test")
(asdf:test-op "com.informatimago.clext.queue.test")))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
......
......@@ -35,7 +35,7 @@
#+mocl
(asdf:defsystem "com.informatimago.clext.pipe"
;; system attributes:
:description "Dummy Informatimago Common Lisp Extensions: Pipes."
:description "Informatimago Common Lisp Extensions: Pipes."
:long-description "
This system would use TRIVIAL-GRAY-STREAMS, which is not available on MOCL.
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: com.informatimago.clext.queue.asd
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; ASD file to load the com.informatimago.clext.queue library.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-09-12 <PJB> Created this .asd file.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2016
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see http://www.gnu.org/licenses/
;;;;**************************************************************************
#+mocl
(asdf:defsystem "com.informatimago.clext.queue"
;; system attributes:
:description "Informatimago Common Lisp Extensions: Queues."
:long-description "
This system would use TRIVIAL-GRAY-STREAMS, which is not available on MOCL.
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:version "1.2.0"
:properties ((#:author-email . "pjb@informatimago.com")"$HOME"/rc
(#:date . "Summer 2015")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ()
:components ())
#-mocl
(asdf:defsystem "com.informatimago.clext.queue"
;; system attributes:
:description "Informatimago Common Lisp Extensions: Queues."
:long-description "
This system provides QUEUES, a pair of input and output stream
with a synchronized queue in the middle.
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:version "1.2.0"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Summer 2015")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
:depends-on ("bordeaux-threads")
:components ((:file "queue"))
#+adsf3 :in-order-to
#+adsf3 ((asdf:test-op (asdf:test-op "com.informatimago.clext.queue.test")))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: com.informatimago.clext.queue.test.asd
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; ASD file to test the com.informatimago.clext.queue library.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-09-29 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2016
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(asdf:defsystem "com.informatimago.clext.queue.test"
;; system attributes:
:description "Informatimago Common Lisp Extensions: Queues - Tests."
:long-description "
Tests the queues.
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:version "1.2.0"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Automn 2015")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
:depends-on ("com.informatimago.common-lisp.cesarum"
"com.informatimago.clext.queue")
:components ((:file "queue-test"))
#+asdf3 :perform #+asdf3 (asdf:test-op
(operation system)
(declare (ignore operation system))
(let ((*package* (find-package "COM.INFORMATIMAGO.CLEXT.QUEUE")))
(uiop:symbol-call "COM.INFORMATIMAGO.CLEXT.QUEUE.TEST" "TEST/ALL")))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
;;;; THE END ;;;;
......@@ -57,11 +57,12 @@
:depends-on ("com.informatimago.common-lisp.cesarum"
"com.informatimago.clext")
:components ((:file "closer-weak-test" :depends-on nil))
#+asdf3 :perform #+asdf3 (asdf:test-op
(operation system)
(declare (ignore operation system))
(let ((*package* (find-package "COM.INFORMATIMAGO.CLEXT.CLOSER-WEAK.TEST")))
(uiop:symbol-call "COM.INFORMATIMAGO.CLEXT.CLOSER-WEAK.TEST" "TEST/ALL")))
#+asdf3 :perform
#+asdf3 (asdf:test-op
(operation system)
(declare (ignore operation system))
(let ((*package* (find-package "COM.INFORMATIMAGO.CLEXT.CLOSER-WEAK.TEST")))
(uiop:symbol-call "COM.INFORMATIMAGO.CLEXT.CLOSER-WEAK.TEST" "TEST/ALL")))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: queue-test.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Tests the atomic non-negative queue, blocking on decrement at 0.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2016-01-16 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2016
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.CLEXT.QUEUE.TEST"
(:use "COMMON-LISP"
"BORDEAUX-THREADS"
"COM.INFORMATIMAGO.CLEXT.QUEUE"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.TIME")
(:export
"TEST/ALL")
(:documentation "Tests the thread-safe message queue."))
(in-package "COM.INFORMATIMAGO.CLEXT.QUEUE.TEST")
(define-test test/queue (&optional (*standard-output* *standard-output*))
"A simple little test. Check the output."
(slow-test 480
(let ((queue (make-queue "test-queue"))
(out (make-lock "out")))
(check string= (queue-name queue) "test-queue")
(check = (queue-count queue) 0)
(make-thread (lambda ()
(loop
:named producer
:with message := 1000
:repeat 50
:do (with-lock-held (out)
(format t "~&Will enqueue: ~A~%" (incf message)) (finish-output))
(enqueue queue message)
(sleep (random 0.1))))
:name "test-queue-consummer"
:initial-bindings `((*standard-output* . ,*standard-output*)))
(loop :named consumer
:with expected := 1000
:repeat 5
:do (loop :repeat 10
:do (let ((message (dequeue queue)))
(with-lock-held (out)
(format t "~&Did dequeue: ~A~%" message) (finish-output))
(check = message (incf expected))))
(terpri) (force-output)
(sleep 2))
(check string= (queue-name queue) "test-queue")
(check = (queue-count queue) 0))))
(define-test test/all ()
(let ((*test-output* *standard-output*))
(test/queue (make-broadcast-stream))))
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: queue.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; A atomic non-negative queue, blocking on decrement at 0.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-08-29 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2016
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.CLEXT.QUEUE"
(:use "COMMON-LISP"
"BORDEAUX-THREADS")
(:export "QUEUE" "QUEUEP"
"MAKE-QUEUE"
"QUEUE-NAME"
"QUEUE-COUNT"
"ENQUEUE"
"DEQUEUE")
(:documentation "Implements a thread-safe message queue."))
(in-package "COM.INFORMATIMAGO.CLEXT.QUEUE")
(defstruct (queue
(:constructor make-queue
(name
&aux
(lock (make-lock (format nil "~A-LOCK" name)))
(not-empty (make-condition-variable :name (format nil "~A-NOT-EMPTY" name)))))
(:copier nil)
(:predicate queuep))
name head tail lock not-empty)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (documentation 'make-queue 'function) "
RETURN: A new queue named NAME
"
(documentation 'queue-name 'function) "
RETURN: The name of the QUEUE.
"
(documentation 'queue-head 'function) "
RETURN: the head CONS cell of the QUEUE.
"
(documentation 'queue-head 'function) "
RETURN: the tail CONS cell of the QUEUE.
"
(documentation 'queuep 'function) "
RETURN: Predicate for the QUEUE type.
"
(documentation 'queue-lock 'function) "
RETURN: The lock of the QUEUE.
"
(documentation 'queue-not-empty 'function) "
RETURN: The NOT-EMPTY condition variable of the QUEUE.
"))
(defun enqueue (queue message)
"
DO: Atomically enqueues the MESSAGE in the QUEUE. If the
queue was empty, then a condition-notify is sent on the
queue not-empty condition.
RETURN: MESSAGE
"
(with-lock-held ((queue-lock queue))
(if (queue-tail queue)
(setf (cdr (queue-tail queue)) (list message)
(queue-tail queue) (cdr (queue-tail queue)))
(progn
(setf (queue-head queue) (setf (queue-tail queue) (list message)))
(condition-notify (queue-not-empty queue)))))
message)
(defun dequeue (queue)
"
DO: Atomically, dequeue the first message from the QUEUE. If
the queue is empty, then wait on the not-empty condition
of the queue.
RETURN: the dequeued MESSAGE.
"
(with-lock-held ((queue-lock queue))
(loop :until (queue-head queue)
:do (condition-wait (queue-not-empty queue) (queue-lock queue)))
(if (eq (queue-head queue) (queue-tail queue))
(prog1 (car (queue-head queue))
(setf (queue-head queue) nil
(queue-tail queue) nil))
(pop (queue-head queue)))))
(defun queue-count (queue)
(with-lock-held ((queue-lock queue))
(length (queue-head queue))))
;;;; THE END ;;;;
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