Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Inspector cleanups.

* swank.lisp (emacs-inspect): Renamed from inspect-for-emacs.
Changed all method-defs acordingly.
(common-seperated-spec, inspector-princ): Moved to
swank-fancy-inspector.lisp.
(inspector-content): Renamed from inspector-content-for-emacs.
(value-part): Renamed from value-part-for-emacs.
(action-part): Renamed from action-part-for-emacs.
(inspect-list): Renamed from inspect-for-emacs-list.
(inspect-list-aux): New.
(inspect-cons): Renamed from inspect-for-emacs-simple-cons.
(*inspect-length*): Deleted.
(inspect-list): Ignore max-length stuff.
(inspector-content): Don't allow nil elements.
(emacs-inspect array): Make the label of element type more
consistent with the others.
  • Loading branch information...
commit 0c75ceac67208ee4017b43cb4a10b060bbbdff7b 1 parent 2e3724d
Helmut Eller authored
22 ChangeLog
... ... @@ -1,4 +1,24 @@
1   -2008-02-07 Helmut Eller <heller@common-lisp.net>
  1 +2008-02-09 Helmut Eller <heller@common-lisp.net>
  2 +
  3 + Inspector cleanups.
  4 +
  5 + * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs.
  6 + Changed all method-defs acordingly.
  7 + (common-seperated-spec, inspector-princ): Moved to
  8 + swank-fancy-inspector.lisp.
  9 + (inspector-content): Renamed from inspector-content-for-emacs.
  10 + (value-part): Renamed from value-part-for-emacs.
  11 + (action-part): Renamed from action-part-for-emacs.
  12 + (inspect-list): Renamed from inspect-for-emacs-list.
  13 + (inspect-list-aux): New.
  14 + (inspect-cons): Renamed from inspect-for-emacs-simple-cons.
  15 + (*inspect-length*): Deleted.
  16 + (inspect-list): Ignore max-length stuff.
  17 + (inspector-content): Don't allow nil elements.
  18 + (emacs-inspect array): Make the label of element type more
  19 + consistent with the others.
  20 +
  21 +2008-02-09 Helmut Eller <heller@common-lisp.net>
