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

[Helmut Eller]

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

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

Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.39 slime/swank-allegro.lisp:1.40
--- slime/swank-allegro.lisp:1.39	Fri Jun 25 01:05:21 2004
+++ slime/swank-allegro.lisp	Sun Jun 27 08:00:23 2004
@@ -297,6 +297,19 @@
 (defimplementation spawn (fn &key name)
   (mp:process-run-function name fn))
 
+(defvar *id-lock* (mp:make-process-lock :name "id lock"))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+  (mp:with-process-lock (*id-lock*)
+    (or (getf (mp:process-property-list thread) 'id)
+        (setf (getf (mp:process-property-list thread) 'id)
+              (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+  (find id mp:*all-processes*
+        :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
 (defimplementation thread-name (thread)
   (mp:process-name thread))