X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-concurrency%2Fmailbox.lisp;h=dfa6c8ff2e988bc4fc1eddf0606ae9eb6aca50af;hb=18a1f7605aa95cb84282900298c369514e9d49c2;hp=ba4f651a602f4a9ed54cadaa6af14d3de41e54f3;hpb=ea0735f0b8bab352d6c9797abec19e8c63563cf6;p=sbcl.git

diff --git a/contrib/sb-concurrency/mailbox.lisp b/contrib/sb-concurrency/mailbox.lisp
index ba4f651..dfa6c8f 100644
--- a/contrib/sb-concurrency/mailbox.lisp
+++ b/contrib/sb-concurrency/mailbox.lisp
@@ -18,7 +18,13 @@
 (defstruct (mailbox (:constructor %make-mailbox (queue semaphore name))
                     (:copier nil)
                     (:predicate mailboxp))
-  "Mailbox aka message queue."
+  "Mailbox aka message queue.
+
+SEND-MESSAGE adds a message to the mailbox, RECEIVE-MESSAGE waits till
+a message becomes available, whereas RECEIVE-MESSAGE-NO-HANG is a non-blocking
+variant, and RECEIVE-PENDING-MESSAGES empties the entire mailbox in one go.
+
+Messages can be arbitrary objects"
   (queue (missing-arg) :type queue)
   (semaphore (missing-arg) :type semaphore)
   (name nil))
@@ -66,19 +72,23 @@ mailbox. Does not remove messages from the mailbox."
     (enqueue message (mailbox-queue mailbox))
     (signal-semaphore (mailbox-semaphore mailbox))))
 
-;;; TODO: TIMEOUT argument.
-(defun receive-message (mailbox &key)
-  "Removes the oldest message from MAILBOX and returns it as the
-primary value. If MAILBOX is empty waits until a message arrives."
+(defun receive-message (mailbox &key timeout)
+  "Removes the oldest message from MAILBOX and returns it as the primary
+value, and a secondary value of T. If MAILBOX is empty waits until a message
+arrives.
+
+If TIMEOUT is provided, and no message arrives within the specified interval,
+returns primary and secondary value of NIL."
   (tagbody
      ;; Disable interrupts for keeping semaphore count in sync with
      ;; #msgs in the mailbox.
      (sb-sys:without-interrupts
        (sb-sys:allow-with-interrupts
-         (wait-on-semaphore (mailbox-semaphore mailbox)))
+         (or (wait-on-semaphore (mailbox-semaphore mailbox) :timeout timeout)
+             (return-from receive-message (values nil nil))))
        (multiple-value-bind (value ok) (dequeue (mailbox-queue mailbox))
          (if ok
-             (return-from receive-message value)
+             (return-from receive-message (values value t))
              (go :error))))
    :error
      (sb-int:bug "Mailbox ~S empty after WAIT-ON-SEMAPHORE."