[slime-cvs] CVS update: slime/swank-backend.lisp slime/swank-allegro.lisp slime/swank-lispworks.lisp slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-clisp.lisp
Helmut Eller
heller at common-lisp.net
Thu Mar 4 22:15:40 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv14565
Modified Files:
swank-backend.lisp swank-allegro.lisp swank-lispworks.lisp
swank-cmucl.lisp swank-sbcl.lisp swank-clisp.lisp
Log Message:
(thread-alive-p): Add default implementation.
(describe-primitive-type): Add default implementation.
(inspected-parts): Implemented for Allegro and CLISP.
Date: Thu Mar 4 17:15:40 2004
Author: heller
Index: slime/swank-backend.lisp
diff -u slime/swank-backend.lisp:1.34 slime/swank-backend.lisp:1.35
--- slime/swank-backend.lisp:1.34 Fri Feb 27 07:32:06 2004
+++ slime/swank-backend.lisp Thu Mar 4 17:15:39 2004
@@ -524,12 +524,13 @@
;;;; Inspector
-(defgeneric inspected-parts (object)
- (:documentation
- "Return a short description and a list of (LABEL . VALUE) pairs."))
+(definterface inspected-parts (object)
+ "Return a short description and a list of (LABEL . VALUE) pairs."
+ (values (format nil "~S is an atom." object) '()))
(definterface describe-primitive-type (object)
- "Return a string describing the primitive type of object.")
+ "Return a string describing the primitive type of object."
+ "N/A")
;;;; Multiprocessing
@@ -582,7 +583,8 @@
"Return a list of all threads.")
(definterface thread-alive-p (thread)
- "Test if THREAD is termintated.")
+ "Test if THREAD is termintated."
+ (member thread (all-threads)))
(definterface interrupt-thread (thread fn)
"Cause THREAD to execute FN.")
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.17 slime/swank-allegro.lisp:1.18
--- slime/swank-allegro.lisp:1.17 Wed Mar 3 15:55:38 2004
+++ slime/swank-allegro.lisp Thu Mar 4 17:15:40 2004
@@ -309,7 +309,19 @@
(push (cons (to-string fspec) location) xrefs)))
(group-xrefs xrefs)))
-;;;; Multiprocessing
+;;;; Inspecting
+
+(defmethod inspected-parts (o)
+ (let* ((class (class-of o))
+ (slots (clos:class-slots class)))
+ (values (format nil "~A~% is a ~A" o class)
+ (mapcar (lambda (slot)
+ (let ((name (clos:slot-definition-name slot)))
+ (cons (to-string name)
+ (slot-value o name))))
+ slots))))
+
+;;;; Multithreading
(defimplementation startup-multiprocessing ()
(mp:start-scheduler))
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.26 slime/swank-lispworks.lisp:1.27
--- slime/swank-lispworks.lisp:1.26 Wed Mar 3 02:08:33 2004
+++ slime/swank-lispworks.lisp Thu Mar 4 17:15:40 2004
@@ -429,10 +429,6 @@
;;; Inspector
-(defimplementation describe-primitive-type (object)
- (declare (ignore object))
- "NYI")
-
(defmethod inspected-parts (o)
(multiple-value-bind (names values _getter _setter type)
(lw:get-inspector-values o nil)
@@ -475,6 +471,9 @@
(defimplementation kill-thread (thread)
(mp:process-kill thread))
+
+(defimplementation thread-alive-p (thread)
+ (mp:process-alive-p thread))
(defvar *mailbox-lock* (mp:make-lock))
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.75 slime/swank-cmucl.lisp:1.76
--- slime/swank-cmucl.lisp:1.75 Wed Mar 3 15:55:38 2004
+++ slime/swank-cmucl.lisp Thu Mar 4 17:15:40 2004
@@ -1227,17 +1227,16 @@
(with-output-to-string (*standard-output*)
(let* ((lowtag (kernel:get-lowtag object))
(lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
- (format t "[lowtag: ~A" lowtag-symbol)
- (cond ((member lowtag (list vm:other-pointer-type
- vm:function-pointer-type
- vm:other-immediate-0-type
- vm:other-immediate-1-type
- ))
- (let* ((type (kernel:get-type object))
- (type-symbol (find type +header-type-symbols+
- :key #'symbol-value)))
- (format t ", type: ~A]" type-symbol)))
- (t (format t "]"))))))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
(defimplementation inspected-parts (o)
(cond ((di::indirect-value-cell-p o)
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.71 slime/swank-sbcl.lisp:1.72
--- slime/swank-sbcl.lisp:1.71 Wed Mar 3 15:55:38 2004
+++ slime/swank-sbcl.lisp Thu Mar 4 17:15:40 2004
@@ -649,10 +649,6 @@
;;;; Inspector
-(defimplementation describe-primitive-type (object)
- (declare (ignore object))
- "NYI")
-
(defmethod inspected-parts (o)
(cond ((sb-di::indirect-value-cell-p o)
(inspected-parts-of-value-cell o))
Index: slime/swank-clisp.lisp
diff -u slime/swank-clisp.lisp:1.22 slime/swank-clisp.lisp:1.23
--- slime/swank-clisp.lisp:1.22 Wed Mar 3 15:55:38 2004
+++ slime/swank-clisp.lisp Thu Mar 4 17:15:40 2004
@@ -160,7 +160,7 @@
(defun find-multiple-definitions (fspec)
(list `(,fspec t)))
-
+(fspec-pathname 'disassemble)
(defun find-definition-in-file (fspec type file)
(declare (ignore fspec type file))
;; FIXME
@@ -509,6 +509,31 @@
(with-condition-restarts condition (list (find-restart 'CONTINUE))
(invoke-debugger condition)))))
nil))
+
+;;; Inspecting
+
+(defmethod inspected-parts (o)
+ (let* ((*print-array* nil) (*print-pretty* t)
+ (*print-circle* t) (*print-escape* t)
+ (*print-lines* custom:*inspect-print-lines*)
+ (*print-level* custom:*inspect-print-level*)
+ (*print-length* custom:*inspect-print-length*)
+ (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
+ (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
+ (*package* tmp-pack)
+ (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
+ (let ((inspection (sys::inspect-backend o)))
+ (values (format nil "~S~% ~A~{~%~A~}" o
+ (sys::insp-title inspection)
+ (sys::insp-blurb inspection))
+ (let ((count (sys::insp-num-slots inspection))
+ (pairs '()))
+ (dotimes (i count)
+ (multiple-value-bind (value name)
+ (funcall (sys::insp-nth-slot inspection) i)
+ (push (cons (to-string (or name i)) value)
+ pairs)))
+ (nreverse pairs))))))
;;; Local Variables:
;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
More information about the slime-cvs
mailing list