[slime-cvs] CVS slime/contrib
CVS User sboukarev
sboukarev at common-lisp.net
Fri May 4 14:34:30 UTC 2012
Update of /project/slime/cvsroot/slime/contrib
In directory tiger.common-lisp.net:/tmp/cvs-serv8547
Modified Files:
ChangeLog swank-fancy-inspector.lisp
Log Message:
* swank-fancy-inspector.lisp (emacs-inspect symbol): On SBCL,
show information about type specifiers.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/04/20 05:54:21 1.546
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/05/04 14:34:30 1.547
@@ -1,3 +1,8 @@
+2012-05-04 Stas Boukarev <stassats at gmail.com>
+
+ * swank-fancy-inspector.lisp (emacs-inspect symbol): On SBCL,
+ show information about type specifiers.
+
2012-04-20 John Smith <ohwoeowho at googlemail.com>
Prettier arglists.
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2012/04/06 18:08:30 1.33
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2012/05/04 14:34:30 1.34
@@ -11,14 +11,14 @@
(defmethod emacs-inspect ((symbol symbol))
(let ((package (symbol-package symbol)))
- (multiple-value-bind (_symbol status)
- (and package (find-symbol (string symbol) package))
+ (multiple-value-bind (_symbol status)
+ (and package (find-symbol (string symbol) package))
(declare (ignore _symbol))
(append
- (label-value-line "Its name is" (symbol-name symbol))
- ;;
- ;; Value
- (cond ((boundp symbol)
+ (label-value-line "Its name is" (symbol-name symbol))
+ ;;
+ ;; Value
+ (cond ((boundp symbol)
(append
(label-value-line (if (constantp symbol)
"It is a constant of value"
@@ -29,42 +29,42 @@
`(" " (:action "[unbind]"
,(lambda () (makunbound symbol))))
'((:newline))))
- (t '("It is unbound." (:newline))))
- (docstring-ispec "Documentation" symbol 'variable)
- (multiple-value-bind (expansion definedp) (macroexpand symbol)
- (if definedp
- (label-value-line "It is a symbol macro with expansion"
- expansion)))
- ;;
- ;; Function
- (if (fboundp symbol)
- (append (if (macro-function symbol)
- `("It a macro with macro-function: "
- (:value ,(macro-function symbol)))
- `("It is a function: "
- (:value ,(symbol-function symbol))))
- `(" " (:action "[unbind]"
- ,(lambda () (fmakunbound symbol))))
- `((:newline)))
- `("It has no function value." (:newline)))
- (docstring-ispec "Function documentation" symbol 'function)
- (when (compiler-macro-function symbol)
- (append
+ (t '("It is unbound." (:newline))))
+ (docstring-ispec "Documentation" symbol 'variable)
+ (multiple-value-bind (expansion definedp) (macroexpand symbol)
+ (if definedp
+ (label-value-line "It is a symbol macro with expansion"
+ expansion)))
+ ;;
+ ;; Function
+ (if (fboundp symbol)
+ (append (if (macro-function symbol)
+ `("It a macro with macro-function: "
+ (:value ,(macro-function symbol)))
+ `("It is a function: "
+ (:value ,(symbol-function symbol))))
+ `(" " (:action "[unbind]"
+ ,(lambda () (fmakunbound symbol))))
+ `((:newline)))
+ `("It has no function value." (:newline)))
+ (docstring-ispec "Function documentation" symbol 'function)
+ (when (compiler-macro-function symbol)
+ (append
(label-value-line "It also names the compiler macro"
(compiler-macro-function symbol) :newline nil)
`(" " (:action "[remove]"
,(lambda ()
- (setf (compiler-macro-function symbol) nil)))
+ (setf (compiler-macro-function symbol) nil)))
(:newline))))
- (docstring-ispec "Compiler macro documentation"
- symbol 'compiler-macro)
- ;;
- ;; Package
+ (docstring-ispec "Compiler macro documentation"
+ symbol 'compiler-macro)
+ ;;
+ ;; Package
(if package
- `("It is " ,(string-downcase (string status))
+ `("It is " ,(string-downcase (string status))
" to the package: "
(:value ,package ,(package-name package))
- ,@(if (eq :internal status)
+ ,@(if (eq :internal status)
`(" "
(:action "[export]"
,(lambda () (export symbol package)))))
@@ -73,33 +73,67 @@
,(lambda () (unintern symbol package)))
(:newline))
'("It is a non-interned symbol." (:newline)))
- ;;
- ;; Plist
- (label-value-line "Property list" (symbol-plist symbol))
- ;;
- ;; Class
- (if (find-class symbol nil)
- `("It names the class "
- (:value ,(find-class symbol) ,(string symbol))
+ ;;
+ ;; Plist
+ (label-value-line "Property list" (symbol-plist symbol))
+ ;;
+ ;; Class
+ (if (find-class symbol nil)
+ `("It names the class "
+ (:value ,(find-class symbol) ,(string symbol))
" "
- (:action "[remove]"
- ,(lambda () (setf (find-class symbol) nil)))
- (:newline)))
- ;;
- ;; More package
- (if (find-package symbol)
- (label-value-line "It names the package" (find-package symbol)))
- ))))
+ (:action "[remove]"
+ ,(lambda () (setf (find-class symbol) nil)))
+ (:newline)))
+ ;;
+ ;; More package
+ (if (find-package symbol)
+ (label-value-line "It names the package" (find-package symbol)))
+ (inspect-type-specifier symbol)))))
+
+#-sbcl
+(defun inspect-type-specifier (symbol)
+ (declare (ignore symbol)))
+
+#+sbcl
+(defun inspect-type-specifier (symbol)
+ (let* ((kind (sb-int:info :type :kind symbol))
+ (fun (case kind
+ (:defined
+ (or (sb-int:info :type :expander symbol) t))
+ (:primitive
+ (or (sb-int:info :type :translator symbol) t)))))
+ (when fun
+ (append
+ (list
+ (format nil "It names a ~@[primitive~* ~]type-specifier."
+ (eq kind :primitive))
+ '(:newline))
+ (docstring-ispec "Type-specifier documentation" symbol 'type)
+ (unless (eq t fun)
+ (append
+ `("Type-specifier lambda-list: "
+ ,(inspector-princ
+ (if (eq :primitive kind)
+ (arglist fun)
+ (sb-int:info :type :lambda-list symbol)))
+ (:newline))
+ (multiple-value-bind (expansion ok)
+ (handler-case (sb-ext:typexpand-1 symbol)
+ (error () (values nil nil)))
+ (when ok
+ (list "Type-specifier expansion: "
+ (princ-to-string expansion))))))))))
(defun docstring-ispec (label object kind)
"Return a inspector spec if OBJECT has a docstring of of kind KIND."
(let ((docstring (documentation object kind)))
(cond ((not docstring) nil)
- ((< (+ (length label) (length docstring))
- 75)
- (list label ": " docstring '(:newline)))
- (t
- (list label ":" '(:newline) " " docstring '(:newline))))))
+ ((< (+ (length label) (length docstring))
+ 75)
+ (list label ": " docstring '(:newline)))
+ (t
+ (list label ":" '(:newline) " " docstring '(:newline))))))
(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil)
(defmethod emacs-inspect ((f function))
@@ -108,12 +142,12 @@
(defun inspect-function (f)
(append
(label-value-line "Name" (function-name f))
- `("Its argument list is: "
+ `("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
@@ -133,9 +167,9 @@
the rest of the list is the method's specialiazers (as per
method-specializers-for-inspect)."
(append (list (swank-mop:generic-function-name
- (swank-mop:method-generic-function method)))
- (swank-mop:method-qualifiers method)
- (method-specializers-for-inspect method)))
+ (swank-mop:method-generic-function method)))
+ (swank-mop:method-qualifiers method)
+ (method-specializers-for-inspect method)))
(defmethod emacs-inspect ((object standard-object))
(let ((class (class-of object)))
@@ -151,30 +185,31 @@
"Return true if SPECIALIZER1 is more specific than SPECIALIZER2."
(let ((s1 specializer1) (s2 specializer2) )
(cond ((typep s1 'swank-mop:eql-specializer)
- (not (typep s2 'swank-mop:eql-specializer)))
- (t
- (flet ((cpl (class)
- (and (swank-mop:class-finalized-p class)
- (swank-mop:class-precedence-list class))))
- (member s2 (cpl s1)))))))
+ (not (typep s2 'swank-mop:eql-specializer)))
+ (t
+ (flet ((cpl (class)
+ (and (swank-mop:class-finalized-p class)
+ (swank-mop:class-precedence-list class))))
+ (member s2 (cpl s1)))))))
(defun methods-by-applicability (gf)
"Return methods ordered by most specific argument types.
`method-specializer<' is used for sorting."
- ;; FIXME: argument-precedence-order and qualifiers are ignored.
+ ;; FIXME: argument-precedence-order and qualifiers are ignored.
(labels ((method< (meth1 meth2)
(loop for s1 in (swank-mop:method-specializers meth1)
for s2 in (swank-mop:method-specializers meth2)
do (cond ((specializer< s2 s1) (return nil))
((specializer< s1 s2) (return t))))))
- (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<)))
+ (stable-sort (copy-seq (swank-mop:generic-function-methods gf))
+ #'method<)))
(defun abbrev-doc (doc &optional (maxlen 80))
"Return the first sentence of DOC, but not more than MAXLAN characters."
(subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
- maxlen
- (length doc))))
+ maxlen
+ (length doc))))
(defstruct (inspector-checklist (:conc-name checklist.)
(:constructor %make-checklist (buttons)))
@@ -253,7 +288,8 @@
(effective-slots
(ecase (ref grouping-kind)
(:all sorted-slots)
- (:inheritance (stable-sort-by-inheritance sorted-slots class sort-predicate)))))
+ (:inheritance (stable-sort-by-inheritance sorted-slots
+ class sort-predicate)))))
`("--------------------"
(:newline)
" Group slots by inheritance "
@@ -326,7 +362,8 @@
and collect (format nil "~A:" (class-name previous-home-class))
and collect '(:newline)
and append (make-slot-listing checklist object class
- (nreverse current-slots) direct-slots
+ (nreverse current-slots)
+ direct-slots
longest-slot-name-length)
and do (setf current-slots (list slot)))
(and current-slots
@@ -347,7 +384,8 @@
(loop
for effective-slot :in effective-slots
for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
- direct-slots :key #'swank-mop:slot-definition-name)
+ direct-slots
+ :key #'swank-mop:slot-definition-name)
for slot-name = (inspector-princ
(swank-mop:slot-definition-name effective-slot))
collect (make-checklist-button checklist)
@@ -372,7 +410,8 @@
(let ((slot-name (swank-mop:slot-definition-name slot)))
(loop for class in (reverse (swank-mop:class-precedence-list class))
thereis (and (member slot-name (swank-mop:class-direct-slots class)
- :key #'swank-mop:slot-definition-name :test #'eq)
+ :key #'swank-mop:slot-definition-name
+ :test #'eq)
class))))
(defun stable-sort-by-inheritance (slots class predicate)
@@ -391,32 +430,32 @@
(eval (read-from-string value-string)))))))
-(defmethod emacs-inspect ((gf standard-generic-function))
+(defmethod emacs-inspect ((gf standard-generic-function))
(flet ((lv (label value) (label-value-line label value)))
- (append
+ (append
(lv "Name" (swank-mop:generic-function-name gf))
(lv "Arguments" (swank-mop:generic-function-lambda-list gf))
(docstring-ispec "Documentation" gf t)
(lv "Method class" (swank-mop:generic-function-method-class gf))
- (lv "Method combination"
- (swank-mop:generic-function-method-combination gf))
+ (lv "Method combination"
+ (swank-mop:generic-function-method-combination gf))
`("Methods: " (:newline))
(loop for method in (funcall *gf-method-getter* gf) append
- `((:value ,method ,(inspector-princ
- ;; drop the name of the GF
- (cdr (method-for-inspect-value method))))
+ `((:value ,method ,(inspector-princ
+ ;; drop the name of the GF
+ (cdr (method-for-inspect-value method))))
" "
- (:action "[remove method]"
+ (:action "[remove method]"
,(let ((m method)) ; LOOP reassigns method
- (lambda ()
+ (lambda ()
(remove-method gf m))))
- (:newline)))
+ (:newline)))
`((:newline))
(all-slots-for-inspector gf))))
(defmethod emacs-inspect ((method standard-method))
`(,@(if (swank-mop:method-generic-function method)
- `("Method defined on the generic function "
+ `("Method defined on the generic function "
(:value ,(swank-mop:method-generic-function method)
,(inspector-princ
(swank-mop:generic-function-name
@@ -427,7 +466,8 @@
"Lambda List: " (:value ,(swank-mop:method-lambda-list method))
(:newline)
"Specializers: " (:value ,(swank-mop:method-specializers method)
- ,(inspector-princ (method-specializers-for-inspect method)))
+ ,(inspector-princ
+ (method-specializers-for-inspect method)))
(:newline)
"Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
(:newline)
@@ -435,93 +475,115 @@
(:newline)
,@(all-slots-for-inspector method)))
+(defun specializer-direct-methods (class)
+ (sort (copy-seq (swank-mop:specializer-direct-methods class))
+ #'string<
+ :key
+ (lambda (x)
+ (symbol-name
+ (let ((name (swank-mop::generic-function-name
+ (swank-mop::method-generic-function x))))
+ (if (symbolp name)
+ name
+ (second name)))))))
+
(defmethod emacs-inspect ((class standard-class))
- `("Name: " (:value ,(class-name class))
- (:newline)
- "Super classes: "
- ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
- (:newline)
- "Direct Slots: "
- ,@(common-seperated-spec
- (swank-mop:class-direct-slots class)
- (lambda (slot)
- `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot)))))
- (:newline)
- "Effective Slots: "
- ,@(if (swank-mop:class-finalized-p class)
- (common-seperated-spec
- (swank-mop:class-slots class)
- (lambda (slot)
- `(:value ,slot ,(inspector-princ
- (swank-mop:slot-definition-name slot)))))
- `("#<N/A (class not finalized)> "
- (:action "[finalize]"
- ,(lambda () (swank-mop:finalize-inheritance class)))))
- (:newline)
- ,@(let ((doc (documentation class t)))
- (when doc
- `("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
- "Sub classes: "
- ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
- (lambda (sub)
- `(:value ,sub ,(inspector-princ (class-name sub)))))
- (:newline)
- "Precedence List: "
- ,@(if (swank-mop:class-finalized-p class)
- (common-seperated-spec (swank-mop:class-precedence-list class)
- (lambda (class)
- `(:value ,class ,(inspector-princ (class-name class)))))
- '("#<N/A (class not finalized)>"))
[574 lines skipped]
More information about the slime-cvs
mailing list