[slime-cvs] CVS update: slime/swank-cmucl.lisp

[Helmut Eller]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv15904

Modified Files:
	swank-cmucl.lisp 
Log Message:
Implement more threading functions.
Date: Sat Feb  7 17:31:11 2004
Author: heller

Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.61 slime/swank-cmucl.lisp:1.62
--- slime/swank-cmucl.lisp:1.61	Sat Feb  7 14:30:05 2004
+++ slime/swank-cmucl.lisp	Sat Feb  7 17:31:11 2004
@@ -1204,7 +1204,8 @@
      (append (apropos-list "-TYPE" "VM" t)
 	     (apropos-list "-TYPE" "BIGNUM" t)))))
 
-(defmethod describe-primitive-type (object)
+
+(defimplementation describe-primitive-type (object)
   (with-output-to-string (*standard-output*)
     (let* ((lowtag (kernel:get-lowtag object))
 	   (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
@@ -1220,7 +1221,7 @@
 	       (format t ", type: ~A]" type-symbol)))
 	    (t (format t "]"))))))
 
-(defmethod inspected-parts (o)
+(defimplementation inspected-parts (o)
   (cond ((di::indirect-value-cell-p o)
 	 (inspected-parts-of-value-cell o))
 	(t
@@ -1326,6 +1327,36 @@
 
   (defimplementation all-threads ()
     (copy-list mp:*all-processes*))
+
+  (defimplementation interrupt-thread (thread fn)
+    (mp:process-interrupt thread fn))
+
+  (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
+  
+  (defstruct (mailbox (:conc-name mailbox.)) 
+    (mutex (mp:make-lock "process mailbox"))
+    (queue '() :type list))
+
+  (defun mailbox (thread)
+    "Return THREAD's mailbox."
+    (mp:with-lock-held (*mailbox-lock*)
+      (or (getf (mp:process-property-list thread) 'mailbox)
+          (setf (getf (mp:process-property-list thread) 'mailbox)
+                (make-mailbox)))))
+  
+  (defimplementation send (thread message)
+    (let* ((mbox (mailbox thread))
+           (mutex (mailbox.mutex mbox)))
+      (mp:with-lock-held (mutex)
+        (setf (mailbox.queue mbox)
+              (nconc (mailbox.queue mbox) (list message))))))
+  
+  (defimplementation receive ()
+    (let* ((mbox (mailbox mp:*current-process*))
+           (mutex (mailbox.mutex mbox)))
+      (mp:process-wait "receive" #'mailbox.queue mbox)
+      (mp:with-lock-held (mutex)
+        (pop (mailbox.queue mbox)))))
 
   )