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

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

Work in progress.

File size: 15.4 KB
Line 
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*)
Note: See TracBrowser for help on using the repository browser.