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

[Helmut Eller]

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

Modified Files:
	swank-sbcl.lisp 
Log Message:
(thread-status): Decode the thread-state-slot instead of returning ???.

Date: Fri Nov 19 02:19:26 2004
Author: heller

Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.108 slime/swank-sbcl.lisp:1.109
--- slime/swank-sbcl.lisp:1.108	Tue Nov 16 00:07:37 2004
+++ slime/swank-sbcl.lisp	Fri Nov 19 02:19:25 2004
@@ -838,8 +838,21 @@
     (format nil "Thread ~D" thread))
 
   (defimplementation thread-status (thread)
-    (declare (ignore thread))
-    "???")
+    (sb-sys:without-gcing
+     (let ((thread (sb-thread::thread-sap-from-id thread)))
+       (cond (thread
+              (let* ((sap (sb-sys:sap-ref-sap thread 
+                                              (* sb-vm::thread-state-slot
+                                                 sb-vm::n-word-bytes)))
+                     (state (ash (sb-sys:sap-int sap)
+                                 (- sb-vm::n-fixnum-tag-bits))))
+                (case state
+                  (0 "running")
+                  (1 "stopping")
+                  (2 "stopped")
+                  (3 "dead")
+                  (t (format nil "??? ~A" state)))))
+             (t "??? ???"))))))
 
   (defimplementation make-lock (&key name)
     (sb-thread:make-mutex :name name))