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

[Helmut Eller]

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

Modified Files:
	swank-abcl.lisp 
Log Message:
(thread-id, find-thread): New backend function.
Date: Sun Jun 27 08:00:17 2004
Author: heller

Index: slime/swank-abcl.lisp
diff -u slime/swank-abcl.lisp:1.5 slime/swank-abcl.lisp:1.6
--- slime/swank-abcl.lisp:1.5	Sun Jun 27 05:18:51 2004
+++ slime/swank-abcl.lisp	Sun Jun 27 08:00:17 2004
@@ -309,10 +309,27 @@
 (defimplementation startup-multiprocessing ()
   #+nil(mp:start-scheduler))
 
-
 (defimplementation spawn (fn &key name)
   (ext:make-thread (lambda () (funcall fn))))
 
+(defvar *thread-props-lock* (ext:make-thread-lock))
+
+(defvar *thread-props* (make-hash-table) ; should be a weak table
+  "A hashtable mapping threads to a plist.")
+
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+  (ext:with-thread-lock (*thread-props-lock*)
+    (or (getf (gethash thread *thread-props*) 'id)
+        (setf (getf (gethash thread *thread-props*) 'id)
+              (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+  (find id (all-threads) 
+        :test (lambda (thread)
+                (getf (gethash thread *thread-props*) 'id))))
+
 (defimplementation thread-name (thread)
   (princ-to-string thread))
 
@@ -337,15 +354,11 @@
 (defimplementation kill-thread (thread)
   (ext:destroy-thread thread))
 
-(defvar *mailbox-lock* (ext:make-thread-lock))
-
-(defvar *thread-mailbox* (make-hash-table))
-
 (defun mailbox (thread)
   "Return THREAD's mailbox."
-  (ext:with-thread-lock (*mailbox-lock*)
-    (or (gethash thread *thread-mailbox*)
-        (setf (gethash thread *thread-mailbox*)
+  (ext:with-thread-lock (*thread-props-lock*)
+    (or (getf (gethash thread *thread-props*) 'mailbox)
+        (setf (getf (gethash thread *thread-props*) 'mailbox)
               (ext:make-mailbox)))))
 
 (defimplementation send (thread object)