[slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank-sbcl.lisp
Dan Barlow
dbarlow at common-lisp.net
Thu Dec 11 16:37:33 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv10371
Modified Files:
ChangeLog slime.el swank-sbcl.lisp
Log Message:
* swank-sbcl.lisp (compiler-note-location): replace with
thinly-ported version from the CMUCL backend which understands
:lisp as a pathname
* slime.el (slime-xrefs-for-notes): a little more temporary
variables, a little less cdr. Should be slightly faster on
big systems
(slime-goto-next-xref): set window point as well as buffer point -
now works in GNU Emacs 21.2.1
Date: Thu Dec 11 11:37:32 2003
Author: dbarlow
Index: slime/ChangeLog
diff -u slime/ChangeLog:1.150 slime/ChangeLog:1.151
--- slime/ChangeLog:1.150 Wed Dec 10 23:57:33 2003
+++ slime/ChangeLog Thu Dec 11 11:37:31 2003
@@ -1,5 +1,15 @@
2003-12-11 Daniel Barlow <dan at telent.net>
+ * swank-sbcl.lisp (compiler-note-location): replace with
+ thinly-ported version from the CMUCL backend which understands
+ :lisp as a pathname
+
+ * slime.el (slime-xrefs-for-notes): a little more temporary
+ variables, a little less cdr. Should be slightly faster on
+ big systems
+ (slime-goto-next-xref): set window point as well as buffer point -
+ now works in GNU Emacs 21.2.1
+
* swank.lisp (swank-compiler): new function abstracts commonality
between swank-compile-{file, string}.
(swank-load-system): call swank-compiler to load asdf system
Index: slime/slime.el
diff -u slime/slime.el:1.139 slime/slime.el:1.140
--- slime/slime.el:1.139 Wed Dec 10 23:57:33 2003
+++ slime/slime.el Thu Dec 11 11:37:32 2003
@@ -2086,22 +2086,23 @@
(if secs (format "[%s secs]" secs) ""))))
(defun slime-xrefs-for-notes (notes)
- (flet ((note-file (n) (cadr (assq :file (cdr (getf n :location))))))
- (let ((xrefs))
- (dolist (note notes)
- (let ((file (assoc (note-file note) xrefs))
- (node
- (cons (format "%s: %s"
- (getf note :severity)
- (replace-regexp-in-string
- "[^[:graph:]]+" " "
- (subseq (getf note :message) 0 )))
- (getf note :location))))
- (when (note-file note)
- (if file
- (push node (cdr file))
- (setf xrefs (acons (note-file note) (list node) xrefs))))))
- xrefs)))
+ (let ((xrefs))
+ (dolist (note notes)
+ (let* ((location (getf n :location))
+ (fn (cadr (assq :file (cdr location))))
+ (file (assoc fn xrefs))
+ (node
+ (cons (format "%s: %s"
+ (getf note :severity)
+ (replace-regexp-in-string
+ "[^[:graph:]]+" " "
+ (subseq (getf note :message) 0 )))
+ location)))
+ (when fn
+ (if file
+ (push node (cdr file))
+ (setf xrefs (acons fn (list node) xrefs))))))
+ xrefs))
(defun slime-compilation-finished (result buffer)
(let ((notes (slime-compiler-notes)))
@@ -3331,9 +3332,10 @@
(defun slime-goto-next-xref ()
"Goto the next cross-reference location."
(let ((location (with-current-buffer (slime-xref-buffer)
- (display-buffer (current-buffer) t)
- (goto-char (next-single-char-property-change
- (point) 'slime-location))
+ (let ((w (display-buffer (current-buffer) t)))
+ (goto-char (1+ (next-single-char-property-change
+ (point) 'slime-location)))
+ (set-window-point w (point)))
(cond ((eobp)
(message "No more xrefs.")
nil)
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.41 slime/swank-sbcl.lisp:1.42
--- slime/swank-sbcl.lisp:1.41 Wed Dec 10 21:20:13 2003
+++ slime/swank-sbcl.lisp Thu Dec 11 11:37:32 2003
@@ -159,7 +159,7 @@
(princ-to-string arglist)
"(-- <Unknown-Function>)")))))
-(defvar *buffername* nil)
+(defvar *buffer-name* nil)
(defvar *buffer-offset*)
(defvar *previous-compiler-condition* nil
@@ -189,31 +189,50 @@
:location (compiler-note-location context))))
(defun compiler-note-location (context)
- "Determine from CONTEXT the current compiler source location."
- (multiple-value-bind (file-name file-pos source-path)
- (if context
- (values
- (sb-c::compiler-error-context-file-name context)
- (sb-c::compiler-error-context-file-position context)
- (current-compiler-error-source-path context)))
- (cond (*buffername*
- ;; account for the added lambda, replace leading
- ;; position with 0
- (make-location
- (list :buffer *buffername*)
- (list :source-path (cons 0 (cddr source-path)) *buffer-offset*)))
- (file-name
- (etypecase file-name
- (pathname
- (make-location
- (list :file (namestring (truename file-name)))
- (list :source-path source-path file-pos)))))
- (*compile-file-truename*
- (make-location
- (list :file (namestring *compile-file-truename*))
- (list :source-path '(0) 1)))
- (t
- (list :error "No source location")))))
+ (cond (context
+ (resolve-note-location
+ *buffer-name*
+ (sb-c::compiler-error-context-file-name context)
+ (sb-c::compiler-error-context-file-position context)
+ (current-compiler-error-source-path context)
+ (sb-c::compiler-error-context-original-source context)))
+ (t
+ (resolve-note-location *buffer-name* nil nil nil nil))))
+
+(defgeneric resolve-note-location (buffer file-name file-position
+ source-path source))
+
+(defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
+ (make-location
+ `(:file ,(truename f))
+ `(:position ,(1+ (source-path-file-position path f)))))
+
+;;; FIXME this one's broken: no source-path-string-position
+(defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
+ (make-location
+ `(:buffer ,b)
+ `(:position ,(+ *buffer-offset*
+ (source-path-string-position path *buffer-substring*)))))
+
+(defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
+ (make-location
+ `(:source-form ,source)
+ `(:position 1)))
+
+(defmethod resolve-note-location (buffer
+ (file (eql nil))
+ (pos (eql nil))
+ (path (eql nil))
+ (source (eql nil)))
+ (cond (buffer
+ (make-location (list :buffer buffer)
+ (list :position *buffer-offset*)))
+ (*compile-file-truename*
+ (make-location (list :file (namestring *compile-file-truename*))
+ (list :position 0)))
+ (t
+ (list :error "No error location available"))))
+
(defun brief-compiler-message-for-emacs (condition error-context)
"Briefly describe a compiler error for Emacs.
@@ -261,7 +280,7 @@
(defmethod compile-string-for-emacs (string &key buffer position)
(with-compilation-hooks ()
(let ((*package* *buffer-package*)
- (*buffername* buffer)
+ (*buffer-name* buffer)
(*buffer-offset* position))
(eval (from-string
(format nil "(funcall (compile nil '(lambda () ~A)))"
More information about the slime-cvs
mailing list