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

[Helmut Eller]

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

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

Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.47 slime/swank-lispworks.lisp:1.48
--- slime/swank-lispworks.lisp:1.47	Fri Jun 25 01:05:38 2004
+++ slime/swank-lispworks.lisp	Sun Jun 27 08:00:43 2004
@@ -91,7 +91,7 @@
 
 (defimplementation call-without-interrupts (fn)
   (lw:without-interrupts (funcall fn)))
-
+  
 (defimplementation getpid ()
   #+win32 (win32:get-current-process-id)
   #-win32 (system::getpid))
@@ -196,8 +196,9 @@
   "Unwind FRAME N times."
   (do ((frame frame (dbg::frame-next frame))
        (i n (if (interesting-frame-p frame) (1- i) i)))
-      ((and (interesting-frame-p frame) (zerop i)) frame)
-    (assert frame)))
+      ((or (not frame)
+           (and (interesting-frame-p frame) (zerop i)))
+       frame)))
 
 (defun nth-frame (index)
   (nth-next-frame *sldb-top-frame* index))
@@ -536,6 +537,19 @@
                  mp:*process-initial-bindings*
                  :key (lambda (x) (symbol-package (car x))))))
     (mp:process-run-function name () fn)))
+
+(defvar *id-lock* (mp:make-lock))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+  (mp:with-lock (*id-lock*)
+    (or (getf (mp:process-plist thread) 'id)
+        (setf (getf (mp:process-plist thread) 'id)
+              (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+  (find id (mp:list-all-processes) 
+        :key (lambda (p) (getf (mp:process-plist p) 'id))))
 
 (defimplementation thread-name (thread)
   (mp:process-name thread))