[slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-lispworks.lisp slime/swank-allegro.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp
Helmut Eller
heller at common-lisp.net
Sat Feb 7 19:30:07 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv5569
Modified Files:
swank-cmucl.lisp swank-lispworks.lisp swank-allegro.lisp
swank-openmcl.lisp swank-sbcl.lisp
Log Message:
Update for modified thread interface.
Date: Sat Feb 7 14:30:06 2004
Author: heller
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.60 slime/swank-cmucl.lisp:1.61
--- slime/swank-cmucl.lisp:1.60 Sat Feb 7 06:40:09 2004
+++ slime/swank-cmucl.lisp Sat Feb 7 14:30:05 2004
@@ -1306,10 +1306,6 @@
#+MP
(progn
- (defvar *known-processes* '() ; FIXME: leakage. -luke
- "List of processes that have been assigned IDs.
- The ID is the position in the list.")
-
(defimplementation startup-multiprocessing ()
(setq *swank-in-background* :spawn)
;; Threads magic: this never returns! But top-level becomes
@@ -1319,29 +1315,17 @@
(defimplementation spawn (fn &key (name "Anonymous"))
(mp:make-process fn :name name))
- (defimplementation thread-id ()
- (mp:without-scheduling
- (or (find-thread-id)
- (prog1 (length *known-processes*)
- (setq *known-processes*
- (append *known-processes* (list (mp:current-process))))))))
-
- (defun find-thread-id (&optional (process (mp:current-process)))
- (position process *known-processes*))
-
- (defun lookup-thread (thread-id)
- (or (nth thread-id *known-processes*)
- (error "Unknown Thread-ID: ~S" thread-id)))
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
- (defimplementation thread-name (thread-id)
- (mp:process-name (lookup-thread thread-id)))
+ (defimplementation thread-status (thread)
+ (mp:process-whostate thread))
- (defimplementation make-lock (&key name)
- (mp:make-lock name))
+ (defimplementation current-thread ()
+ mp:*current-process*)
- (defimplementation call-with-lock-held (lock function)
- (mp:with-lock-held (lock)
- (funcall function)))
+ (defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
)
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.20 slime/swank-lispworks.lisp:1.21
--- slime/swank-lispworks.lisp:1.20 Sat Jan 31 06:50:25 2004
+++ slime/swank-lispworks.lisp Sat Feb 7 14:30:05 2004
@@ -7,8 +7,6 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-lispworks.lisp,v 1.20 2004/01/31 11:50:25 heller Exp $
-;;;
(in-package :swank)
@@ -210,15 +208,21 @@
(invoke-restart-interactively (nth-restart index)))
(defimplementation frame-locals (n)
- (let ((frame (nth-frame n)))
+ (let ((frame (nth-frame n))
+ (*print-readably* nil)
+ (*print-pretty* t)
+ (*print-circle* t))
(if (dbg::call-frame-p frame)
(destructuring-bind (vars with)
(dbg::frame-locals-format-list frame #'list 75 0)
(declare (ignore with))
- (loop for (name value symbol location) in vars
- collect (list :name (to-string symbol) :id 0
- :value-string
- (to-string value)))))))
+ (mapcar (lambda (var)
+ (destructuring-bind (name value symbol location) var
+ (declare (ignore name location))
+ (list :name (to-string symbol) :id 0
+ :value-string
+ (to-string value))))
+ vars)))))
(defimplementation frame-catch-tags (index)
(declare (ignore index))
@@ -402,12 +406,13 @@
(defimplementation spawn (fn &key name)
(mp:process-run-function name () fn))
-;; XXX: shortcut
-(defimplementation thread-id ()
- (mp:process-name mp:*current-process*))
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
-(defimplementation thread-name (thread-id)
- thread-id)
+(defimplementation thread-status (thread)
+ (format nil "~A ~D"
+ (mp:process-whostate thread)
+ (mp:process-priority thread)))
(defimplementation make-lock (&key name)
(mp:make-lock :name name))
@@ -417,6 +422,9 @@
(defimplementation current-thread ()
mp:*current-process*)
+
+(defimplementation all-threads ()
+ (mp:list-all-processes))
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.12 slime/swank-allegro.lisp:1.13
--- slime/swank-allegro.lisp:1.12 Sat Jan 31 06:50:25 2004
+++ slime/swank-allegro.lisp Sat Feb 7 14:30:05 2004
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-allegro.lisp,v 1.12 2004/01/31 11:50:25 heller Exp $
+;;; $Id: swank-allegro.lisp,v 1.13 2004/02/07 19:30:05 heller Exp $
;;;
;;; This code was written for
;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)"
@@ -323,12 +323,12 @@
(defimplementation spawn (fn &key name)
(mp:process-run-function name fn))
-;; XXX: shurtcut
-(defimplementation thread-id ()
- (mp:process-name mp:*current-process*))
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
-(defimplementation thread-name (thread-id)
- thread-id)
+(defimplementation thread-status (thread)
+ (format nil "~A ~D" (mp:process-whostate thread)
+ (mp:process-priority thread)))
(defimplementation make-lock (&key name)
(mp:make-process-lock :name name))
@@ -340,7 +340,7 @@
mp:*current-process*)
(defimplementation all-threads ()
- mp:*all-processes*)
+ (copy-list mp:*all-processes*))
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.60 slime/swank-openmcl.lisp:1.61
--- slime/swank-openmcl.lisp:1.60 Thu Feb 5 02:01:50 2004
+++ slime/swank-openmcl.lisp Sat Feb 7 14:30:05 2004
@@ -603,18 +603,11 @@
(defimplementation startup-multiprocessing ()
(setq *swank-in-background* :spawn))
-(defimplementation thread-id ()
- (let* ((thread ccl:*current-process*)
- (id (ccl::process-serial-number thread)))
- (ccl:with-lock-grabbed (*known-processes-lock*)
- (unless (rassoc thread *known-processes* :key #'car)
- (setq *known-processes*
- (acons id (list thread (make-mailbox)) *known-processes*))))
- id))
+(defimplementation thread-name (thread)
+ (ccl::process-name thread))
-(defimplementation thread-name (thread-id)
- (ccl:with-lock-grabbed (*known-processes-lock*)
- (ccl::process-name (cdr (assoc thread-id *known-processes*)))))
+(defimplementation thread-status (thread)
+ (format nil "~A" (ccl:process-whostate thread)))
(defimplementation make-lock (&key name)
(ccl:make-lock name))
@@ -625,6 +618,9 @@
(defimplementation current-thread ()
ccl:*current-process*)
+
+(defimplementation all-threads ()
+ (ccl:all-processes))
(defimplementation interrupt-thread (thread fn)
(ccl:process-interrupt thread fn))
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.62 slime/swank-sbcl.lisp:1.63
--- slime/swank-sbcl.lisp:1.62 Sat Feb 7 08:19:17 2004
+++ slime/swank-sbcl.lisp Sat Feb 7 14:30:05 2004
@@ -628,6 +628,11 @@
(sb-profile:profile))
+;;;;
+
+
+
+
;;;; Multiprocessing
#+SB-THREAD
@@ -639,11 +644,12 @@
(defimplementation startup-multiprocessing ()
(setq *swank-in-background* :spawn))
- (defimplementation thread-id ()
- (sb-thread:current-thread-id))
+ (defimplementation thread-name (thread)
+ (format nil "Thread ~D" thread))
- (defimplementation thread-name (thread-id)
- (format nil "Thread ~S" thread-id))
+ (defimplementation thread-status (thread)
+ (declare (ignore thread))
+ "???")
(defimplementation make-lock (&key name)
(sb-thread:make-mutex :name name))
@@ -655,7 +661,7 @@
(defimplementation current-thread ()
(sb-thread:current-thread-id))
- (defun all-threads ()
+ (defimplementation all-threads ()
(sb-thread::mapcar-threads
(lambda (sap)
(sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
More information about the slime-cvs
mailing list