/[slime]/slime/swank-lispworks.lisp
ViewVC logotype

Diff of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.101 by heller, Sun Aug 3 18:23:10 2008 UTC revision 1.102 by heller, Mon Aug 4 09:13:06 2008 UTC
# Line 735  function names like \(SETF GET)." Line 735  function names like \(SETF GET)."
735  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
736    (mp:process-alive-p thread))    (mp:process-alive-p thread))
737    
738    (defstruct (mailbox (:conc-name mailbox.))
739      (mutex (mp:make-lock :name "thread mailbox"))
740      (queue '() :type list))
741    
742  (defvar *mailbox-lock* (mp:make-lock))  (defvar *mailbox-lock* (mp:make-lock))
743    
744  (defun mailbox (thread)  (defun mailbox (thread)
745    (mp:with-lock (*mailbox-lock*)    (mp:with-lock (*mailbox-lock*)
746      (or (getf (mp:process-plist thread) 'mailbox)      (or (getf (mp:process-plist thread) 'mailbox)
747          (setf (getf (mp:process-plist thread) 'mailbox)          (setf (getf (mp:process-plist thread) 'mailbox)
748                (mp:make-mailbox)))))                (make-mailbox)))))
749    
750  (defimplementation receive ()  (defimplementation receive ()
751    (receive-if (constantly t)))    (let* ((mbox (mailbox mp:*current-process*))
752             (lock (mailbox.mutex mbox)))
753        (loop
754         (mp:process-wait "receive" #'mailbox.queue mbox)
755         (mp:without-interrupts
756           (mp:with-lock (lock "receive/try" 0.1)
757             (when (mailbox.queue mbox)
758               (return (pop (mailbox.queue mbox)))))))))
759    
760  (defimplementation receive-if (test)  (defimplementation receive-if (test)
761    (loop    (let* ((mbox (mailbox mp:*current-process*))
762     (let* ((self mp:*current-process*)           (lock (mailbox.mutex mbox)))
763            (q (getf (mp:process-plist self) 'queue))      (loop
764            (tail (member-if test q)))       (mp:process-wait "receive-if"
765       (cond (tail                        (lambda () (some test (mailbox.queue mbox))))
766              (setf (getf (mp:process-plist self) 'queue)       (mp:without-interrupts
767                    (nconc (ldiff q tail) (cdr tail)))         (mp:with-lock (lock "receive-if/try" 0.1)
768              (return (car tail)))           (let* ((q (mailbox.queue mbox))
769             (t                  (tail (member-if test q)))
770              (setf (getf (mp:process-plist self) 'queue)             (when tail
771                    (nconc q (list (mp:mailbox-read (mailbox self))))))))))               (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
772                 (return (car tail)))))))))
773  (defimplementation send (thread object)  
774    (mp:mailbox-send (mailbox thread) object))  (defimplementation send (thread message)
775      (let ((mbox (mailbox thread)))
776        (mp:without-interrupts
777          (mp:with-lock ((mailbox.mutex mbox))
778            (setf (mailbox.queue mbox)
779                  (nconc (mailbox.queue mbox) (list message)))))))
780    
781  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
782    

Legend:
Removed from v.1.101  
changed lines
  Added in v.1.102

  ViewVC Help
Powered by ViewVC 1.1.5