[bknr-cvs] r2475 - in branches/trunk-reorg/thirdparty/slime: . CVS contrib contrib/CVS
hhubner at common-lisp.net
hhubner at common-lisp.net
Mon Feb 11 14:25:00 UTC 2008
Author: hhubner
Date: Mon Feb 11 09:24:55 2008
New Revision: 2475
Modified:
branches/trunk-reorg/thirdparty/slime/CVS/Entries
branches/trunk-reorg/thirdparty/slime/ChangeLog
branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el
branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el
branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp
branches/trunk-reorg/thirdparty/slime/slime.el
branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp
branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp
branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp
branches/trunk-reorg/thirdparty/slime/swank-corman.lisp
branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp
branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp
branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp
branches/trunk-reorg/thirdparty/slime/swank-scl.lisp
branches/trunk-reorg/thirdparty/slime/swank.lisp
Log:
update slime from cvs
Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/CVS/Entries (original)
+++ branches/trunk-reorg/thirdparty/slime/CVS/Entries Mon Feb 11 09:24:55 2008
@@ -1,7 +1,6 @@
D/contrib////
D/doc////
/.cvsignore/1.5/Thu Oct 11 14:10:25 2007//
-/ChangeLog/1.1282/Thu Feb 7 08:07:30 2008//
/HACKING/1.8/Thu Oct 11 14:10:25 2007//
/NEWS/1.9/Sun Dec 2 04:22:09 2007//
/PROBLEMS/1.8/Thu Oct 11 14:10:25 2007//
@@ -12,24 +11,25 @@
/nregex.lisp/1.4/Thu Oct 11 14:10:25 2007//
/sbcl-pprint-patch.lisp/1.1/Thu Oct 11 14:10:25 2007//
/slime-autoloads.el/1.4/Thu Feb 7 08:07:30 2008//
-/slime.el/1.901/Thu Feb 7 08:07:31 2008//
-/swank-abcl.lisp/1.45/Thu Feb 7 08:07:31 2008//
-/swank-allegro.lisp/1.99/Thu Feb 7 08:07:31 2008//
-/swank-backend.lisp/1.127/Thu Feb 7 08:07:31 2008//
-/swank-clisp.lisp/1.65/Thu Feb 7 08:07:31 2008//
-/swank-cmucl.lisp/1.176/Thu Feb 7 08:07:31 2008//
-/swank-corman.lisp/1.13/Thu Feb 7 08:07:31 2008//
-/swank-ecl.lisp/1.12/Thu Feb 7 08:07:31 2008//
/swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007//
-/swank-lispworks.lisp/1.94/Thu Feb 7 08:07:31 2008//
/swank-loader.lisp/1.77/Thu Feb 7 08:07:31 2008//
-/swank-openmcl.lisp/1.122/Thu Feb 7 08:07:31 2008//
-/swank-sbcl.lisp/1.189/Thu Feb 7 08:07:31 2008//
-/swank-scl.lisp/1.15/Thu Feb 7 08:07:31 2008//
/swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007//
/swank-source-path-parser.lisp/1.18/Thu Feb 7 07:59:36 2008//
/swank.asd/1.5/Thu Oct 11 14:10:25 2007//
-/swank.lisp/1.527/Thu Feb 7 08:07:31 2008//
/test-all.sh/1.2/Thu Oct 11 14:10:25 2007//
/test.sh/1.9/Thu Oct 11 14:10:25 2007//
/xref.lisp/1.2/Thu Oct 11 14:10:25 2007//
+/ChangeLog/1.1289/Mon Feb 11 14:20:11 2008//
+/slime.el/1.904/Mon Feb 11 14:20:11 2008//
+/swank-abcl.lisp/1.47/Mon Feb 11 14:20:11 2008//
+/swank-allegro.lisp/1.101/Mon Feb 11 14:20:11 2008//
+/swank-backend.lisp/1.129/Mon Feb 11 14:20:11 2008//
+/swank-clisp.lisp/1.67/Mon Feb 11 14:20:11 2008//
+/swank-cmucl.lisp/1.178/Mon Feb 11 14:20:11 2008//
+/swank-corman.lisp/1.15/Mon Feb 11 14:20:11 2008//
+/swank-ecl.lisp/1.14/Mon Feb 11 14:20:11 2008//
+/swank-lispworks.lisp/1.97/Mon Feb 11 14:20:11 2008//
+/swank-openmcl.lisp/1.124/Mon Feb 11 14:20:11 2008//
+/swank-sbcl.lisp/1.191/Mon Feb 11 14:20:11 2008//
+/swank-scl.lisp/1.18/Mon Feb 11 14:20:11 2008//
+/swank.lisp/1.531/Mon Feb 11 14:20:11 2008//
Modified: branches/trunk-reorg/thirdparty/slime/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/ChangeLog (original)
+++ branches/trunk-reorg/thirdparty/slime/ChangeLog Mon Feb 11 09:24:55 2008
@@ -1,3 +1,78 @@
+2008-02-10 Helmut Eller <heller at common-lisp.net>
+
+ Remove remaining traces of make-default-inspector.
+
+ * swank-scl.lisp (make-default-inspector, scl-inspector): Deleted.
+ * swank-lispworks.lisp (make-default-inspector)
+ (lispworks-inspector): Deleted.
+
+2008-02-09 Helmut Eller <heller at common-lisp.net>
+
+ Drop the first return value of emacs-inspect.
+
+ * swank.lisp (emacs-inspect): Drop the first return value. It
+ wasn't used anymore. Update all methods and callers.
+
+2008-02-09 Helmut Eller <heller at common-lisp.net>
+
+ Remove obsolete *slime-inspect-contents-limit*.
+
+ * swank.lisp (*slime-inspect-contents-limit*): Deleted and all its
+ uses. The new implementation isn't specific to hash-tables or
+ arrays.
+
+2008-02-09 Helmut Eller <heller at common-lisp.net>
+
+ Limit the length of the inspector content.
+ That's similar to the limitation of the length of backtraces in
+ the debugger.
+
+ * swank.lisp (*inspectee-content*): New variable.
+ (content-range): New function.
+ (inspect-object): Use it with a length of 1000.
+ (inspector-range): New function. Called from Emacs.
+
+ * slime.el (slime-inspector-insert-content)
+ (slime-inspector-insert-range, slime-inspector-insert-range-button)
+ (slime-inspector-fetch-range): New functions.
+ (slime-inspector-operate-on-point): Handle range-buttons.
+
+2008-02-09 Helmut Eller <heller at common-lisp.net>
+
+ Make slime-property-bounds more useful.
+
+ * slime.el (slime-property-bounds): Remove special casing for
+ whitespace at the end.
+ (slime-repl-send-input): Don't mark the newline with the
+ slime-repl-old-input property.
+ (sldb-frame-region): Use slime-property-bounds.
+
+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 accordingly.
+ (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.
+
+ * slime.el (slime-repl-set-package): Make it fit within 80 columns.
+
2008-02-05 Marco Baringer <mb at bese.it>
* slime.el (slime-search-buffer-package): Ask the lisp to read the
Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries (original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries Mon Feb 11 09:24:55 2008
@@ -1,4 +1,3 @@
-/ChangeLog/1.87/Thu Feb 7 08:07:31 2008//
/README/1.3/Thu Oct 11 14:10:25 2007//
/bridge.el/1.1/Thu Oct 11 14:10:25 2007//
/inferior-slime.el/1.2/Thu Oct 11 14:10:25 2007//
@@ -7,8 +6,6 @@
/slime-banner.el/1.4/Thu Oct 11 14:10:25 2007//
/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007//
/slime-editing-commands.el/1.6/Thu Feb 7 07:59:35 2008//
-/slime-fancy-inspector.el/1.2/Thu Oct 11 14:10:25 2007//
-/slime-fancy.el/1.4/Thu Oct 11 14:10:25 2007//
/slime-fuzzy.el/1.6/Thu Feb 7 07:59:35 2008//
/slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007//
/slime-indentation.el/1.1/Sun Feb 3 18:45:14 2008//
@@ -25,7 +22,6 @@
/swank-arglists.lisp/1.20/Thu Feb 7 08:07:31 2008//
/swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007//
/swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007//
-/swank-fancy-inspector.lisp/1.7/Thu Feb 7 08:07:32 2008//
/swank-fuzzy.lisp/1.7/Thu Feb 7 07:59:35 2008//
/swank-goo.goo/1.1/Thu Feb 7 08:07:32 2008//
/swank-indentation.lisp/1.1/Sun Feb 3 18:45:14 2008//
@@ -34,4 +30,8 @@
/swank-motd.lisp/1.1/Sun Feb 3 18:39:23 2008//
/swank-presentation-streams.lisp/1.5/Thu Feb 7 08:07:32 2008//
/swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007//
+/ChangeLog/1.89/Mon Feb 11 14:20:11 2008//
+/slime-fancy-inspector.el/1.3/Mon Feb 11 14:20:11 2008//
+/slime-fancy.el/1.5/Mon Feb 11 14:20:11 2008//
+/swank-fancy-inspector.lisp/1.11/Mon Feb 11 14:20:11 2008//
D
Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog (original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog Mon Feb 11 09:24:55 2008
@@ -1,3 +1,16 @@
+2008-02-10 Helmut Eller <heller at common-lisp.net>
+
+ Fix some bugs introduced by the recent reorganization.
+
+ * swank-fancy-inspector.lisp (emacs-inspect pathname): Fix it
+ again.
+
+ * slime-fancy-inspector.el: Use slime-require.
+
+ * slime-fancy.el: slime-fancy-inspector-init no longer exists, so
+ don't call it. Once loaded, it's also no longer possible to turn
+ the fancy inspector off.
+
2008-02-04 Marco Baringer <mb at bese.it>
* swank-presentation-streams.lisp (presenting-object-1): Add
Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el (original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el Mon Feb 11 09:24:55 2008
@@ -3,26 +3,7 @@
;; Author: Marco Baringer <mb at bese.it> and others
;; License: GNU GPL (same license as Emacs)
;;
-;;; Installation
-;;
-;; Add this to your .emacs:
-;;
-;; (add-to-list 'load-path "<directory-of-this-file>")
-;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector)))
-;; (add-hook 'slime-connected-hook 'slime-install-fancy-inspector)
-
-(defun slime-install-fancy-inspector ()
- (slime-eval-async '(swank:swank-require :swank-fancy-inspector)
- (lambda (_)
- (slime-eval-async '(swank:fancy-inspector-init)))))
-
-(defun slime-deinstall-fancy-inspector ()
- (slime-eval-async '(swank:fancy-inspector-unload)))
-
-(defun slime-fancy-inspector-init ()
- (add-hook 'slime-connected-hook 'slime-install-fancy-inspector))
-(defun slime-fancy-inspector-unload ()
- (remove-hook 'slime-connected-hook 'slime-install-fancy-inspector))
+(slime-require :swank-fancy-inspector)
(provide 'slime-fancy-inspector)
\ No newline at end of file
Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el (original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el Mon Feb 11 09:24:55 2008
@@ -31,9 +31,8 @@
(require 'slime-editing-commands)
(slime-editing-commands-init)
-;; Makes the inspector fancier.
+;; Makes the inspector fancier. (Once loaded, can't be turned off.)
(require 'slime-fancy-inspector)
-(slime-fancy-inspector-init)
;; Just adds the command C-c M-i. We do not make fuzzy completion the
;; default completion invoked by TAB. --mkoeppe
Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp Mon Feb 11 09:24:55 2008
@@ -6,14 +6,12 @@
(in-package :swank)
-(defmethod inspect-for-emacs ((symbol symbol))
+(defmethod emacs-inspect ((symbol symbol))
(let ((package (symbol-package symbol)))
(multiple-value-bind (_symbol status)
(and package (find-symbol (string symbol) package))
(declare (ignore _symbol))
- (values
- "A symbol."
- (append
+ (append
(label-value-line "Its name is" (symbol-name symbol))
;;
;; Value
@@ -77,7 +75,7 @@
;; More package
(if (find-package symbol)
(label-value-line "It names the package" (find-package symbol)))
- )))))
+ ))))
(defun docstring-ispec (label object kind)
"Return a inspector spec if OBJECT has a docstring of of kind KIND."
@@ -89,16 +87,15 @@
(t
(list label ": " '(:newline) " " docstring '(:newline))))))
-(defmethod inspect-for-emacs ((f function))
- (values "A function."
- (append
+(defmethod emacs-inspect ((f function))
+ (append
(label-value-line "Name" (function-name f))
`("Its argument list is: "
,(inspector-princ (arglist f)) (:newline))
(docstring-ispec "Documentation" f t)
(if (function-lambda-expression f)
(label-value-line "Lambda Expression"
- (function-lambda-expression f))))))
+ (function-lambda-expression f)))))
(defun method-specializers-for-inspect (method)
"Return a \"pretty\" list of the method's specializers. Normal
@@ -122,11 +119,10 @@
(swank-mop:method-qualifiers method)
(method-specializers-for-inspect method)))
-(defmethod inspect-for-emacs ((object standard-object))
+(defmethod emacs-inspect ((object standard-object))
(let ((class (class-of object)))
- (values "An object."
`("Class: " (:value ,class) (:newline)
- ,@(all-slots-for-inspector object)))))
+ ,@(all-slots-for-inspector object))))
(defvar *gf-method-getter* 'methods-by-applicability
"This function is called to get the methods of a generic function.
@@ -224,11 +220,9 @@
append slot-presentation
collect '(:newline))))))
-(defmethod inspect-for-emacs ((gf standard-generic-function))
+(defmethod emacs-inspect ((gf standard-generic-function))
(flet ((lv (label value) (label-value-line label value)))
- (values
- "A generic function."
- (append
+ (append
(lv "Name" (swank-mop:generic-function-name gf))
(lv "Arguments" (swank-mop:generic-function-lambda-list gf))
(docstring-ispec "Documentation" gf t)
@@ -247,10 +241,9 @@
(remove-method gf m))))
(:newline)))
`((:newline))
- (all-slots-for-inspector gf)))))
+ (all-slots-for-inspector gf))))
-(defmethod inspect-for-emacs ((method standard-method))
- (values "A method."
+(defmethod emacs-inspect ((method standard-method))
`("Method defined on the generic function "
(:value ,(swank-mop:method-generic-function method)
,(inspector-princ
@@ -267,10 +260,9 @@
(:newline)
"Method function: " (:value ,(swank-mop:method-function method))
(:newline)
- ,@(all-slots-for-inspector method))))
+ ,@(all-slots-for-inspector method)))
-(defmethod inspect-for-emacs ((class standard-class))
- (values "A class."
+(defmethod emacs-inspect ((class standard-class))
`("Name: " (:value ,(class-name class))
(:newline)
"Super classes: "
@@ -326,10 +318,9 @@
`(:value ,(swank-mop:class-prototype class))
'"#<N/A (class not finalized)>")
(:newline)
- ,@(all-slots-for-inspector class))))
+ ,@(all-slots-for-inspector class)))
-(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition))
- (values "A slot."
+(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition))
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
@@ -342,7 +333,7 @@
"#<unspecified>") (:newline)
"Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
(:newline)
- ,@(all-slots-for-inspector slot))))
+ ,@(all-slots-for-inspector slot)))
;; Wrapper structure over the list of symbols of a package that should
@@ -434,10 +425,10 @@
(:newline)
)))))
-(defmethod inspect-for-emacs ((%container %package-symbols-container))
+(defmethod emacs-inspect ((%container %package-symbols-container))
(with-struct (%container. title description symbols grouping-kind) %container
- (values title
- `(, at description
+ `(,title (:newline)
+ , at description
(:newline)
" " ,(ecase grouping-kind
(:symbol
@@ -449,9 +440,9 @@
,(lambda () (setf grouping-kind :symbol))
:refreshp t)))
(:newline) (:newline)
- ,@(make-symbols-listing grouping-kind symbols)))))
+ ,@(make-symbols-listing grouping-kind symbols))))
-(defmethod inspect-for-emacs ((package package))
+(defmethod emacs-inspect ((package package))
(let ((package-name (package-name package))
(package-nicknames (package-nicknames package))
(package-use-list (package-use-list package))
@@ -479,8 +470,6 @@
external-symbols (sort external-symbols #'string<)) ; SBCL 0.9.18.
- (values
- "A package."
`("" ; dummy to preserve indentation.
"Name: " (:value ,package-name) (:newline)
@@ -542,27 +531,27 @@
(:newline)
,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
:title (format nil "All shadowed symbols of package \"~A\"" package-name)
- :description nil)))))))
+ :description nil))))))
-(defmethod inspect-for-emacs ((pathname pathname))
- (values (if (wild-pathname-p pathname)
- "A wild pathname."
- "A pathname.")
- (append (label-value-line*
- ("Namestring" (namestring pathname))
- ("Host" (pathname-host pathname))
- ("Device" (pathname-device pathname))
- ("Directory" (pathname-directory pathname))
- ("Name" (pathname-name pathname))
- ("Type" (pathname-type pathname))
- ("Version" (pathname-version pathname)))
- (unless (or (wild-pathname-p pathname)
- (not (probe-file pathname)))
- (label-value-line "Truename" (truename pathname))))))
+(defmethod emacs-inspect ((pathname pathname))
+ `(,(if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ (:newline)
+ ,@(label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ ,@ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname)))))
-(defmethod inspect-for-emacs ((pathname logical-pathname))
- (values "A logical pathname."
+(defmethod emacs-inspect ((pathname logical-pathname))
(append
(label-value-line*
("Namestring" (namestring pathname))
@@ -579,10 +568,10 @@
("Type" (pathname-type pathname))
("Version" (pathname-version pathname))
("Truename" (if (not (wild-pathname-p pathname))
- (probe-file pathname)))))))
+ (probe-file pathname))))))
-(defmethod inspect-for-emacs ((n number))
- (values "A number." `("Value: " ,(princ-to-string n))))
+(defmethod emacs-inspect ((n number))
+ `("Value: " ,(princ-to-string n)))
(defun format-iso8601-time (time-value &optional include-timezone-p)
"Formats a universal time TIME-VALUE in ISO 8601 format, with
@@ -604,8 +593,7 @@
year month day hour minute second
include-timezone-p (format-iso8601-timezone zone)))))
-(defmethod inspect-for-emacs ((i integer))
- (values "A number."
+(defmethod emacs-inspect ((i integer))
(append
`(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
i i i i (ignore-errors (coerce i 'float)))
@@ -614,23 +602,20 @@
(label-value-line "Code-char" (code-char i)))
(label-value-line "Integer-length" (integer-length i))
(ignore-errors
- (label-value-line "Universal-time" (format-iso8601-time i t))))))
+ (label-value-line "Universal-time" (format-iso8601-time i t)))))
-(defmethod inspect-for-emacs ((c complex))
- (values "A complex number."
+(defmethod emacs-inspect ((c complex))
(label-value-line*
("Real part" (realpart c))
- ("Imaginary part" (imagpart c)))))
+ ("Imaginary part" (imagpart c))))
-(defmethod inspect-for-emacs ((r ratio))
- (values "A non-integer ratio."
+(defmethod emacs-inspect ((r ratio))
(label-value-line*
("Numerator" (numerator r))
("Denominator" (denominator r))
- ("As float" (float r)))))
+ ("As float" (float r))))
-(defmethod inspect-for-emacs ((f float))
- (values "A floating point number."
+(defmethod emacs-inspect ((f float))
(cond
((> f most-positive-long-float)
(list "Positive infinity."))
@@ -647,13 +632,11 @@
(:value ,significand) " * "
(:value ,(float-radix f)) "^" (:value ,exponent) (:newline))
(label-value-line "Digits" (float-digits f))
- (label-value-line "Precision" (float-precision f))))))))
+ (label-value-line "Precision" (float-precision f)))))))
-(defmethod inspect-for-emacs ((stream file-stream))
- (multiple-value-bind (title content)
+(defmethod emacs-inspect ((stream file-stream))
+ (multiple-value-bind (content)
(call-next-method)
- (declare (ignore title))
- (values "A file stream."
(append
`("Pathname: "
(:value ,(pathname stream))
@@ -665,14 +648,13 @@
(ed-in-emacs `(,pathname :charpos ,position))))
:refreshp nil)
(:newline))
- content))))
+ content)))
-(defmethod inspect-for-emacs ((condition stream-error))
- (multiple-value-bind (title content)
+(defmethod emacs-inspect ((condition stream-error))
+ (multiple-value-bind (content)
(call-next-method)
(let ((stream (stream-error-stream condition)))
(if (typep stream 'file-stream)
- (values "A stream error."
(append
`("Pathname: "
(:value ,(pathname stream))
@@ -684,16 +666,22 @@
(ed-in-emacs `(,pathname :charpos ,position))))
:refreshp nil)
(:newline))
- content))
- (values title content)))))
+ content)
+ content))))
-(defvar *fancy-inpector-undo-list* nil)
-
-(defslimefun fancy-inspector-init ()
- t)
-
-(defslimefun fancy-inspector-unload ()
- (loop while *fancy-inpector-undo-list* do
- (funcall (pop *fancy-inpector-undo-list*))))
+(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)))
(provide :swank-fancy-inspector)
Modified: branches/trunk-reorg/thirdparty/slime/slime.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/slime.el (original)
+++ branches/trunk-reorg/thirdparty/slime/slime.el Mon Feb 11 09:24:55 2008
@@ -2267,11 +2267,7 @@
(save-excursion
(when (or (re-search-backward regexp nil t)
(re-search-forward regexp nil t))
- ;; package name can be a string designator, convert it to a string.
- ;;(slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0))))
- ;; "COMMON-LISP-USER")
- (match-string-no-properties 2)
- ))))
+ (match-string-no-properties 2)))))
;;; Synchronous requests are implemented in terms of asynchronous
;;; ones. We make an asynchronous request with a continuation function
@@ -3176,14 +3172,14 @@
(let ((end (point))) ; end of input, without the newline
(slime-repl-add-to-input-history
(buffer-substring slime-repl-input-start-mark end))
- (when newline
- (insert "\n")
- (slime-repl-show-maximum-output))
(let ((inhibit-read-only t))
(add-text-properties slime-repl-input-start-mark
(point)
`(slime-repl-old-input
,(incf slime-repl-old-input-counter))))
+ (when newline
+ (insert "\n")
+ (slime-repl-show-maximum-output))
(let ((overlay (make-overlay slime-repl-input-start-mark end)))
;; These properties are on an overlay so that they won't be taken
;; by kill/yank.
@@ -3216,25 +3212,9 @@
(defun slime-property-bounds (prop)
"Return two the positions of the previous and next changes to PROP.
PROP is the name of a text property."
- (let* ((beg (save-excursion
- ;; previous-single-char-property-change searches for a
- ;; property change from the previous character, but we
- ;; want to look for a change from the point. We step
- ;; forward one char to avoid doing the wrong thing if
- ;; we're at the beginning of the old input. -luke
- ;; (18/Jun/2004)
- (unless (not (get-text-property (point) prop))
- ;; alanr unless we are sitting right after it May 19, 2005
- (ignore-errors (forward-char)))
- (previous-single-char-property-change (point) prop)))
- (end (save-excursion
- (if (get-text-property (point) prop)
- (progn (goto-char (next-single-char-property-change
- (point) prop))
- (skip-chars-backward "\n \t\r" beg)
- (point))
- (point)))))
- (values beg end)))
+ (assert (get-text-property (point) prop))
+ (let ((end (next-single-char-property-change (point) prop)))
+ (list (previous-single-char-property-change end prop) end)))
(defun slime-repl-closing-return ()
"Evaluate the current input string after closing all open lists."
@@ -3321,12 +3301,11 @@
(defun slime-repl-set-package (package)
"Set the package of the REPL buffer to PACKAGE."
- (interactive (list (slime-read-package-name "Package: "
- (if (string= (slime-current-package)
- (with-current-buffer (slime-repl-buffer)
- (slime-current-package)))
- nil
- (slime-pretty-find-buffer-package)))))
+ (interactive (list (slime-read-package-name
+ "Package: "
+ (if (equal (slime-current-package) (slime-lisp-package))
+ nil
+ (slime-pretty-find-buffer-package)))))
(with-current-buffer (slime-output-buffer)
(let ((unfinished-input (slime-repl-current-input)))
(destructuring-bind (name prompt-string)
@@ -6821,11 +6800,7 @@
(get-text-property (point) 'details-visible-p)))
(defun sldb-frame-region ()
- (save-excursion
- (goto-char (next-single-property-change (point) 'frame nil (point-max)))
- (backward-char)
- (values (previous-single-property-change (point) 'frame)
- (next-single-property-change (point) 'frame nil (point-max)))))
+ (slime-property-bounds 'frame))
(defun sldb-forward-frame ()
(goto-char (next-single-char-property-change (point) 'frame)))
@@ -7540,8 +7515,8 @@
(while (eq (char-before) ?\n)
(backward-delete-char 1))
(insert "\n" (fontify label "--------------------") "\n")
- (save-excursion
- (mapc slime-inspector-insert-ispec-function content))
+ (save-excursion
+ (slime-inspector-insert-content content))
(pop-to-buffer (current-buffer))
(when point
(check-type point cons)
@@ -7549,6 +7524,22 @@
(goto-line (car point))
(move-to-column (cdr point)))))))))
+(defun slime-inspector-insert-content (content)
+ (destructuring-bind (ispecs len start end) content
+ (slime-inspector-insert-range ispecs len start end t t)))
+
+(defun slime-inspector-insert-range (ispecs len start end prev next)
+ "Insert ISPECS at point.
+LEN is the length of the entire content on the Lisp side.
+START and END are the positions of the subsequnce that ISPECS represents.
+If PREV resp. NEXT are true insert range-buttons as needed."
+ (let ((limit 2000))
+ (when (and prev (> start 0))
+ (slime-inspector-insert-range-button (max 0 (- start limit)) start t))
+ (mapc #'slime-inspector-insert-ispec ispecs)
+ (when (and next (< end len))
+ (slime-inspector-insert-range-button end (min len (+ end limit)) nil))))
+
(defun slime-inspector-insert-ispec (ispec)
(if (stringp ispec)
(insert ispec)
@@ -7580,10 +7571,14 @@
(current-column))))
(defun slime-inspector-operate-on-point ()
- "If point is on a value then recursivly call the inspector on
- that value. If point is on an action then call that action."
+ "Invoke the command for the text at point.
+1. If point is on a value then recursivly call the inspector on
+that value.
+2. If point is on an action then call that action.
+3. If point is on a range-button fetch and insert the range."
(interactive)
(let ((part-number (get-text-property (point) 'slime-part-number))
+ (range-button (get-text-property (point) 'slime-range-button))
(action-number (get-text-property (point) 'slime-action-number))
(opener (lexical-let ((point (slime-inspector-position)))
(lambda (parts)
@@ -7593,6 +7588,8 @@
(slime-eval-async `(swank:inspect-nth-part ,part-number)
opener)
(push (slime-inspector-position) slime-inspector-mark-stack))
+ (range-button
+ (slime-inspector-fetch-range range-button))
(action-number
(slime-eval-async `(swank::inspector-call-nth-action ,action-number)
opener)))))
@@ -7693,7 +7690,6 @@
(progn (goto-char maxpos) (setq previously-wrapped-p t))
(error "No inspectable objects")))))))
-
(defun slime-inspector-previous-inspectable-object (arg)
"Move point to the previous inspectable object.
With optional ARG, move across that many objects.
@@ -7717,6 +7713,25 @@
(lambda (parts)
(slime-open-inspector parts point)))))
+(defun slime-inspector-insert-range-button (start end previous)
+ (slime-insert-propertized
+ (list 'slime-range-button (list start end previous)
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-action-face)
+ (if previous " [--more--]\n" " [--more--]")))
+
+(defun slime-inspector-fetch-range (button)
+ (destructuring-bind (start end previous) button
+ (slime-eval-async
+ `(swank:inspector-range ,start ,end)
+ (slime-rcurry
+ (lambda (content prev)
+ (let ((inhibit-read-only t))
+ (apply #'delete-region (slime-property-bounds 'slime-range-button))
+ (destructuring-bind (i l s e) content
+ (slime-inspector-insert-range i l s e prev (not prev)))))
+ previous))))
+
(slime-define-keys slime-inspector-mode-map
([return] 'slime-inspector-operate-on-point)
((kbd "M-RET") 'slime-inspector-copy-down)
@@ -9630,7 +9645,7 @@
;; Local Variables:
;; outline-regexp: ";;;;+"
;; indent-tabs-mode: nil
-;; coding: latin-1-unix!
+;; coding: latin-1-unix
;; unibyte: t
;; compile-command: "emacs -batch -L . -eval '(byte-compile-file \"slime.el\")' ; rm -v slime.elc"
;; End:
Modified: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp Mon Feb 11 09:24:55 2008
@@ -421,8 +421,7 @@
;;;; Inspecting
-(defmethod inspect-for-emacs ((slot mop::slot-definition))
- (values "A slot."
+(defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: " (:value ,(mop::%slot-definition-name slot))
(:newline)
"Documentation:" (:newline)
@@ -434,10 +433,9 @@
`(:value ,(mop::%slot-definition-initform slot))
"#<unspecified>") (:newline)
" Function: " (:value ,(mop::%slot-definition-initfunction slot))
- (:newline))))
+ (:newline)))
-(defmethod inspect-for-emacs ((f function))
- (values "A function."
+(defmethod emacs-inspect ((f function))
`(,@(when (function-name f)
`("Name: "
,(princ-to-string (function-name f)) (:newline)))
@@ -449,19 +447,18 @@
`("Documentation:" (:newline) ,(documentation f t) (:newline)))
,@(when (function-lambda-expression f)
`("Lambda expression:"
- (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
+ (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))
#|
-(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)
(mapcar (lambda (slot)
(let ((name (mop::slot-definition-name slot)))
(cons (princ-to-string name)
(slot-value o name))))
- slots))))
+ slots)))
|#
;;;; Multithreading
Modified: branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp Mon Feb 11 09:24:55 2008
@@ -564,23 +564,22 @@
;;;; Inspecting
-(defmethod inspect-for-emacs ((f function))
- (values "A function."
+(defmethod emacs-inspect ((f function))
(append
(label-value-line "Name" (function-name f))
`("Formals" ,(princ-to-string (arglist f)) (:newline))
(let ((doc (documentation (excl::external-fn_symdef f) 'function)))
(when doc
- `("Documentation:" (:newline) ,doc))))))
+ `("Documentation:" (:newline) ,doc)))))
-(defmethod inspect-for-emacs ((o t))
- (values "A value." (allegro-inspect o)))
+(defmethod emacs-inspect ((o t))
+ (allegro-inspect o))
-(defmethod inspect-for-emacs ((o function))
- (values "A function." (allegro-inspect o)))
+(defmethod emacs-inspect ((o function))
+ (allegro-inspect o))
-(defmethod inspect-for-emacs ((o standard-object))
- (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
+(defmethod emacs-inspect ((o standard-object))
+ (allegro-inspect o))
(defun allegro-inspect (o)
(loop for (d dd) on (inspect::inspect-ctl o)
Modified: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp Mon Feb 11 09:24:55 2008
@@ -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,13 +836,11 @@
;;;; Inspector
-(defgeneric inspect-for-emacs (object)
+(defgeneric emacs-inspect (object)
(:documentation
"Explain to Emacs how to inspect OBJECT.
-Returns two values: a string which will be used as the title of
-the inspector buffer and a list specifying how to render the
-object for inspection.
+Returns a list specifying how to render the object for inspection.
Every element of the list must be either a string, which will be
inserted into the buffer as is, or a list of the form:
@@ -861,20 +855,17 @@
string) which when clicked will call LAMBDA. If REFRESH is
non-NIL the currently inspected object will be re-inspected
after calling the lambda.
+"))
- 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
output of CL:DESCRIBE."
- (values
- "A value."
`("Type: " (:value ,(type-of object)) (:newline)
"Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
(:newline) (:newline)
- ,(with-output-to-string (desc) (describe object desc)))))
+ ,(with-output-to-string (desc) (describe object desc))))
;;; Utilities for inspector methods.
;;;
Modified: branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp Mon Feb 11 09:24:55 2008
@@ -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*)
@@ -638,9 +638,10 @@
(*package* tmp-pack)
(sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
(let ((inspection (sys::inspect-backend o)))
- (values (format nil "~S~% ~A~{~%~A~}" o
+ (append (list
+ (format nil "~S~% ~A~{~%~A~}~%" o
(sys::insp-title inspection)
- (sys::insp-blurb inspection))
+ (sys::insp-blurb inspection)))
(loop with count = (sys::insp-num-slots inspection)
for i below count
append (multiple-value-bind (value name)
Modified: branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp Mon Feb 11 09:24:55 2008
@@ -1822,11 +1822,6 @@
;;;; Inspecting
-(defclass cmucl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
- (make-instance 'cmucl-inspector))
-
(defconstant +lowtag-symbols+
'(vm:even-fixnum-type
vm:function-pointer-type
@@ -1869,10 +1864,9 @@
: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)))))
+ `("Value: " (:value ,(c:value-cell-ref o))))
((alien::alien-value-p o)
(inspect-alien-value o))
(t
@@ -1880,63 +1874,59 @@
(defun cmucl-inspect (o)
(destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
- (values (format nil "~A~%" text)
- (if labeledp
- (loop for (label . value) in parts
- append (label-value-line label value))
- (loop for value in parts for i from 0
- append (label-value-line i value))))))
+ (list* (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (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)
- (append (label-value-line*
- ("Self" (kernel:%function-self o))
- ("Next" (kernel:%function-next o))
- ("Name" (kernel:%function-name o))
- ("Arglist" (kernel:%function-arglist o))
- ("Type" (kernel:%function-type o))
- ("Code" (kernel:function-code-header o)))
- (list
- (with-output-to-string (s)
- (disassem:disassemble-function o :stream s))))))
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s)))))
((= header vm:closure-header-type)
- (values (format nil "~A is a closure" o)
- (append
- (label-value-line "Function" (kernel:%closure-function o))
- `("Environment:" (:newline))
- (loop for i from 0 below (1- (kernel:get-closure-length o))
- append (label-value-line
- i (kernel:%closure-index-ref o i))))))
+ (list* (format nil "~A is a closure.~%" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (1- (kernel:get-closure-length o))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
((eval::interpreted-function-p o)
(cmucl-inspect o))
(t
(call-next-method)))))
-(defmethod inspect-for-emacs ((o kernel:funcallable-instance))
- (values
- (format nil "~A is a funcallable-instance." o)
- (append (label-value-line*
- (:function (kernel:%funcallable-instance-function o))
- (:lexenv (kernel:%funcallable-instance-lexenv o))
- (:layout (kernel:%funcallable-instance-layout o)))
- (nth-value 1 (cmucl-inspect o)))))
-
-(defmethod inspect-for-emacs ((o kernel:code-component))
- (values (format nil "~A is a code data-block." o)
- (append
- (label-value-line*
- ("code-size" (kernel:%code-code-size o))
- ("entry-points" (kernel:%code-entry-points o))
- ("debug-info" (kernel:%code-debug-info o))
- ("trace-table-offset" (kernel:code-header-ref
- o vm:code-trace-table-offset-slot)))
- `("Constants:" (:newline))
- (loop for i from vm:code-constants-offset
- below (kernel:get-header-data o)
- append (label-value-line i (kernel:code-header-ref o i)))
- `("Code:" (:newline)
+(defmethod emacs-inspect ((o kernel:funcallable-instance))
+ (append (label-value-line*
+ (:function (kernel:%funcallable-instance-function o))
+ (:lexenv (kernel:%funcallable-instance-lexenv o))
+ (:layout (kernel:%funcallable-instance-layout o)))
+ (cmucl-inspect o)))
+
+(defmethod emacs-inspect ((o kernel:code-component))
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:" (:newline)
, (with-output-to-string (s)
(cond ((kernel:%code-debug-info o)
(disassem:disassemble-code-component o :stream s))
@@ -1948,63 +1938,57 @@
(* vm:code-constants-offset vm:word-bytes))
(ash 1 vm:lowtag-bits))
(ash (kernel:%code-code-size o) vm:word-shift)
- :stream s))))))))
+ :stream s)))))))
-(defmethod inspect-for-emacs ((o kernel:fdefn))
- (values (format nil "~A is a fdenf object." o)
- (label-value-line*
- ("name" (kernel:fdefn-name o))
- ("function" (kernel:fdefn-function o))
- ("raw-addr" (sys:sap-ref-32
- (sys:int-sap (kernel:get-lisp-obj-address o))
- (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
+(defmethod emacs-inspect ((o kernel:fdefn))
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
-(defmethod inspect-for-emacs ((o array))
+#+(or)
+(defmethod emacs-inspect ((o array))
(if (typep o 'simple-array)
(call-next-method)
- (values (format nil "~A is an array." o)
- (label-value-line*
- (:header (describe-primitive-type o))
- (:rank (array-rank o))
- (:fill-pointer (kernel:%array-fill-pointer o))
- (:fill-pointer-p (kernel:%array-fill-pointer-p o))
- (:elements (kernel:%array-available-elements o))
- (:data (kernel:%array-data-vector o))
- (:displacement (kernel:%array-displacement o))
- (:displaced-p (kernel:%array-displaced-p o))
- (:dimensions (array-dimensions o))))))
-
-(defmethod inspect-for-emacs ((o simple-vector))
- (values (format nil "~A is a simple-vector." o)
- (append
- (label-value-line*
- (:header (describe-primitive-type o))
- (:length (c::vector-length o)))
- (loop for i below (length o)
- append (label-value-line i (aref o i))))))
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+
+(defmethod emacs-inspect ((o simple-vector))
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (loop for i below (length o)
+ append (label-value-line i (aref o i)))))
(defun inspect-alien-record (alien)
- (values
- (format nil "~A is an alien value." alien)
- (with-struct (alien::alien-value- sap type) alien
- (with-struct (alien::alien-record-type- kind name fields) type
- (append
- (label-value-line*
- (:sap sap)
- (:kind kind)
- (:name name))
- (loop for field in fields
- append (let ((slot (alien::alien-record-field-name field)))
- (label-value-line slot (alien:slot alien slot)))))))))
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (label-value-line slot (alien:slot alien slot))))))))
(defun inspect-alien-pointer (alien)
- (values
- (format nil "~A is an alien value." alien)
- (with-struct (alien::alien-value- sap type) alien
- (label-value-line*
- (:sap sap)
- (:type type)
- (:to (alien::deref alien))))))
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien)))))
(defun inspect-alien-value (alien)
(typecase (alien::alien-value-type alien)
Modified: branches/trunk-reorg/thirdparty/slime/swank-corman.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-corman.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-corman.lisp Mon Feb 11 09:24:55 2008
@@ -393,8 +393,7 @@
collect (funcall callback e)
collect ", ")))
-(defmethod inspect-for-emacs ((class standard-class))
- (values "A class."
+(defmethod emacs-inspect ((class standard-class))
`("Name: " (:value ,(class-name class))
(:newline)
"Super classes: "
@@ -428,12 +427,11 @@
(lambda (class)
`(:value ,class ,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
- (:newline))))
+ (:newline)))
-(defmethod inspect-for-emacs ((slot cons))
+(defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions
(if (eq (car slot) :name)
- (values "A slot."
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
@@ -445,13 +443,14 @@
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
- (:newline)))
+ (:newline))
(call-next-method)))
-(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal))
- (values (if (wild-pathname-p pathname)
+(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
+ (list* (if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
+ '(:newline)
(append (label-value-line*
("Namestring" (namestring pathname))
("Host" (pathname-host pathname))
@@ -464,13 +463,11 @@
(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))))
(defun inspect-structure (o)
- (values
- (format nil "~A is a structure" o)
(let* ((template (cl::uref o 1))
(num-slots (cl::struct-template-num-slots template)))
(cond ((symbolp template)
@@ -479,7 +476,7 @@
(t
(loop for i below num-slots
append (label-value-line (elt template (+ 6 (* i 5)))
- (cl::uref o (+ 2 i)))))))))
+ (cl::uref o (+ 2 i))))))))
;;; Threads
Modified: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp Mon Feb 11 09:24:55 2008
@@ -248,12 +248,12 @@
;;;; Inspector
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
; ecl clos support leaves some to be desired
(cond
((streamp o)
- (values
- (format nil "~S is an ordinary stream" o)
+ (list*
+ (format nil "~S is an ordinary stream~%" o)
(append
(list
"Open for "
@@ -285,7 +285,7 @@
(t
(let* ((cl (si:instance-class o))
(slots (clos:class-slots cl)))
- (values (format nil "~S is an instance of class ~A"
+ (list* (format nil "~S is an instance of class ~A~%"
o (clos::class-name cl))
(loop for x in slots append
(let* ((name (clos:slot-definition-name x))
Modified: branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp Mon Feb 11 09:24:55 2008
@@ -624,32 +624,27 @@
append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
;;; Inspector
-(defclass lispworks-inspector (backend-inspector) ())
-(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)
(multiple-value-bind (names values _getter _setter type)
(lw:get-inspector-values o nil)
(declare (ignore _getter _setter))
- (values "A value."
(append
(label-value-line "Type" type)
(loop for name in names
for value in values
- append (label-value-line name value))))))
+ append (label-value-line name value)))))
;;; Miscellaneous
Modified: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp Mon Feb 11 09:24:55 2008
@@ -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
@@ -814,24 +814,16 @@
collect " = "
collect `(:value ,value)
collect '(:newline))))
- (values (with-output-to-string (s)
- (let ((*print-lines* 1)
- (*print-right-margin* 80))
- (pprint o s)))
- lines)))
+ 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)
- (multiple-value-bind (title content)
- (call-next-method)
- (values
- title
- (append content
+ (append (call-next-method)
`((:newline)
(:value ,(make-instance 'uvector-inspector :object o)
- "Underlying UVECTOR")))))))
+ "Underlying UVECTOR")))))
(defclass uvector-inspector ()
((object :initarg :object)))
@@ -840,15 +832,14 @@
(: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)
(loop
for index below (ccl::uvsize object)
collect (format nil "~D: " index)
collect `(:value ,(ccl::uvref object index))
- collect `(:newline)))))
+ collect `(:newline))))
(defun closure-closed-over-values (closure)
(let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure)))))
@@ -860,9 +851,9 @@
(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))
- (values
- (format nil "A closure: ~a" c)
+(defmethod emacs-inspect ((c ccl::compiled-lexical-closure))
+ (list*
+ (format nil "A closure: ~a~%" c)
`(,@(if (arglist c)
(list "Its argument list is: "
(funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c)))
Modified: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp Mon Feb 11 09:24:55 2008
@@ -1001,41 +1001,38 @@
;;;; 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)))))
+ (label-value-line* (:value (sb-kernel:value-cell-ref o))))
(t
(multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
- (if label
- (values text (loop for (l . v) in parts
- append (label-value-line l v)))
- (values text (loop for value in parts for i from 0
- append (label-value-line i value))))))))
+ (list* (format nil "~a~%" text)
+ (if label
+ (loop for (l . v) in parts
+ append (label-value-line l v))
+ (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."
(label-value-line*
(:name (sb-kernel:%simple-fun-name o))
(:arglist (sb-kernel:%simple-fun-arglist o))
(:self (sb-kernel:%simple-fun-self o))
(:next (sb-kernel:%simple-fun-next o))
(:type (sb-kernel:%simple-fun-type o))
- (:code (sb-kernel:fun-code-header o)))))
+ (:code (sb-kernel:fun-code-header o))))
((= header sb-vm:closure-header-widetag)
- (values "A closure."
(append
(label-value-line :function (sb-kernel:%closure-fun o))
`("Closed over values:" (:newline))
(loop for i below (1- (sb-kernel:get-closure-length o))
append (label-value-line
- i (sb-kernel:%closure-index-ref o i))))))
+ i (sb-kernel:%closure-index-ref o i)))))
(t (call-next-method o)))))
-(defmethod inspect-for-emacs ((o sb-kernel:code-component))
- (values (format nil "~A is a code data-block." o)
+(defmethod emacs-inspect ((o sb-kernel:code-component))
(append
(label-value-line*
(:code-size (sb-kernel:%code-code-size o))
@@ -1060,28 +1057,24 @@
sb-vm:n-word-bytes))
(ash 1 sb-vm:n-lowtag-bits))
(ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
- :stream s))))))))
+ :stream s)))))))
-(defmethod inspect-for-emacs ((o sb-ext:weak-pointer))
- (values "A weak pointer."
+(defmethod emacs-inspect ((o sb-ext:weak-pointer))
(label-value-line*
- (:value (sb-ext:weak-pointer-value o)))))
+ (:value (sb-ext:weak-pointer-value o))))
-(defmethod inspect-for-emacs ((o sb-kernel:fdefn))
- (values "A fdefn object."
+(defmethod emacs-inspect ((o sb-kernel:fdefn))
(label-value-line*
(:name (sb-kernel:fdefn-name o))
- (:function (sb-kernel:fdefn-fun o)))))
+ (:function (sb-kernel:fdefn-fun o))))
-(defmethod inspect-for-emacs :around ((o generic-function))
- (multiple-value-bind (title contents) (call-next-method)
- (values title
+(defmethod emacs-inspect :around ((o generic-function))
(append
- contents
+ (call-next-method)
(label-value-line*
(:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
(:initial-methods (sb-pcl::generic-function-initial-methods o))
- )))))
+ )))
;;;; Multiprocessing
Modified: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp Mon Feb 11 09:24:55 2008
@@ -1693,11 +1693,6 @@
;;;; Inspecting
-(defclass scl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
- (make-instance 'scl-inspector))
-
(defconstant +lowtag-symbols+
'(vm:even-fixnum-type
vm:instance-pointer-type
@@ -1740,10 +1735,9 @@
: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)))))
+ `("Value: " (:value ,(c:value-cell-ref o))))
((alien::alien-value-p o)
(inspect-alien-value o))
(t
@@ -1752,17 +1746,17 @@
(defun scl-inspect (o)
(destructuring-bind (text labeledp . parts)
(inspect::describe-parts o)
- (values (format nil "~A~%" text)
+ (list* (format nil "~A~%" text)
(if labeledp
(loop for (label . value) in parts
append (label-value-line label value))
(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)
+ (list* (format nil "~A is a function.~%" o)
(append (label-value-line*
("Self" (kernel:%function-self o))
("Next" (kernel:%function-next o))
@@ -1774,7 +1768,7 @@
(with-output-to-string (s)
(disassem:disassemble-function o :stream s))))))
((= header vm:closure-header-type)
- (values (format nil "~A is a closure" o)
+ (list* (format nil "~A is a closure.~%" o)
(append
(label-value-line "Function" (kernel:%closure-function o))
`("Environment:" (:newline))
@@ -1788,8 +1782,7 @@
(call-next-method)))))
-(defmethod inspect-for-emacs ((o kernel:code-component))
- (values (format nil "~A is a code data-block." o)
+(defmethod emacs-inspect ((o kernel:code-component))
(append
(label-value-line*
("code-size" (kernel:%code-code-size o))
@@ -1813,20 +1806,19 @@
(* vm:code-constants-offset vm:word-bytes))
(ash 1 vm:lowtag-bits))
(ash (kernel:%code-code-size o) vm:word-shift)
- :stream s))))))))
+ :stream s)))))))
-(defmethod inspect-for-emacs ((o kernel:fdefn))
- (values (format nil "~A is a fdenf object." o)
- (label-value-line*
+(defmethod emacs-inspect ((o kernel:fdefn))
+ (label-value-line*
("name" (kernel:fdefn-name o))
("function" (kernel:fdefn-function o))
("raw-addr" (sys:sap-ref-32
(sys:int-sap (kernel:get-lisp-obj-address o))
- (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
+ (* 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)
+ (list* (format nil "~A is an array.~%" o)
(label-value-line*
(:header (describe-primitive-type o))
(:rank (array-rank o))
@@ -1838,13 +1830,13 @@
(:displaced-p (kernel:%array-displaced-p o))
(:dimensions (array-dimensions o)))))
(t
- (values (format nil "~A is an simple-array." o)
+ (list* (format nil "~A is an simple-array.~%" o)
(label-value-line*
(:header (describe-primitive-type o))
(:length (length o)))))))
-(defmethod inspect-for-emacs ((o simple-vector))
- (values (format nil "~A is a vector." o)
+(defmethod emacs-inspect ((o simple-vector))
+ (list* (format nil "~A is a vector.~%" o)
(append
(label-value-line*
(:header (describe-primitive-type o))
@@ -1854,8 +1846,6 @@
append (label-value-line i (aref o i)))))))
(defun inspect-alien-record (alien)
- (values
- (format nil "~A is an alien value." alien)
(with-struct (alien::alien-value- sap type) alien
(with-struct (alien::alien-record-type- kind name fields) type
(append
@@ -1865,16 +1855,14 @@
(:name name))
(loop for field in fields
append (let ((slot (alien::alien-record-field-name field)))
- (label-value-line slot (alien:slot alien slot)))))))))
+ (label-value-line slot (alien:slot alien slot))))))))
(defun inspect-alien-pointer (alien)
- (values
- (format nil "~A is an alien value." alien)
- (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-value- sap type) alien
(label-value-line*
(:sap sap)
(:type type)
- (:to (alien::deref alien))))))
+ (:to (alien::deref alien)))))
(defun inspect-alien-value (alien)
(typecase (alien::alien-value-type alien)
Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp Mon Feb 11 09:24:55 2008
@@ -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,176 +2677,19 @@
;;;; 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)))
-
-(defun inspect-for-emacs-simple-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-for-emacs-list '#1=(a #1# . #1# ))
-
-(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."
- (do ((n 0 (+ n 2)) ;Counter.
- (fast list (cddr fast)) ;Fast pointer: leaps by 2.
- (slow list (cdr slow))) ;Slow pointer: leaps by 1.
- (nil)
- (cond ((null fast) (return (values n nil)))
- ((not (consp fast)) (return (values n fast)))
- ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
- ((and (eq fast slow) (> n 0)) (return nil))
- ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
-
-(defvar *slime-inspect-contents-limit* nil "How many elements of
- 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))
- (values (prin1-to-string ht)
- (append
- (label-value-line*
- ("Count" (hash-table-count ht))
- ("Size" (hash-table-size ht))
- ("Test" (hash-table-test ht))
- ("Rehash size" (hash-table-rehash-size ht))
- ("Rehash threshold" (hash-table-rehash-threshold ht)))
- (let ((weakness (hash-table-weakness ht)))
- (when weakness
- `("Weakness: " (:value ,weakness) (:newline))))
- (unless (zerop (hash-table-count ht))
- `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline)
- "Contents: " (:newline)))
- (if (and *slime-inspect-contents-limit*
- (>= (hash-table-count ht) *slime-inspect-contents-limit*))
- (inspect-bigger-piece-actions ht (hash-table-count ht))
- nil)
- (loop for key being the hash-keys of ht
- for value being the hash-values of ht
- repeat (or *slime-inspect-contents-limit* most-positive-fixnum)
- append `((:value ,key) " = " (:value ,value)
- " " (:action "[remove entry]"
- ,(let ((key key))
- (lambda () (remhash key ht))))
- (:newline))))))
-
-(defun inspect-bigger-piece-actions (thing size)
- (append
- (if (> size *slime-inspect-contents-limit*)
- (list (inspect-show-more-action thing)
- '(:newline))
- nil)
- (list (inspect-whole-thing-action thing size)
- '(:newline))))
-
-(defun inspect-whole-thing-action (thing size)
- `(:action ,(format nil "Inspect all ~a elements."
- size)
- ,(lambda()
- (let ((*slime-inspect-contents-limit* nil))
- (swank::inspect-object thing)))))
-
-(defun inspect-show-more-action (thing)
- `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..."
- *slime-inspect-contents-limit* )
- ,(lambda()
- (let ((*slime-inspect-contents-limit*
- (progn (format t "How many elements should be shown? ") (read))))
- (swank::inspect-object thing)))))
-
-(defmethod inspect-for-emacs ((array array))
- (values "An array."
- (append
- (label-value-line*
- ("Dimensions" (array-dimensions array))
- ("Its element type is" (array-element-type array))
- ("Total size" (array-total-size array))
- ("Adjustable" (adjustable-array-p array)))
- (when (array-has-fill-pointer-p array)
- (label-value-line "Fill pointer" (fill-pointer array)))
- '("Contents:" (:newline))
- (if (and *slime-inspect-contents-limit*
- (>= (array-total-size array) *slime-inspect-contents-limit*))
- (inspect-bigger-piece-actions array (length array))
- nil)
- (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))
- (values "A character."
- (append
- (label-value-line*
- ("Char code" (char-code char))
- ("Lower cased" (char-downcase char))
- ("Upper cased" (char-upcase char)))
- (if (get-macro-character char)
- `("In the current readtable ("
- (:value ,*readtable*) ") it is a macro character: "
- (:value ,(get-macro-character char)))))))
-
(defvar *inspectee*)
+(defvar *inspectee-content*)
(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)
+(defvar *inspector-stack*)
+(defvar *inspector-history*)
(defun reset-inspector ()
(setq *inspectee* nil
- *inspector-stack* nil
+ *inspectee-content* nil
*inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
*inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
+ *inspector-stack* '()
*inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
(defslimefun init-inspector (string)
@@ -2854,54 +2697,57 @@
(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 inspect-object (o)
+ (push (setq *inspectee* o) *inspector-stack*)
+ (unless (find o *inspector-history*)
+ (vector-push-extend o *inspector-history*))
+ (let ((*print-pretty* nil) ; print everything in the same line
+ (*print-circle* t)
+ (*print-readably* nil))
+ (setq *inspectee-content* (inspector-content (emacs-inspect o))))
+ (list :title (with-output-to-string (s)
+ (print-unreadable-object (o s :type t :identity t)))
+ :id (assign-index o *inspectee-parts*)
+ :content (content-range *inspectee-content* 0 500)))
-(defun inspector-content-for-emacs (specs)
+(defun inspector-content (specs)
(loop for part in specs collect
(etypecase part
- (null ; XXX encourages sloppy programming
- nil)
+ ;;(null ; XXX encourages sloppy programming
+ ;; nil)
(string part)
(cons (destructure-case part
((:newline)
- (string #\newline))
+ '#.(string #\newline))
((:value obj &optional str)
- (value-part-for-emacs obj str))
+ (value-part obj str))
((:action label lambda &key (refreshp t))
- (action-part-for-emacs label lambda refreshp)))))))
+ (action-part 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)
+(defun value-part (object string)
(list :value
(or string (print-part-to-string object))
(assign-index object *inspectee-parts*)))
-(defun action-part-for-emacs (label lambda refreshp)
+(defun action-part (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)))))
+(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 content-range (list start end)
+ (let* ((len (length list)) (end (min len end)))
+ (list (subseq list start end) len start end)))
(defslimefun inspector-nth-part (index)
(aref *inspectee-parts* index))
@@ -2910,18 +2756,20 @@
(with-buffer-syntax ()
(inspect-object (inspector-nth-part index))))
+(defslimefun inspector-range (from to)
+ (content-range *inspectee-content* from to))
+
(defslimefun inspector-call-nth-action (index &rest args)
- (destructuring-bind (action-lambda refreshp)
- (aref *inspectee-actions* index)
- (apply action-lambda 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."
+ "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*)
@@ -2931,10 +2779,10 @@
(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*))
+ (let ((pos (position *inspectee* *inspector-history*)))
+ (cond ((= (1+ pos) (length *inspector-history*))
nil)
- (t (inspect-object (aref *inspector-history* (1+ position))))))))
+ (t (inspect-object (aref *inspector-history* (1+ pos))))))))
(defslimefun inspector-reinspect ()
(inspect-object *inspectee*))
@@ -2968,6 +2816,111 @@
(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)
+ (label-value-line*
+ ('car (car cons))
+ ('cdr (cdr cons))))
+
+;; (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)
+ (list* 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))))))
+
+(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.
+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.
+ (nil)
+ (cond ((null fast) (return (values n nil)))
+ ((not (consp fast)) (return (values n fast)))
+ ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
+ ((and (eq fast slow) (> n 0)) (return nil))
+ ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
+
+;;;;; Hashtables
+
+(defmethod emacs-inspect ((ht hash-table))
+ (append
+ (label-value-line*
+ ("Count" (hash-table-count ht))
+ ("Size" (hash-table-size ht))
+ ("Test" (hash-table-test ht))
+ ("Rehash size" (hash-table-rehash-size ht))
+ ("Rehash threshold" (hash-table-rehash-threshold ht)))
+ (let ((weakness (hash-table-weakness ht)))
+ (when weakness
+ (label-value-line "Weakness:" weakness)))
+ (unless (zerop (hash-table-count ht))
+ `((:action "[clear hashtable]"
+ ,(lambda () (clrhash ht))) (:newline)
+ "Contents: " (:newline)))
+ (loop for key being the hash-keys of ht
+ for value being the hash-values of ht
+ append `((:value ,key) " = " (:value ,value)
+ " " (:action "[remove entry]"
+ ,(let ((key key))
+ (lambda () (remhash key ht))))
+ (:newline)))))
+
+;;;;; Arrays
+
+(defmethod emacs-inspect ((array array))
+ (append
+ (label-value-line*
+ ("Dimensions" (array-dimensions 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)
+ (label-value-line "Fill pointer" (fill-pointer array)))
+ '("Contents:" (:newline))
+ (loop for i below (array-total-size array)
+ append (label-value-line i (row-major-aref array i)))))
+
+;;;;; Chars
+
+(defmethod emacs-inspect ((char character))
+ (append
+ (label-value-line*
+ ("Char code" (char-code char))
+ ("Lower cased" (char-downcase char))
+ ("Upper cased" (char-upcase char)))
+ (if (get-macro-character char)
+ `("In the current readtable ("
+ (:value ,*readtable*) ") it is a macro character: "
+ (:value ,(get-macro-character char))))))
;;;; Thread listing
More information about the Bknr-cvs
mailing list