[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv5277

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-openmcl.lisp 
	swank.lisp 
Log Message:
Generalize list-threads for implementation-dependent attributes.

* swank-backend.lisp (thread-attributes): New function.
* swank-openmcl (thread-attributes): Implement it.
* swank.lisp (list-threads): Return a table with the attribute
names as the first row and the new attributes in the last columns.
* slime.el (slime-update-threads-buffer): For now, ignore the
extra attributes.

--- /project/slime/cvsroot/slime/ChangeLog	2009/06/28 19:14:54	1.1797
+++ /project/slime/cvsroot/slime/ChangeLog	2009/06/28 19:15:07	1.1798
@@ -1,3 +1,14 @@
+2009-06-28  Terje Norderhaug <terje at in-progress.com>
+
+	Generalize list-threads for implementation-dependent attributes.
+
+	* swank-backend.lisp (thread-attributes): New function.
+	* swank-openmcl (thread-attributes): Implement it.
+	* swank.lisp (list-threads): Return a table with the attribute
+	names as the first row and the new attributes in the last columns.
+	* slime.el (slime-update-threads-buffer): For now, ignore the
+	extra attributes.
+
 2009-06-28  Stelian Ionescu <stelian.ionescu-zeus at poste.it>
 
 	* slime.el (slime-compiler-macroexpand-inplace)
--- /project/slime/cvsroot/slime/slime.el	2009/06/28 19:14:54	1.1192
+++ /project/slime/cvsroot/slime/slime.el	2009/06/28 19:15:08	1.1193
@@ -6122,7 +6122,7 @@
 
 (defun slime-update-threads-buffer ()
   (interactive)
-  (let ((threads (slime-eval '(swank:list-threads))))
+  (let ((threads (cdr (slime-eval '(swank:list-threads)))))
     (with-current-buffer slime-threads-buffer-name
       (let ((inhibit-read-only t))
         (erase-buffer)
--- /project/slime/cvsroot/slime/swank-backend.lisp	2009/06/21 07:22:56	1.176
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2009/06/28 19:15:08	1.177
@@ -1007,6 +1007,11 @@
   (declare (ignore thread description))
   "")
 
+(definterface thread-attributes (thread)
+  "Return a plist of implementation-dependent attributes for THREAD"
+  (declare (ignore thread))
+  '())
+
 (definterface make-lock (&key name)
    "Make a lock for thread synchronization.
 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/06/28 08:27:03	1.180
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/06/28 19:15:08	1.181
@@ -843,6 +843,9 @@
 (defimplementation thread-status (thread)
   (format nil "~A" (ccl:process-whostate thread)))
 
+(defimplementation thread-attributes (thread)
+   (list :priority (ccl::process-priority thread)))
+
 (defimplementation make-lock (&key name)
   (ccl:make-lock name))
 
--- /project/slime/cvsroot/slime/swank.lisp	2009/06/24 15:33:20	1.650
+++ /project/slime/cvsroot/slime/swank.lisp	2009/06/28 19:15:08	1.651
@@ -3595,15 +3595,23 @@
 a time.")
 
 (defslimefun list-threads ()
-  "Return a list ((ID NAME STATUS DESCRIPTION) ...) of all threads."
+  "Return a list (LABELS (ID NAME STATUS DESCRIPTION ATTRS ...) ...).
+LABELS is a list of attribute names and the remaining lists are the
+corresponding attribute values per thread."
   (setq *thread-list* (all-threads))
-  (loop for thread in  *thread-list* 
-       for name = (thread-name thread)
-        collect (list (thread-id thread)
-                      (if (symbolp name) (symbol-name name) name)
-                      (thread-status thread)
-                      (thread-description thread)
-                      )))
+  (let* ((plist (thread-attributes (car *thread-list*)))
+         (labels (loop for (key) on plist by #'cddr 
+                       collect key)))
+    `((:id :name :status :description , at labels)
+      ,@(loop for thread in *thread-list*
+              for name = (thread-name thread)
+              for attributes = (thread-attributes thread)
+              collect (list* (thread-id thread)
+                             (if (symbolp name) (symbol-name name) name)
+                             (thread-status thread)
+                             (thread-description thread)
+                             (loop for label in labels
+                                   collect (getf attributes label)))))))
 
 (defslimefun quit-thread-browser ()
   (setq *thread-list* nil))