source: trunk/j/src/org/armedbear/lisp/slime.lisp @ 8911

Last change on this file since 8911 was 8911, checked in by piso, 16 years ago

Work in progress.

File size: 16.4 KB
Line 
1;;; slime.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: slime.lisp,v 1.33 2005-04-10 20:07:51 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                 :name "slime read-port-and-connect")))
111
112(defun slime-busy-p ()
113  (not (null *continuations*)))
114
115(defun dispatch-return (message)
116  (assert (eq (first message) :return))
117  (let* ((value (second message))
118         (id (third message))
119         rec)
120    (with-mutex (*continuations-lock*)
121      (setf rec (and id (assoc id *continuations*)))
122      (when rec
123        (setf *continuations* (remove rec *continuations*))))
124    (cond (rec
125           (cond ((eq (first value) :ok)
126                  (funcall (cdr rec) (second value)))
127                 ((eq (first value) :abort)
128                  (if (second value)
129                      (funcall (cdr rec) (second value))
130                      (status "Evaluation aborted.")))))
131          (t
132           (error "Unexpected message: ~S" message)))))
133
134(defun dispatch-loop ()
135  (loop
136    (let (message)
137      (handler-case
138          (setf message (swank-protocol:decode-message *stream*))
139        (stream-error () (disconnect) (status "Slime not connected")))
140;;       (sys::%format t "message = ~S~%" message)
141      (when (eq (first message) :return)
142        (dispatch-return message)))
143    (with-mutex (*continuations-lock*)
144      (unless *continuations*
145        (return))))
146;;   (sys::%format t "leaving dispatch-loop~%")
147  )
148
149(defun slime-eval (form)
150  (if (slime-local-p)
151      (eval form)
152      (handler-case
153          (progn
154            (swank-protocol:encode-message `(:eval ,form) *stream*)
155            (let* ((message (swank-protocol:decode-message *stream*))
156                   (kind (first message)))
157              (case kind
158                (:return
159                 (let ((result (second message)))
160                   (when (eq (first result) :ok)
161                     (second result)))))))
162        (stream-error () (disconnect)))))
163
164(defun slime-eval-async (form continuation)
165  (cond ((slime-local-p)
166         nil) ;; FIXME
167        ((not (slime-connected-p))
168         (status "Slime not connected"))
169        (t
170         (handler-case
171             (with-mutex (*continuations-lock*)
172               (let ((continuations *continuations*)
173                     (id (incf *continuation-counter*)))
174                 (push (cons id continuation) *continuations*)
175                 (swank-protocol:encode-message `(:eval-async ,form ,id) *stream*)
176                 (unless continuations
177                   (make-thread #'(lambda () (dispatch-loop))))))
178           (stream-error () (disconnect))))))
179
180(defvar *prefix* nil)
181(defvar *completions* ())
182(defvar *completion-index* 0)
183
184(defun completions (prefix)
185  (slime-eval `(swank:completion-set ,prefix ,(package-name *package*))))
186
187(defun delimiter-p (c)
188  (member c '(#\space #\( #\) #\')))
189
190(defun completion-prefix ()
191  (let* ((string (line-chars (current-line)))
192         (end (mark-charpos (current-point))))
193    (do ((start (1- end) (1- start)))
194        ((< start 0) (when (> end 0) (subseq string 0 end)))
195      (let ((c (schar string start)))
196        (when (delimiter-p c)
197          (incf start)
198          (return (when (> end start) (subseq string start end))))))))
199
200(defun slime-complete-symbol ()
201  (when (slime-busy-p)
202    (return-from slime-complete-symbol))
203  (unless (slime-connected-p)
204    (status "Slime not connected")
205    (return-from slime-complete-symbol))
206  (cond ((eq *last-command* 'complete)
207         (unless (> (length *completions*) 1)
208           (return-from slime-complete-symbol))
209         (undo)
210         (incf *completion-index*)
211         (when (> *completion-index* (1- (length *completions*)))
212           (setf *completion-index* 0)))
213        (t
214         (setf *prefix* (completion-prefix)
215               *completions* nil
216               *completion-index* 0)
217         (when *prefix*
218           (setf *completions* (completions *prefix*)))))
219  (when *completions*
220    (let* ((completion (string-downcase (nth *completion-index* *completions*)))
221           (point (current-point))
222           (flags (line-flags (mark-line point))))
223      (with-single-undo
224        (goto-char (make-mark (mark-line point)
225                              (- (mark-charpos point) (length *prefix*))))
226        (set-mark point)
227        (delete-region)
228        (insert completion)
229        (setf (line-flags (mark-line point)) flags)))
230    (setf *current-command* 'complete))
231  (values))
232
233(defun symbol-name-at-mark (mark)
234  (let* ((string (line-chars (mark-line mark)))
235         (length (length string))
236         (charpos (mark-charpos mark))
237         (begin 0)
238         end)
239    (when (= charpos length)
240      (decf charpos))
241    (loop
242      (aver (< charpos length))
243      (cond ((not (delimiter-p (schar string charpos)))
244             (return))
245            ((zerop charpos)
246             (return-from symbol-name-at-mark nil))
247            (t
248             (decf charpos))))
249    (dotimes (i charpos)
250      (let ((c (schar string i)))
251        (when (delimiter-p c)
252          (setf begin (1+ i)))))
253    (do ((i charpos (1+ i)))
254        ((= i length) (setf end i))
255      (when (delimiter-p (schar string i))
256        (setf end i)
257        (return)))
258    (subseq string begin end)))
259
260(defun enclosing-operator-names (mark)
261  "Return the list of operator names of the forms containing point."
262  (let ((result ()))
263    (loop
264      (let* ((mark1 (copy-mark mark))
265             (mark2 (progn (backward-up-list mark) (copy-mark mark))))
266        (when (mark= mark1 mark2) ; Can't go back any further.
267          (return)))
268      (unless (looking-at mark "(")
269        (return))
270      (forward-char mark)
271      (let ((name (symbol-name-at-mark mark)))
272        (cond ((string-equal name "defun")
273               (return))
274              ((null name)
275               (return))
276              (t
277               (push name result))))
278      (backward-up-list mark))
279    (nreverse result)))
280
281(defun slime-space ()
282  (unwind-protect
283      (when (and (slime-connected-p)
284                 (not (slime-busy-p)))
285        (let ((names (enclosing-operator-names (current-point))))
286          (when names
287            (slime-eval-async
288             `(swank:arglist-for-echo-area (quote ,names))
289             #'(lambda (message)
290                (when (stringp message)
291                  (status (string-trim '(#\") message))))))))
292    (insert #\space)))
293
294(defun find-buffer-package ()
295;;   (save-excursion
296;;    (when (let ((case-fold-search t)
297;;                (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>"))
298;;            (or (re-search-backward regexp nil t)
299;;                (re-search-forward regexp nil t)))
300;;      (goto-char (match-end 0))
301;;      (skip-chars-forward " \n\t\f\r#")
302;;      (let ((pkg (ignore-errors (read (current-buffer)))))
303;;        (if pkg (format "%s" pkg))))))
304  (let (mark (current-point))
305     (loop
306        (setf mark (search-backward "(in-package"
307                                      :start mark
308                                      :ignore-case t
309                                      :whole-words-only t))
310        (cond ((null mark)
311               (return))
312              ((eql (mark-charpos mark) 0)
313               (return))
314              (t
315               (move-to-position mark (1- (mark-charpos mark))))))
316    (when mark
317      (let* ((line-chars (line-chars (mark-line mark)))
318             (package-name
319              (ignore-errors
320               (read-from-string (subseq line-chars
321                                         (+ (mark-charpos mark)
322                                            (length "(in-package")))))))
323        (when package-name
324          (string package-name))))))
325
326(defstruct (slime-definition (:type list))
327  spec location)
328
329(defun goto-source-location (name location)
330  (when (eq (car location) :location)
331    (let (file position function-name)
332      (dolist (item (cdr location))
333        (case (car item)
334          (:file
335           (setf file (cadr item)))
336          (:position
337           (setf position (cadr item)))))
338      (when file
339        (let ((buffer (find-file-buffer file)))
340          (when buffer
341            (let* ((short-name
342                    (let ((index (position #\: name :from-end t)))
343                      (if index (subseq name (1+ index)) name))))
344              (switch-to-buffer buffer)
345              (with-single-undo
346                (goto-char (or position 0))
347                (let (pattern pos)
348                  (cond ((string-equal (pathname-type file) "java")
349                         (setf pattern (format nil "// ### ~A" short-name))
350                         (setf pos (search-forward pattern
351                                                   :ignore-case t
352                                                   :whole-words-only t)))
353                        (t
354                         (setf pattern (format nil "^\\s*\\(def\\S*\\s+~A" short-name))
355                         (setf pos (re-search-forward pattern
356                                                      :ignore-case t
357                                                      :whole-words-only t))))
358                  (when pos
359                    (goto-char pos))
360                  (setf pos (search-forward short-name :ignore-case t))
361                  (when pos
362                    (goto-char pos))))
363              (update-display))))))))
364
365;; FIXME
366(defun find-tag-at-point ()
367  (j::%execute-command "findTagAtDot"))
368
369;; FIXME
370(defun push-position ()
371  (j::%execute-command "pushPosition"))
372
373(defun slime-edit-definition (&optional function-name package-name)
374  (unless (slime-connected-p)
375    (find-tag-at-point)
376    (return-from slime-edit-definition))
377  (let ((pathname (buffer-pathname (current-buffer))))
378    (when (and pathname
379               (string-equal (pathname-type pathname) "el"))
380      (find-tag-at-point)
381      (return-from slime-edit-definition)))
382  (unless function-name
383    (setf function-name (string-upcase (symbol-name-at-mark (current-point)))))
384  (when function-name
385    (setf function-name (string function-name))
386    (let ((pos (position #\: function-name)))
387      (when pos
388        (setf package-name (subseq function-name 0 pos))
389        (setf function-name (subseq function-name (1+ (position #\: function-name :from-end t))))))
390    (unless package-name
391      (setf package-name (find-buffer-package)))
392    (let ((definitions
393            (slime-eval `(swank:find-definitions-for-function-name ,function-name
394                                                                   ,package-name))))
395      (sys::%format t "definitions = ~S~%" definitions)
396      (cond (definitions
397              (push-position)
398              (goto-source-location function-name
399                                    (slime-definition-location (car definitions))))
400            (t
401             (find-tag-at-point))))))
402
403(defun slime-eval-region ()
404  (let ((mark (current-mark)))
405    (when mark
406      (let* ((string (buffer-substring (current-point) mark))
407             (package (find-buffer-package)))
408        (slime-eval-async
409         `(swank:eval-region ,string ,package) 'display-eval-result)))))
410
411(defun last-expression ()
412  (let (start end)
413    (backward-sexp)
414    (setf start (current-point))
415    (undo)
416    (setf end (current-point))
417    (buffer-substring start end)))
418
419(defun display-eval-result (value)
420  (status value))
421
422(defun slime-eval-last-expression ()
423  (let* ((string (last-expression))
424         (package (find-buffer-package)))
425    (slime-eval-async
426     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
427
428(defun slime-eval-defun ()
429  (let* ((string (defun-at-point))
430         (package (find-buffer-package)))
431    (slime-eval-async
432     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
433
434(defun slime-compile-defun ()
435  (let* ((string (defun-at-point))
436         (package (find-buffer-package)))
437    (slime-eval-async
438     `(swank:swank-compile-string ,string ,package) 'display-eval-result)))
439
440(defun slime-load-file ()
441  (let ((pathname (buffer-pathname)))
442    (slime-eval-async
443     `(swank:swank-load-file ,pathname) 'display-eval-result)))
444
445(defun slime-compile-file ()
446  (let ((pathname (buffer-pathname)))
447    (slime-eval-async
448     `(swank:swank-compile-file ,pathname nil) 'display-eval-result)))
449
450(defun slime-compile-and-load-file ()
451  (let ((pathname (buffer-pathname)))
452    (slime-eval-async
453     `(swank:swank-compile-file ,pathname t) 'display-eval-result)))
454
455(eval-when (:compile-toplevel :load-toplevel :execute)
456  (unless (find-package '#:emacs)
457    (defpackage #:emacs
458      (:use #:cl #:ext #:j))))
459
460(defun initialize-keymaps ()
461  (let ((emulation (variable-value 'emulation)))
462    (cond ((null emulation)
463           (map-key-for-mode "Tab" "(slime:slime-complete-symbol)" "Lisp Shell")
464           (map-key-for-mode "Ctrl Alt I" "(slime:slime-complete-symbol)" "Lisp")
465           (map-key-for-mode "Space" "(slime:slime-space)" "Lisp Shell")
466           (map-key-for-mode "Space" "(slime:slime-space)" "Lisp")
467           (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp Shell")
468           (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp")
469           (map-key-for-mode "Ctrl Alt R" "(slime:slime-eval-region)" "Lisp")
470           (map-key-for-mode "Ctrl Alt E" "(slime:slime-eval-last-expression)" "Lisp")
471           (map-key-for-mode "Ctrl Alt K" "(slime:slime-compile-and-load-file)" "Lisp")
472           (map-key-for-mode "Ctrl Alt X" "(slime:slime-eval-defun)" "Lisp")
473           (map-key-for-mode "Ctrl Alt C" "(slime:slime-compile-defun)" "Lisp"))
474          ((and (stringp emulation)
475                (string-equal emulation "emacs")
476                (fboundp 'emacs::define-keys-for-slime))
477           (emacs::define-keys-for-slime)))))
478
479(initialize-keymaps)
480
481(pushnew :slime *features*)
Note: See TracBrowser for help on using the repository browser.