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

Diff of /slime/swank-allegro.lisp

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

revision 1.106 by heller, Mon Aug 4 21:38:07 2008 UTC revision 1.107 by heller, Thu Aug 7 07:53:47 2008 UTC
# Line 661  Line 661 
661  (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))  (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
662    
663  (defstruct (mailbox (:conc-name mailbox.))  (defstruct (mailbox (:conc-name mailbox.))
664    (mutex (mp:make-process-lock :name "process mailbox"))    (lock (mp:make-process-lock :name "process mailbox"))
665    (queue '() :type list))    (queue '() :type list)
666      (gate (mp:make-gate)))
667    
668  (defun mailbox (thread)  (defun mailbox (thread)
669    "Return THREAD's mailbox."    "Return THREAD's mailbox."
# Line 672  Line 673 
673                (make-mailbox)))))                (make-mailbox)))))
674    
675  (defimplementation send (thread message)  (defimplementation send (thread message)
676    (let* ((mbox (mailbox thread))    (let* ((mbox (mailbox thread)))
677           (mutex (mailbox.mutex mbox)))      (mp:with-process-lock ((mailbox.lock mbox))
678      (mp:with-process-lock (mutex)        (setf (mailbox.queue mbox)
679        (setf (mailbox.queue mbox)              (nconc (mailbox.queue mbox) (list message)))
680              (nconc (mailbox.queue mbox) (list message))))))        (mp:open-gate (mailbox.gate mbox)))))
681    
682  (defimplementation receive ()  (defimplementation receive ()
683    (let* ((mbox (mailbox mp:*current-process*))    (receive-if (constantly t)))
          (mutex (mailbox.mutex mbox)))  
     (mp:process-wait "receive" #'mailbox.queue mbox)  
     (mp:with-process-lock (mutex)  
       (pop (mailbox.queue mbox)))))  
684    
685  (defimplementation receive-if (test)  (defimplementation receive-if (test)
686    (let ((mbox (mailbox mp:*current-process*)))    (let ((mbox (mailbox mp:*current-process*)))
687      (mp:process-wait "receive-if"      (loop
688                       (lambda () (some test (mailbox.queue mbox))))       (check-slime-interrupts)
689      (mp:with-process-lock ((mailbox.mutex mbox))       (mp:with-process-lock ((mailbox.lock mbox))
690        (let* ((q (mailbox.queue mbox))         (let* ((q (mailbox.queue mbox))
691               (tail (member-if test q)))                (tail (member-if test q)))
692          (assert tail)           (when tail
693          (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))             (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
694          (car tail)))))             (return (car tail)))
695             (mp:close-gate (mailbox.gate mbox))))
696        (mp:process-wait-with-timeout "receive-if" 0.5
697                                      #'mp:gate-open-p (mailbox.gate mbox)))))
698    
699  (defimplementation quit-lisp ()  (defimplementation quit-lisp ()
700    (excl:exit 0 :quiet t))    (excl:exit 0 :quiet t))

Legend:
Removed from v.1.106  
changed lines
  Added in v.1.107

  ViewVC Help
Powered by ViewVC 1.1.5