Skip to content
Browse files

(thread-alive-p): Add default implementation.

(describe-primitive-type): Add default implementation.
(inspected-parts): Implemented for Allegro and CLISP.
  • Loading branch information...
1 parent bcb7772 commit aeada8415dad2cb81fea5c975d19cdd42a18c40d Helmut Eller committed
Showing with 59 additions and 26 deletions.
  1. +13 −1 swank-allegro.lisp
  2. +7 −5 swank-backend.lisp
  3. +26 −1 swank-clisp.lisp
  4. +10 −11 swank-cmucl.lisp
  5. +3 −4 swank-lispworks.lisp
  6. +0 −4 swank-sbcl.lisp
View
14 swank-allegro.lisp
@@ -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))
View
12 swank-backend.lisp
@@ -524,12 +524,13 @@ LOCATION is a source location of the form:
;;;; 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 @@ Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
"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.")
View
27 swank-clisp.lisp
@@ -160,7 +160,7 @@ Return NIL if the symbol is unbound."
(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
@@ -510,6 +510,31 @@ Return NIL if the symbol is unbound."
(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)
;;; End:
View
21 swank-cmucl.lisp
@@ -1227,17 +1227,16 @@ LRA = ~X~%" (mapcar #'fixnum
(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)
View
7 swank-lispworks.lisp
@@ -429,10 +429,6 @@ Return NIL if the symbol is unbound."
;;; 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)
@@ -476,6 +472,9 @@ Return NIL if the symbol is unbound."
(defimplementation kill-thread (thread)
(mp:process-kill thread))
+(defimplementation thread-alive-p (thread)
+ (mp:process-alive-p thread))
+
(defvar *mailbox-lock* (mp:make-lock))
(defun mailbox (thread)
View
4 swank-sbcl.lisp
@@ -649,10 +649,6 @@ stack."
;;;; 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))

0 comments on commit aeada84

Please sign in to comment.
Something went wrong with that request. Please try again.