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

Last change on this file since 8440 was 8440, checked in by piso, 17 years ago

Work in progress.

File size: 15.5 KB
Line 
1;;; slime.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: slime.lisp,v 1.27 2005-02-01 03:38:22 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-point ()
234  (let ((string (line-chars (current-line)))
235        (point-charpos (mark-charpos (current-point)))
236        (begin 0)
237        end)
238    (when (= point-charpos (length string))
239      (decf point-charpos))
240    (loop
241      (aver (< point-charpos (length string)))
242      (cond ((not (delimiter-p (schar string point-charpos)))
243             (return))
244            ((zerop point-charpos)
245             (return-from symbol-name-at-point nil))
246            (t
247             (decf point-charpos))))
248    (dotimes (i point-charpos)
249      (let ((c (schar string i)))
250        (when (delimiter-p c)
251          (setf begin (1+ i)))))
252    (do ((i point-charpos (1+ i)))
253        ((= i (length string)) (setf end i))
254      (when (delimiter-p (schar string i))
255        (setf end i)
256        (return)))
257    (subseq string begin end)))
258
259(defun enclosing-operator-names ()
260  "Return the list of operator names of the forms containing point."
261  (let ((result ()))
262    (save-excursion
263      (loop
264        (let ((point1 (current-point))
265              (point2 (progn (backward-up-list) (current-point))))
266          (when (and (equal (mark-line point1) (mark-line point2))
267                     (eql (mark-charpos point1) (mark-charpos point2)))
268            (return)))
269        (unless (looking-at "(")
270          (return))
271        (when (looking-at "(")
272          (forward-char)
273          (let ((name (symbol-name-at-point)))
274            (cond ((string-equal name "defun")
275                   (return))
276                  ((null name)
277                   (return))
278                  (t
279                   (push name result))))
280          (backward-up-list))))
281    (nreverse result)))
282
283(defun slime-space ()
284  (unwind-protect
285   (when (and (slime-connected-p)
286              (not (slime-busy-p)))
287     (let ((names (enclosing-operator-names)))
288       (when names
289         (slime-eval-async
290          `(swank:arglist-for-echo-area (quote ,names))
291          #'(lambda (message)
292             (when (stringp message)
293               (status (string-trim '(#\") message))))))))
294   (insert #\space)))
295
296(defun find-buffer-package ()
297;;   (save-excursion
298;;    (when (let ((case-fold-search t)
299;;                (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>"))
300;;            (or (re-search-backward regexp nil t)
301;;                (re-search-forward regexp nil t)))
302;;      (goto-char (match-end 0))
303;;      (skip-chars-forward " \n\t\f\r#")
304;;      (let ((pkg (ignore-errors (read (current-buffer)))))
305;;        (if pkg (format "%s" pkg))))))
306  (let (mark (current-point))
307     (loop
308        (setf mark (search-backward "(in-package"
309                                      :start mark
310                                      :ignore-case t
311                                      :whole-words-only t))
312        (cond ((null mark)
313               (return))
314              ((eql (mark-charpos mark) 0)
315               (return))
316              (t
317               (move-to-position mark (1- (mark-charpos mark))))))
318    (when mark
319      (let* ((line-chars (line-chars (mark-line mark)))
320             (package-name
321              (ignore-errors
322               (read-from-string (subseq line-chars
323                                         (+ (mark-charpos mark)
324                                            (length "(in-package")))))))
325        (when package-name
326          (string package-name))))))
327
328(defstruct (slime-definition (:type list))
329  spec location)
330
331(defun goto-source-location (name location)
332  (when (eq (car location) :location)
333    (let (file position function-name)
334      (dolist (item (cdr location))
335        (case (car item)
336          (:file
337           (setf file (cadr item)))
338          (:position
339           (setf position (cadr item)))))
340      (when file
341        (let ((buffer (find-file-buffer file)))
342          (when buffer
343            (let* ((short-name
344                    (let ((index (position #\: name :from-end t)))
345                      (if index (subseq name (1+ index)) name))))
346              (switch-to-buffer buffer)
347              (with-single-undo
348                (goto-char (or position 0))
349                (let* ((pattern (format nil "^\\s*\\(def\\S*\\s+~A" short-name))
350                       (pos (re-search-forward pattern
351                                               :ignore-case t
352                                               :whole-words-only t)))
353                  (when pos
354                    (goto-char pos))
355                  (setf pos (search-forward short-name :ignore-case t))
356                  (when pos
357                    (goto-char pos))))
358              (update-display))))))))
359
360;; FIXME
361(defun find-tag-at-point ()
362  (j::%execute-command "findTagAtDot"))
363
364;; FIXME
365(defun push-position ()
366  (j::%execute-command "pushPosition"))
367
368(defun slime-edit-definition (&optional function-name package-name)
369  (unless (slime-connected-p)
370    (find-tag-at-point)
371    (return-from slime-edit-definition))
372  (let ((pathname (buffer-pathname (current-buffer))))
373    (when (and pathname
374               (string-equal (pathname-type pathname) "el"))
375      (find-tag-at-point)
376      (return-from slime-edit-definition)))
377  (unless function-name
378    (setf function-name (string-upcase (symbol-name-at-point))))
379  (when function-name
380    (setf function-name (string function-name))
381    (let ((pos (position #\: function-name)))
382      (when pos
383        (setf package-name (subseq function-name 0 pos))
384        (setf function-name (subseq function-name (1+ (position #\: function-name :from-end t))))))
385    (let ((definitions
386            (slime-eval `(swank:find-definitions-for-function-name ,function-name
387                                                                   ,package-name))))
388      (cond (definitions
389              (push-position)
390              (goto-source-location function-name
391                                    (slime-definition-location (car definitions))))
392            (t
393             (find-tag-at-point))))))
394
395(defun slime-eval-region ()
396  (let ((mark (current-mark)))
397    (when mark
398      (let* ((string (buffer-substring (current-point) mark))
399             (package (find-buffer-package)))
400        (slime-eval-async
401         `(swank:eval-region ,string ,package) 'display-eval-result)))))
402
403(defun last-expression ()
404  (let (start end)
405    (backward-sexp)
406    (setf start (current-point))
407    (undo)
408    (setf end (current-point))
409    (buffer-substring start end)))
410
411(defun display-eval-result (value)
412  (status value))
413
414(defun slime-eval-last-expression ()
415  (let* ((string (last-expression))
416         (package (find-buffer-package)))
417    (slime-eval-async
418     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
419
420(defun slime-eval-defun ()
421  (let* ((string (defun-at-point))
422         (package (find-buffer-package)))
423    (slime-eval-async
424     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
425
426(defun slime-compile-defun ()
427  (let* ((string (defun-at-point))
428         (package (find-buffer-package)))
429    (slime-eval-async
430     `(swank:swank-compile-string ,string ,package) 'display-eval-result)))
431
432(defun slime-load-file ()
433  (let ((pathname (buffer-pathname)))
434    (slime-eval-async
435     `(swank:swank-load-file ,pathname) 'display-eval-result)))
436
437(defun slime-compile-file ()
438  (let ((pathname (buffer-pathname)))
439    (slime-eval-async
440     `(swank:swank-compile-file ,pathname nil) 'display-eval-result)))
441
442(defun slime-compile-and-load-file ()
443  (let ((pathname (buffer-pathname)))
444    (slime-eval-async
445     `(swank:swank-compile-file ,pathname t) 'display-eval-result)))
446
447(map-key-for-mode "Tab" "(slime:slime-complete-symbol)" "Lisp Shell")
448(map-key-for-mode "Ctrl Alt I" "(slime:slime-complete-symbol)" "Lisp")
449(map-key-for-mode "Space" "(slime:slime-space)" "Lisp Shell")
450;; (map-key-for-mode "Space" "(slime:slime-space)" "Lisp")
451(map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp Shell")
452(map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp")
453(map-key-for-mode "Ctrl Alt R" "(slime:slime-eval-region)" "Lisp")
454(map-key-for-mode "Ctrl Alt E" "(slime:slime-eval-last-expression)" "Lisp")
455(map-key-for-mode "Ctrl Alt K" "(slime:slime-compile-and-load-file)" "Lisp")
456(map-key-for-mode "Ctrl Alt X" "(slime:slime-eval-defun)" "Lisp")
457(map-key-for-mode "Ctrl Alt C" "(slime:slime-compile-defun)" "Lisp")
458
459(pushnew :slime *features*)
Note: See TracBrowser for help on using the repository browser.