60 lines
2.1 KiB
Common Lisp
60 lines
2.1 KiB
Common Lisp
(defvar *self*)
|
|
|
|
(defclass queue ()
|
|
((condition :initform (make-condition-variable)
|
|
:reader condition-of)
|
|
(mailbox :initform '()
|
|
:accessor mailbox-of)
|
|
(lock :initform (make-lock)
|
|
:reader lock-of)))
|
|
|
|
(defun message (recipient name &rest message)
|
|
(with-lock-held ((lock-of recipient))
|
|
;; it would have been better to implement tail-consing or a LIFO
|
|
(setf (mailbox-of recipient)
|
|
(nconc (mailbox-of recipient)
|
|
(list (list* name message))))
|
|
(condition-notify (condition-of recipient)))
|
|
message)
|
|
|
|
(defun mklist (x)
|
|
(if (listp x)
|
|
x
|
|
(list x)))
|
|
|
|
(defun slurp-message ()
|
|
(with-lock-held ((lock-of *self*))
|
|
(if (not (endp (mailbox-of *self*)))
|
|
(pop (mailbox-of *self*))
|
|
(progn (condition-wait (condition-of *self*)
|
|
(lock-of *self*))
|
|
(assert (not (endp (mailbox-of *self*))))
|
|
(pop (mailbox-of *self*))))))
|
|
|
|
(defmacro receive-message (&body cases)
|
|
(let ((msg-name (gensym "MESSAGE"))
|
|
(block-name (gensym "BLOCK")))
|
|
`(let ((,msg-name (slurp-message)))
|
|
(block ,block-name
|
|
,@(loop for i in cases
|
|
for ((name . case) . body) = (cons (mklist (car i))
|
|
(cdr i))
|
|
when (typep i '(or (cons (eql quote)
|
|
t)
|
|
(cons (cons (eql quote) t)
|
|
t)))
|
|
do (warn "~S is a quoted form" i)
|
|
collect `(when ,(if (null name)
|
|
't
|
|
`(eql ',name (car ,msg-name)))
|
|
(destructuring-bind ,case
|
|
(cdr ,msg-name)
|
|
(return-from ,block-name
|
|
(progn ,@body)))))
|
|
(error "Unknown message: ~S" ,msg-name)))))
|
|
|
|
(defmacro receive-one-message (message &body body)
|
|
`(receive-message (,message . ,body)))
|
|
|
|
(defun queue () (make-instance 'queue))
|