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@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@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@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@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@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@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@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@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@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@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@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 - `(,@description + `(,title (:newline) + ,@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