[slime-cvs] CVS update: slime/swank.lisp
Helmut Eller
heller at common-lisp.net
Thu Oct 28 21:21:57 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv15871
Modified Files:
swank.lisp
Log Message:
(*sldb-stepping-p*): New variable. Used to tell emacs that the
debugger buffer should not be closed even if we unwind.
(debug-in-emacs): Use it.
(sldb-step): Moved to the front end.
(inspector-princ, method-specializers-for-inspect): Simplified.
(methods-by-applicability): Use a simpler algorithm. I doubt there is
much difference in practice.
(inspect-for-emacs)[symbol, function, standard-generic-function]
[standard-method]: Use less than 80 columns.
(inspector-call-nth-action): Don't accept &rest args. Was never used.
Date: Thu Oct 28 23:21:54 2004
Author: heller
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.255 slime/swank.lisp:1.256
--- slime/swank.lisp:1.255 Tue Oct 26 02:30:47 2004
+++ slime/swank.lisp Thu Oct 28 23:21:53 2004
@@ -1363,6 +1363,9 @@
(defvar *sldb-restarts* nil
"The list of currenlty active restarts.")
+(defvar *sldb-stepping-p* nil
+ "True when during execution of a stepp command.")
+
;; A set of printer variables used in the debugger.
(define-printer-variables sldb-print
(pretty nil)
@@ -1380,6 +1383,7 @@
(symbol-value '*buffer-package*))
*package*))
(*sldb-level* (1+ *sldb-level*))
+ (*sldb-stepping-p* nil)
(*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
(force-user-output)
(with-printer-settings sldb-print
@@ -1398,7 +1402,8 @@
*sldb-level*))
(handler-bind ((sldb-condition #'handle-sldb-condition))
(read-from-emacs))))))
- (send-to-emacs `(:debug-return ,(current-thread) ,level))))
+ (send-to-emacs `(:debug-return
+ ,(current-thread) ,level ,*sldb-stepping-p*))))
(defun handle-sldb-condition (condition)
"Handle an internal debugger condition.
@@ -1546,6 +1551,14 @@
(with-buffer-syntax ()
(sldb-break-at-start (read-from-string name))))
+(defslimefun sldb-step (frame)
+ (cond ((find-restart 'continue)
+ (activate-stepping frame)
+ (setq *sldb-stepping-p* t)
+ (continue))
+ (t
+ (error "No continue restart."))))
+
;;;; Compilation Commands.
@@ -2534,7 +2547,8 @@
;;;; Inspecting
-(defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v))))
+(defun common-seperated-spec (list &optional (callback (lambda (v)
+ `(:value ,v))))
(butlast
(loop
for i in list
@@ -2542,27 +2556,11 @@
collect ", ")))
(defun inspector-princ (list)
- "Just like princ-to-string, but don't rewrite (function foo) as
- #'foo. Do NOT pass circular lists to this function."
- (with-output-to-string (as-string)
- (labels ((printer (object)
- (typecase object
- (null (princ nil as-string))
- (cons
- (write-char #\( as-string)
- (printer (car object))
- (loop
- for (head . tail) on (cdr object)
- do (write-char #\Space as-string)
- do (printer head)
- unless (listp tail)
- do (progn
- (write-string " . " as-string)
- (printer tail))
- and return t)
- (write-char #\) as-string))
- (t (princ object as-string)))))
- (printer 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) inspector)
(declare (ignore inspector))
@@ -2663,80 +2661,93 @@
(:value ,*readtable*) ") it is a macro character: "
(:value ,(get-macro-character char)))))))
-;; Shouldn't most of this stuff be done by describe-symbol-for-emacs? -- he
+(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))))))
+
(defmethod inspect-for-emacs ((symbol symbol) inspector)
(declare (ignore inspector))
- (let ((internal-external (multiple-value-bind (symbol status)
- (intern (symbol-name symbol) (symbol-package symbol))
- (declare (ignore symbol))
- (ecase status
- ((:internal :inherited) :internal)
- (:external :external))))
- (package (when (find-package symbol)
- `("It names the package " (:value ,(find-package symbol)) (:newline))))
- (class (when (find-class symbol nil)
- `("It names the class " (:value ,(find-class symbol) ,(inspector-princ (class-name (find-class symbol))))
- " " (:action ,(format nil "[remove name ~S (does not affect class object)]" symbol)
- ,(lambda () (setf (find-class symbol) nil)))))))
- (values "A symbol."
-55 `("Its name is: " (:value ,(symbol-name symbol))
- (:newline)
- ;; check to see whether it is a global variable, a
- ;; constant, or a symbol macro.
- ,@(let ((documentation (when (documentation symbol 'variable)
- `((:newline)
- "Documentation:"
- (:newline)
- ,(documentation symbol 'variable)))))
- (cond
- ((constantp symbol)
- `("It is a constant of value: " (:value ,(symbol-value symbol)) , at documentation))
- ((boundp symbol)
- `("It is a global variable bound to: " (:value ,(symbol-value symbol)) , at documentation))
- ((nth-value 1 (macroexpand symbol))
- `("It is a symbol macro with expansion: " (:value ,(macroexpand symbol))))
- (t
- `("It is unbound."))))
- (:newline)
- ,@(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 "[make funbound]" ,(lambda () (fmakunbound symbol))))
- `((:newline))
- (when (documentation symbol 'function)
- `("Documentation:" (:newline) ,(documentation symbol 'function) (:newline)))
- (when (compiler-macro-function symbol)
- `("It also names the compiler macro: " (:value ,(compiler-macro-function symbol)) (:newline)))
- (when (documentation symbol 'compiler-macro)
- `("Documentation:" (:newline) ,(documentation symbol 'compiler-macro) (:newline))))
- `("It has no function value." (:newline)))
- "It is " ,(case internal-external
- (:internal "internal")
- (:external "external")) " to the package: " (:value ,(symbol-package symbol))
- ,@(when (eql :internal internal-external)
- `(" " (:action ,(with-output-to-string (export-label)
- (princ "[export from " export-label)
- (princ (package-name (symbol-package symbol)) export-label)
- (princ "]" export-label))
- ,(lambda () (export symbol (symbol-package symbol))))))
- (:newline)
- "Property list: " (:value ,(symbol-plist symbol))
- (:newline)
- , at package
- , at class))))
+ (let ((package (symbol-package symbol)))
+ (multiple-value-bind (_symbol status)
+ (and package (find-symbol (string symbol) package))
+ (declare (ignore _symbol))
+ (values
+ "A symbol."
+ (append
+ (label-value-line "Its name is" (symbol-name symbol))
+ ;;
+ ;; Value
+ (cond ((boundp symbol)
+ (label-value-line (if (constantp symbol)
+ "It is a constant of value"
+ "It is a global variable bound to")
+ (symbol-value symbol)))
+ (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 "[make funbound]"
+ ,(lambda () (fmakunbound symbol))))
+ `((:newline)))
+ `("It has no function value." (:newline)))
+ (docstring-ispec "Function Documentation" symbol 'function)
+ (if (compiler-macro-function symbol)
+ (label-value-line "It also names the compiler macro"
+ (compiler-macro-function symbol)))
+ (docstring-ispec "Compiler Macro Documentation"
+ symbol 'compiler-macro)
+ ;;
+ ;; Package
+ `("It is " ,(string-downcase (string status)) " to the package: "
+ (:value ,package ,(package-name package))
+ ,@(if (eq :internal status)
+ `((:action " [export it]"
+ ,(lambda () (export symbol package)))))
+ (: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))
+ (: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)))
+ )))))
(defmethod inspect-for-emacs ((f function) inspector)
(declare (ignore inspector))
(values "A function."
- `("Name: " (:value ,(function-name f)) (:newline)
- "Its argument list is: " ,(inspector-princ (arglist f))
- (:newline)
- ,@(when (function-lambda-expression f)
- `("Lambda Expression: " (:value ,(function-lambda-expression f)) (:newline)))
- ,@(when (documentation f t)
- `("Documentation:" (:newline) ,(documentation f t) (:newline))))))
+ (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))))))
(defun method-specializers-for-inspect (method)
"Return a \"pretty\" list of the method's specializers. Normal
@@ -2755,17 +2766,10 @@
specialiazed on, the second element is the method qualifiers,
the rest of the list is the method's specialiazers (as per
method-specializers-for-inspect)."
- (if (swank-mop:method-qualifiers method)
- (list*
- (swank-mop:generic-function-name (swank-mop:method-generic-function method))
- (let ((quals (swank-mop:method-qualifiers method)))
- (if (= 1 (length quals))
- (first quals)
- quals))
- (method-specializers-for-inspect method))
- (list*
- (swank-mop:generic-function-name (swank-mop:method-generic-function method))
- (method-specializers-for-inspect method))))
+ (append (list (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method)))
+ (swank-mop:method-qualifiers method)
+ (method-specializers-for-inspect method)))
(defmethod inspect-for-emacs ((o standard-object) inspector)
(declare (ignore inspector))
@@ -2798,96 +2802,69 @@
The default returns the method sorted by applicability.
See `methods-by-applicability'.")
-;;; Largely inspired by (+ copied from) the McCLIM listener
+(defun specializer< (specializer1 specializer2)
+ "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)))))))
+
(defun methods-by-applicability (gf)
- "Return methods ordered by qualifiers, then by most specific argument types.
+ "Return methods ordered by most specific argument types.
-Qualifier ordering is: :before, :around, primary, and :after.
-We use the length of the class precedence list to determine which type is
-more specific."
- ;;FIXME: How to deal with argument-precedence-order?
+`method-specializer<' is used for sorting."
+ ;; FIXME: argument-precedence-order and qualifiers are ignored.
(let ((methods (copy-list (swank-mop:generic-function-methods gf))))
- ;; sorter function (most specific is defined as smaller)
- (flet ((method< (meth1 meth2)
- ;; First ordering rule is by qualifiers, that is :before-methods
- ;; come before :around methods, before primary methods, before
- ;; :after methods, other qualifiers are treated like none at all
- ;; (so like primary methods)
- (let ((qualifier-order '(:before :around nil :after)))
- (let ((q1 (or (position (first (swank-mop:method-qualifiers meth1)) qualifier-order) 2))
- (q2 (or (position (first (swank-mop:method-qualifiers meth2)) qualifier-order) 2)))
- (cond ((< q1 q2) (return-from method< t))
- ((> q1 q2) (return-from method< nil)))))
- ;; If qualifiers are equal, go by arguments
- (loop for sp1 in (swank-mop:method-specializers meth1)
- for sp2 in (swank-mop:method-specializers meth2)
- do (cond
- ((eq sp1 sp2)) ;; continue comparision
- ;; an eql specializer is most specific
- ((typep sp1 'swank-mop:eql-specializer)
- (return-from method< t))
- ((typep sp2 'swank-mop:eql-specializer)
- (return-from method< nil))
- ;; otherwise the longer the CPL the more specific
- ;; the specializer is
- ;; FIXME: Taking the CPL as indicator has the problem
- ;; that unfinalized classes are most specific. Can we pick
- ;; a reasonable default or do something with SUBTYPEP ?
- (t (let ((l1 (if (swank-mop:class-finalized-p sp1)
- (length (swank-mop:class-precedence-list sp1))
- 0))
- (l2 (if (swank-mop:class-finalized-p sp2)
- (length (swank-mop:class-precedence-list sp2))
- 0)))
- (cond
- ((> l1 l2)
- (return-from method< t))
- ((< l1 l2)
- (return-from method< nil))))))
- finally (return nil))))
- (declare (dynamic-extent #'method<))
- (sort methods #'method<))))
+ (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 methods #'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))))
(defmethod inspect-for-emacs ((gf standard-generic-function) inspector)
(declare (ignore inspector))
- (values "A generic function."
- `("Name: " (:value ,(swank-mop:generic-function-name gf)) (:newline)
- "Its argument list is: " ,(inspector-princ (swank-mop:generic-function-lambda-list gf)) (:newline)
- "Documentation: " (:newline)
- ,(inspector-princ (documentation gf t)) (:newline)
- "Its method class is: " (:value ,(swank-mop:generic-function-method-class gf)) (:newline)
- "It uses " (:value ,(swank-mop:generic-function-method-combination gf)) " method combination." (:newline)
- "Methods: " (:newline)
- ,@(loop
- for method in (funcall *gf-method-getter* gf)
- collect `(:value ,method ,(inspector-princ
- ;; drop the first element (the name of the generic function)
- (cdr (method-for-inspect-value method))))
- collect " "
- collect (let ((meth method))
- `(:action "[remove method]" ,(lambda () (remove-method gf meth))))
- collect '(:newline)
- if (documentation method t)
- collect " Documentation: " and
- collect (abbrev-doc (documentation method t)) and
- collect '(:newline)))))
+ (flet ((lv (label value) (label-value-line label value)))
+ (values
+ "A generic function."
+ (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))
+ `("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))))
+ (:action " [remove method]"
+ ,(let ((m method)) ; LOOP reassigns method
+ (lambda ()
+ (remove-method gf m))))
+ (:newline)))))))
(defmethod inspect-for-emacs ((method standard-method) inspector)
(declare (ignore inspector))
(values "A method."
- `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method)
- ,(inspector-princ
- (swank-mop:generic-function-name
- (swank-mop:method-generic-function method))))
+ `("Method defined on the generic function "
+ (:value ,(swank-mop:method-generic-function method)
+ ,(inspector-princ
+ (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method))))
(:newline)
- ,@(when (documentation method t)
- `("Documentation:" (:newline) ,(documentation method t) (:newline)))
+ ,@(docstring-ispec "Documentation" method t)
"Lambda List: " (:value ,(swank-mop:method-lambda-list method))
(:newline)
"Specializers: " (:value ,(swank-mop:method-specializers method)
@@ -3172,8 +3149,8 @@
(with-buffer-syntax ()
(inspect-object (inspector-nth-part index))))
-(defslimefun inspector-call-nth-action (index &rest args)
- (apply (aref *inspectee-actions* index) args)
+(defslimefun inspector-call-nth-action (index)
+ (funcall (aref *inspectee-actions* index))
(inspect-object (pop *inspector-stack*)))
(defslimefun inspector-pop ()
@@ -3419,6 +3396,6 @@
(add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
-;;; Local Variables:
-;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
-;;; End:
+;; Local Variables:
+;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
+;; End:
More information about the slime-cvs
mailing list