2 22
3 23 Cleanup slime-repl-set-package.
4 24
51 contrib/swank-fancy-inspector.lisp
@@ -6,7 +6,7 @@
6 6
7 7 (in-package :swank)
8 8
9   -(defmethod inspect-for-emacs ((symbol symbol))
  9 +(defmethod emacs-inspect ((symbol symbol))
10 10 (let ((package (symbol-package symbol)))
11 11 (multiple-value-bind (_symbol status)
12 12 (and package (find-symbol (string symbol) package))
@@ -89,7 +89,7 @@
89 89 (t
90 90 (list label ": " '(:newline) " " docstring '(:newline))))))
91 91
92   -(defmethod inspect-for-emacs ((f function))
  92 +(defmethod emacs-inspect ((f function))
93 93 (values "A function."
94 94 (append
95 95 (label-value-line "Name" (function-name f))
@@ -122,7 +122,7 @@
122 122 (swank-mop:method-qualifiers method)
123 123 (method-specializers-for-inspect method)))
124 124
125   -(defmethod inspect-for-emacs ((object standard-object))
  125 +(defmethod emacs-inspect ((object standard-object))
126 126 (let ((class (class-of object)))
127 127 (values "An object."
128 128 `("Class: " (:value ,class) (:newline)
@@ -224,7 +224,7 @@ See `methods-by-applicability'.")
224 224 append slot-presentation
225 225 collect '(:newline))))))
226 226
227   -(defmethod inspect-for-emacs ((gf standard-generic-function))
  227 +(defmethod emacs-inspect ((gf standard-generic-function))
228 228 (flet ((lv (label value) (label-value-line label value)))
229 229 (values
230 230 "A generic function."
@@ -249,7 +249,7 @@ See `methods-by-applicability'.")
249 249 `((:newline))
250 250 (all-slots-for-inspector gf)))))
251 251
252   -(defmethod inspect-for-emacs ((method standard-method))
  252 +(defmethod emacs-inspect ((method standard-method))
253 253 (values "A method."
254 254 `("Method defined on the generic function "
255 255 (:value ,(swank-mop:method-generic-function method)
@@ -269,7 +269,7 @@ See `methods-by-applicability'.")
269 269 (:newline)
270 270 ,@(all-slots-for-inspector method))))
271 271
272   -(defmethod inspect-for-emacs ((class standard-class))
  272 +(defmethod emacs-inspect ((class standard-class))
273 273 (values "A class."
274 274 `("Name: " (:value ,(class-name class))
275 275 (:newline)
@@ -328,7 +328,7 @@ See `methods-by-applicability'.")
328 328 (:newline)
329 329 ,@(all-slots-for-inspector class))))
330 330
331   -(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition))
  331 +(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition))
332 332 (values "A slot."
333 333 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
334 334 (:newline)
@@ -434,7 +434,7 @@ SPECIAL-OPERATOR groups."
434 434 (:newline)
435 435 )))))
436 436
437   -(defmethod inspect-for-emacs ((%container %package-symbols-container))
  437 +(defmethod emacs-inspect ((%container %package-symbols-container))
438 438 (with-struct (%container. title description symbols grouping-kind) %container
439 439 (values title
440 440 `(,@description
@@ -451,7 +451,7 @@ SPECIAL-OPERATOR groups."
451 451 (:newline) (:newline)
452 452 ,@(make-symbols-listing grouping-kind symbols)))))
453 453
454   -(defmethod inspect-for-emacs ((package package))
  454 +(defmethod emacs-inspect ((package package))
455 455 (let ((package-name (package-name package))
456 456 (package-nicknames (package-nicknames package))
457 457 (package-use-list (package-use-list package))
@@ -545,7 +545,7 @@ SPECIAL-OPERATOR groups."
545 545 :description nil)))))))
546 546
547 547
548   -(defmethod inspect-for-emacs ((pathname pathname))
  548 +(defmethod emacs-inspect ((pathname pathname))
549 549 (values (if (wild-pathname-p pathname)
550 550 "A wild pathname."
551 551 "A pathname.")
@@ -561,7 +561,7 @@ SPECIAL-OPERATOR groups."
561 561 (not (probe-file pathname)))
562 562 (label-value-line "Truename" (truename pathname))))))
563 563
564   -(defmethod inspect-for-emacs ((pathname logical-pathname))
  564 +(defmethod emacs-inspect ((pathname logical-pathname))
565 565 (values "A logical pathname."
566 566 (append
567 567 (label-value-line*
@@ -581,7 +581,7 @@ SPECIAL-OPERATOR groups."
581 581 ("Truename" (if (not (wild-pathname-p pathname))
582 582 (probe-file pathname)))))))
583 583
584   -(defmethod inspect-for-emacs ((n number))
  584 +(defmethod emacs-inspect ((n number))
585 585 (values "A number." `("Value: " ,(princ-to-string n))))
586 586
587 587 (defun format-iso8601-time (time-value &optional include-timezone-p)
@@ -604,7 +604,7 @@ SPECIAL-OPERATOR groups."
604 604 year month day hour minute second
605 605 include-timezone-p (format-iso8601-timezone zone)))))
606 606
607   -(defmethod inspect-for-emacs ((i integer))
  607 +(defmethod emacs-inspect ((i integer))
608 608 (values "A number."
609 609 (append
610 610 `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
@@ -616,20 +616,20 @@ SPECIAL-OPERATOR groups."
616 616 (ignore-errors
617 617 (label-value-line "Universal-time" (format-iso8601-time i t))))))
618 618
619   -(defmethod inspect-for-emacs ((c complex))
  619 +(defmethod emacs-inspect ((c complex))
620 620 (values "A complex number."
621 621 (label-value-line*
622 622 ("Real part" (realpart c))
623 623 ("Imaginary part" (imagpart c)))))
624 624
625   -(defmethod inspect-for-emacs ((r ratio))
  625 +(defmethod emacs-inspect ((r ratio))
626 626 (values "A non-integer ratio."
627 627 (label-value-line*
628 628 ("Numerator" (numerator r))
629 629 ("Denominator" (denominator r))
630 630 ("As float" (float r)))))
631 631
632   -(defmethod inspect-for-emacs ((f float))
  632 +(defmethod emacs-inspect ((f float))
633 633 (values "A floating point number."
634 634 (cond
635 635 ((> f most-positive-long-float)
@@ -649,7 +649,7 @@ SPECIAL-OPERATOR groups."
649 649 (label-value-line "Digits" (float-digits f))
650 650 (label-value-line "Precision" (float-precision f))))))))
651 651
652   -(defmethod inspect-for-emacs ((stream file-stream))
  652 +(defmethod emacs-inspect ((stream file-stream))
653 653 (multiple-value-bind (title content)
654 654 (call-next-method)
655 655 (declare (ignore title))
@@ -667,7 +667,7 @@ SPECIAL-OPERATOR groups."
667 667 (:newline))
668 668 content))))
669 669
670   -(defmethod inspect-for-emacs ((condition stream-error))
  670 +(defmethod emacs-inspect ((condition stream-error))
671 671 (multiple-value-bind (title content)
672 672 (call-next-method)
673 673 (let ((stream (stream-error-stream condition)))
@@ -687,6 +687,21 @@ SPECIAL-OPERATOR groups."
687 687 content))
688 688 (values title content)))))
689 689
  690 +(defun common-seperated-spec (list &optional (callback (lambda (v)
  691 + `(:value ,v))))
  692 + (butlast
  693 + (loop
  694 + for i in list
  695 + collect (funcall callback i)
  696 + collect ", ")))
  697 +
  698 +(defun inspector-princ (list)
  699 + "Like princ-to-string, but don't rewrite (function foo) as #'foo.
  700 +Do NOT pass circular lists to this function."
  701 + (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
  702 + (set-pprint-dispatch '(cons (member function)) nil)
  703 + (princ-to-string list)))
  704 +
690 705 (defvar *fancy-inpector-undo-list* nil)
691 706
692 707 (defslimefun fancy-inspector-init ()
6 swank-abcl.lisp
@@ -421,7 +421,7 @@ part of *sysdep-pathnames* in swank.loader.lisp.
421 421
422 422 ;;;; Inspecting
423 423
424   -(defmethod inspect-for-emacs ((slot mop::slot-definition))
  424 +(defmethod emacs-inspect ((slot mop::slot-definition))
425 425 (values "A slot."
426 426 `("Name: " (:value ,(mop::%slot-definition-name slot))
427 427 (:newline)
@@ -436,7 +436,7 @@ part of *sysdep-pathnames* in swank.loader.lisp.
436 436 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
437 437 (:newline))))
438 438
439   -(defmethod inspect-for-emacs ((f function))
  439 +(defmethod emacs-inspect ((f function))
440 440 (values "A function."
441 441 `(,@(when (function-name f)
442 442 `("Name: "
@@ -453,7 +453,7 @@ part of *sysdep-pathnames* in swank.loader.lisp.
453 453
454 454 #|
455 455
456   -(defmethod inspect-for-emacs ((o t))
  456 +(defmethod emacs-inspect ((o t))
457 457 (let* ((class (class-of o))
458 458 (slots (mop::class-slots class)))
459 459 (values (format nil "~A~% is a ~A" o class)
8 swank-allegro.lisp
@@ -564,7 +564,7 @@
564 564
565 565 ;;;; Inspecting
566 566
567   -(defmethod inspect-for-emacs ((f function))
  567 +(defmethod emacs-inspect ((f function))
568 568 (values "A function."
569 569 (append
570 570 (label-value-line "Name" (function-name f))
@@ -573,13 +573,13 @@
573 573 (when doc
574 574 `("Documentation:" (:newline) ,doc))))))
575 575
576   -(defmethod inspect-for-emacs ((o t))
  576 +(defmethod emacs-inspect ((o t))
577 577 (values "A value." (allegro-inspect o)))
578 578
579   -(defmethod inspect-for-emacs ((o function))
  579 +(defmethod emacs-inspect ((o function))
580 580 (values "A function." (allegro-inspect o)))
581 581
582   -(defmethod inspect-for-emacs ((o standard-object))
  582 +(defmethod emacs-inspect ((o standard-object))
583 583 (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
584 584
585 585 (defun allegro-inspect (o)
10 swank-backend.lisp
@@ -33,11 +33,7 @@
33 33 #:declaration-arglist
34 34 #:type-specifier-arglist
35 35 ;; inspector related symbols
36   - #:inspector
37   - #:backend-inspector
38   - #:inspect-for-emacs
39   - #:raw-inspection
40   - #:fancy-inspection
  36 + #:emacs-inspect
41 37 #:label-value-line
42 38 #:label-value-line*
43 39 #:with-struct
@@ -840,7 +836,7 @@ themselves, that is, their dispatch functions, are left alone.")
840 836
841 837 ;;;; Inspector
842 838
843   -(defgeneric inspect-for-emacs (object)
  839 +(defgeneric emacs-inspect (object)
844 840 (:documentation
845 841 "Explain to Emacs how to inspect OBJECT.
846 842
@@ -864,7 +860,7 @@ inserted into the buffer as is, or a list of the form:
864 860
865 861 NIL - do nothing."))
866 862
867   -(defmethod inspect-for-emacs ((object t))
  863 +(defmethod emacs-inspect ((object t))
868 864 "Generic method for inspecting any kind of object.
869 865
870 866 Since we don't know how to deal with OBJECT we simply dump the
2  swank-clisp.lisp
@@ -627,7 +627,7 @@ Execute BODY with NAME's function slot set to FUNCTION."
627 627
628 628 ;;;; Inspecting
629 629
630   -(defmethod inspect-for-emacs ((o t))
  630 +(defmethod emacs-inspect ((o t))
631 631 (let* ((*print-array* nil) (*print-pretty* t)
632 632 (*print-circle* t) (*print-escape* t)
633 633 (*print-lines* custom:*inspect-print-lines*)
14 swank-cmucl.lisp
@@ -1869,7 +1869,7 @@ The `symbol-value' of each element is a type tag.")
1869 1869 :key #'symbol-value)))
1870 1870 (format t ", type: ~A" type-symbol))))))
1871 1871
1872   -(defmethod inspect-for-emacs ((o t))
  1872 +(defmethod emacs-inspect ((o t))
1873 1873 (cond ((di::indirect-value-cell-p o)
1874 1874 (values (format nil "~A is a value cell." o)
1875 1875 `("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1887,7 +1887,7 @@ The `symbol-value' of each element is a type tag.")
1887 1887 (loop for value in parts for i from 0
1888 1888 append (label-value-line i value))))))
1889 1889
1890   -(defmethod inspect-for-emacs ((o function))
  1890 +(defmethod emacs-inspect ((o function))
1891 1891 (let ((header (kernel:get-type o)))
1892 1892 (cond ((= header vm:function-header-type)
1893 1893 (values (format nil "~A is a function." o)
@@ -1914,7 +1914,7 @@ The `symbol-value' of each element is a type tag.")
1914 1914 (t
1915 1915 (call-next-method)))))
1916 1916
1917   -(defmethod inspect-for-emacs ((o kernel:funcallable-instance))
  1917 +(defmethod emacs-inspect ((o kernel:funcallable-instance))
1918 1918 (values
1919 1919 (format nil "~A is a funcallable-instance." o)
1920 1920 (append (label-value-line*
@@ -1923,7 +1923,7 @@ The `symbol-value' of each element is a type tag.")
1923 1923 (:layout (kernel:%funcallable-instance-layout o)))
1924 1924 (nth-value 1 (cmucl-inspect o)))))
1925 1925
1926   -(defmethod inspect-for-emacs ((o kernel:code-component))
  1926 +(defmethod emacs-inspect ((o kernel:code-component))
1927 1927 (values (format nil "~A is a code data-block." o)
1928 1928 (append
1929 1929 (label-value-line*
@@ -1950,7 +1950,7 @@ The `symbol-value' of each element is a type tag.")
1950 1950 (ash (kernel:%code-code-size o) vm:word-shift)
1951 1951 :stream s))))))))
1952 1952
1953   -(defmethod inspect-for-emacs ((o kernel:fdefn))
  1953 +(defmethod emacs-inspect ((o kernel:fdefn))
1954 1954 (values (format nil "~A is a fdenf object." o)
1955 1955 (label-value-line*
1956 1956 ("name" (kernel:fdefn-name o))
@@ -1959,7 +1959,7 @@ The `symbol-value' of each element is a type tag.")
1959 1959 (sys:int-sap (kernel:get-lisp-obj-address o))
1960 1960 (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
1961 1961
1962   -(defmethod inspect-for-emacs ((o array))
  1962 +(defmethod emacs-inspect ((o array))
1963 1963 (if (typep o 'simple-array)
1964 1964 (call-next-method)
1965 1965 (values (format nil "~A is an array." o)
@@ -1974,7 +1974,7 @@ The `symbol-value' of each element is a type tag.")
1974 1974 (:displaced-p (kernel:%array-displaced-p o))
1975 1975 (:dimensions (array-dimensions o))))))
1976 1976
1977   -(defmethod inspect-for-emacs ((o simple-vector))
  1977 +(defmethod emacs-inspect ((o simple-vector))
1978 1978 (values (format nil "~A is a simple-vector." o)
1979 1979 (append
1980 1980 (label-value-line*
8 swank-corman.lisp
@@ -393,7 +393,7 @@
393 393 collect (funcall callback e)
394 394 collect ", ")))
395 395
396   -(defmethod inspect-for-emacs ((class standard-class))
  396 +(defmethod emacs-inspect ((class standard-class))
397 397 (values "A class."
398 398 `("Name: " (:value ,(class-name class))
399 399 (:newline)
@@ -430,7 +430,7 @@
430 430 '("#<N/A (class not finalized)>"))
431 431 (:newline))))
432 432
433   -(defmethod inspect-for-emacs ((slot cons))
  433 +(defmethod emacs-inspect ((slot cons))
434 434 ;; Inspects slot definitions
435 435 (if (eq (car slot) :name)
436 436 (values "A slot."
@@ -448,7 +448,7 @@
448 448 (:newline)))
449 449 (call-next-method)))
450 450
451   -(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal))
  451 +(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
452 452 (values (if (wild-pathname-p pathname)
453 453 "A wild pathname."
454 454 "A pathname.")
@@ -464,7 +464,7 @@
464 464 (not (probe-file pathname)))
465 465 (label-value-line "Truename" (truename pathname))))))
466 466
467   -(defmethod inspect-for-emacs ((o t))
  467 +(defmethod emacs-inspect ((o t))
468 468 (cond ((cl::structurep o) (inspect-structure o))
469 469 (t (call-next-method))))
470 470
2  swank-ecl.lisp
@@ -248,7 +248,7 @@
248 248
249 249 ;;;; Inspector
250 250
251   -(defmethod inspect-for-emacs ((o t))
  251 +(defmethod emacs-inspect ((o t))
252 252 ; ecl clos support leaves some to be desired
253 253 (cond
254 254 ((streamp o)
6 swank-lispworks.lisp
@@ -629,15 +629,15 @@ function names like \(SETF GET)."
629 629 (defimplementation make-default-inspector ()
630 630 (make-instance 'lispworks-inspector))
631 631
632   -(defmethod inspect-for-emacs ((o t))
  632 +(defmethod emacs-inspect ((o t))
633 633 (lispworks-inspect o))
634 634
635   -(defmethod inspect-for-emacs ((o function))
  635 +(defmethod emacs-inspect ((o function))
636 636 (lispworks-inspect o))
637 637
638 638 ;; FIXME: slot-boundp-using-class in LW works with names so we can't
639 639 ;; use our method in swank.lisp.
640   -(defmethod inspect-for-emacs ((o standard-object))
  640 +(defmethod emacs-inspect ((o standard-object))
641 641 (lispworks-inspect o))
642 642
643 643 (defun lispworks-inspect (o)
8 swank-openmcl.lisp
@@ -802,7 +802,7 @@ at least the filename containing it."
802 802 (string (gethash typecode *value2tag*))
803 803 (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
804 804
805   -(defmethod inspect-for-emacs ((o t))
  805 +(defmethod emacs-inspect ((o t))
806 806 (let* ((i (inspector::make-inspector o))
807 807 (count (inspector::compute-line-count i))
808 808 (lines
@@ -820,7 +820,7 @@ at least the filename containing it."
820 820 (pprint o s)))
821 821 lines)))
822 822
823   -(defmethod inspect-for-emacs :around ((o t))
  823 +(defmethod emacs-inspect :around ((o t))
824 824 (if (or (uvector-inspector-p o)
825 825 (not (ccl:uvectorp o)))
826 826 (call-next-method)
@@ -840,7 +840,7 @@ at least the filename containing it."
840 840 (:method ((object t)) nil)
841 841 (:method ((object uvector-inspector)) t))
842 842
843   -(defmethod inspect-for-emacs ((uv uvector-inspector))
  843 +(defmethod emacs-inspect ((uv uvector-inspector))
844 844 (with-slots (object)
845 845 uv
846 846 (values (format nil "The UVECTOR for ~S." object)
@@ -860,7 +860,7 @@ at least the filename containing it."
860 860 (cellp (ccl::closed-over-value-p value)))
861 861 (list label (if cellp (ccl::closed-over-value value) value))))))
862 862
863   -(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure))
  863 +(defmethod emacs-inspect ((c ccl::compiled-lexical-closure))
864 864 (values
865 865 (format nil "A closure: ~a" c)
866 866 `(,@(if (arglist c)
12 swank-sbcl.lisp
@@ -1001,7 +1001,7 @@ stack."
1001 1001
1002 1002 ;;;; Inspector
1003 1003
1004   -(defmethod inspect-for-emacs ((o t))
  1004 +(defmethod emacs-inspect ((o t))
1005 1005 (cond ((sb-di::indirect-value-cell-p o)
1006 1006 (values "A value cell." (label-value-line*
1007 1007 (:value (sb-kernel:value-cell-ref o)))))
@@ -1013,7 +1013,7 @@ stack."
1013 1013 (values text (loop for value in parts for i from 0
1014 1014 append (label-value-line i value))))))))
1015 1015
1016   -(defmethod inspect-for-emacs ((o function))
  1016 +(defmethod emacs-inspect ((o function))
1017 1017 (let ((header (sb-kernel:widetag-of o)))
1018 1018 (cond ((= header sb-vm:simple-fun-header-widetag)
1019 1019 (values "A simple-fun."
@@ -1034,7 +1034,7 @@ stack."
1034 1034 i (sb-kernel:%closure-index-ref o i))))))
1035 1035 (t (call-next-method o)))))
1036 1036
1037   -(defmethod inspect-for-emacs ((o sb-kernel:code-component))
  1037 +(defmethod emacs-inspect ((o sb-kernel:code-component))
1038 1038 (values (format nil "~A is a code data-block." o)
1039 1039 (append
1040 1040 (label-value-line*
@@ -1062,18 +1062,18 @@ stack."
1062 1062 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1063 1063 :stream s))))))))
1064 1064
1065   -(defmethod inspect-for-emacs ((o sb-ext:weak-pointer))
  1065 +(defmethod emacs-inspect ((o sb-ext:weak-pointer))
1066 1066 (values "A weak pointer."
1067 1067 (label-value-line*
1068 1068 (:value (sb-ext:weak-pointer-value o)))))
1069 1069
1070   -(defmethod inspect-for-emacs ((o sb-kernel:fdefn))
  1070 +(defmethod emacs-inspect ((o sb-kernel:fdefn))
1071 1071 (values "A fdefn object."
1072 1072 (label-value-line*
1073 1073 (:name (sb-kernel:fdefn-name o))
1074 1074 (:function (sb-kernel:fdefn-fun o)))))
1075 1075
1076   -(defmethod inspect-for-emacs :around ((o generic-function))
  1076 +(defmethod emacs-inspect :around ((o generic-function))
1077 1077 (multiple-value-bind (title contents) (call-next-method)
1078 1078 (values title
1079 1079 (append
12 swank-scl.lisp
@@ -1740,7 +1740,7 @@ The `symbol-value' of each element is a type tag.")
1740 1740 :key #'symbol-value)))
1741 1741 (format t ", type: ~A" type-symbol))))))
1742 1742
1743   -(defmethod inspect-for-emacs ((o t))
  1743 +(defmethod emacs-inspect ((o t))
1744 1744 (cond ((di::indirect-value-cell-p o)
1745 1745 (values (format nil "~A is a value cell." o)
1746 1746 `("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1759,7 +1759,7 @@ The `symbol-value' of each element is a type tag.")
1759 1759 (loop for value in parts for i from 0
1760 1760 append (label-value-line i value))))))
1761 1761
1762   -(defmethod inspect-for-emacs ((o function))
  1762 +(defmethod emacs-inspect ((o function))
1763 1763 (let ((header (kernel:get-type o)))
1764 1764 (cond ((= header vm:function-header-type)
1765 1765 (values (format nil "~A is a function." o)
@@ -1788,7 +1788,7 @@ The `symbol-value' of each element is a type tag.")
1788 1788 (call-next-method)))))
1789 1789
1790 1790
1791   -(defmethod inspect-for-emacs ((o kernel:code-component))
  1791 +(defmethod emacs-inspect ((o kernel:code-component))
1792 1792 (values (format nil "~A is a code data-block." o)
1793 1793 (append
1794 1794 (label-value-line*
@@ -1815,7 +1815,7 @@ The `symbol-value' of each element is a type tag.")
1815 1815 (ash (kernel:%code-code-size o) vm:word-shift)
1816 1816 :stream s))))))))
1817 1817
1818   -(defmethod inspect-for-emacs ((o kernel:fdefn))
  1818 +(defmethod emacs-inspect ((o kernel:fdefn))
1819 1819 (values (format nil "~A is a fdenf object." o)
1820 1820 (label-value-line*
1821 1821 ("name" (kernel:fdefn-name o))
@@ -1824,7 +1824,7 @@ The `symbol-value' of each element is a type tag.")
1824 1824 (sys:int-sap (kernel:get-lisp-obj-address o))
1825 1825 (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
1826 1826
1827   -(defmethod inspect-for-emacs ((o array))
  1827 +(defmethod emacs-inspect ((o array))
1828 1828 (cond ((kernel:array-header-p o)
1829 1829 (values (format nil "~A is an array." o)
1830 1830 (label-value-line*
@@ -1843,7 +1843,7 @@ The `symbol-value' of each element is a type tag.")
1843 1843 (:header (describe-primitive-type o))
1844 1844 (:length (length o)))))))
1845 1845
1846   -(defmethod inspect-for-emacs ((o simple-vector))
  1846 +(defmethod emacs-inspect ((o simple-vector))
1847 1847 (values (format nil "~A is a vector." o)
1848 1848 (append
1849 1849 (label-value-line*
374 swank.lisp
@@ -13,7 +13,7 @@
13 13 ;;; available to us here via the `SWANK-BACKEND' package.
14 14
15 15 (defpackage :swank
16   - (:use :common-lisp :swank-backend)
  16 + (:use :cl :swank-backend)
17 17 (:export #:startup-multiprocessing
18 18 #:start-server
19 19 #:create-server
@@ -24,8 +24,8 @@
24 24 #:print-indentation-lossage
25 25 #:swank-debugger-hook
26 26 #:run-after-init-hook
27   - #:inspect-for-emacs
28   - #:inspect-slot-for-emacs
  27 + #:emacs-inspect
  28 + ;;#:inspect-slot-for-emacs
29 29 ;; These are user-configurable variables:
30 30 #:*communication-style*
31 31 #:*dont-close*
@@ -2677,67 +2677,182 @@ The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
2677 2677
2678 2678 ;;;; Inspecting
2679 2679
2680   -(defun common-seperated-spec (list &optional (callback (lambda (v)
2681   - `(:value ,v))))
2682   - (butlast
2683   - (loop
2684   - for i in list
2685   - collect (funcall callback i)
2686   - collect ", ")))
2687   -
2688   -(defun inspector-princ (list)
2689   - "Like princ-to-string, but don't rewrite (function foo) as #'foo.
2690   -Do NOT pass circular lists to this function."
2691   - (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
2692   - (set-pprint-dispatch '(cons (member function)) nil)
2693   - (princ-to-string list)))
2694   -
2695   -(defmethod inspect-for-emacs ((object cons))
2696   - (if (consp (cdr object))
2697   - (inspect-for-emacs-list object)
2698   - (inspect-for-emacs-simple-cons object)))
2699   -
2700   -(defun inspect-for-emacs-simple-cons (cons)
  2680 +(defvar *inspectee*)
  2681 +(defvar *inspectee-parts*)
  2682 +(defvar *inspectee-actions*)
  2683 +(defvar *inspector-stack*)
  2684 +(defvar *inspector-history*)
  2685 +
  2686 +(defun reset-inspector ()
  2687 + (setq *inspectee* nil
  2688 + *inspector-stack* '()
  2689 + *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
  2690 + *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
  2691 + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
  2692 +
  2693 +(defslimefun init-inspector (string)
  2694 + (with-buffer-syntax ()
  2695 + (reset-inspector)
  2696 + (inspect-object (eval (read-from-string string)))))
  2697 +
  2698 +(defun inspect-object (object)
  2699 + (push (setq *inspectee* object) *inspector-stack*)
  2700 + (unless (find object *inspector-history*)
  2701 + (vector-push-extend object *inspector-history*))
  2702 + (let ((*print-pretty* nil) ; print everything in the same line
  2703 + (*print-circle* t)
  2704 + (*print-readably* nil))
  2705 + (multiple-value-bind (_ content) (emacs-inspect object)
  2706 + (declare (ignore _))
  2707 + (list :title (with-output-to-string (s)
  2708 + (print-unreadable-object (object s :type t :identity t)))
  2709 + :id (assign-index object *inspectee-parts*)
  2710 + :content (inspector-content content)))))
  2711 +
  2712 +(defun inspector-content (specs)
  2713 + (loop for part in specs collect
  2714 + (etypecase part
  2715 + ;;(null ; XXX encourages sloppy programming
  2716 + ;; nil)
  2717 + (string part)
  2718 + (cons (destructure-case part
  2719 + ((:newline)
  2720 + '#.(string #\newline))
  2721 + ((:value obj &optional str)
  2722 + (value-part obj str))
  2723 + ((:action label lambda &key (refreshp t))
  2724 + (action-part label lambda refreshp)))))))
  2725 +
  2726 +(defun assign-index (object vector)
  2727 + (let ((index (fill-pointer vector)))
  2728 + (vector-push-extend object vector)
  2729 + index))
  2730 +
  2731 +(defun value-part (object string)
  2732 + (list :value
  2733 + (or string (print-part-to-string object))
  2734 + (assign-index object *inspectee-parts*)))
  2735 +
  2736 +(defun action-part (label lambda refreshp)
  2737 + (list :action label (assign-index (list lambda refreshp)
  2738 + *inspectee-actions*)))
  2739 +
  2740 +(defun print-part-to-string (value)
  2741 + (let ((string (to-string value))
  2742 + (pos (position value *inspector-history*)))
  2743 + (if pos
  2744 + (format nil "#~D=~A" pos string)
  2745 + string)))
  2746 +
  2747 +(defslimefun inspector-nth-part (index)
  2748 + (aref *inspectee-parts* index))
  2749 +
  2750 +(defslimefun inspect-nth-part (index)
  2751 + (with-buffer-syntax ()
  2752 + (inspect-object (inspector-nth-part index))))
  2753 +
  2754 +(defslimefun inspector-call-nth-action (index &rest args)
  2755 + (destructuring-bind (fun refreshp) (aref *inspectee-actions* index)
  2756 + (apply fun args)
  2757 + (if refreshp
  2758 + (inspect-object (pop *inspector-stack*))
  2759 + ;; tell emacs that we don't want to refresh the inspector buffer
  2760 + nil)))
  2761 +
  2762 +(defslimefun inspector-pop ()
  2763 + "Drop the inspector stack and inspect the second element.
  2764 +Return nil if there's no second element."
  2765 + (with-buffer-syntax ()
  2766 + (cond ((cdr *inspector-stack*)
  2767 + (pop *inspector-stack*)
  2768 + (inspect-object (pop *inspector-stack*)))
  2769 + (t nil))))
  2770 +
  2771 +(defslimefun inspector-next ()
  2772 + "Inspect the next element in the *inspector-history*."
  2773 + (with-buffer-syntax ()
  2774 + (let ((position (position *inspectee* *inspector-history*)))
  2775 + (cond ((= (1+ position) (length *inspector-history*))
  2776 + nil)
  2777 + (t (inspect-object (aref *inspector-history* (1+ position))))))))
  2778 +
  2779 +(defslimefun inspector-reinspect ()
  2780 + (inspect-object *inspectee*))
  2781 +
  2782 +(defslimefun quit-inspector ()
  2783 + (reset-inspector)
  2784 + nil)
  2785 +
  2786 +(defslimefun describe-inspectee ()
  2787 + "Describe the currently inspected object."
  2788 + (with-buffer-syntax ()
  2789 + (describe-to-string *inspectee*)))
  2790 +
  2791 +(defslimefun pprint-inspector-part (index)
  2792 + "Pretty-print the currently inspected object."
  2793 + (with-buffer-syntax ()
  2794 + (swank-pprint (list (inspector-nth-part index)))))
  2795 +
  2796 +(defslimefun inspect-in-frame (string index)
  2797 + (with-buffer-syntax ()
  2798 + (reset-inspector)
  2799 + (inspect-object (eval-in-frame (from-string string) index))))
  2800 +
  2801 +(defslimefun inspect-current-condition ()
  2802 + (with-buffer-syntax ()
  2803 + (reset-inspector)
  2804 + (inspect-object *swank-debugger-condition*)))
  2805 +
  2806 +(defslimefun inspect-frame-var (frame var)
  2807 + (with-buffer-syntax ()
  2808 + (reset-inspector)
  2809 + (inspect-object (frame-var-value frame var))))
  2810 +
  2811 +;;;;; Lists
  2812 +
  2813 +(defmethod emacs-inspect ((o cons))
  2814 + (if (consp (cdr o))
  2815 + (inspect-list o)
  2816 + (inspect-cons o)))
  2817 +
  2818 +(defun inspect-cons (cons)
2701 2819 (values "A cons cell."
2702 2820 (label-value-line*
2703 2821 ('car (car cons))
2704 2822 ('cdr (cdr cons)))))
2705 2823
2706   -(defun inspect-for-emacs-list (list)
2707   - (let ((maxlen 40))
2708   - (multiple-value-bind (length tail) (safe-length list)
2709   - (flet ((frob (title list)
2710   - (let (lines)
2711   - (loop for i from 0 for rest on list do
2712   - (if (consp (cdr rest)) ; e.g. (A . (B . ...))
2713   - (push (label-value-line i (car rest)) lines)
2714   - (progn ; e.g. (A . NIL) or (A . B)
2715   - (push (label-value-line i (car rest) :newline nil) lines)
2716   - (when (cdr rest)
2717   - (push '((:newline)) lines)
2718   - (push (label-value-line ':tail () :newline nil) lines))
2719   - (loop-finish)))
2720   - finally
2721   - (setf lines (reduce #'append (nreverse lines) :from-end t)))
2722   - (values title (append '("Elements:" (:newline)) lines)))))
2723   -
2724   - (cond ((not length) ; circular
2725   - (frob "A circular list."
2726   - (cons (car list)
2727   - (ldiff (cdr list) list))))
2728   - ((and (<= length maxlen) (not tail))
2729   - (frob "A proper list." list))
2730   - (tail
2731   - (frob "An improper list." list))
2732   - (t
2733   - (frob "A proper list." list)))))))
2734   -
2735   -;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
  2824 +;; (inspect-list '#1=(a #1# . #1# ))
  2825 +;; (inspect-list (list* 'a 'b 'c))
  2826 +;; (inspect-list (make-list 10000))
  2827 +
  2828 +(defun inspect-list (list)
  2829 + (multiple-value-bind (length tail) (safe-length list)
  2830 + (flet ((frob (title list)
  2831 + (values nil (append `(,title (:newline))
  2832 + (inspect-list-aux list)))))
  2833 + (cond ((not length)
  2834 + (frob "A circular list:"
  2835 + (cons (car list)
  2836 + (ldiff (cdr list) list))))
  2837 + ((not tail)
  2838 + (frob "A proper list:" list))
  2839 + (t
  2840 + (frob "An improper list:" list))))))
  2841 +
  2842 +(defun inspect-list-aux (list)
  2843 + (loop for i from 0 for rest on list while (consp rest) append
  2844 + (cond ((consp (cdr rest))
  2845 + (label-value-line i (car rest)))
  2846 + ((cdr rest)
  2847 + (label-value-line* (i (car rest))
  2848 + (:tail (cdr rest))))
  2849 + (t
  2850 + (label-value-line i (car rest))))))
2736 2851
2737 2852 (defun safe-length (list)
2738 2853 "Similar to `list-length', but avoid errors on improper lists.
2739 2854 Return two values: the length of the list and the last cdr.
2740   -NIL is returned if the list is circular."
  2855 +Return NIL if LIST is circular."
2741 2856 (do ((n 0 (+ n 2)) ;Counter.
2742 2857 (fast list (cddr fast)) ;Fast pointer: leaps by 2.
2743 2858 (slow list (cdr slow))) ;Slow pointer: leaps by 1.
@@ -2752,7 +2867,9 @@ NIL is returned if the list is circular."
2752 2867 a hash table or array to show by default. If table has more than
2753 2868 this then offer actions to view more. Set to nil for no limit." )
2754 2869
2755   -(defmethod inspect-for-emacs ((ht hash-table))
  2870 +;;;;; Hashtables
  2871 +
  2872 +(defmethod emacs-inspect ((ht hash-table))
2756 2873 (values (prin1-to-string ht)
2757 2874 (append
2758 2875 (label-value-line*
@@ -2804,12 +2921,14 @@ NIL is returned if the list is circular."
2804 2921 (progn (format t "How many elements should be shown? ") (read))))
2805 2922 (swank::inspect-object thing)))))
2806 2923
2807   -(defmethod inspect-for-emacs ((array array))
  2924 +;;;;; Arrays
  2925 +
  2926 +(defmethod emacs-inspect ((array array))
2808 2927 (values "An array."
2809 2928 (append
2810 2929 (label-value-line*
2811 2930 ("Dimensions" (array-dimensions array))
2812   - ("Its element type is" (array-element-type array))
  2931 + ("Element type" (array-element-type array))
2813 2932 ("Total size" (array-total-size array))
2814 2933 ("Adjustable" (adjustable-array-p array)))
2815 2934 (when (array-has-fill-pointer-p array)
@@ -2822,7 +2941,9 @@ NIL is returned if the list is circular."
2822 2941 (loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
2823 2942 append (label-value-line i (row-major-aref array i))))))
2824 2943
2825   -(defmethod inspect-for-emacs ((char character))
  2944 +;;;;; Chars
  2945 +
  2946 +(defmethod emacs-inspect ((char character))
2826 2947 (values "A character."
2827 2948 (append
2828 2949 (label-value-line*
@@ -2833,141 +2954,6 @@ NIL is returned if the list is circular."
2833 2954 `("In the current readtable ("
2834 2955 (:value ,*readtable*) ") it is a macro character: "
2835 2956 (:value ,(get-macro-character char)))))))
2836   -
2837   -(defvar *inspectee*)
2838   -(defvar *inspectee-parts*)
2839   -(defvar *inspectee-actions*)
2840   -(defvar *inspector-stack* '())
2841   -(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
2842   -(declaim (type vector *inspector-history*))
2843   -(defvar *inspect-length* 30)
2844   -
2845   -(defun reset-inspector ()
2846   - (setq *inspectee* nil
2847   - *inspector-stack* nil
2848   - *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
2849   - *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
2850   - *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
2851   -
2852   -(defslimefun init-inspector (string)
2853   - (with-buffer-syntax ()
2854   - (reset-inspector)
2855   - (inspect-object (eval (read-from-string string)))))
2856   -
2857   -(defun print-part-to-string (value)
2858   - (let ((string (to-string value))
2859   - (pos (position value *inspector-history*)))
2860   - (if pos
2861   - (format nil "#~D=~A" pos string)
2862   - string)))
2863   -
2864   -(defun inspector-content-for-emacs (specs)
2865   - (loop for part in specs collect
2866   - (etypecase part
2867   - (null ; XXX encourages sloppy programming
2868   - nil)
2869   - (string part)
2870   - (cons (destructure-case part
2871   - ((:newline)
2872   - (string #\newline))
2873   - ((:value obj &optional str)
2874   - (value-part-for-emacs obj str))
2875   - ((:action label lambda &key (refreshp t))
2876   - (action-part-for-emacs label lambda refreshp)))))))
2877   -
2878   -(defun assign-index (object vector)
2879   - (let ((index (fill-pointer vector)))
2880   - (vector-push-extend object vector)
2881   - index))
2882   -
2883   -(defun value-part-for-emacs (object string)
2884   - (list :value
2885   - (or string (print-part-to-string object))
2886   - (assign-index object *inspectee-parts*)))
2887   -
2888   -(defun action-part-for-emacs (label lambda refreshp)
2889   - (list :action label (assign-index (list lambda refreshp)
2890   - *inspectee-actions*)))
2891   -
2892   -(defun inspect-object (object)
2893   - (push (setq *inspectee* object) *inspector-stack*)
2894   - (unless (find object *inspector-history*)
2895   - (vector-push-extend object *inspector-history*))
2896   - (let ((*print-pretty* nil) ; print everything in the same line
2897   - (*print-circle* t)
2898   - (*print-readably* nil))
2899   - (multiple-value-bind (_ content) (inspect-for-emacs object)
2900   - (declare (ignore _))
2901   - (list :title (with-output-to-string (s)
2902   - (print-unreadable-object (object s :type t :identity t)))
2903   - :id (assign-index object *inspectee-parts*)
2904   - :content (inspector-content-for-emacs content)))))
2905   -
2906   -(defslimefun inspector-nth-part (index)
2907   - (aref *inspectee-parts* index))
2908   -
2909   -(defslimefun inspect-nth-part (index)
2910   - (with-buffer-syntax ()
2911   - (inspect-object (inspector-nth-part index))))
2912   -
2913   -(defslimefun inspector-call-nth-action (index &rest args)
2914   - (destructuring-bind (action-lambda refreshp)
2915   - (aref *inspectee-actions* index)
2916   - (apply action-lambda args)
2917   - (if refreshp
2918   - (inspect-object (pop *inspector-stack*))
2919   - ;; tell emacs that we don't want to refresh the inspector buffer
2920   - nil)))
2921   -
2922   -(defslimefun inspector-pop ()
2923   - "Drop the inspector stack and inspect the second element. Return
2924   -nil if there's no second element."
2925   - (with-buffer-syntax ()
2926   - (cond ((cdr *inspector-stack*)
2927   - (pop *inspector-stack*)
2928   - (inspect-object (pop *inspector-stack*)))
2929   - (t nil))))
2930   -
2931   -(defslimefun inspector-next ()
2932   - "Inspect the next element in the *inspector-history*."
2933   - (with-buffer-syntax ()
2934   - (let ((position (position *inspectee* *inspector-history*)))
2935   - (cond ((= (1+ position) (length *inspector-history*))
2936   - nil)
2937   - (t (inspect-object (aref *inspector-history* (1+ position))))))))
2938   -
2939   -(defslimefun inspector-reinspect ()
2940   - (inspect-object *inspectee*))
2941   -
2942   -(defslimefun quit-inspector ()
2943   - (reset-inspector)
2944   - nil)
2945   -
2946   -(defslimefun describe-inspectee ()
2947   - "Describe the currently inspected object."
2948   - (with-buffer-syntax ()
2949   - (describe-to-string *inspectee*)))
2950   -
2951   -(defslimefun pprint-inspector-part (index)
2952   - "Pretty-print the currently inspected object."
2953   - (with-buffer-syntax ()
2954   - (swank-pprint (list (inspector-nth-part index)))))
2955   -
2956   -(defslimefun inspect-in-frame (string index)
2957   - (with-buffer-syntax ()
2958   - (reset-inspector)
2959   - (inspect-object (eval-in-frame (from-string string) index))))
2960   -
2961   -(defslimefun inspect-current-condition ()
2962   - (with-buffer-syntax ()
2963   - (reset-inspector)
2964   - (inspect-object *swank-debugger-condition*)))
2965   -
2966   -(defslimefun inspect-frame-var (frame var)
2967   - (with-buffer-syntax ()
2968   - (reset-inspector)
2969   - (inspect-object (frame-var-value frame var))))
2970   -
2971 2957
2972 2958 ;;;; Thread listing
2973 2959

0 comments on commit 0c75cea

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