[slime-cvs] CVS slime
CVS User sboukarev
sboukarev at common-lisp.net
Thu May 3 14:12:23 UTC 2012
Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv7687
Modified Files:
ChangeLog swank-backend.lisp swank-sbcl.lisp
Log Message:
* swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over
:buffer, because the buffer can be killed in the mean time and the
silly "No buffer named x.lisp" would be displayed.
--- /project/slime/cvsroot/slime/ChangeLog 2012/05/03 07:44:53 1.2324
+++ /project/slime/cvsroot/slime/ChangeLog 2012/05/03 14:12:22 1.2325
@@ -1,5 +1,11 @@
2012-05-03 Stas Boukarev <stassats at gmail.com>
+ * swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over
+ :buffer, because the buffer can be killed in the mean time and the
+ silly "No buffer named x.lisp" would be displayed.
+
+2012-05-03 Stas Boukarev <stassats at gmail.com>
+
* swank.lisp (find-definitions-find-symbol): Put back accidentally
removed with-buffer-syntax.
--- /project/slime/cvsroot/slime/swank-backend.lisp 2012/04/07 10:23:38 1.217
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2012/05/03 14:12:22 1.218
@@ -239,19 +239,21 @@
(defmacro with-struct ((conc-name &rest names) obj &body body)
"Like with-slots but works only for structs."
- (flet ((reader (slot) (intern (concatenate 'string
- (symbol-name conc-name)
- (symbol-name slot))
- (symbol-package conc-name))))
+ (flet ((reader (slot)
+ ;; Use read-from-string instead of intern so that
+ ;; conc-name can be a string such as ext:struct- and not
+ ;; cause errors and not force interning ext::struct-
+ (read-from-string
+ (concatenate 'string (string conc-name) (string slot)))))
(let ((tmp (gensym "OO-")))
- ` (let ((,tmp ,obj))
- (symbol-macrolet
- ,(loop for name in names collect
- (typecase name
- (symbol `(,name (,(reader name) ,tmp)))
- (cons `(,(first name) (,(reader (second name)) ,tmp)))
- (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
- , at body)))))
+ ` (let ((,tmp ,obj))
+ (symbol-macrolet
+ ,(loop for name in names collect
+ (typecase name
+ (symbol `(,name (,(reader name) ,tmp)))
+ (cons `(,(first name) (,(reader (second name)) ,tmp)))
+ (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
+ , at body)))))
(defmacro when-let ((var value) &body body)
`(let ((,var ,value))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/04/27 14:57:59 1.309
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2012/05/03 14:12:23 1.310
@@ -789,49 +789,64 @@
(defun categorize-definition-source (definition-source)
- (with-struct (sb-introspect::definition-source-
- pathname form-path character-offset plist)
- definition-source
+ (with-struct ("sb-introspect:definition-source-"
+ pathname form-path character-offset plist)
+ definition-source
(cond ((getf plist :emacs-buffer) :buffer)
- ((and pathname (or form-path character-offset)) :file)
+ ((and pathname (or form-path character-offset)
+ (probe-file pathname)) :file)
(pathname :file-without-position)
(t :invalid))))
+(defun definition-source-buffer-location (definition-source)
+ (with-struct ("sb-introspect:definition-source-"
+ form-path character-offset plist)
+ definition-source
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
+ emacs-string &allow-other-keys)
+ plist
+ (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
+ (multiple-value-bind (start end)
+ (if form-path
+ (with-debootstrapping
+ (source-path-string-position form-path
+ emacs-string))
+ (values character-offset
+ most-positive-fixnum))
+ (make-location
+ `(:buffer ,emacs-buffer)
+ `(:offset ,emacs-position ,start)
+ `(:snippet
+ ,(subseq emacs-string
+ start
+ (min end (+ start *source-snippet-size*))))))))))
+
+(defun definition-source-file-location (definition-source)
+ (with-struct ("sb-introspect:definition-source-"
+ pathname form-path character-offset plist
+ file-write-date) definition-source
+ (let* ((namestring (namestring (translate-logical-pathname pathname)))
+ (pos (if form-path
+ (source-file-position namestring file-write-date
+ form-path)
+ character-offset))
+ (snippet (source-hint-snippet namestring file-write-date pos)))
+ (make-location `(:file ,namestring)
+ ;; /file positions/ in Common Lisp start from
+ ;; 0, buffer positions in Emacs start from 1.
+ `(:position ,(1+ pos))
+ `(:snippet ,snippet)))))
+
(defun definition-source-for-emacs (definition-source type name)
- (with-struct (sb-introspect::definition-source-
- pathname form-path character-offset plist
- file-write-date)
- definition-source
+ (with-struct ("sb-introspect:definition-source-"
+ pathname form-path character-offset plist
+ file-write-date)
+ definition-source
(ecase (categorize-definition-source definition-source)
(:buffer
- (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
- emacs-string &allow-other-keys)
- plist
- (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
- (multiple-value-bind (start end)
- (if form-path
- (with-debootstrapping
- (source-path-string-position form-path emacs-string))
- (values character-offset most-positive-fixnum))
- (make-location
- `(:buffer ,emacs-buffer)
- `(:offset ,emacs-position ,start)
- `(:snippet
- ,(subseq emacs-string
- start
- (min end (+ start *source-snippet-size*)))))))))
+ (definition-source-buffer-location definition-source))
(:file
- (let* ((namestring (namestring (translate-logical-pathname pathname)))
- (pos (if form-path
- (source-file-position namestring file-write-date
- form-path)
- character-offset))
- (snippet (source-hint-snippet namestring file-write-date pos)))
- (make-location `(:file ,namestring)
- ;; /file positions/ in Common Lisp start from
- ;; 0, buffer positions in Emacs start from 1.
- `(:position ,(1+ pos))
- `(:snippet ,snippet))))
+ (definition-source-file-location definition-source))
(:file-without-position
(make-location `(:file ,(namestring
(translate-logical-pathname pathname)))
@@ -840,9 +855,9 @@
`(:snippet ,(format nil "(defun ~a "
(symbol-name name))))))
(:invalid
- (error "DEFINITION-SOURCE of ~A ~A did not contain ~
+ (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
meaningful information."
- (string-downcase type) name)))))
+ type name)))))
(defun source-file-position (filename write-date form-path)
(let ((source (get-source-code filename write-date))
More information about the slime-cvs
mailing list