queues.lisp

   1 ;;; ;;;  _*_ Mode: lisp ; Syntax: Common-Lisp
   2 ;; File queue.cl
   3 ;; Creator Bernhard Lahres
   4 ;; changed to make them useful by Michael Trowe
   5 ;; Date 11/02/93
   6 ;;
   7 ;;
   8 ;; Classes queue and queue-list
   9 ;;
  10 ;; queue manages a queue and offers the functions enter-value
  11 ;; and get-value
  12 ;;
  13 ;; queue-list manages a list of named queues and offers the methods
  14 ;; add-named-queue, delete-named-queue and get-named-queue
  15 ;;
  16
  17
  18 (in-package nc)
  19
  20 ;; class queue
  21
  22 (defclass queue()
  23   ((head :accessor head :initform ())
  24    (tail :accessor tail :initform ())))
  25
  26 (defun mq (&rest inits)
  27   (let ((q (make-instance 'lockable-queue)))
  28     (setf (head q) inits)
  29     (setf (tail q) (last inits))
  30     q))
  31
  32 (defmethod empty-queue-p ((queue queue))
  33   (null (head queue)))
  34
  35 (defmethod enqueue ((queue queue) value)
  36   (let ((new-pair (cons value nil)))
  37     (if (empty-queue-p queue)
  38         (setf (head queue) new-pair)
  39       (setf (cdr (tail queue)) new-pair))
  40     (setf (tail queue) new-pair)
  41     queue))
  42
  43
  44 (defmethod dequeue ((queue queue))
  45   (prog1 (car (head queue))
  46     (setf (head queue) (cdr (head queue)))))
  47
  48
  49
  50 (defmethod describe-queue ((queue queue))
  51   (dolist (element (head queue))
  52     (describe element)))
  53
  54 (defmethod all-elements ((queue queue))
  55   (head queue))
  56
  57
  58 (defmethod find-and-delete ((queue queue) element &key (test #'eql))
  59   (loop for pair on (head queue)
  60       and previous = () then pair
  61       for test-result = (funcall test element (car pair))
  62       until test-result
  63       finally (when test-result
  64                 (if previous
  65                     (setf (cdr previous) (cdr pair))
  66                   (setf (head queue) (cdr pair)))
  67                 (when (endp (cdr pair))
  68                   (setf (tail queue) previous))
  69                 (return (car pair)))))
  70
  71 ;;; class lockable-queue
  72 ;;; queue with a lock for use with multiple processes and
  73 ;;; methods for locking and unlocking the queue
  74
  75 (defclass lockable-queue (queue)
  76         ((queue-lock
  77         :accessor queue-lock
  78         :initform (acl-compat-mp:make-process-lock))))
  79
  80 (defmethod enqueue  ((queue lockable-queue) value)
  81   (declare (ignore value))
  82   (acl-compat-mp:with-process-lock ((queue-lock queue)) (call-next-method)))
  83
  84 (defmethod dequeue  ((queue lockable-queue))
  85   (acl-compat-mp:with-process-lock ((queue-lock queue)) (call-next-method)))
  86
  87 (defmethod all-elements ((queue lockable-queue))
  88   (acl-compat-mp:with-process-lock ((queue-lock queue)) (call-next-method)))
  89
  90
  91 ;; class named-queue
  92 ;; this class is simply a queue with a name, but no additional methods
  93
  94 (defclass named-queue (queue)
  95          ((name :accessor name :initarg :name)))
  96
  97 (defclass lockable-named-queue (named-queue lockable-queue) ())
  98
  99
 100 ;; class attributed-queue
 101 ;; this class is simply a queue with attributes, but no additional methods
 102
 103 (defclass attributed-queue (lockable-queue)
 104   ((attribute :accessor attribute :initarg :attribute)))
 105
 106
 107
 108
 109
 110 ;; class queue-list
 111 ;; this class manages a set of named queues
 112
 113 (defclass queue-list ()
 114           ((name :accessor name :initarg :name)
 115            (queues :accessor queues :initform nil)))
 116
 117
 118
 119 ;; enter new named queue
 120 ;; return value is the list of named queues
 121
 122 (defmethod add-named-queue ((queue-list queue-list) name)
 123   (setf (queues queue-list)  (cons (make-instance 'named-queue :name name) (queues queue-list))))
 124
 125
 126
 127 ;; get named queue
 128 ;; return value is a object of class named-queue
 129 ;; if no object with name 'name' is contained in the list,
 130 ;; the return value is nil
 131
 132 (defmethod get-named-queue ((queue-list queue-list) name)
 133   (let ((result nil))
 134     (dolist (element (queues queue-list) result)
 135       (if (eq (name element) name)
 136           (return element)
 137           nil))))
 138
 139
 140 ;; delete a named queue, which was inserted with add-named-queue
 141 ;; the return value is the list of named queues
 142 ;; Should no named queue with name 'name' be contained,
 143 ;; no action is taken.
 144
 145 (defmethod delete-named-queue ((queue-list queue-list) name)
 146   (defun name-equal (list-element)
 147     (eq (name list-element) name))
 148   (setf (queues queue-list)
 149         (remove-if #'name-equal (queues queue-list))))