[slime-cvs] CVS slime
heller
heller at common-lisp.net
Sat Feb 9 18:39:04 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv18556
Modified Files:
ChangeLog swank-abcl.lisp swank-allegro.lisp
swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp
swank-corman.lisp swank-ecl.lisp swank-lispworks.lisp
swank-openmcl.lisp swank-sbcl.lisp swank-scl.lisp swank.lisp
Log Message:
Inspector cleanups.
* swank.lisp (emacs-inspect): Renamed from inspect-for-emacs.
Changed all method-defs acordingly.
(common-seperated-spec, inspector-princ): Moved to
swank-fancy-inspector.lisp.
(inspector-content): Renamed from inspector-content-for-emacs.
(value-part): Renamed from value-part-for-emacs.
(action-part): Renamed from action-part-for-emacs.
(inspect-list): Renamed from inspect-for-emacs-list.
(inspect-list-aux): New.
(inspect-cons): Renamed from inspect-for-emacs-simple-cons.
(*inspect-length*): Deleted.
(inspect-list): Ignore max-length stuff.
(inspector-content): Don't allow nil elements.
(emacs-inspect array): Make the label of element type more
consistent with the others.
--- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:31:58 1.1283
+++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:38:58 1.1284
@@ -1,4 +1,24 @@
-2008-02-07 Helmut Eller <heller at common-lisp.net>
+2008-02-09 Helmut Eller <heller at common-lisp.net>
+
+ Inspector cleanups.
+
+ * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs.
+ Changed all method-defs acordingly.
+ (common-seperated-spec, inspector-princ): Moved to
+ swank-fancy-inspector.lisp.
+ (inspector-content): Renamed from inspector-content-for-emacs.
+ (value-part): Renamed from value-part-for-emacs.
+ (action-part): Renamed from action-part-for-emacs.
+ (inspect-list): Renamed from inspect-for-emacs-list.
+ (inspect-list-aux): New.
+ (inspect-cons): Renamed from inspect-for-emacs-simple-cons.
+ (*inspect-length*): Deleted.
+ (inspect-list): Ignore max-length stuff.
+ (inspector-content): Don't allow nil elements.
+ (emacs-inspect array): Make the label of element type more
+ consistent with the others.
+
+2008-02-09 Helmut Eller <heller at common-lisp.net>
Cleanup slime-repl-set-package.
--- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/04 17:35:04 1.45
+++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/09 18:38:58 1.46
@@ -421,7 +421,7 @@
;;;; Inspecting
-(defmethod inspect-for-emacs ((slot mop::slot-definition))
+(defmethod emacs-inspect ((slot mop::slot-definition))
(values "A slot."
`("Name: " (:value ,(mop::%slot-definition-name slot))
(:newline)
@@ -436,7 +436,7 @@
" Function: " (:value ,(mop::%slot-definition-initfunction slot))
(:newline))))
-(defmethod inspect-for-emacs ((f function))
+(defmethod emacs-inspect ((f function))
(values "A function."
`(,@(when (function-name f)
`("Name: "
@@ -453,7 +453,7 @@
#|
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(let* ((class (class-of o))
(slots (mop::class-slots class)))
(values (format nil "~A~% is a ~A" o class)
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/04 17:35:04 1.99
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/09 18:38:58 1.100
@@ -564,7 +564,7 @@
;;;; Inspecting
-(defmethod inspect-for-emacs ((f function))
+(defmethod emacs-inspect ((f function))
(values "A function."
(append
(label-value-line "Name" (function-name f))
@@ -573,13 +573,13 @@
(when doc
`("Documentation:" (:newline) ,doc))))))
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(values "A value." (allegro-inspect o)))
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
(values "A function." (allegro-inspect o)))
-(defmethod inspect-for-emacs ((o standard-object))
+(defmethod emacs-inspect ((o standard-object))
(values (format nil "~A is a standard-object." o) (allegro-inspect o)))
(defun allegro-inspect (o)
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/04 17:35:04 1.127
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/09 18:38:58 1.128
@@ -33,11 +33,7 @@
#:declaration-arglist
#:type-specifier-arglist
;; inspector related symbols
- #:inspector
- #:backend-inspector
- #:inspect-for-emacs
- #:raw-inspection
- #:fancy-inspection
+ #:emacs-inspect
#:label-value-line
#:label-value-line*
#:with-struct
@@ -840,7 +836,7 @@
;;;; Inspector
-(defgeneric inspect-for-emacs (object)
+(defgeneric emacs-inspect (object)
(:documentation
"Explain to Emacs how to inspect OBJECT.
@@ -864,7 +860,7 @@
NIL - do nothing."))
-(defmethod inspect-for-emacs ((object t))
+(defmethod emacs-inspect ((object t))
"Generic method for inspecting any kind of object.
Since we don't know how to deal with OBJECT we simply dump the
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/04 17:35:04 1.65
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/09 18:38:58 1.66
@@ -627,7 +627,7 @@
;;;; Inspecting
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(let* ((*print-array* nil) (*print-pretty* t)
(*print-circle* t) (*print-escape* t)
(*print-lines* custom:*inspect-print-lines*)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/04 17:35:03 1.176
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/09 18:38:58 1.177
@@ -1869,7 +1869,7 @@
:key #'symbol-value)))
(format t ", type: ~A" type-symbol))))))
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(cond ((di::indirect-value-cell-p o)
(values (format nil "~A is a value cell." o)
`("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1887,7 +1887,7 @@
(loop for value in parts for i from 0
append (label-value-line i value))))))
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
(let ((header (kernel:get-type o)))
(cond ((= header vm:function-header-type)
(values (format nil "~A is a function." o)
@@ -1914,7 +1914,7 @@
(t
(call-next-method)))))
-(defmethod inspect-for-emacs ((o kernel:funcallable-instance))
+(defmethod emacs-inspect ((o kernel:funcallable-instance))
(values
(format nil "~A is a funcallable-instance." o)
(append (label-value-line*
@@ -1923,7 +1923,7 @@
(:layout (kernel:%funcallable-instance-layout o)))
(nth-value 1 (cmucl-inspect o)))))
-(defmethod inspect-for-emacs ((o kernel:code-component))
+(defmethod emacs-inspect ((o kernel:code-component))
(values (format nil "~A is a code data-block." o)
(append
(label-value-line*
@@ -1950,7 +1950,7 @@
(ash (kernel:%code-code-size o) vm:word-shift)
:stream s))))))))
-(defmethod inspect-for-emacs ((o kernel:fdefn))
+(defmethod emacs-inspect ((o kernel:fdefn))
(values (format nil "~A is a fdenf object." o)
(label-value-line*
("name" (kernel:fdefn-name o))
@@ -1959,7 +1959,7 @@
(sys:int-sap (kernel:get-lisp-obj-address o))
(* vm:fdefn-raw-addr-slot vm:word-bytes))))))
-(defmethod inspect-for-emacs ((o array))
+(defmethod emacs-inspect ((o array))
(if (typep o 'simple-array)
(call-next-method)
(values (format nil "~A is an array." o)
@@ -1974,7 +1974,7 @@
(:displaced-p (kernel:%array-displaced-p o))
(:dimensions (array-dimensions o))))))
-(defmethod inspect-for-emacs ((o simple-vector))
+(defmethod emacs-inspect ((o simple-vector))
(values (format nil "~A is a simple-vector." o)
(append
(label-value-line*
--- /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/04 17:39:52 1.13
+++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/09 18:38:58 1.14
@@ -393,7 +393,7 @@
collect (funcall callback e)
collect ", ")))
-(defmethod inspect-for-emacs ((class standard-class))
+(defmethod emacs-inspect ((class standard-class))
(values "A class."
`("Name: " (:value ,(class-name class))
(:newline)
@@ -430,7 +430,7 @@
'("#<N/A (class not finalized)>"))
(:newline))))
-(defmethod inspect-for-emacs ((slot cons))
+(defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions
(if (eq (car slot) :name)
(values "A slot."
@@ -448,7 +448,7 @@
(:newline)))
(call-next-method)))
-(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal))
+(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
(values (if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
@@ -464,7 +464,7 @@
(not (probe-file pathname)))
(label-value-line "Truename" (truename pathname))))))
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(cond ((cl::structurep o) (inspect-structure o))
(t (call-next-method))))
--- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/04 17:35:03 1.12
+++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/09 18:38:58 1.13
@@ -248,7 +248,7 @@
;;;; Inspector
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
; ecl clos support leaves some to be desired
(cond
((streamp o)
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/04 17:35:03 1.94
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/09 18:39:02 1.95
@@ -629,15 +629,15 @@
(defimplementation make-default-inspector ()
(make-instance 'lispworks-inspector))
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(lispworks-inspect o))
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
(lispworks-inspect o))
;; FIXME: slot-boundp-using-class in LW works with names so we can't
;; use our method in swank.lisp.
-(defmethod inspect-for-emacs ((o standard-object))
+(defmethod emacs-inspect ((o standard-object))
(lispworks-inspect o))
(defun lispworks-inspect (o)
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/04 20:35:11 1.122
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/09 18:39:02 1.123
@@ -802,7 +802,7 @@
(string (gethash typecode *value2tag*))
(string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(let* ((i (inspector::make-inspector o))
(count (inspector::compute-line-count i))
(lines
@@ -820,7 +820,7 @@
(pprint o s)))
lines)))
-(defmethod inspect-for-emacs :around ((o t))
+(defmethod emacs-inspect :around ((o t))
(if (or (uvector-inspector-p o)
(not (ccl:uvectorp o)))
(call-next-method)
@@ -840,7 +840,7 @@
(:method ((object t)) nil)
(:method ((object uvector-inspector)) t))
-(defmethod inspect-for-emacs ((uv uvector-inspector))
+(defmethod emacs-inspect ((uv uvector-inspector))
(with-slots (object)
uv
(values (format nil "The UVECTOR for ~S." object)
@@ -860,7 +860,7 @@
(cellp (ccl::closed-over-value-p value)))
(list label (if cellp (ccl::closed-over-value value) value))))))
-(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure))
+(defmethod emacs-inspect ((c ccl::compiled-lexical-closure))
(values
(format nil "A closure: ~a" c)
`(,@(if (arglist c)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/04 17:41:22 1.189
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/09 18:39:02 1.190
@@ -1001,7 +1001,7 @@
;;;; Inspector
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(cond ((sb-di::indirect-value-cell-p o)
(values "A value cell." (label-value-line*
(:value (sb-kernel:value-cell-ref o)))))
@@ -1013,7 +1013,7 @@
(values text (loop for value in parts for i from 0
append (label-value-line i value))))))))
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
(let ((header (sb-kernel:widetag-of o)))
(cond ((= header sb-vm:simple-fun-header-widetag)
(values "A simple-fun."
@@ -1034,7 +1034,7 @@
i (sb-kernel:%closure-index-ref o i))))))
(t (call-next-method o)))))
-(defmethod inspect-for-emacs ((o sb-kernel:code-component))
+(defmethod emacs-inspect ((o sb-kernel:code-component))
(values (format nil "~A is a code data-block." o)
(append
(label-value-line*
@@ -1062,18 +1062,18 @@
(ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
:stream s))))))))
-(defmethod inspect-for-emacs ((o sb-ext:weak-pointer))
+(defmethod emacs-inspect ((o sb-ext:weak-pointer))
(values "A weak pointer."
(label-value-line*
(:value (sb-ext:weak-pointer-value o)))))
-(defmethod inspect-for-emacs ((o sb-kernel:fdefn))
+(defmethod emacs-inspect ((o sb-kernel:fdefn))
(values "A fdefn object."
(label-value-line*
(:name (sb-kernel:fdefn-name o))
(:function (sb-kernel:fdefn-fun o)))))
-(defmethod inspect-for-emacs :around ((o generic-function))
+(defmethod emacs-inspect :around ((o generic-function))
(multiple-value-bind (title contents) (call-next-method)
(values title
(append
--- /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/04 17:35:03 1.15
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/09 18:39:02 1.16
@@ -1740,7 +1740,7 @@
:key #'symbol-value)))
(format t ", type: ~A" type-symbol))))))
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
(cond ((di::indirect-value-cell-p o)
(values (format nil "~A is a value cell." o)
`("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1759,7 +1759,7 @@
(loop for value in parts for i from 0
append (label-value-line i value))))))
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
(let ((header (kernel:get-type o)))
(cond ((= header vm:function-header-type)
(values (format nil "~A is a function." o)
@@ -1788,7 +1788,7 @@
(call-next-method)))))
-(defmethod inspect-for-emacs ((o kernel:code-component))
+(defmethod emacs-inspect ((o kernel:code-component))
(values (format nil "~A is a code data-block." o)
(append
(label-value-line*
@@ -1815,7 +1815,7 @@
(ash (kernel:%code-code-size o) vm:word-shift)
:stream s))))))))
-(defmethod inspect-for-emacs ((o kernel:fdefn))
+(defmethod emacs-inspect ((o kernel:fdefn))
(values (format nil "~A is a fdenf object." o)
(label-value-line*
("name" (kernel:fdefn-name o))
@@ -1824,7 +1824,7 @@
(sys:int-sap (kernel:get-lisp-obj-address o))
(* vm:fdefn-raw-addr-slot vm:word-bytes))))))
-(defmethod inspect-for-emacs ((o array))
+(defmethod emacs-inspect ((o array))
(cond ((kernel:array-header-p o)
(values (format nil "~A is an array." o)
(label-value-line*
@@ -1843,7 +1843,7 @@
(:header (describe-primitive-type o))
(:length (length o)))))))
-(defmethod inspect-for-emacs ((o simple-vector))
+(defmethod emacs-inspect ((o simple-vector))
(values (format nil "~A is a vector." o)
(append
(label-value-line*
--- /project/slime/cvsroot/slime/swank.lisp 2008/02/04 20:35:11 1.527
+++ /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:39:02 1.528
@@ -13,7 +13,7 @@
;;; available to us here via the `SWANK-BACKEND' package.
(defpackage :swank
- (:use :common-lisp :swank-backend)
+ (:use :cl :swank-backend)
(:export #:startup-multiprocessing
#:start-server
#:create-server
@@ -24,8 +24,8 @@
#:print-indentation-lossage
#:swank-debugger-hook
#:run-after-init-hook
- #:inspect-for-emacs
- #:inspect-slot-for-emacs
+ #:emacs-inspect
+ ;;#:inspect-slot-for-emacs
;; These are user-configurable variables:
#:*communication-style*
#:*dont-close*
@@ -2677,67 +2677,182 @@
;;;; Inspecting
-(defun common-seperated-spec (list &optional (callback (lambda (v)
- `(:value ,v))))
- (butlast
- (loop
- for i in list
- collect (funcall callback i)
- collect ", ")))
-
-(defun inspector-princ (list)
- "Like princ-to-string, but don't rewrite (function foo) as #'foo.
-Do NOT pass circular lists to this function."
- (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
- (set-pprint-dispatch '(cons (member function)) nil)
- (princ-to-string list)))
-
-(defmethod inspect-for-emacs ((object cons))
- (if (consp (cdr object))
- (inspect-for-emacs-list object)
- (inspect-for-emacs-simple-cons object)))
+(defvar *inspectee*)
+(defvar *inspectee-parts*)
+(defvar *inspectee-actions*)
+(defvar *inspector-stack*)
+(defvar *inspector-history*)
+
+(defun reset-inspector ()
+ (setq *inspectee* nil
+ *inspector-stack* '()
+ *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
+ *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
+ *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
+
+(defslimefun init-inspector (string)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (eval (read-from-string string)))))
+
+(defun inspect-object (object)
+ (push (setq *inspectee* object) *inspector-stack*)
+ (unless (find object *inspector-history*)
+ (vector-push-extend object *inspector-history*))
+ (let ((*print-pretty* nil) ; print everything in the same line
+ (*print-circle* t)
+ (*print-readably* nil))
+ (multiple-value-bind (_ content) (emacs-inspect object)
+ (declare (ignore _))
+ (list :title (with-output-to-string (s)
+ (print-unreadable-object (object s :type t :identity t)))
+ :id (assign-index object *inspectee-parts*)
+ :content (inspector-content content)))))
+
+(defun inspector-content (specs)
+ (loop for part in specs collect
+ (etypecase part
+ ;;(null ; XXX encourages sloppy programming
+ ;; nil)
+ (string part)
+ (cons (destructure-case part
+ ((:newline)
+ '#.(string #\newline))
+ ((:value obj &optional str)
+ (value-part obj str))
+ ((:action label lambda &key (refreshp t))
+ (action-part label lambda refreshp)))))))
+
+(defun assign-index (object vector)
+ (let ((index (fill-pointer vector)))
+ (vector-push-extend object vector)
+ index))
+
+(defun value-part (object string)
+ (list :value
+ (or string (print-part-to-string object))
+ (assign-index object *inspectee-parts*)))
+
+(defun action-part (label lambda refreshp)
+ (list :action label (assign-index (list lambda refreshp)
+ *inspectee-actions*)))
+
+(defun print-part-to-string (value)
+ (let ((string (to-string value))
+ (pos (position value *inspector-history*)))
+ (if pos
+ (format nil "#~D=~A" pos string)
+ string)))
+
+(defslimefun inspector-nth-part (index)
+ (aref *inspectee-parts* index))
+
+(defslimefun inspect-nth-part (index)
+ (with-buffer-syntax ()
+ (inspect-object (inspector-nth-part index))))
+
+(defslimefun inspector-call-nth-action (index &rest args)
+ (destructuring-bind (fun refreshp) (aref *inspectee-actions* index)
+ (apply fun args)
+ (if refreshp
+ (inspect-object (pop *inspector-stack*))
+ ;; tell emacs that we don't want to refresh the inspector buffer
+ nil)))
+
+(defslimefun inspector-pop ()
+ "Drop the inspector stack and inspect the second element.
+Return nil if there's no second element."
+ (with-buffer-syntax ()
+ (cond ((cdr *inspector-stack*)
+ (pop *inspector-stack*)
+ (inspect-object (pop *inspector-stack*)))
+ (t nil))))
+
+(defslimefun inspector-next ()
+ "Inspect the next element in the *inspector-history*."
+ (with-buffer-syntax ()
+ (let ((position (position *inspectee* *inspector-history*)))
+ (cond ((= (1+ position) (length *inspector-history*))
+ nil)
+ (t (inspect-object (aref *inspector-history* (1+ position))))))))
-(defun inspect-for-emacs-simple-cons (cons)
+(defslimefun inspector-reinspect ()
+ (inspect-object *inspectee*))
+
+(defslimefun quit-inspector ()
+ (reset-inspector)
+ nil)
+
+(defslimefun describe-inspectee ()
+ "Describe the currently inspected object."
+ (with-buffer-syntax ()
+ (describe-to-string *inspectee*)))
+
+(defslimefun pprint-inspector-part (index)
+ "Pretty-print the currently inspected object."
+ (with-buffer-syntax ()
+ (swank-pprint (list (inspector-nth-part index)))))
+
+(defslimefun inspect-in-frame (string index)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (eval-in-frame (from-string string) index))))
+
+(defslimefun inspect-current-condition ()
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object *swank-debugger-condition*)))
+
+(defslimefun inspect-frame-var (frame var)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (frame-var-value frame var))))
+
+;;;;; Lists
+
+(defmethod emacs-inspect ((o cons))
+ (if (consp (cdr o))
+ (inspect-list o)
+ (inspect-cons o)))
+
+(defun inspect-cons (cons)
(values "A cons cell."
(label-value-line*
('car (car cons))
('cdr (cdr cons)))))
-(defun inspect-for-emacs-list (list)
- (let ((maxlen 40))
- (multiple-value-bind (length tail) (safe-length list)
- (flet ((frob (title list)
- (let (lines)
- (loop for i from 0 for rest on list do
- (if (consp (cdr rest)) ; e.g. (A . (B . ...))
- (push (label-value-line i (car rest)) lines)
- (progn ; e.g. (A . NIL) or (A . B)
- (push (label-value-line i (car rest) :newline nil) lines)
- (when (cdr rest)
- (push '((:newline)) lines)
- (push (label-value-line ':tail () :newline nil) lines))
- (loop-finish)))
- finally
- (setf lines (reduce #'append (nreverse lines) :from-end t)))
- (values title (append '("Elements:" (:newline)) lines)))))
-
- (cond ((not length) ; circular
- (frob "A circular list."
- (cons (car list)
- (ldiff (cdr list) list))))
- ((and (<= length maxlen) (not tail))
- (frob "A proper list." list))
- (tail
- (frob "An improper list." list))
- (t
- (frob "A proper list." list)))))))
+;; (inspect-list '#1=(a #1# . #1# ))
+;; (inspect-list (list* 'a 'b 'c))
+;; (inspect-list (make-list 10000))
+
+(defun inspect-list (list)
+ (multiple-value-bind (length tail) (safe-length list)
+ (flet ((frob (title list)
+ (values nil (append `(,title (:newline))
+ (inspect-list-aux list)))))
+ (cond ((not length)
+ (frob "A circular list:"
+ (cons (car list)
+ (ldiff (cdr list) list))))
+ ((not tail)
+ (frob "A proper list:" list))
+ (t
+ (frob "An improper list:" list))))))
-;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
+(defun inspect-list-aux (list)
+ (loop for i from 0 for rest on list while (consp rest) append
+ (cond ((consp (cdr rest))
+ (label-value-line i (car rest)))
+ ((cdr rest)
+ (label-value-line* (i (car rest))
+ (:tail (cdr rest))))
+ (t
+ (label-value-line i (car rest))))))
(defun safe-length (list)
"Similar to `list-length', but avoid errors on improper lists.
Return two values: the length of the list and the last cdr.
-NIL is returned if the list is circular."
+Return NIL if LIST is circular."
(do ((n 0 (+ n 2)) ;Counter.
(fast list (cddr fast)) ;Fast pointer: leaps by 2.
(slow list (cdr slow))) ;Slow pointer: leaps by 1.
@@ -2752,7 +2867,9 @@
a hash table or array to show by default. If table has more than
this then offer actions to view more. Set to nil for no limit." )
-(defmethod inspect-for-emacs ((ht hash-table))
+;;;;; Hashtables
+
+(defmethod emacs-inspect ((ht hash-table))
(values (prin1-to-string ht)
(append
(label-value-line*
@@ -2804,12 +2921,14 @@
(progn (format t "How many elements should be shown? ") (read))))
(swank::inspect-object thing)))))
-(defmethod inspect-for-emacs ((array array))
+;;;;; Arrays
+
+(defmethod emacs-inspect ((array array))
(values "An array."
(append
(label-value-line*
("Dimensions" (array-dimensions array))
- ("Its element type is" (array-element-type array))
+ ("Element type" (array-element-type array))
("Total size" (array-total-size array))
("Adjustable" (adjustable-array-p array)))
(when (array-has-fill-pointer-p array)
@@ -2822,7 +2941,9 @@
(loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
append (label-value-line i (row-major-aref array i))))))
-(defmethod inspect-for-emacs ((char character))
+;;;;; Chars
+
+(defmethod emacs-inspect ((char character))
(values "A character."
(append
(label-value-line*
@@ -2833,141 +2954,6 @@
`("In the current readtable ("
(:value ,*readtable*) ") it is a macro character: "
(:value ,(get-macro-character char)))))))
-
-(defvar *inspectee*)
-(defvar *inspectee-parts*)
-(defvar *inspectee-actions*)
-(defvar *inspector-stack* '())
-(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
-(declaim (type vector *inspector-history*))
-(defvar *inspect-length* 30)
-
-(defun reset-inspector ()
- (setq *inspectee* nil
- *inspector-stack* nil
- *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
- *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
- *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
-
-(defslimefun init-inspector (string)
- (with-buffer-syntax ()
- (reset-inspector)
- (inspect-object (eval (read-from-string string)))))
-
-(defun print-part-to-string (value)
- (let ((string (to-string value))
- (pos (position value *inspector-history*)))
- (if pos
- (format nil "#~D=~A" pos string)
- string)))
-
-(defun inspector-content-for-emacs (specs)
- (loop for part in specs collect
- (etypecase part
- (null ; XXX encourages sloppy programming
- nil)
- (string part)
- (cons (destructure-case part
- ((:newline)
- (string #\newline))
- ((:value obj &optional str)
- (value-part-for-emacs obj str))
- ((:action label lambda &key (refreshp t))
- (action-part-for-emacs label lambda refreshp)))))))
-
-(defun assign-index (object vector)
- (let ((index (fill-pointer vector)))
- (vector-push-extend object vector)
- index))
-
-(defun value-part-for-emacs (object string)
- (list :value
- (or string (print-part-to-string object))
- (assign-index object *inspectee-parts*)))
-
-(defun action-part-for-emacs (label lambda refreshp)
- (list :action label (assign-index (list lambda refreshp)
- *inspectee-actions*)))
-
-(defun inspect-object (object)
- (push (setq *inspectee* object) *inspector-stack*)
- (unless (find object *inspector-history*)
- (vector-push-extend object *inspector-history*))
- (let ((*print-pretty* nil) ; print everything in the same line
- (*print-circle* t)
- (*print-readably* nil))
- (multiple-value-bind (_ content) (inspect-for-emacs object)
- (declare (ignore _))
- (list :title (with-output-to-string (s)
- (print-unreadable-object (object s :type t :identity t)))
- :id (assign-index object *inspectee-parts*)
- :content (inspector-content-for-emacs content)))))
-
-(defslimefun inspector-nth-part (index)
- (aref *inspectee-parts* index))
-
-(defslimefun inspect-nth-part (index)
- (with-buffer-syntax ()
- (inspect-object (inspector-nth-part index))))
-
-(defslimefun inspector-call-nth-action (index &rest args)
- (destructuring-bind (action-lambda refreshp)
- (aref *inspectee-actions* index)
- (apply action-lambda args)
- (if refreshp
- (inspect-object (pop *inspector-stack*))
- ;; tell emacs that we don't want to refresh the inspector buffer
- nil)))
-
-(defslimefun inspector-pop ()
- "Drop the inspector stack and inspect the second element. Return
-nil if there's no second element."
- (with-buffer-syntax ()
- (cond ((cdr *inspector-stack*)
- (pop *inspector-stack*)
- (inspect-object (pop *inspector-stack*)))
- (t nil))))
-
-(defslimefun inspector-next ()
- "Inspect the next element in the *inspector-history*."
- (with-buffer-syntax ()
- (let ((position (position *inspectee* *inspector-history*)))
- (cond ((= (1+ position) (length *inspector-history*))
- nil)
- (t (inspect-object (aref *inspector-history* (1+ position))))))))
[36 lines skipped]
More information about the slime-cvs
mailing list