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

[Helmut Eller]

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

Modified Files:
      Tag: stateless-emacs
	swank-lispworks.lisp 
Log Message:
*** empty log message ***
Date: Sat Jan 31 06:40:50 2004
Author: heller

Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.19 slime/swank-lispworks.lisp:1.19.2.1
--- slime/swank-lispworks.lisp:1.19	Wed Jan 21 18:03:23 2004
+++ slime/swank-lispworks.lisp	Sat Jan 31 06:40:50 2004
@@ -7,7 +7,7 @@
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
-;;;   $Id: swank-lispworks.lisp,v 1.19 2004/01/21 23:03:23 heller Exp $
+;;;   $Id: swank-lispworks.lisp,v 1.19.2.1 2004/01/31 11:40:50 heller Exp $
 ;;;
 
 (in-package :swank)
@@ -296,6 +296,7 @@
   (etypecase dspec
     (cons (ecase (car dspec)
             (defun `(:function-name ,(symbol-name (cadr dspec))))
+            (method `(:function-name ,(symbol-name (cadr dspec))))
             ;; XXX this isn't quite right
             (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
     (symbol `(:function-name ,(symbol-name dspec)))))
@@ -413,4 +414,24 @@
 
 (defimplementation call-with-lock-held (lock function)
   (mp:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+  mp:*current-process*)
+
+(defimplementation interrupt-thread (thread fn)
+  (mp:process-interrupt thread fn))
+
+(defvar *mailbox-lock* (mp:make-lock))
+
+(defun mailbox (thread)
+  (mp:with-lock (*mailbox-lock*)
+    (or (getf (mp:process-plist thread) 'mailbox)
+        (setf (getf (mp:process-plist thread) 'mailbox)
+              (mp:make-mailbox)))))
+
+(defimplementation receive ()
+  (mp:mailbox-read (mailbox mp:*current-process*)))
+
+(defimplementation send (thread object)
+  (mp:mailbox-send (mailbox thread) object))