[slime-cvs] CVS slime
trittweiler
trittweiler at common-lisp.net
Wed Jul 16 16:14:51 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv31805
Modified Files:
swank.lisp slime.el ChangeLog
Log Message:
Recompilation support added to xref buffers. You can now use
`C-c C-c' in an xref buffer to recompile the defun represented by
the xref at point. Similiarly, you can use `C-c C-k' to recompile
all xrefs displayed.
For example, if you've changed a macro, and want to recompile all
the functions in the image which use that macro, you first call
`slime-who-macroexpands' (C-c C-w RET), and then issues `C-c C-k'
in the xref buffer that just popped up.
[There's no guarantee that this will actually recompile all
functions that depend on the changed macro, as this obviously
depends on the quality of the backend's WHO-MACROEXPANDS
implementation.]
* swank.lisp: Introduced the notion of a SWANK-COMPILATION-UNIT,
so we're able to compile different stuff comming from Slime one
after the other, and have compiler notes &c. collected in a
contiguous manner.
(defstruct :swank-compilation-unit): New. Contains compilation
notes, compilation results, etc.
(*swank-compilation-unit*): New. Current Swank Compilation Unit.
(with-swank-compilation-unit): New. Like WITH-COMPILATION-UNIT.
(swank-compilation-unit-for-emacs): New.
(swank-compiler): Adapted; collect compilation stuff into the
current swank-compilation-unit.
(compile-string-for-emacs): Use WITH-SWANK-COMPILATION-UNIT.
(compile-file-for-emacs): Ditto.
(*compiler-notes*, clear-compiler-notes): Removed.
(compiler-notes-for-emacs): Removed.
* slime.el (slime-compilation-unit, slime-last-compilation-unit),
(slime-compiler-notes, slime-compiler-results): New/Adapted.
(slime-make-compile-expression-for-swank): Factored out from
`slime-compile-string'.
(slime-recompile-location): New.
(slime-recompile-locations): New.
(slime-pop-to-location): &optional `where' arg can now also be
'excursion to only reset the current-buffer, but not switch.
(slime-xref-mode-map): Add `C-c C-c' and `C-c C-k'.
(slime-xref-dspec-at-point): New.
(slime-all-xrefs): New.
(slime-recompile-xref): New.
(slime-recompile-all-xrefs): New.
(slime-make-xref-recompilation-cont): New.
(slime-xref-inert-recompilation-flags): New.
(slime-trim-whitespace): New utility.
--- /project/slime/cvsroot/slime/swank.lisp 2008/07/05 13:37:25 1.546
+++ /project/slime/cvsroot/slime/swank.lisp 2008/07/16 16:14:50 1.547
@@ -56,7 +56,8 @@
#:profile-package
#:default-directory
#:set-default-directory
- #:quit-lisp))
+ #:quit-lisp
+ #:with-swank-compilation-unit))
(in-package :swank)
@@ -2195,15 +2196,16 @@
;;;; Compilation Commands.
-(defvar *compiler-notes* '()
- "List of compiler notes for the last compilation unit.")
+(defstruct (:swank-compilation-unit
+ (:type list) :named
+ (:conc-name swank-compilation-unit.)
+ (:constructor make-swank-compilation-unit ()))
+ notes ;
+ results ; a result is of type (MEMBER T NIL :COMPLAINED)
+ durations ;
+ )
-(defun clear-compiler-notes ()
- (setf *compiler-notes* '()))
-
-(defslimefun compiler-notes-for-emacs ()
- "Return the list of compiler notes for the last compilation unit."
- (reverse *compiler-notes*))
+(defvar *swank-compilation-unit* nil)
(defun measure-time-interval (fn)
"Call FN and return the first return value and the elapsed time.
@@ -2216,8 +2218,10 @@
(/ 1000000 internal-time-units-per-second)))))
(defun record-note-for-condition (condition)
- "Record a note for a compiler-condition."
- (push (make-compiler-note condition) *compiler-notes*))
+ "Record a note for a compiler-condition into the currently active
+Swank-Compilation-Unit."
+ (push (make-compiler-note condition)
+ (swank-compilation-unit.notes *swank-compilation-unit*)))
(defun make-compiler-note (condition)
"Make a compiler note data structure from a compiler-condition."
@@ -2229,41 +2233,65 @@
(let ((s (short-message condition)))
(if s (list :short-message s)))))
+(defmacro with-swank-compilation-unit ((&key override) &body body)
+ "Similiar to CL:WITH-COMPILATION-UNIT. Within a
+Swank-Compilation-Unit all notes, results etc. produced by
+COMPILE-FILE-FOR-EMACS and COMPILE-STRING-FOR-EMACS (possibly called
+more than once) will be collected into this unit."
+ (if override
+ `(let ((*swank-compilation-unit* (make-swank-compilation-unit)))
+ , at body)
+ `(let ((*swank-compilation-unit* (or *swank-compilation-unit*
+ (make-swank-compilation-unit))))
+ , at body)))
+
+(defun swank-compilation-unit-for-emacs (unit)
+ "Make a Swank-Compilation-Unit suitable for Emacs."
+ (let ((new (make-swank-compilation-unit)))
+ (with-struct (swank-compilation-unit. notes results durations) unit
+ (setf (swank-compilation-unit.notes new) (reverse notes))
+ (setf (swank-compilation-unit.results new) (reverse results))
+ (setf (swank-compilation-unit.durations new)
+ (reverse (mapcar #'(lambda (usecs) (/ usecs 1000000.0)) durations))))
+ new))
+
(defun swank-compiler (function)
- (clear-compiler-notes)
- (multiple-value-bind (result usecs)
- (with-simple-restart (abort "Abort SLIME compilation.")
- (handler-bind ((compiler-condition #'record-note-for-condition))
- (measure-time-interval function)))
- ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
- ;; unfortunately the SWANK protocol doesn't support returning multiple
- ;; values, so we gotta convert it explicitely to a list in either case.
- (if (and (not result) (eq usecs 't))
- (list nil nil)
- (list (to-string result)
- (format nil "~,2F" (/ usecs 1000000.0))))))
+ (let ((notes-p))
+ (multiple-value-bind (result usecs)
+ (with-simple-restart (abort "Abort SLIME compilation.")
+ (handler-bind ((compiler-condition #'(lambda (c)
+ (setf notes-p t)
+ (record-note-for-condition c))))
+ (measure-time-interval function)))
+ (when result (setf result (if notes-p :complained t)))
+ (push result (swank-compilation-unit.results *swank-compilation-unit*))
+ (push usecs (swank-compilation-unit.durations *swank-compilation-unit*))
+ (swank-compilation-unit-for-emacs *swank-compilation-unit*))))
(defslimefun compile-file-for-emacs (filename load-p)
"Compile FILENAME and, when LOAD-P, load the result.
Record compiler notes signalled as `compiler-condition's."
- (with-buffer-syntax ()
- (let ((*compile-print* nil))
- (swank-compiler
- (lambda ()
- (swank-compile-file filename load-p
- (or (guess-external-format filename)
- :default)))))))
+ (with-swank-compilation-unit (:override nil)
+ (with-buffer-syntax ()
+ (let ((*compile-print* nil))
+ (swank-compiler
+ (lambda ()
+ (swank-compile-file filename load-p
+ (or (guess-external-format filename)
+ :default))))))))
(defslimefun compile-string-for-emacs (string buffer position directory debug)
"Compile STRING (exerpted from BUFFER at POSITION).
Record compiler notes signalled as `compiler-condition's."
- (with-buffer-syntax ()
- (swank-compiler
- (lambda ()
- (let ((*compile-print* nil) (*compile-verbose* t))
- (swank-compile-string string :buffer buffer :position position
- :directory directory
- :debug debug))))))
+ (with-swank-compilation-unit (:override nil)
+ (with-buffer-syntax ()
+ (swank-compiler
+ (lambda ()
+ (let ((*compile-print* nil) (*compile-verbose* t))
+ (swank-compile-string string :buffer buffer :position position
+ :directory directory
+ :debug debug)))))))
+
(defun file-newer-p (new-file old-file)
"Returns true if NEW-FILE is newer than OLD-FILE."
@@ -3111,4 +3139,4 @@
(defun init ()
(run-hook *after-init-hook*))
-;;; swank.lisp ends here
+;;; swank.lisp ends here
\ No newline at end of file
--- /project/slime/cvsroot/slime/slime.el 2008/07/05 11:48:12 1.944
+++ /project/slime/cvsroot/slime/slime.el 2008/07/16 16:14:50 1.945
@@ -3753,6 +3753,25 @@
:group 'slime-mode
:type 'boolean)
+(defstruct (slime-compilation-unit
+ (:type list)
+ (:conc-name slime-compilation-unit.)
+ (:constructor nil)
+ (:copier nil))
+ tag notes results durations)
+
+(defvar slime-last-compilation-unit nil
+ "The result of the most recently issued compilation.")
+
+(defun slime-compiler-notes ()
+ "Return all compiler notes, warnings, and errors."
+ (slime-compilation-unit.notes slime-last-compilation-unit))
+
+(defun slime-compiler-results ()
+ "Return the results of the most recently issued compilations."
+ (slime-compilation-unit.results slime-last-compilation-unit))
+
+
(defun slime-compile-and-load-file ()
"Compile and load the buffer's file and highlight compiler notes.
@@ -3806,14 +3825,32 @@
(defun slime-compile-string (string start-offset)
(slime-eval-async
- `(swank:compile-string-for-emacs
- ,string
- ,(buffer-name)
- ,start-offset
- ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))
- ',slime-compile-with-maximum-debug)
+ (slime-make-compile-expression-for-swank string start-offset)
(slime-make-compilation-finished-continuation (current-buffer))))
+(defun slime-make-compile-expression-for-swank (string start-offset)
+ `(swank:compile-string-for-emacs
+ ,string
+ ,(buffer-name)
+ ,start-offset
+ ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))
+ ',slime-compile-with-maximum-debug))
+
+(defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot)
+ (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot))
+ (lambda (result)
+ (slime-compilation-finished result buffer snapshot))))
+
+(defun slime-compilation-finished (compilation-unit buffer &optional emacs-snapshot)
+ (with-struct (slime-compilation-unit. notes durations) compilation-unit
+ (with-current-buffer buffer
+ (setf slime-compilation-just-finished t)
+ (setf slime-last-compilation-unit compilation-unit)
+ (slime-show-note-counts notes (reduce #'+ durations))
+ (when slime-highlight-compiler-notes
+ (slime-highlight-notes notes)))
+ (run-hook-with-args 'slime-compilation-finished-hook notes emacs-snapshot)))
+
(defun slime-note-count-string (severity count &optional suppress-if-zero)
(cond ((and (zerop count) suppress-if-zero)
"")
@@ -3832,49 +3869,8 @@
(slime-note-count-string "warning" nwarnings)
(slime-note-count-string "style-warning" nstyle-warnings t)
(slime-note-count-string "note" nnotes)
- (if secs (format "[%s secs]" secs) ""))))
+ (if secs (format "[%.2f secs]" secs) ""))))
-(defun slime-xrefs-for-notes (notes)
- (let ((xrefs))
- (dolist (note notes)
- (let* ((location (getf note :location))
- (fn (cadr (assq :file (cdr location))))
- (file (assoc fn xrefs))
- (node
- (cons (format "%s: %s"
- (getf note :severity)
- (slime-one-line-ify (getf note :message)))
- location)))
- (when fn
- (if file
- (push node (cdr file))
- (setf xrefs (acons fn (list node) xrefs))))))
- xrefs))
-
-(defun slime-one-line-ify (string)
- "Return a single-line version of STRING.
-Each newlines and following indentation is replaced by a single space."
- (with-temp-buffer
- (insert string)
- (goto-char (point-min))
- (while (re-search-forward "\n[\n \t]*" nil t)
- (replace-match " "))
- (buffer-string)))
-
-(defun slime-compilation-finished (result buffer &optional emacs-snapshot)
- (let ((notes (slime-compiler-notes)))
- (with-current-buffer buffer
- (setf slime-compilation-just-finished t)
- (destructuring-bind (result secs) result
- (slime-show-note-counts notes secs)
- (when slime-highlight-compiler-notes
- (slime-highlight-notes notes))))
- (run-hook-with-args 'slime-compilation-finished-hook notes emacs-snapshot)))
-
-(defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot)
- (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot))
- (lambda (result)
- (slime-compilation-finished result buffer snapshot))))
(defun slime-highlight-notes (notes)
"Highlight compiler notes, warnings, and errors in the buffer."
@@ -3886,9 +3882,6 @@
(slime-remove-old-overlays)
(mapc #'slime-overlay-note (slime-merge-notes-for-display notes))))))
-(defun slime-compiler-notes ()
- "Return all compiler notes, warnings, and errors."
- (slime-eval `(swank:compiler-notes-for-emacs)))
(defun slime-remove-old-overlays ()
"Delete the existing Slime overlays in the current buffer."
@@ -3911,6 +3904,38 @@
(with-current-buffer %buffer
(funcall predicate)))
(buffer-list)))
+
+;;;;; Recompilation.
+
+;;; FIXME: Add maximum-debug-p.
+
+(defun slime-recompile-location (location)
+ (save-excursion
+ (slime-pop-to-location location 'excursion)
+ (slime-compile-defun)))
+
+(defun slime-recompile-locations (locations)
+ (flet ((make-compile-expr (loc)
+ (save-excursion
+ (slime-pop-to-location loc 'excursion)
+ (multiple-value-bind (start end) (slime-region-for-defun-at-point)
+ (slime-make-compile-expression-for-swank
+ (buffer-substring-no-properties start end)
+ start)))))
+ (slime-eval-async
+ `(swank:with-swank-compilation-unit (:override t)
+ ;; We have to compile each location seperately because of
+ ;; buffer and offset tracking during notes generation.
+ ,@(loop for loc in locations
+ collect (make-compile-expr loc)))
+ (slime-make-compilation-finished-continuation (current-buffer)))))
+
+;;; FIXME: implement:
+
+;; (defun slime-recompile-symbol-at-point (name)
+;; (interactive (list (slime-read-symbol-name "Name: ")))
+;; )
+
;;;;; Merging together compiler notes in the same location.
@@ -3958,6 +3983,33 @@
;;;;; Compiler notes list
+(defun slime-one-line-ify (string)
+ "Return a single-line version of STRING.
+Each newlines and following indentation is replaced by a single space."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward "\n[\n \t]*" nil t)
+ (replace-match " "))
+ (buffer-string)))
+
+(defun slime-xrefs-for-notes (notes)
+ (let ((xrefs))
+ (dolist (note notes)
+ (let* ((location (getf note :location))
+ (fn (cadr (assq :file (cdr location))))
+ (file (assoc fn xrefs))
+ (node
+ (cons (format "%s: %s"
+ (getf note :severity)
+ (slime-one-line-ify (getf note :message)))
+ location)))
+ (when fn
+ (if file
+ (push node (cdr file))
+ (setf xrefs (acons fn (list node) xrefs))))))
+ xrefs))
+
(defun slime-maybe-show-xrefs-for-notes (&optional notes emacs-snapshot)
"Show the compiler notes NOTES if they come from more than one file."
(let* ((notes (or notes (slime-compiler-notes)))
@@ -5046,12 +5098,13 @@
(defun slime-pop-to-location (location &optional where)
(slime-goto-source-location location)
(ecase where
- ((nil) (switch-to-buffer (current-buffer)))
- (window (pop-to-buffer (current-buffer) t))
- (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))
+ ((nil) (switch-to-buffer (current-buffer)))
+ (window (pop-to-buffer (current-buffer) t))
+ (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))
+ (excursion nil))) ; NOP, slime-goto-source-location did set-buffer.
(defun slime-find-definitions (name)
- "Find definitions for NAME and pass them to CONT."
+ "Find definitions for NAME."
(funcall slime-find-definitions-function name))
(defun slime-find-definitions-rpc (name)
@@ -5863,7 +5916,9 @@
(" " 'slime-goto-xref)
("q" 'slime-xref-quit)
("n" 'slime-next-line/not-add-newlines)
- ("p" 'previous-line))
+ ("p" 'previous-line)
+ ("\C-c\C-c" 'slime-recompile-xref)
+ ("\C-c\C-k" 'slime-recompile-all-xrefs))
(defun slime-next-line/not-add-newlines ()
(interactive)
@@ -6030,6 +6085,22 @@
(or (get-text-property (point) 'slime-location)
(error "No reference at point."))))
+(defun slime-xref-dspec-at-point ()
+ (save-excursion
+ (beginning-of-line 1)
+ (slime-trim-whitespace (substring-no-properties (thing-at-point 'line)))))
+
+(defun slime-all-xrefs ()
+ (let ((xrefs nil))
+ (save-excursion
+ (beginning-of-buffer)
+ (while (ignore-errors (slime-next-line/not-add-newlines) t)
+ (when-let (loc (get-text-property (point) 'slime-location))
+ (let* ((dspec (slime-xref-dspec-at-point))
+ (xref (make-slime-xref :dspec dspec :location loc)))
+ (push xref xrefs)))))
+ (nreverse xrefs)))
+
(defun slime-goto-xref ()
"Goto the cross-referenced location at point."
(interactive)
@@ -6073,6 +6144,58 @@
(slime-xref-cleanup)
(slime-set-emacs-snapshot snapshot)))
+(defun slime-recompile-xref ()
+ (interactive)
+ (let ((location (slime-xref-location-at-point))
+ (dspec (slime-xref-dspec-at-point)))
+ (add-hook 'slime-compilation-finished-hook
+ (slime-make-xref-recompilation-cont (list dspec))
+ nil)
+ (slime-recompile-location location)))
+
+(defun slime-recompile-all-xrefs ()
+ (interactive)
+ (let ((dspecs) (locations))
+ (dolist (xref (slime-all-xrefs))
+ (when (slime-xref-has-location-p xref)
+ (push (slime-xref.dspec xref) dspecs)
+ (push (slime-xref.location xref) locations)))
+ (add-hook 'slime-compilation-finished-hook
+ (slime-make-xref-recompilation-cont dspecs)
+ nil)
+ (slime-recompile-locations locations)))
+
+(defun slime-make-xref-recompilation-cont (dspecs)
+ ;; Extreme long-windedness to insert status of recompilation;
+ ;; sometimes Elisp resembles more of an Ewwlisp.
+ (lexical-let ((dspecs dspecs) (buffer (current-buffer)))
+ (labels ((recompilation-cont (&rest args)
+ (with-current-buffer buffer
+ (remove-hook 'slime-compilation-finished-hook
+ #'recompilation-cont)
+ (save-excursion
+ (slime-xref-insert-recompilation-flags
+ dspecs (slime-compiler-results))))))
+ #'recompilation-cont)))
+
+(defun slime-xref-insert-recompilation-flags (dspecs compilation-results)
+ (let* ((buffer-read-only nil)
+ (max-dspec-length (reduce #'max dspecs :key #'length :initial-value 0))
+ (max-column (+ max-dspec-length 2))) ; 2 initial spaces
+ (beginning-of-buffer)
+ (loop for dspec in dspecs
+ for result in compilation-results
+ do (save-excursion
+ (search-forward dspec)
+ (dotimes (i (- max-column (current-column)))
+ (insert " "))
+ (insert " ")
+ (insert (format "[%s]"
+ (case result
+ ((t) :success)
+ ((nil) :failure)
+ (t result))))))))
+
(defun slime-xref-cleanup ()
"Delete overlays created by xref mode and kill the xref buffer."
(sldb-delete-overlays)
@@ -9080,6 +9203,11 @@
(list (nthcdr n seq))
(seq (> (length seq) n))))
+(defun slime-trim-whitespace (str)
+ (save-match-data
+ (string-match "^\\s-*\\(.*?\\)\\s-*$" str)
+ (match-string 1 str)))
+
;;;;; Buffer related
(defun slime-buffer-narrowed-p (&optional buffer)
--- /project/slime/cvsroot/slime/ChangeLog 2008/07/05 13:38:25 1.1367
+++ /project/slime/cvsroot/slime/ChangeLog 2008/07/16 16:14:50 1.1368
@@ -1,3 +1,58 @@
+2008-07-16 Tobias C. Rittweiler <tcr at freebits.de>
+
+ Recompilation support added to xref buffers. You can now use
+ `C-c C-c' in an xref buffer to recompile the defun represented by
+ the xref at point. Similiarly, you can use `C-c C-k' to recompile
+ all xrefs displayed.
+
+ For example, if you've changed a macro, and want to recompile all
+ the functions in the image which use that macro, you first call
+ `slime-who-macroexpands' (C-c C-w RET), and then issues `C-c C-k'
+ in the xref buffer that just popped up.
+
+ [There's no guarantee that this will actually recompile all
+ functions that depend on the changed macro, as this obviously
+ depends on the quality of the backend's WHO-MACROEXPANDS
+ implementation.]
+
+ * swank.lisp: Introduced the notion of a SWANK-COMPILATION-UNIT,
+ so we're able to compile different stuff comming from Slime one
+ after the other, and have compiler notes &c. collected in a
+ contiguous manner.
+
+ (defstruct :swank-compilation-unit): New. Contains compilation
+ notes, compilation results, etc.
+ (*swank-compilation-unit*): New. Current Swank Compilation Unit.
+ (with-swank-compilation-unit): New. Like WITH-COMPILATION-UNIT.
+ (swank-compilation-unit-for-emacs): New.
+ (swank-compiler): Adapted; collect compilation stuff into the
+ current swank-compilation-unit.
+ (compile-string-for-emacs): Use WITH-SWANK-COMPILATION-UNIT.
+ (compile-file-for-emacs): Ditto.
+
+ (*compiler-notes*, clear-compiler-notes): Removed.
+ (compiler-notes-for-emacs): Removed.
+
+ * slime.el (slime-compilation-unit, slime-last-compilation-unit),
+ (slime-compiler-notes, slime-compiler-results): New/Adapted.
+
+ (slime-make-compile-expression-for-swank): Factored out from
+ `slime-compile-string'.
+ (slime-recompile-location): New.
+ (slime-recompile-locations): New.
+ (slime-pop-to-location): &optional `where' arg can now also be
+ 'excursion to only reset the current-buffer, but not switch.
+
+ (slime-xref-mode-map): Add `C-c C-c' and `C-c C-k'.
+ (slime-xref-dspec-at-point): New.
+ (slime-all-xrefs): New.
+ (slime-recompile-xref): New.
+ (slime-recompile-all-xrefs): New.
+ (slime-make-xref-recompilation-cont): New.
+ (slime-xref-inert-recompilation-flags): New.
+
+ (slime-trim-whitespace): New utility.
+
2008-07-05 Tobias C. Rittweiler <tcr at freebits.de>
* swank.lisp: Revert Melis' change from 2008-07-04; Global IO
More information about the slime-cvs
mailing list