1 | ;;; slime.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2004 Peter Graves |
---|
4 | ;;; $Id: slime.lisp,v 1.26 2004-09-21 13:53:08 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | ;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs", |
---|
21 | ;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller. |
---|
22 | |
---|
23 | (in-package #:system) |
---|
24 | |
---|
25 | (defpackage #:j |
---|
26 | (:use #:cl #:ext #:java)) |
---|
27 | |
---|
28 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
29 | (require '#:j) |
---|
30 | (resolve 'with-mutex) |
---|
31 | (require '#:swank-protocol) |
---|
32 | (sys:load-system-file "swank-package")) |
---|
33 | |
---|
34 | (defpackage #:slime |
---|
35 | (:use #:cl #:ext #:j) |
---|
36 | (:export #:slime |
---|
37 | #:slime-complete-symbol |
---|
38 | #:slime-space |
---|
39 | #:slime-edit-definition |
---|
40 | #:slime-eval-region |
---|
41 | #:slime-eval-last-expression |
---|
42 | #:slime-eval-defun |
---|
43 | #:slime-compile-defun |
---|
44 | #:slime-load-file |
---|
45 | #:slime-compile-file |
---|
46 | #:slime-compile-and-load-file)) |
---|
47 | |
---|
48 | (in-package #:slime) |
---|
49 | |
---|
50 | (defvar *stream* nil) |
---|
51 | |
---|
52 | (defvar *continuation-counter* 0) |
---|
53 | |
---|
54 | (defvar *continuations* nil) |
---|
55 | |
---|
56 | (defvar *continuations-lock* (make-mutex)) |
---|
57 | |
---|
58 | (defvar *repl-buffer-name* nil) |
---|
59 | |
---|
60 | (defvar *repl-buffer* nil) |
---|
61 | |
---|
62 | (defun slime-local-p () |
---|
63 | (let ((name (buffer-name))) |
---|
64 | (and name |
---|
65 | (search name "jlisp")))) |
---|
66 | |
---|
67 | (defun slime-connected-p () |
---|
68 | (or (not (null *stream*)) |
---|
69 | (slime-local-p))) |
---|
70 | |
---|
71 | (defun connect (host port) |
---|
72 | (when *stream* |
---|
73 | (disconnect)) |
---|
74 | (ignore-errors |
---|
75 | (let* ((socket (sys::make-socket host port)) |
---|
76 | (stream (and socket (get-socket-stream socket)))) |
---|
77 | (when stream |
---|
78 | (setf *stream* stream) |
---|
79 | (return-from connect t))))) |
---|
80 | |
---|
81 | (defun disconnect () |
---|
82 | (when *stream* |
---|
83 | (ignore-errors |
---|
84 | (close *stream*)) |
---|
85 | (setf *stream* nil) |
---|
86 | (with-mutex (*continuations-lock*) |
---|
87 | (setf *continuations* nil)))) |
---|
88 | |
---|
89 | (defun read-port-and-connect (retries) |
---|
90 | (status "Slime polling for connection...") |
---|
91 | (dotimes (i retries (status "Slime timed out")) |
---|
92 | (unless (buffer-live-p *repl-buffer*) |
---|
93 | (status "Killed") |
---|
94 | (return)) |
---|
95 | (when (probe-file (swank-protocol:port-file)) |
---|
96 | (let ((port (with-open-file (s (swank-protocol:port-file) |
---|
97 | :direction :input) |
---|
98 | (read s)))) |
---|
99 | (when (connect "127.0.0.1" port) |
---|
100 | (status "Slime connected!") |
---|
101 | (return)))) |
---|
102 | (sleep 1))) |
---|
103 | |
---|
104 | (defun slime () |
---|
105 | (when *stream* |
---|
106 | (disconnect)) |
---|
107 | (setf *repl-buffer* (current-buffer)) |
---|
108 | (unless (slime-local-p) |
---|
109 | (make-thread #'(lambda () (read-port-and-connect 60))))) |
---|
110 | |
---|
111 | (defun slime-busy-p () |
---|
112 | (not (null *continuations*))) |
---|
113 | |
---|
114 | (defun dispatch-return (message) |
---|
115 | (assert (eq (first message) :return)) |
---|
116 | (let* ((value (second message)) |
---|
117 | (id (third message)) |
---|
118 | rec) |
---|
119 | (with-mutex (*continuations-lock*) |
---|
120 | (setf rec (and id (assoc id *continuations*))) |
---|
121 | (when rec |
---|
122 | (setf *continuations* (remove rec *continuations*)))) |
---|
123 | (cond (rec |
---|
124 | (cond ((eq (first value) :ok) |
---|
125 | (funcall (cdr rec) (second value))) |
---|
126 | ((eq (first value) :abort) |
---|
127 | (if (second value) |
---|
128 | (funcall (cdr rec) (second value)) |
---|
129 | (status "Evaluation aborted."))))) |
---|
130 | (t |
---|
131 | (error "Unexpected message: ~S" message))))) |
---|
132 | |
---|
133 | (defun dispatch-loop () |
---|
134 | (loop |
---|
135 | (let (message) |
---|
136 | (handler-case |
---|
137 | (setf message (swank-protocol:decode-message *stream*)) |
---|
138 | (stream-error () (disconnect) (status "Slime not connected"))) |
---|
139 | ;; (sys::%format t "message = ~S~%" message) |
---|
140 | (when (eq (first message) :return) |
---|
141 | (dispatch-return message))) |
---|
142 | (with-mutex (*continuations-lock*) |
---|
143 | (unless *continuations* |
---|
144 | (return)))) |
---|
145 | ;; (sys::%format t "leaving dispatch-loop~%") |
---|
146 | ) |
---|
147 | |
---|
148 | (defun slime-eval (form) |
---|
149 | (if (slime-local-p) |
---|
150 | (eval form) |
---|
151 | (handler-case |
---|
152 | (progn |
---|
153 | (swank-protocol:encode-message `(:eval ,form) *stream*) |
---|
154 | (let* ((message (swank-protocol:decode-message *stream*)) |
---|
155 | (kind (first message))) |
---|
156 | (case kind |
---|
157 | (:return |
---|
158 | (let ((result (second message))) |
---|
159 | (when (eq (first result) :ok) |
---|
160 | (second result))))))) |
---|
161 | (stream-error () (disconnect))))) |
---|
162 | |
---|
163 | (defun slime-eval-async (form continuation) |
---|
164 | (cond ((slime-local-p) |
---|
165 | nil) ;; FIXME |
---|
166 | ((not (slime-connected-p)) |
---|
167 | (status "Slime not connected")) |
---|
168 | (t |
---|
169 | (handler-case |
---|
170 | (with-mutex (*continuations-lock*) |
---|
171 | (let ((continuations *continuations*) |
---|
172 | (id (incf *continuation-counter*))) |
---|
173 | (push (cons id continuation) *continuations*) |
---|
174 | (swank-protocol:encode-message `(:eval-async ,form ,id) *stream*) |
---|
175 | (unless continuations |
---|
176 | (make-thread #'(lambda () (dispatch-loop)))))) |
---|
177 | (stream-error () (disconnect)))))) |
---|
178 | |
---|
179 | (defvar *prefix* nil) |
---|
180 | (defvar *completions* ()) |
---|
181 | (defvar *completion-index* 0) |
---|
182 | |
---|
183 | (defun completions (prefix) |
---|
184 | (slime-eval `(swank:completion-set ,prefix ,(package-name *package*)))) |
---|
185 | |
---|
186 | (defun delimiter-p (c) |
---|
187 | (member c '(#\space #\( #\) #\'))) |
---|
188 | |
---|
189 | (defun completion-prefix () |
---|
190 | (let* ((string (line-chars (current-line))) |
---|
191 | (end (mark-charpos (current-point)))) |
---|
192 | (do ((start (1- end) (1- start))) |
---|
193 | ((< start 0) (when (> end 0) (subseq string 0 end))) |
---|
194 | (let ((c (schar string start))) |
---|
195 | (when (delimiter-p c) |
---|
196 | (incf start) |
---|
197 | (return (when (> end start) (subseq string start end)))))))) |
---|
198 | |
---|
199 | (defun slime-complete-symbol () |
---|
200 | (when (slime-busy-p) |
---|
201 | (return-from slime-complete-symbol)) |
---|
202 | (unless (slime-connected-p) |
---|
203 | (status "Slime not connected") |
---|
204 | (return-from slime-complete-symbol)) |
---|
205 | (cond ((eq *last-command* 'complete) |
---|
206 | (unless (> (length *completions*) 1) |
---|
207 | (return-from slime-complete-symbol)) |
---|
208 | (undo) |
---|
209 | (incf *completion-index*) |
---|
210 | (when (> *completion-index* (1- (length *completions*))) |
---|
211 | (setf *completion-index* 0))) |
---|
212 | (t |
---|
213 | (setf *prefix* (completion-prefix) |
---|
214 | *completions* nil |
---|
215 | *completion-index* 0) |
---|
216 | (when *prefix* |
---|
217 | (setf *completions* (completions *prefix*))))) |
---|
218 | (when *completions* |
---|
219 | (let* ((completion (string-downcase (nth *completion-index* *completions*))) |
---|
220 | (point (current-point)) |
---|
221 | (flags (line-flags (mark-line point)))) |
---|
222 | (with-single-undo |
---|
223 | (goto-char (make-mark (mark-line point) |
---|
224 | (- (mark-charpos point) (length *prefix*)))) |
---|
225 | (set-mark point) |
---|
226 | (delete-region) |
---|
227 | (insert completion) |
---|
228 | (setf (line-flags (mark-line point)) flags))) |
---|
229 | (setf *current-command* 'complete)) |
---|
230 | (values)) |
---|
231 | |
---|
232 | (defun symbol-name-at-point () |
---|
233 | (let ((string (line-chars (current-line))) |
---|
234 | (point-charpos (mark-charpos (current-point))) |
---|
235 | (begin 0) |
---|
236 | end) |
---|
237 | (when (= point-charpos (length string)) |
---|
238 | (decf point-charpos)) |
---|
239 | (loop |
---|
240 | (aver (< point-charpos (length string))) |
---|
241 | (cond ((not (delimiter-p (schar string point-charpos))) |
---|
242 | (return)) |
---|
243 | ((zerop point-charpos) |
---|
244 | (return-from symbol-name-at-point nil)) |
---|
245 | (t |
---|
246 | (decf point-charpos)))) |
---|
247 | (dotimes (i point-charpos) |
---|
248 | (let ((c (schar string i))) |
---|
249 | (when (delimiter-p c) |
---|
250 | (setf begin (1+ i))))) |
---|
251 | (do ((i point-charpos (1+ i))) |
---|
252 | ((= i (length string)) (setf end i)) |
---|
253 | (when (delimiter-p (schar string i)) |
---|
254 | (setf end i) |
---|
255 | (return))) |
---|
256 | (subseq string begin end))) |
---|
257 | |
---|
258 | (defun enclosing-operator-names () |
---|
259 | "Return the list of operator names of the forms containing point." |
---|
260 | (let ((result ())) |
---|
261 | (save-excursion |
---|
262 | (loop |
---|
263 | (let ((point1 (current-point)) |
---|
264 | (point2 (progn (backward-up-list) (current-point)))) |
---|
265 | (when (and (equal (mark-line point1) (mark-line point2)) |
---|
266 | (eql (mark-charpos point1) (mark-charpos point2))) |
---|
267 | (return))) |
---|
268 | (unless (looking-at "(") |
---|
269 | (return)) |
---|
270 | (when (looking-at "(") |
---|
271 | (forward-char) |
---|
272 | (let ((name (symbol-name-at-point))) |
---|
273 | (cond ((string-equal name "defun") |
---|
274 | (return)) |
---|
275 | ((null name) |
---|
276 | (return)) |
---|
277 | (t |
---|
278 | (push name result)))) |
---|
279 | (backward-up-list)))) |
---|
280 | (nreverse result))) |
---|
281 | |
---|
282 | (defun slime-space () |
---|
283 | (unwind-protect |
---|
284 | (when (and (slime-connected-p) |
---|
285 | (not (slime-busy-p))) |
---|
286 | (let ((names (enclosing-operator-names))) |
---|
287 | (when names |
---|
288 | (slime-eval-async |
---|
289 | `(swank:arglist-for-echo-area (quote ,names)) |
---|
290 | #'(lambda (message) |
---|
291 | (when (stringp message) |
---|
292 | (status (string-trim '(#\") message)))))))) |
---|
293 | (insert #\space))) |
---|
294 | |
---|
295 | (defun find-buffer-package () |
---|
296 | ;; (save-excursion |
---|
297 | ;; (when (let ((case-fold-search t) |
---|
298 | ;; (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>")) |
---|
299 | ;; (or (re-search-backward regexp nil t) |
---|
300 | ;; (re-search-forward regexp nil t))) |
---|
301 | ;; (goto-char (match-end 0)) |
---|
302 | ;; (skip-chars-forward " \n\t\f\r#") |
---|
303 | ;; (let ((pkg (ignore-errors (read (current-buffer))))) |
---|
304 | ;; (if pkg (format "%s" pkg)))))) |
---|
305 | (let (mark (current-point)) |
---|
306 | (loop |
---|
307 | (setf mark (search-backward "(in-package" |
---|
308 | :start mark |
---|
309 | :ignore-case t |
---|
310 | :whole-words-only t)) |
---|
311 | (cond ((null mark) |
---|
312 | (return)) |
---|
313 | ((eql (mark-charpos mark) 0) |
---|
314 | (return)) |
---|
315 | (t |
---|
316 | (move-to-position mark (1- (mark-charpos mark)))))) |
---|
317 | (when mark |
---|
318 | (let* ((line-chars (line-chars (mark-line mark))) |
---|
319 | (package-name |
---|
320 | (ignore-errors |
---|
321 | (read-from-string (subseq line-chars |
---|
322 | (+ (mark-charpos mark) |
---|
323 | (length "(in-package"))))))) |
---|
324 | (when package-name |
---|
325 | (string package-name)))))) |
---|
326 | |
---|
327 | (defstruct (slime-definition (:type list)) |
---|
328 | spec location) |
---|
329 | |
---|
330 | (defun goto-source-location (name location) |
---|
331 | (when (eq (car location) :location) |
---|
332 | (let (file position function-name) |
---|
333 | (dolist (item (cdr location)) |
---|
334 | (case (car item) |
---|
335 | (:file |
---|
336 | (setf file (cadr item))) |
---|
337 | (:position |
---|
338 | (setf position (cadr item))))) |
---|
339 | (when file |
---|
340 | (let ((buffer (find-file-buffer file))) |
---|
341 | (when buffer |
---|
342 | (let* ((short-name |
---|
343 | (let ((index (position #\: name :from-end t))) |
---|
344 | (if index (subseq name (1+ index)) name)))) |
---|
345 | (switch-to-buffer buffer) |
---|
346 | (with-single-undo |
---|
347 | (goto-char (or position 0)) |
---|
348 | (let* ((pattern (format nil "^\\s*\\(def\\S*\\s+~A" short-name)) |
---|
349 | (pos (re-search-forward pattern |
---|
350 | :ignore-case t |
---|
351 | :whole-words-only t))) |
---|
352 | (when pos |
---|
353 | (goto-char pos)) |
---|
354 | (setf pos (search-forward short-name :ignore-case t)) |
---|
355 | (when pos |
---|
356 | (goto-char pos)))) |
---|
357 | (update-display)))))))) |
---|
358 | |
---|
359 | ;; FIXME |
---|
360 | (defun find-tag-at-point () |
---|
361 | (j::%execute-command "findTagAtDot")) |
---|
362 | |
---|
363 | ;; FIXME |
---|
364 | (defun push-position () |
---|
365 | (j::%execute-command "pushPosition")) |
---|
366 | |
---|
367 | (defun slime-edit-definition (&optional function-name package-name) |
---|
368 | (unless (slime-connected-p) |
---|
369 | (find-tag-at-point) |
---|
370 | (return-from slime-edit-definition)) |
---|
371 | (let ((pathname (buffer-pathname (current-buffer)))) |
---|
372 | (when (and pathname |
---|
373 | (string-equal (pathname-type pathname) "el")) |
---|
374 | (find-tag-at-point) |
---|
375 | (return-from slime-edit-definition))) |
---|
376 | (unless function-name |
---|
377 | (setf function-name (string-upcase (symbol-name-at-point)))) |
---|
378 | (when function-name |
---|
379 | (setf function-name (string function-name)) |
---|
380 | (let ((pos (position #\: function-name))) |
---|
381 | (when pos |
---|
382 | (setf package-name (subseq function-name 0 pos)) |
---|
383 | (setf function-name (subseq function-name (1+ (position #\: function-name :from-end t)))))) |
---|
384 | (let ((definitions |
---|
385 | (slime-eval `(swank:find-definitions-for-function-name ,function-name |
---|
386 | ,package-name)))) |
---|
387 | (cond (definitions |
---|
388 | (push-position) |
---|
389 | (goto-source-location function-name |
---|
390 | (slime-definition-location (car definitions)))) |
---|
391 | (t |
---|
392 | (find-tag-at-point)))))) |
---|
393 | |
---|
394 | (defun slime-eval-region () |
---|
395 | (let ((mark (current-mark))) |
---|
396 | (when mark |
---|
397 | (let* ((string (buffer-substring (current-point) mark)) |
---|
398 | (package (find-buffer-package))) |
---|
399 | (slime-eval-async |
---|
400 | `(swank:eval-region ,string ,package) 'display-eval-result))))) |
---|
401 | |
---|
402 | (defun last-expression () |
---|
403 | (let (start end) |
---|
404 | (backward-sexp) |
---|
405 | (setf start (current-point)) |
---|
406 | (undo) |
---|
407 | (setf end (current-point)) |
---|
408 | (buffer-substring start end))) |
---|
409 | |
---|
410 | (defun display-eval-result (value) |
---|
411 | (status value)) |
---|
412 | |
---|
413 | (defun slime-eval-last-expression () |
---|
414 | (let* ((string (last-expression)) |
---|
415 | (package (find-buffer-package))) |
---|
416 | (slime-eval-async |
---|
417 | `(swank:eval-string-async ,string ,package) 'display-eval-result))) |
---|
418 | |
---|
419 | (defun slime-eval-defun () |
---|
420 | (let* ((string (defun-at-point)) |
---|
421 | (package (find-buffer-package))) |
---|
422 | (slime-eval-async |
---|
423 | `(swank:eval-string-async ,string ,package) 'display-eval-result))) |
---|
424 | |
---|
425 | (defun slime-compile-defun () |
---|
426 | (let* ((string (defun-at-point)) |
---|
427 | (package (find-buffer-package))) |
---|
428 | (slime-eval-async |
---|
429 | `(swank:swank-compile-string ,string ,package) 'display-eval-result))) |
---|
430 | |
---|
431 | (defun slime-load-file () |
---|
432 | (let ((pathname (buffer-pathname))) |
---|
433 | (slime-eval-async |
---|
434 | `(swank:swank-load-file ,pathname) 'display-eval-result))) |
---|
435 | |
---|
436 | (defun slime-compile-file () |
---|
437 | (let ((pathname (buffer-pathname))) |
---|
438 | (slime-eval-async |
---|
439 | `(swank:swank-compile-file ,pathname nil) 'display-eval-result))) |
---|
440 | |
---|
441 | (defun slime-compile-and-load-file () |
---|
442 | (let ((pathname (buffer-pathname))) |
---|
443 | (slime-eval-async |
---|
444 | `(swank:swank-compile-file ,pathname t) 'display-eval-result))) |
---|
445 | |
---|
446 | (map-key-for-mode "Tab" "(slime:slime-complete-symbol)" "Lisp Shell") |
---|
447 | (map-key-for-mode "Ctrl Alt I" "(slime:slime-complete-symbol)" "Lisp") |
---|
448 | (map-key-for-mode "Space" "(slime:slime-space)" "Lisp Shell") |
---|
449 | (map-key-for-mode "Space" "(slime:slime-space)" "Lisp") |
---|
450 | (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp Shell") |
---|
451 | (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp") |
---|
452 | (map-key-for-mode "Ctrl Alt R" "(slime:slime-eval-region)" "Lisp") |
---|
453 | (map-key-for-mode "Ctrl Alt E" "(slime:slime-eval-last-expression)" "Lisp") |
---|
454 | (map-key-for-mode "Ctrl Alt K" "(slime:slime-compile-and-load-file)" "Lisp") |
---|
455 | (map-key-for-mode "Ctrl Alt X" "(slime:slime-eval-defun)" "Lisp") |
---|
456 | (map-key-for-mode "Ctrl Alt C" "(slime:slime-compile-defun)" "Lisp") |
---|
457 | |
---|
458 | (pushnew :slime *features*) |
---|