Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.358 diff -u -r1.358 slime.el --- slime.el 9 Jul 2004 12:09:18 -0000 1.358 +++ slime.el 9 Jul 2004 15:22:19 -0000 @@ -3058,10 +3058,12 @@ "Merge NOTES together. Keep the highest severity, concatenate the messages." (let* ((new-severity (reduce #'slime-most-severe notes :key #'slime-note.severity)) - (new-message (mapconcat #'slime-note.message notes "\n"))) + (new-message (mapconcat #'slime-note.message notes "\n")) + (new-references (reduce #'append notes :key #'slime-note.references))) (let ((new-note (copy-list (car notes)))) (setf (getf new-note :message) new-message) (setf (getf new-note :severity) new-severity) + (setf (getf new-note :references) new-references) new-note))) (defun slime-intersperse (element list) @@ -3158,6 +3160,9 @@ (or (plist-get note :short-message) (plist-get note :message))) +(defun slime-note.references (note) + (plist-get note :references)) + (defun slime-note.location (note) (plist-get note :location)) @@ -3195,10 +3200,27 @@ (slime-set-truncate-lines)) (slime-define-keys slime-compiler-notes-mode-map - ((kbd "RET") 'slime-compiler-notes-show-details) - ([mouse-2] 'slime-compiler-notes-show-details/mouse) + ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details) + ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse) ("q" 'slime-compiler-notes-quit)) +(defun slime-compiler-notes-default-action-or-show-details/mouse (event) + "Invoke the action pointed at by the mouse, or show details." + (interactive "e") + (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) + 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))))) + +(defun slime-compiler-notes-default-action-or-show-details () + "Invoke the action at point, or show details." + (interactive) + (let ((fn (get-text-property (point) + 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))) + (defun slime-compiler-notes-quit () (interactive) (let ((config slime-compiler-notes-saved-window-configuration)) @@ -3214,13 +3236,6 @@ (slime-tree-toggle tree)) (t (slime-show-source-location (slime-note.location note)))))) - -(defun slime-compiler-notes-show-details/mouse (event) - (interactive "e") - (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event - (goto-char pos) - (slime-compiler-notes-show-details))) - ;;;;;;; Tree Widget @@ -3257,7 +3272,29 @@ (not (slime-tree.kids tree))) (defun slime-tree-default-printer (tree) - (princ (slime-tree.item tree) (current-buffer))) + (princ (slime-tree.item tree) (current-buffer)) + (let ((note (plist-get (slime-tree.plist tree) 'note))) + (when note + (let ((references (slime-note.references note))) + (when references + (terpri (current-buffer)) + (princ "See also:" (current-buffer)) + (terpri (current-buffer)) + (slime-tree-insert-references references)))))) + +(defun slime-tree-insert-references (references) + "Insert documentation references from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (loop for refs on references + for ref = (car refs) + do + (destructuring-bind (where type what) ref + (insert " " (sldb-format-reference-source where) ", ") + (slime-insert-propertized (sldb-reference-properties where type what) + (sldb-format-reference-node what)) + (insert (format " [%s]" (slime-cl-symbol-name type))) + (when (cdr refs) + (terpri (current-buffer)))))) (defun slime-tree-decoration (tree) (cond ((slime-tree-leaf-p tree) "-- ") @@ -5554,6 +5591,7 @@ (member (slime-cl-symbol-name type) '("function" "special-operator" "macro" "section" "glossary" "issue")))) `(sldb-default-action sldb-lookup-reference + slime-compiler-notes-default-action sldb-lookup-reference sldb-reference ,ref face sldb-reference-face mouse-face highlight))) @@ -5569,7 +5607,7 @@ (upcase (slime-cl-symbol-name what)) (if (listp what) (mapconcat (lambda (x) (format "%S" x)) what ".") - what))) + what))) (defun sldb-lookup-reference () "Browse the documentation reference at point." Index: swank-backend.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v retrieving revision 1.61 diff -u -r1.61 swank-backend.lisp --- swank-backend.lisp 4 Jul 2004 03:21:43 -0000 1.61 +++ swank-backend.lisp 9 Jul 2004 15:22:19 -0000 @@ -25,6 +25,7 @@ #:position-pos #:print-output-to-string #:quit-lisp + #:references #:unbound-slot-filler)) (in-package :swank-backend) @@ -238,6 +239,10 @@ (short-message :initarg :short-message :initform nil :accessor short-message) + + (references :initarg :references + :initform nil + :accessor references) (location :initarg :location :accessor location))) Index: swank-sbcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v retrieving revision 1.94 diff -u -r1.94 swank-sbcl.lisp --- swank-sbcl.lisp 30 Jun 2004 13:45:32 -0000 1.94 +++ swank-sbcl.lisp 9 Jul 2004 15:22:20 -0000 @@ -178,11 +178,14 @@ (style-warning :style-warning) (warning :warning)) :short-message (brief-compiler-message-for-emacs condition) + :references (let ((c (if (typep condition 'sb-int:encapsulated-condition) + (sb-int:encapsulated-condition condition) + condition))) + (when (typep c 'sb-int:reference-condition) + (sb-int:reference-condition-references c))) :message (long-compiler-message-for-emacs condition context) :location (compiler-note-location context)))) - - (defun compiler-note-location (context) (cond (context (resolve-note-location @@ -238,7 +241,8 @@ When Emacs presents the message it already has the source popped up and the source form highlighted. This makes much of the information in the error-context redundant." - (princ-to-string condition)) + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) (defun long-compiler-message-for-emacs (condition error-context) "Describe a compiler error for Emacs including context information." @@ -247,8 +251,9 @@ (if error-context (values (sb-c::compiler-error-context-enclosing-source error-context) (sb-c::compiler-error-context-source error-context))) - (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A" - enclosing source condition))) + (let ((sb-int:*print-condition-references* nil)) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A" + enclosing source condition)))) (defun current-compiler-error-source-path (context) "Return the source-path for the current compiler error. Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.210 diff -u -r1.210 swank.lisp --- swank.lisp 7 Jul 2004 15:09:33 -0000 1.210 +++ swank.lisp 9 Jul 2004 15:22:21 -0000 @@ -1438,6 +1438,7 @@ (list* :message (message condition) :severity (severity condition) :location (location condition) + :references (references condition) (let ((s (short-message condition))) (if s (list :short-message s)))))