/[slime]/slime/slime.el
ViewVC logotype

Contents of /slime/slime.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1430 - (show annotations)
Tue Apr 23 16:37:14 2013 UTC (11 months, 3 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.1429: +1 -1 lines
* slime.el (slime-draw-connection-list): Make sure not to call
goto-char on NIL.
1 ;;; slime.el --- Superior Lisp Interaction Mode for Emacs
2 ;;
3 ;;;; License
4 ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
5 ;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
6 ;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler
7 ;;
8 ;; For a detailed list of contributors, see the manual.
9 ;;
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2 of
13 ;; the License, or (at your option) any later version.
14 ;;
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19 ;;
20 ;; You should have received a copy of the GNU General Public
21 ;; License along with this program; if not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
23 ;; MA 02111-1307, USA.
24
25
26 ;;;; Commentary
27 ;;
28 ;; This file contains extensions for programming in Common Lisp. The
29 ;; main features are:
30 ;;
31 ;; A socket-based communication/RPC interface between Emacs and
32 ;; Lisp, enabling introspection and remote development.
33 ;;
34 ;; The `slime-mode' minor-mode complementing `lisp-mode'. This new
35 ;; mode includes many commands for interacting with the Common Lisp
36 ;; process.
37 ;;
38 ;; A Common Lisp debugger written in Emacs Lisp. The debugger pops up
39 ;; an Emacs buffer similar to the Emacs/Elisp debugger.
40 ;;
41 ;; A Common Lisp inspector to interactively look at run-time data.
42 ;;
43 ;; Trapping compiler messages and creating annotations in the source
44 ;; file on the appropriate forms.
45 ;;
46 ;; SLIME should work with Emacs 22 and 23. If it works on XEmacs,
47 ;; consider yourself lucky.
48 ;;
49 ;; In order to run SLIME, a supporting Lisp server called Swank is
50 ;; required. Swank is distributed with slime.el and will automatically
51 ;; be started in a normal installation.
52
53
54 ;;;; Dependencies and setup
55
56 (eval-and-compile
57 (when (<= emacs-major-version 20)
58 (error "Slime requires an Emacs version of 21, or above")))
59
60 (eval-and-compile
61 (require 'cl)
62 (when (locate-library "hyperspec")
63 (require 'hyperspec)))
64 (require 'thingatpt)
65 (require 'comint)
66 (require 'timer)
67 (require 'pp)
68 (require 'font-lock)
69 (when (featurep 'xemacs)
70 (require 'overlay)
71 (unless (find-coding-system 'utf-8-unix)
72 (require 'un-define)))
73 (require 'easymenu)
74 (eval-when (compile)
75 (require 'arc-mode)
76 (require 'apropos)
77 (require 'outline)
78 (require 'etags)
79 (require 'compile)
80 (require 'gud))
81
82 (eval-and-compile
83 (defvar slime-path
84 (let ((path (or (locate-library "slime") load-file-name)))
85 (and path (file-name-directory path)))
86 "Directory containing the Slime package.
87 This is used to load the supporting Common Lisp library, Swank.
88 The default value is automatically computed from the location of the
89 Emacs Lisp package."))
90
91 (defvar slime-lisp-modes '(lisp-mode))
92 (defvar slime-setup-contribs nil)
93
94 (defun slime-setup (&optional contribs)
95 "Setup Emacs so that lisp-mode buffers always use SLIME.
96 CONTRIBS is a list of contrib packages to load."
97 (when (member 'lisp-mode slime-lisp-modes)
98 (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
99 (setq slime-setup-contribs contribs)
100 (slime-setup-contribs))
101
102 (defun slime-setup-contribs ()
103 "Load and initialize contribs."
104 (when slime-setup-contribs
105 (add-to-list 'load-path (expand-file-name "contrib" slime-path))
106 (dolist (c slime-setup-contribs)
107 (require c)
108 (let ((init (intern (format "%s-init" c))))
109 (when (fboundp init)
110 (funcall init))))))
111
112 (defun slime-lisp-mode-hook ()
113 (slime-mode 1)
114 (set (make-local-variable 'lisp-indent-function)
115 'common-lisp-indent-function))
116
117 (eval-and-compile
118 (defun slime-changelog-date (&optional interactivep)
119 "Return the datestring of the latest entry in the ChangeLog file.
120 Return nil if the ChangeLog file cannot be found."
121 (interactive "p")
122 (let ((changelog (expand-file-name "ChangeLog" slime-path))
123 (date nil))
124 (when (file-exists-p changelog)
125 (with-temp-buffer
126 (insert-file-contents-literally changelog nil 0 100)
127 (goto-char (point-min))
128 (setq date (symbol-name (read (current-buffer))))))
129 (when interactivep
130 (message "Slime ChangeLog dates %s." date))
131 date)))
132
133 (defvar slime-protocol-version nil)
134 (setq slime-protocol-version
135 (eval-when-compile (slime-changelog-date)))
136
137
138 ;;;; Customize groups
139 ;;
140 ;;;;; slime
141
142 (defgroup slime nil
143 "Interaction with the Superior Lisp Environment."
144 :prefix "slime-"
145 :group 'applications)
146
147 ;;;;; slime-ui
148
149 (defgroup slime-ui nil
150 "Interaction with the Superior Lisp Environment."
151 :prefix "slime-"
152 :group 'slime)
153
154 (defcustom slime-truncate-lines t
155 "Set `truncate-lines' in popup buffers.
156 This applies to buffers that present lines as rows of data, such as
157 debugger backtraces and apropos listings."
158 :type 'boolean
159 :group 'slime-ui)
160
161 (defcustom slime-kill-without-query-p nil
162 "If non-nil, kill SLIME processes without query when quitting Emacs.
163 This applies to the *inferior-lisp* buffer and the network connections."
164 :type 'boolean
165 :group 'slime-ui)
166
167 ;;;;; slime-lisp
168
169 (defgroup slime-lisp nil
170 "Lisp server configuration."
171 :prefix "slime-"
172 :group 'slime)
173
174 (defcustom slime-backend "swank-loader.lisp"
175 "The name of the Lisp file that loads the Swank server.
176 This name is interpreted relative to the directory containing
177 slime.el, but could also be set to an absolute filename."
178 :type 'string
179 :group 'slime-lisp)
180
181 (defcustom slime-connected-hook nil
182 "List of functions to call when SLIME connects to Lisp."
183 :type 'hook
184 :group 'slime-lisp)
185
186 (defcustom slime-enable-evaluate-in-emacs nil
187 "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs.
188 The default is nil, as this feature can be a security risk."
189 :type '(boolean)
190 :group 'slime-lisp)
191
192 (defcustom slime-lisp-host "127.0.0.1"
193 "The default hostname (or IP address) to connect to."
194 :type 'string
195 :group 'slime-lisp)
196
197 (defcustom slime-port 4005
198 "Port to use as the default for `slime-connect'."
199 :type 'integer
200 :group 'slime-lisp)
201
202 (defvar slime-connect-host-history (list slime-lisp-host))
203 (defvar slime-connect-port-history (list (prin1-to-string slime-port)))
204
205 (defvar slime-net-valid-coding-systems
206 '((iso-latin-1-unix nil "iso-latin-1-unix")
207 (iso-8859-1-unix nil "iso-latin-1-unix")
208 (binary nil "iso-latin-1-unix")
209 (utf-8-unix t "utf-8-unix")
210 (emacs-mule-unix t "emacs-mule-unix")
211 (euc-jp-unix t "euc-jp-unix"))
212 "A list of valid coding systems.
213 Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
214
215 (defun slime-find-coding-system (name)
216 "Return the coding system for the symbol NAME.
217 The result is either an element in `slime-net-valid-coding-systems'
218 of nil."
219 (let ((probe (assq name slime-net-valid-coding-systems)))
220 (when (and probe (if (fboundp 'check-coding-system)
221 (ignore-errors (check-coding-system (car probe)))
222 (eq (car probe) 'binary)))
223 probe)))
224
225 (defcustom slime-net-coding-system
226 (car (find-if 'slime-find-coding-system
227 slime-net-valid-coding-systems :key 'car))
228 "Coding system used for network connections.
229 See also `slime-net-valid-coding-systems'."
230 :type (cons 'choice
231 (mapcar (lambda (x)
232 (list 'const (car x)))
233 slime-net-valid-coding-systems))
234 :group 'slime-lisp)
235
236 ;;;;; slime-mode
237
238 (defgroup slime-mode nil
239 "Settings for slime-mode Lisp source buffers."
240 :prefix "slime-"
241 :group 'slime)
242
243 (defcustom slime-find-definitions-function 'slime-find-definitions-rpc
244 "Function to find definitions for a name.
245 The function is called with the definition name, a string, as its
246 argument."
247 :type 'function
248 :group 'slime-mode
249 :options '(slime-find-definitions-rpc
250 slime-etags-definitions
251 (lambda (name)
252 (append (slime-find-definitions-rpc name)
253 (slime-etags-definitions name)))
254 (lambda (name)
255 (or (slime-find-definitions-rpc name)
256 (and tags-table-list
257 (slime-etags-definitions name))))))
258
259 (defcustom slime-complete-symbol-function 'slime-simple-complete-symbol
260 "*Function to perform symbol completion."
261 :group 'slime-mode
262 :type '(choice (const :tag "Simple" slime-simple-complete-symbol)
263 (const :tag "Compound" slime-complete-symbol*)
264 (const :tag "Fuzzy" slime-fuzzy-complete-symbol)))
265
266 ;;;;; slime-mode-faces
267
268 (defgroup slime-mode-faces nil
269 "Faces in slime-mode source code buffers."
270 :prefix "slime-"
271 :group 'slime-mode)
272
273 (defun slime-underline-color (color)
274 "Return a legal value for the :underline face attribute based on COLOR."
275 ;; In XEmacs the :underline attribute can only be a boolean.
276 ;; In GNU it can be the name of a colour.
277 (if (featurep 'xemacs)
278 (if color t nil)
279 color))
280
281 (defface slime-error-face
282 `((((class color) (background light))
283 (:underline ,(slime-underline-color "red")))
284 (((class color) (background dark))
285 (:underline ,(slime-underline-color "red")))
286 (t (:underline t)))
287 "Face for errors from the compiler."
288 :group 'slime-mode-faces)
289
290 (defface slime-warning-face
291 `((((class color) (background light))
292 (:underline ,(slime-underline-color "orange")))
293 (((class color) (background dark))
294 (:underline ,(slime-underline-color "coral")))
295 (t (:underline t)))
296 "Face for warnings from the compiler."
297 :group 'slime-mode-faces)
298
299 (defface slime-style-warning-face
300 `((((class color) (background light))
301 (:underline ,(slime-underline-color "brown")))
302 (((class color) (background dark))
303 (:underline ,(slime-underline-color "gold")))
304 (t (:underline t)))
305 "Face for style-warnings from the compiler."
306 :group 'slime-mode-faces)
307
308 (defface slime-note-face
309 `((((class color) (background light))
310 (:underline ,(slime-underline-color "brown4")))
311 (((class color) (background dark))
312 (:underline ,(slime-underline-color "light goldenrod")))
313 (t (:underline t)))
314 "Face for notes from the compiler."
315 :group 'slime-mode-faces)
316
317 (defun slime-face-inheritance-possible-p ()
318 "Return true if the :inherit face attribute is supported."
319 (assq :inherit custom-face-attributes))
320
321 (defface slime-highlight-face
322 (if (slime-face-inheritance-possible-p)
323 '((t (:inherit highlight :underline nil)))
324 '((((class color) (background light))
325 (:background "darkseagreen2"))
326 (((class color) (background dark))
327 (:background "darkolivegreen"))
328 (t (:inverse-video t))))
329 "Face for compiler notes while selected."
330 :group 'slime-mode-faces)
331
332 ;;;;; sldb
333
334 (defgroup slime-debugger nil
335 "Backtrace options and fontification."
336 :prefix "sldb-"
337 :group 'slime)
338
339 (defmacro define-sldb-faces (&rest faces)
340 "Define the set of SLDB faces.
341 Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES).
342 NAME is a symbol; the face will be called sldb-NAME-face.
343 DESCRIPTION is a one-liner for the customization buffer.
344 PROPERTIES specifies any default face properties."
345 `(progn ,@(loop for face in faces
346 collect `(define-sldb-face ,@face))))
347
348 (defmacro define-sldb-face (name description &optional default)
349 (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))))
350 `(defface ,facename
351 (list (list t ,default))
352 ,(format "Face for %s." description)
353 :group 'slime-debugger)))
354
355 (define-sldb-faces
356 (topline "the top line describing the error")
357 (condition "the condition class")
358 (section "the labels of major sections in the debugger buffer")
359 (frame-label "backtrace frame numbers")
360 (restart-type "restart names."
361 (if (slime-face-inheritance-possible-p)
362 '(:inherit font-lock-keyword-face)))
363 (restart "restart descriptions")
364 (restart-number "restart numbers (correspond to keystrokes to invoke)"
365 '(:bold t))
366 (frame-line "function names and arguments in the backtrace")
367 (restartable-frame-line
368 "frames which are surely restartable"
369 '(:foreground "lime green"))
370 (non-restartable-frame-line
371 "frames which are surely not restartable")
372 (detailed-frame-line
373 "function names and arguments in a detailed (expanded) frame")
374 (local-name "local variable names")
375 (local-value "local variable values")
376 (catch-tag "catch tags"))
377
378
379 ;;;; Minor modes
380
381 ;;;;; slime-mode
382
383 (defvar slime-mode-indirect-map (make-sparse-keymap)
384 "Empty keymap which has `slime-mode-map' as it's parent.
385 This is a hack so that we can reinitilize the real slime-mode-map
386 more easily. See `slime-init-keymaps'.")
387
388 (defvar slime-modeline-string)
389 (defvar slime-buffer-connection)
390 (defvar slime-dispatching-connection)
391 (defvar slime-current-thread)
392
393 (define-minor-mode slime-mode
394 "\\<slime-mode-map>\
395 SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).
396
397 Commands to compile the current buffer's source file and visually
398 highlight any resulting compiler notes and warnings:
399 \\[slime-compile-and-load-file] - Compile and load the current buffer's file.
400 \\[slime-compile-file] - Compile (but not load) the current buffer's file.
401 \\[slime-compile-defun] - Compile the top-level form at point.
402
403 Commands for visiting compiler notes:
404 \\[slime-next-note] - Goto the next form with a compiler note.
405 \\[slime-previous-note] - Goto the previous form with a compiler note.
406 \\[slime-remove-notes] - Remove compiler-note annotations in buffer.
407
408 Finding definitions:
409 \\[slime-edit-definition] \
410 - Edit the definition of the function called at point.
411 \\[slime-pop-find-definition-stack] \
412 - Pop the definition stack to go back from a definition.
413
414 Documentation commands:
415 \\[slime-describe-symbol] - Describe symbol.
416 \\[slime-apropos] - Apropos search.
417 \\[slime-disassemble-symbol] - Disassemble a function.
418
419 Evaluation commands:
420 \\[slime-eval-defun] - Evaluate top-level from containing point.
421 \\[slime-eval-last-expression] - Evaluate sexp before point.
422 \\[slime-pprint-eval-last-expression] \
423 - Evaluate sexp before point, pretty-print result.
424
425 Full set of commands:
426 \\{slime-mode-map}"
427 nil
428 nil
429 slime-mode-indirect-map
430 (slime-setup-command-hooks)
431 (setq slime-modeline-string (slime-modeline-string)))
432
433
434
435 ;;;;;; Modeline
436
437 ;; For XEmacs only
438 (make-variable-buffer-local
439 (defvar slime-modeline-string nil
440 "The string that should be displayed in the modeline."))
441
442 (add-to-list 'minor-mode-alist
443 `(slime-mode ,(if (featurep 'xemacs)
444 'slime-modeline-string
445 '(:eval (slime-modeline-string)))))
446
447 (defun slime-modeline-string ()
448 "Return the string to display in the modeline.
449 \"Slime\" only appears if we aren't connected. If connected,
450 include package-name, connection-name, and possibly some state
451 information."
452 (let ((conn (slime-current-connection)))
453 ;; Bail out early in case there's no connection, so we won't
454 ;; implicitly invoke `slime-connection' which may query the user.
455 (if (not conn)
456 (and slime-mode " Slime")
457 (let ((local (eq conn slime-buffer-connection))
458 (pkg (slime-current-package)))
459 (concat " "
460 (if local "{" "[")
461 (if pkg (slime-pretty-package-name pkg) "?")
462 " "
463 ;; ignore errors for closed connections
464 (ignore-errors (slime-connection-name conn))
465 (slime-modeline-state-string conn)
466 (if local "}" "]"))))))
467
468 (defun slime-pretty-package-name (name)
469 "Return a pretty version of a package name NAME."
470 (cond ((string-match "^#?:\\(.*\\)$" name)
471 (match-string 1 name))
472 ((string-match "^\"\\(.*\\)\"$" name)
473 (match-string 1 name))
474 (t name)))
475
476 (defun slime-modeline-state-string (conn)
477 "Return a string possibly describing CONN's state."
478 (cond ((not (eq (process-status conn) 'open))
479 (format " %s" (process-status conn)))
480 ((let ((pending (length (slime-rex-continuations conn)))
481 (sldbs (length (sldb-buffers conn))))
482 (cond ((and (zerop sldbs) (zerop pending)) nil)
483 ((zerop sldbs) (format " %s" pending))
484 (t (format " %s/%s" pending sldbs)))))))
485
486 (defmacro slime-recompute-modelines ()
487 ;; Avoid a needless runtime funcall on GNU Emacs:
488 (and (featurep 'xemacs) `(slime-xemacs-recompute-modelines)))
489
490 (when (featurep 'xemacs)
491 (defun slime-xemacs-recompute-modelines ()
492 (let (redraw-modeline)
493 (walk-windows
494 (lambda (object)
495 (setq object (window-buffer object))
496 (when (or (symbol-value-in-buffer 'slime-mode object)
497 (symbol-value-in-buffer 'slime-popup-buffer-mode object))
498 ;; Only do the unwind-protect of #'with-current-buffer if we're
499 ;; actually interested in this buffer
500 (with-current-buffer object
501 (setq redraw-modeline
502 (or (not (equal slime-modeline-string
503 (setq slime-modeline-string
504 (slime-modeline-string))))
505 redraw-modeline)))))
506 'never 'visible)
507 (and redraw-modeline (redraw-modeline t)))))
508
509 (and (featurep 'xemacs)
510 (pushnew 'slime-xemacs-recompute-modelines pre-idle-hook))
511
512
513 ;;;;; Key bindings
514
515 (defvar slime-parent-map nil
516 "Parent keymap for shared between all Slime related modes.")
517
518 (defvar slime-parent-bindings
519 '(("\M-." slime-edit-definition)
520 ("\M-," slime-pop-find-definition-stack)
521 ("\M-_" slime-edit-uses) ; for German layout
522 ("\M-?" slime-edit-uses) ; for USian layout
523 ("\C-x4." slime-edit-definition-other-window)
524 ("\C-x5." slime-edit-definition-other-frame)
525 ("\C-x\C-e" slime-eval-last-expression)
526 ("\C-\M-x" slime-eval-defun)
527 ;; Include PREFIX keys...
528 ("\C-c" slime-prefix-map)))
529
530 (defvar slime-prefix-map nil
531 "Keymap for commands prefixed with `slime-prefix-key'.")
532
533 (defvar slime-prefix-bindings
534 '(("\C-r" slime-eval-region)
535 (":" slime-interactive-eval)
536 ("\C-e" slime-interactive-eval)
537 ("E" slime-edit-value)
538 ("\C-l" slime-load-file)
539 ("\C-b" slime-interrupt)
540 ("\M-d" slime-disassemble-symbol)
541 ("\C-t" slime-toggle-trace-fdefinition)
542 ("I" slime-inspect)
543 ("\C-xt" slime-list-threads)
544 ("\C-xn" slime-cycle-connections)
545 ("\C-xc" slime-list-connections)
546 ("<" slime-list-callers)
547 (">" slime-list-callees)
548 ;; Include DOC keys...
549 ("\C-d" slime-doc-map)
550 ;; Include XREF WHO-FOO keys...
551 ("\C-w" slime-who-map)
552 ))
553
554 (defvar slime-editing-map nil
555 "These keys are useful for buffers where the user can insert and
556 edit s-exprs, e.g. for source buffers and the REPL.")
557
558 (defvar slime-editing-keys
559 `(;; Arglist display & completion
560 ("\M-\t" slime-complete-symbol)
561 (" " slime-space)
562 ;; Evaluating
563 ;;("\C-x\M-e" slime-eval-last-expression-display-output :inferior t)
564 ("\C-c\C-p" slime-pprint-eval-last-expression)
565 ;; Macroexpand
566 ("\C-c\C-m" slime-expand-1)
567 ("\C-c\M-m" slime-macroexpand-all)
568 ;; Misc
569 ("\C-c\C-u" slime-undefine-function)
570 (,(kbd "C-M-.") slime-next-location)
571 (,(kbd "C-M-,") slime-previous-location)
572 ;; Obsolete, redundant bindings
573 ("\C-c\C-i" slime-complete-symbol)
574 ;;("\M-*" pop-tag-mark) ; almost to clever
575 ))
576
577 (defvar slime-mode-map nil
578 "Keymap for slime-mode.")
579
580 (defvar slime-keys
581 '( ;; Compiler notes
582 ("\M-p" slime-previous-note)
583 ("\M-n" slime-next-note)
584 ("\C-c\M-c" slime-remove-notes)
585 ("\C-c\C-k" slime-compile-and-load-file)
586 ("\C-c\M-k" slime-compile-file)
587 ("\C-c\C-c" slime-compile-defun)))
588
589 (defun slime-nop ()
590 "The null command. Used to shadow currently-unused keybindings."
591 (interactive)
592 (call-interactively 'undefined))
593
594 (defvar slime-doc-map nil
595 "Keymap for documentation commands. Bound to a prefix key.")
596
597 (defvar slime-doc-bindings
598 '((?a slime-apropos)
599 (?z slime-apropos-all)
600 (?p slime-apropos-package)
601 (?d slime-describe-symbol)
602 (?f slime-describe-function)
603 (?h slime-documentation-lookup)
604 (?~ common-lisp-hyperspec-format)
605 (?# common-lisp-hyperspec-lookup-reader-macro)))
606
607 (defvar slime-who-map nil
608 "Keymap for who-xref commands. Bound to a prefix key.")
609
610 (defvar slime-who-bindings
611 '((?c slime-who-calls)
612 (?w slime-calls-who)
613 (?r slime-who-references)
614 (?b slime-who-binds)
615 (?s slime-who-sets)
616 (?m slime-who-macroexpands)
617 (?a slime-who-specializes)))
618
619 (defun slime-init-keymaps ()
620 "(Re)initialize the keymaps for `slime-mode'."
621 (interactive)
622 (slime-init-keymap 'slime-doc-map t t slime-doc-bindings)
623 (slime-init-keymap 'slime-who-map t t slime-who-bindings)
624 (slime-init-keymap 'slime-prefix-map t nil slime-prefix-bindings)
625 (slime-init-keymap 'slime-parent-map nil nil slime-parent-bindings)
626 (slime-init-keymap 'slime-editing-map nil nil slime-editing-keys)
627 (set-keymap-parent slime-editing-map slime-parent-map)
628 (slime-init-keymap 'slime-mode-map nil nil slime-keys)
629 (set-keymap-parent slime-mode-map slime-editing-map)
630 (set-keymap-parent slime-mode-indirect-map slime-mode-map))
631
632 (defun slime-init-keymap (keymap-name prefixp bothp bindings)
633 (set keymap-name (make-sparse-keymap))
634 (when prefixp (define-prefix-command keymap-name))
635 (slime-bind-keys (eval keymap-name) bothp bindings))
636
637 (defun slime-bind-keys (keymap bothp bindings)
638 "Add BINDINGS to KEYMAP.
639 If BOTHP is true also add bindings with control modifier."
640 (loop for (key command) in bindings do
641 (cond (bothp
642 (define-key keymap `[,key] command)
643 (unless (equal key ?h) ; But don't bind C-h
644 (define-key keymap `[(control ,key)] command)))
645 (t (define-key keymap key command)))))
646
647 (slime-init-keymaps)
648
649 (define-minor-mode slime-editing-mode
650 "Minor mode which makes slime-editing-map available.
651 \\{slime-editing-map}"
652 nil
653 nil
654 slime-editing-map)
655
656
657 ;;;; Setup initial `slime-mode' hooks
658
659 (make-variable-buffer-local
660 (defvar slime-pre-command-actions nil
661 "List of functions to execute before the next Emacs command.
662 This list of flushed between commands."))
663
664 (defun slime-pre-command-hook ()
665 "Execute all functions in `slime-pre-command-actions', then NIL it."
666 (dolist (undo-fn slime-pre-command-actions)
667 (funcall undo-fn))
668 (setq slime-pre-command-actions nil))
669
670 (defun slime-post-command-hook ()
671 (when (null pre-command-hook) ; sometimes this is lost
672 (add-hook 'pre-command-hook 'slime-pre-command-hook)))
673
674 (defun slime-setup-command-hooks ()
675 "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'."
676 (slime-add-local-hook 'pre-command-hook 'slime-pre-command-hook)
677 (slime-add-local-hook 'post-command-hook 'slime-post-command-hook))
678
679
680 ;;;; Framework'ey bits
681 ;;;
682 ;;; This section contains some standard SLIME idioms: basic macros,
683 ;;; ways of showing messages to the user, etc. All the code in this
684 ;;; file should use these functions when applicable.
685 ;;;
686 ;;;;; Syntactic sugar
687
688 (defmacro* when-let ((var value) &rest body)
689 "Evaluate VALUE, if the result is non-nil bind it to VAR and eval BODY.
690
691 \(fn (VAR VALUE) &rest BODY)"
692 `(let ((,var ,value))
693 (when ,var ,@body)))
694
695 (put 'when-let 'lisp-indent-function 1)
696
697 (defmacro destructure-case (value &rest patterns)
698 "Dispatch VALUE to one of PATTERNS.
699 A cross between `case' and `destructuring-bind'.
700 The pattern syntax is:
701 ((HEAD . ARGS) . BODY)
702 The list of patterns is searched for a HEAD `eq' to the car of
703 VALUE. If one is found, the BODY is executed with ARGS bound to the
704 corresponding values in the CDR of VALUE."
705 (let ((operator (gensym "op-"))
706 (operands (gensym "rand-"))
707 (tmp (gensym "tmp-")))
708 `(let* ((,tmp ,value)
709 (,operator (car ,tmp))
710 (,operands (cdr ,tmp)))
711 (case ,operator
712 ,@(mapcar (lambda (clause)
713 (if (eq (car clause) t)
714 `(t ,@(cdr clause))
715 (destructuring-bind ((op &rest rands) &rest body) clause
716 `(,op (destructuring-bind ,rands ,operands
717 . ,(or body
718 '((ignore)) ; suppress some warnings
719 ))))))
720 patterns)
721 ,@(if (eq (caar (last patterns)) t)
722 '()
723 `((t (error "Elisp destructure-case failed: %S" ,tmp))))))))
724
725 (put 'destructure-case 'lisp-indent-function 1)
726
727 (defmacro slime-define-keys (keymap &rest key-command)
728 "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)."
729 `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c))
730 key-command)))
731
732 (put 'slime-define-keys 'lisp-indent-function 1)
733
734 (defmacro* with-struct ((conc-name &rest slots) struct &body body)
735 "Like with-slots but works only for structs.
736 \(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)"
737 (let ((struct-var (gensym "struct"))
738 (reader (lambda (slot)
739 (intern (concat (symbol-name conc-name)
740 (symbol-name slot))))))
741 `(let ((,struct-var ,struct))
742 (symbol-macrolet
743 ,(mapcar (lambda (slot)
744 (etypecase slot
745 (symbol `(,slot (,(funcall reader slot) ,struct-var)))
746 (cons `(,(first slot) (,(funcall reader (second slot))
747 ,struct-var)))))
748 slots)
749 . ,body))))
750
751 (put 'with-struct 'lisp-indent-function 2)
752
753 ;;;;; Very-commonly-used functions
754
755 (defvar slime-message-function 'message)
756
757 ;; Interface
758 (defun slime-buffer-name (type &optional hidden)
759 (assert (keywordp type))
760 (concat (if hidden " " "")
761 (format "*slime-%s*" (substring (symbol-name type) 1))))
762
763 ;; Interface
764 (defun slime-message (format &rest args)
765 "Like `message' but with special support for multi-line messages.
766 Single-line messages use the echo area."
767 (apply slime-message-function format args))
768
769 (defun slime-display-warning (message &rest args)
770 (display-warning '(slime warning) (apply #'format message args)))
771
772 (defvar slime-background-message-function 'slime-display-oneliner)
773
774 ;; Interface
775 (defun slime-background-message (format-string &rest format-args)
776 "Display a message in passing.
777 This is like `slime-message', but less distracting because it
778 will never pop up a buffer or display multi-line messages.
779 It should be used for \"background\" messages such as argument lists."
780 (apply slime-background-message-function format-string format-args))
781
782 (defun slime-display-oneliner (format-string &rest format-args)
783 (let* ((msg (apply #'format format-string format-args)))
784 (unless (minibuffer-window-active-p (minibuffer-window))
785 (message "%s" (slime-oneliner msg)))))
786
787 (defun slime-oneliner (string)
788 "Return STRING truncated to fit in a single echo-area line."
789 (substring string 0 (min (length string)
790 (or (position ?\n string) most-positive-fixnum)
791 (1- (window-width (minibuffer-window))))))
792
793 ;; Interface
794 (defun slime-set-truncate-lines ()
795 "Apply `slime-truncate-lines' to the current buffer."
796 (when slime-truncate-lines
797 (set (make-local-variable 'truncate-lines) t)))
798
799 ;; Interface
800 (defun slime-read-package-name (prompt &optional initial-value)
801 "Read a package name from the minibuffer, prompting with PROMPT."
802 (let ((completion-ignore-case t))
803 (completing-read prompt (slime-bogus-completion-alist
804 (slime-eval
805 `(swank:list-all-package-names t)))
806 nil t initial-value)))
807
808 ;; Interface
809 (defun slime-read-symbol-name (prompt &optional query)
810 "Either read a symbol name or choose the one at point.
811 The user is prompted if a prefix argument is in effect, if there is no
812 symbol at point, or if QUERY is non-nil."
813 (cond ((or current-prefix-arg query (not (slime-symbol-at-point)))
814 (slime-read-from-minibuffer prompt (slime-symbol-at-point)))
815 (t (slime-symbol-at-point))))
816
817 ;; Interface
818 (defmacro slime-propertize-region (props &rest body)
819 "Execute BODY and add PROPS to all the text it inserts.
820 More precisely, PROPS are added to the region between the point's
821 positions before and after executing BODY."
822 (let ((start (gensym)))
823 `(let ((,start (point)))
824 (prog1 (progn ,@body)
825 (add-text-properties ,start (point) ,props)))))
826
827 (put 'slime-propertize-region 'lisp-indent-function 1)
828
829 (defun slime-add-face (face string)
830 (add-text-properties 0 (length string) (list 'face face) string)
831 string)
832
833 (put 'slime-add-face 'lisp-indent-function 1)
834
835 ;; Interface
836 (defsubst slime-insert-propertized (props &rest args)
837 "Insert all ARGS and then add text-PROPS to the inserted text."
838 (slime-propertize-region props (apply #'insert args)))
839
840 (defmacro slime-with-rigid-indentation (level &rest body)
841 "Execute BODY and then rigidly indent its text insertions.
842 Assumes all insertions are made at point."
843 (let ((start (gensym)) (l (gensym)))
844 `(let ((,start (point)) (,l ,(or level '(current-column))))
845 (prog1 (progn ,@body)
846 (slime-indent-rigidly ,start (point) ,l)))))
847
848 (put 'slime-with-rigid-indentation 'lisp-indent-function 1)
849
850 (defun slime-indent-rigidly (start end column)
851 ;; Similar to `indent-rigidly' but doesn't inherit text props.
852 (let ((indent (make-string column ?\ )))
853 (save-excursion
854 (goto-char end)
855 (beginning-of-line)
856 (while (and (<= start (point))
857 (progn
858 (insert-before-markers indent)
859 (zerop (forward-line -1))))))))
860
861 (defun slime-insert-indented (&rest strings)
862 "Insert all arguments rigidly indented."
863 (slime-with-rigid-indentation nil
864 (apply #'insert strings)))
865
866 (defun slime-property-bounds (prop)
867 "Return two the positions of the previous and next changes to PROP.
868 PROP is the name of a text property."
869 (assert (get-text-property (point) prop))
870 (let ((end (next-single-char-property-change (point) prop)))
871 (list (previous-single-char-property-change end prop) end)))
872
873 (defun slime-curry (fun &rest args)
874 "Partially apply FUN to ARGS. The result is a new function.
875 This idiom is preferred over `lexical-let'."
876 `(lambda (&rest more) (apply ',fun (append ',args more))))
877
878 (defun slime-rcurry (fun &rest args)
879 "Like `slime-curry' but ARGS on the right are applied."
880 `(lambda (&rest more) (apply ',fun (append more ',args))))
881
882
883 ;;;;; Temporary popup buffers
884
885 (defvar slime-popup-restore-data nil
886 "Data needed when closing popup windows.
887 This is used as buffer local variable.
888 The format is (POPUP-WINDOW SELECTED-WINDOW OLD-BUFFER).
889 POPUP-WINDOW is the window used to display the temp buffer.
890 That window may have been reused or freshly created.
891 SELECTED-WINDOW is the window that was selected before displaying
892 the popup buffer.
893 OLD-BUFFER is the buffer that was previously displayed in POPUP-WINDOW.
894 OLD-BUFFER is nil if POPUP-WINDOW was newly created.
895
896 See `view-return-to-alist' for a similar idea.")
897
898 ;; keep compiler quiet
899 (defvar slime-buffer-package)
900 (defvar slime-buffer-connection)
901
902 ;; Interface
903 (defmacro* slime-with-popup-buffer ((name &key package connection select mode)
904 &body body)
905 "Similar to `with-output-to-temp-buffer'.
906 Bind standard-output and initialize some buffer-local variables.
907 Restore window configuration when closed.
908
909 NAME is the name of the buffer to be created.
910 PACKAGE is the value `slime-buffer-package'.
911 CONNECTION is the value for `slime-buffer-connection',
912 if nil, no explicit connection is associated with
913 the buffer. If t, the current connection is taken.
914 MODE is the name of a major mode which will be enabled.
915 "
916 `(let* ((vars% (list ,(if (eq package t) '(slime-current-package) package)
917 ,(if (eq connection t) '(slime-connection) connection)))
918 (standard-output (slime-make-popup-buffer ,name vars% ,mode)))
919 (with-current-buffer standard-output
920 (prog1 (progn ,@body)
921 (assert (eq (current-buffer) standard-output))
922 (setq buffer-read-only t)
923 (set-window-point (slime-display-popup-buffer ,(or select nil))
924 (point))))))
925
926 (put 'slime-with-popup-buffer 'lisp-indent-function 1)
927
928 (defun slime-make-popup-buffer (name buffer-vars mode)
929 "Return a temporary buffer called NAME.
930 The buffer also uses the minor-mode `slime-popup-buffer-mode'."
931 (with-current-buffer (get-buffer-create name)
932 (kill-all-local-variables)
933 (when mode
934 (funcall mode))
935 (setq buffer-read-only nil)
936 (erase-buffer)
937 (set-syntax-table lisp-mode-syntax-table)
938 (slime-init-popup-buffer buffer-vars)
939 (current-buffer)))
940
941 (defun slime-init-popup-buffer (buffer-vars)
942 (slime-popup-buffer-mode 1)
943 (setf slime-buffer-package (car buffer-vars)
944 slime-buffer-connection (cadr buffer-vars)))
945
946 (defun slime-display-popup-buffer (select)
947 "Display the current buffer.
948 Save the selected-window in a buffer-local variable, so that we
949 can restore it later."
950 (let ((selected-window (selected-window))
951 (old-windows))
952 (walk-windows (lambda (w) (push (cons w (window-buffer w)) old-windows))
953 nil t)
954 (let ((new-window (display-buffer (current-buffer))))
955 (unless slime-popup-restore-data
956 (set (make-local-variable 'slime-popup-restore-data)
957 (list new-window
958 selected-window
959 (cdr (find new-window old-windows :key #'car)))))
960 (when select
961 (select-window new-window))
962 new-window)))
963
964 (defun slime-close-popup-window ()
965 (when slime-popup-restore-data
966 (destructuring-bind (popup-window selected-window old-buffer)
967 slime-popup-restore-data
968 (kill-local-variable 'slime-popup-restore-data)
969 (bury-buffer)
970 (when (eq popup-window (selected-window))
971 (cond ((and (not old-buffer) (not (one-window-p)))
972 (delete-window popup-window))
973 ((and old-buffer (buffer-live-p old-buffer))
974 (set-window-buffer popup-window old-buffer))))
975 (when (window-live-p selected-window)
976 (select-window selected-window)))))
977
978 (defmacro slime-save-local-variables (vars &rest body)
979 (let ((vals (make-symbol "vals")))
980 `(let ((,vals (mapcar (lambda (var)
981 (if (slime-local-variable-p var)
982 (cons var (eval var))))
983 ',vars)))
984 (prog1 (progn . ,body)
985 (mapc (lambda (var+val)
986 (when (consp var+val)
987 (set (make-local-variable (car var+val)) (cdr var+val))))
988 ,vals)))))
989
990 (put 'slime-save-local-variables 'lisp-indent-function 1)
991
992 (define-minor-mode slime-popup-buffer-mode
993 "Mode for displaying read only stuff"
994 nil
995 nil
996 '(("q" . slime-popup-buffer-quit-function)
997 ;;("\C-c\C-z" . slime-switch-to-output-buffer)
998 ("\M-." . slime-edit-definition)))
999
1000 (add-to-list 'minor-mode-alist
1001 `(slime-popup-buffer-mode
1002 ,(if (featurep 'xemacs)
1003 'slime-modeline-string
1004 '(:eval (unless slime-mode
1005 (slime-modeline-string))))))
1006
1007 (set-keymap-parent slime-popup-buffer-mode-map slime-parent-map)
1008
1009 (make-variable-buffer-local
1010 (defvar slime-popup-buffer-quit-function 'slime-popup-buffer-quit
1011 "The function that is used to quit a temporary popup buffer."))
1012
1013 (defun slime-popup-buffer-quit-function ()
1014 "Wrapper to invoke the value of `slime-popup-buffer-quit-function'."
1015 (interactive)
1016 (funcall slime-popup-buffer-quit-function))
1017
1018 ;; Interface
1019 (defun slime-popup-buffer-quit (&optional kill-buffer-p)
1020 "Get rid of the current (temp) buffer without asking.
1021 Restore the window configuration unless it was changed since we
1022 last activated the buffer."
1023 (interactive)
1024 (let ((buffer (current-buffer)))
1025 (slime-close-popup-window)
1026 (when kill-buffer-p
1027 (kill-buffer buffer))))
1028
1029 ;;;;; Filename translation
1030 ;;;
1031 ;;; Filenames passed between Emacs and Lisp should be translated using
1032 ;;; these functions. This way users who run Emacs and Lisp on separate
1033 ;;; machines have a chance to integrate file operations somehow.
1034
1035 (defvar slime-to-lisp-filename-function #'convert-standard-filename
1036 "Function to translate Emacs filenames to CL namestrings.")
1037 (defvar slime-from-lisp-filename-function #'identity
1038 "Function to translate CL namestrings to Emacs filenames.")
1039
1040 (defun slime-to-lisp-filename (filename)
1041 "Translate the string FILENAME to a Lisp filename."
1042 (funcall slime-to-lisp-filename-function filename))
1043
1044 (defun slime-from-lisp-filename (filename)
1045 "Translate the Lisp filename FILENAME to an Emacs filename."
1046 (funcall slime-from-lisp-filename-function filename))
1047
1048
1049 ;;;; Starting SLIME
1050 ;;;
1051 ;;; This section covers starting an inferior-lisp, compiling and
1052 ;;; starting the server, initiating a network connection.
1053
1054 ;;;;; Entry points
1055
1056 ;; We no longer load inf-lisp, but we use this variable for backward
1057 ;; compatibility.
1058 (defvar inferior-lisp-program "lisp"
1059 "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.")
1060
1061 (defvar slime-lisp-implementations nil
1062 "*A list of known Lisp implementations.
1063 The list should have the form:
1064 ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...)
1065
1066 NAME is a symbol for the implementation.
1067 PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process.
1068 For KEYWORD-ARGS see `slime-start'.
1069
1070 Here's an example:
1071 ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command)
1072 (acl (\"acl7\") :coding-system emacs-mule))")
1073
1074 (defvar slime-default-lisp nil
1075 "*The name of the default Lisp implementation.
1076 See `slime-lisp-implementations'")
1077
1078 ;; dummy definitions for the compiler
1079 (defvar slime-net-processes)
1080 (defvar slime-default-connection)
1081
1082 (defun slime (&optional command coding-system)
1083 "Start an inferior^_superior Lisp and connect to its Swank server."
1084 (interactive)
1085 (let ((inferior-lisp-program (or command inferior-lisp-program))
1086 (slime-net-coding-system (or coding-system slime-net-coding-system)))
1087 (slime-start* (cond ((and command (symbolp command))
1088 (slime-lisp-options command))
1089 (t (slime-read-interactive-args))))))
1090
1091 (defvar slime-inferior-lisp-program-history '()
1092 "History list of command strings. Used by `slime'.")
1093
1094 (defun slime-read-interactive-args ()
1095 "Return the list of args which should be passed to `slime-start'.
1096
1097 The rules for selecting the arguments are rather complicated:
1098
1099 - In the most common case, i.e. if there's no prefix-arg in
1100 effect and if `slime-lisp-implementations' is nil, use
1101 `inferior-lisp-program' as fallback.
1102
1103 - If the table `slime-lisp-implementations' is non-nil use the
1104 implementation with name `slime-default-lisp' or if that's nil
1105 the first entry in the table.
1106
1107 - If the prefix-arg is `-', prompt for one of the registered
1108 lisps.
1109
1110 - If the prefix-arg is positive, read the command to start the
1111 process."
1112 (let ((table slime-lisp-implementations))
1113 (cond ((not current-prefix-arg) (slime-lisp-options))
1114 ((eq current-prefix-arg '-)
1115 (let ((key (completing-read
1116 "Lisp name: " (mapcar (lambda (x)
1117 (list (symbol-name (car x))))
1118 table)
1119 nil t)))
1120 (slime-lookup-lisp-implementation table (intern key))))
1121 (t
1122 (destructuring-bind (program &rest program-args)
1123 (split-string (read-shell-command
1124 "Run lisp: " inferior-lisp-program
1125 'slime-inferior-lisp-program-history))
1126 (let ((coding-system
1127 (if (eq 16 (prefix-numeric-value current-prefix-arg))
1128 (read-coding-system "set slime-coding-system: "
1129 slime-net-coding-system)
1130 slime-net-coding-system)))
1131 (list :program program :program-args program-args
1132 :coding-system coding-system)))))))
1133
1134 (defun slime-lisp-options (&optional name)
1135 (let ((table slime-lisp-implementations))
1136 (assert (or (not name) table))
1137 (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations
1138 (or name slime-default-lisp
1139 (car (car table)))))
1140 (t (destructuring-bind (program &rest args)
1141 (split-string inferior-lisp-program)
1142 (list :program program :program-args args))))))
1143
1144 (defun slime-lookup-lisp-implementation (table name)
1145 (let ((arguments (rest (assoc name table))))
1146 (unless arguments
1147 (error "Could not find lisp implementation with the name '%S'" name))
1148 (when (and (= (length arguments) 1)
1149 (functionp (first arguments)))
1150 (setf arguments (funcall (first arguments))))
1151 (destructuring-bind ((prog &rest args) &rest keys) arguments
1152 (list* :name name :program prog :program-args args keys))))
1153
1154 (defun* slime-start (&key (program inferior-lisp-program) program-args
1155 directory
1156 (coding-system slime-net-coding-system)
1157 (init 'slime-init-command)
1158 name
1159 (buffer "*inferior-lisp*")
1160 init-function
1161 env)
1162 "Start a Lisp process and connect to it.
1163 This function is intended for programmatic use if `slime' is not
1164 flexible enough.
1165
1166 PROGRAM and PROGRAM-ARGS are the filename and argument strings
1167 for the subprocess.
1168 INIT is a function that should return a string to load and start
1169 Swank. The function will be called with the PORT-FILENAME and ENCODING as
1170 arguments. INIT defaults to `slime-init-command'.
1171 CODING-SYSTEM a symbol for the coding system. The default is
1172 slime-net-coding-system
1173 ENV environment variables for the subprocess (see `process-environment').
1174 INIT-FUNCTION function to call right after the connection is established.
1175 BUFFER the name of the buffer to use for the subprocess.
1176 NAME a symbol to describe the Lisp implementation
1177 DIRECTORY change to this directory before starting the process.
1178 "
1179 (let ((args (list :program program :program-args program-args :buffer buffer
1180 :coding-system coding-system :init init :name name
1181 :init-function init-function :env env)))
1182 (slime-check-coding-system coding-system)
1183 (when (slime-bytecode-stale-p)
1184 (slime-urge-bytecode-recompile))
1185 (let ((proc (slime-maybe-start-lisp program program-args env
1186 directory buffer)))
1187 (slime-inferior-connect proc args)
1188 (pop-to-buffer (process-buffer proc)))))
1189
1190 (defun slime-start* (options)
1191 (apply #'slime-start options))
1192
1193 (defun slime-connect (host port &optional _coding-system interactive-p)
1194 "Connect to a running Swank server. Return the connection."
1195 (interactive (list (read-from-minibuffer
1196 "Host: " (first slime-connect-host-history)
1197 nil nil '(slime-connect-host-history . 1))
1198 (string-to-number
1199 (read-from-minibuffer
1200 "Port: " (first slime-connect-port-history)
1201 nil nil '(slime-connect-port-history . 1)))
1202 nil t))
1203 (when (and interactive-p
1204 slime-net-processes
1205 (y-or-n-p "Close old connections first? "))
1206 (slime-disconnect-all))
1207 (message "Connecting to Swank on port %S.." port)
1208 (let* ((process (slime-net-connect host port))
1209 (slime-dispatching-connection process))
1210 (slime-setup-connection process)))
1211
1212 ;; FIXME: seems redundant
1213 (defun slime-start-and-init (options fun)
1214 (let* ((rest (plist-get options :init-function))
1215 (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun)))
1216 (t fun))))
1217 (slime-start* (plist-put (copy-list options) :init-function init))))
1218
1219 ;;;;; Start inferior lisp
1220 ;;;
1221 ;;; Here is the protocol for starting SLIME:
1222 ;;;
1223 ;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale.
1224 ;;; 1. Emacs starts an inferior Lisp process.
1225 ;;; 2. Emacs tells Lisp (via stdio) to load and start Swank.
1226 ;;; 3. Lisp recompiles the Swank if needed.
1227 ;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file.
1228 ;;; 5. Emacs reads the temp file to get the port and then connects.
1229 ;;; 6. Emacs prints a message of warm encouragement for the hacking ahead.
1230 ;;;
1231 ;;; Between steps 2-5 Emacs polls for the creation of the temp file so
1232 ;;; that it can make the connection. This polling may continue for a
1233 ;;; fair while if Swank needs recompilation.
1234
1235 (defvar slime-connect-retry-timer nil
1236 "Timer object while waiting for an inferior-lisp to start.")
1237
1238 ;;; Recompiling bytecode:
1239
1240 (defun slime-bytecode-stale-p ()
1241 "Return true if slime.elc is older than slime.el."
1242 (when-let (libfile (locate-library "slime"))
1243 (let* ((basename (file-name-sans-extension libfile))
1244 (sourcefile (concat basename ".el"))
1245 (bytefile (concat basename ".elc")))
1246 (and (file-exists-p bytefile)
1247 (file-newer-than-file-p sourcefile bytefile)))))
1248
1249 (defun slime-recompile-bytecode ()
1250 "Recompile and reload slime.
1251 Warning: don't use this in XEmacs, it seems to crash it!"
1252 (interactive)
1253 (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime"))
1254 ".el")))
1255 (byte-compile-file sourcefile t)))
1256
1257 (defun slime-urge-bytecode-recompile ()
1258 "Urge the user to recompile slime.elc.
1259 Return true if we have been given permission to continue."
1260 (cond ((featurep 'xemacs)
1261 ;; My XEmacs crashes and burns if I recompile/reload an elisp
1262 ;; file from itself. So they have to do it themself.
1263 (or (y-or-n-p "slime.elc is older than source. Continue? ")
1264 (signal 'quit nil)))
1265 ((y-or-n-p "slime.elc is older than source. Recompile first? ")
1266 (slime-recompile-bytecode))
1267 (t)))
1268
1269 (defun slime-abort-connection ()
1270 "Abort connection the current connection attempt."
1271 (interactive)
1272 (cond (slime-connect-retry-timer
1273 (slime-cancel-connect-retry-timer)
1274 (message "Cancelled connection attempt."))
1275 (t (error "Not connecting"))))
1276
1277 ;;; Starting the inferior Lisp and loading Swank:
1278
1279 (defun slime-maybe-start-lisp (program program-args env directory buffer)
1280 "Return a new or existing inferior lisp process."
1281 (cond ((not (comint-check-proc buffer))
1282 (slime-start-lisp program program-args env directory buffer))
1283 ((slime-reinitialize-inferior-lisp-p program program-args env buffer)
1284 (when-let (conn (find (get-buffer-process buffer) slime-net-processes
1285 :key #'slime-inferior-process))
1286 (slime-net-close conn))
1287 (get-buffer-process buffer))
1288 (t (slime-start-lisp program program-args env directory
1289 (generate-new-buffer-name buffer)))))
1290
1291 (defun slime-reinitialize-inferior-lisp-p (program program-args env buffer)
1292 (let ((args (slime-inferior-lisp-args (get-buffer-process buffer))))
1293 (and (equal (plist-get args :program) program)
1294 (equal (plist-get args :program-args) program-args)
1295 (equal (plist-get args :env) env)
1296 (not (y-or-n-p "Create an additional *inferior-lisp*? ")))))
1297
1298 (defvar slime-inferior-process-start-hook nil
1299 "Hook called whenever a new process gets started.")
1300
1301 (defun slime-start-lisp (program program-args env directory buffer)
1302 "Does the same as `inferior-lisp' but less ugly.
1303 Return the created process."
1304 (with-current-buffer (get-buffer-create buffer)
1305 (when directory
1306 (cd (expand-file-name directory)))
1307 (comint-mode)
1308 (let ((process-environment (append env process-environment))
1309 (process-connection-type nil))
1310 (comint-exec (current-buffer) "inferior-lisp" program nil program-args))
1311 (lisp-mode-variables t)
1312 (let ((proc (get-buffer-process (current-buffer))))
1313 (slime-set-query-on-exit-flag proc)
1314 (run-hooks 'slime-inferior-process-start-hook)
1315 proc)))
1316
1317 (defun slime-inferior-connect (process args)
1318 "Start a Swank server in the inferior Lisp and connect."
1319 (slime-delete-swank-port-file 'quiet)
1320 (slime-start-swank-server process args)
1321 (slime-read-port-and-connect process))
1322
1323 (defvar slime-inferior-lisp-args nil
1324 "A buffer local variable in the inferior proccess.
1325 See `slime-start'.")
1326
1327 (defun slime-start-swank-server (process args)
1328 "Start a Swank server on the inferior lisp."
1329 (destructuring-bind (&key coding-system init &allow-other-keys) args
1330 (with-current-buffer (process-buffer process)
1331 (make-local-variable 'slime-inferior-lisp-args)
1332 (setq slime-inferior-lisp-args args)
1333 (let ((str (funcall init (slime-swank-port-file) coding-system)))
1334 (goto-char (process-mark process))
1335 (insert-before-markers str)
1336 (process-send-string process str)))))
1337
1338 (defun slime-inferior-lisp-args (process)
1339 "Return the initial process arguments.
1340 See `slime-start'."
1341 (with-current-buffer (process-buffer process)
1342 slime-inferior-lisp-args))
1343
1344 ;; XXX load-server & start-server used to be separated. maybe that was better.
1345 (defun slime-init-command (port-filename _coding-system)
1346 "Return a string to initialize Lisp."
1347 (let ((loader (if (file-name-absolute-p slime-backend)
1348 slime-backend
1349 (concat slime-path slime-backend))))
1350 ;; Return a single form to avoid problems with buffered input.
1351 (format "%S\n\n"
1352 `(progn
1353 (load ,(expand-file-name loader)
1354 :verbose t)
1355 (funcall (read-from-string "swank-loader:init"))
1356 (funcall (read-from-string "swank:start-server")
1357 ,port-filename)))))
1358
1359 (defun slime-swank-port-file ()
1360 "Filename where the SWANK server writes its TCP port number."
1361 (concat (file-name-as-directory (slime-temp-directory))
1362 (format "slime.%S" (emacs-pid))))
1363
1364 (defun slime-temp-directory ()
1365 (cond ((fboundp 'temp-directory) (temp-directory))
1366 ((boundp 'temporary-file-directory) temporary-file-directory)
1367 (t "/tmp/")))
1368
1369 (defun slime-delete-swank-port-file (&optional quiet)
1370 (condition-case data
1371 (delete-file (slime-swank-port-file))
1372 (error
1373 (ecase quiet
1374 ((nil) (signal (car data) (cdr data)))
1375 (quiet)
1376 (message (message "Unable to delete swank port file %S"
1377 (slime-swank-port-file)))))))
1378
1379 (defun slime-read-port-and-connect (inferior-process)
1380 (slime-attempt-connection inferior-process nil 1))
1381
1382 (defun slime-attempt-connection (process retries attempt)
1383 ;; A small one-state machine to attempt a connection with
1384 ;; timer-based retries.
1385 (slime-cancel-connect-retry-timer)
1386 (let ((file (slime-swank-port-file)))
1387 (unless (active-minibuffer-window)
1388 (message "Polling %S .. %d (Abort with `M-x slime-abort-connection'.)"
1389 file attempt))
1390 (cond ((and (file-exists-p file)
1391 (> (nth 7 (file-attributes file)) 0)) ; file size
1392 (let ((port (slime-read-swank-port))
1393 (args (slime-inferior-lisp-args process)))
1394 (slime-delete-swank-port-file 'message)
1395 (let ((c (slime-connect slime-lisp-host port
1396 (plist-get args :coding-system))))
1397 (slime-set-inferior-process c process))))
1398 ((and retries (zerop retries))
1399 (message "Gave up connecting to Swank after %d attempts." attempt))
1400 ((eq (process-status process) 'exit)
1401 (message "Failed to connect to Swank: inferior process exited."))
1402 (t
1403 (when (and (file-exists-p file)
1404 (zerop (nth 7 (file-attributes file))))
1405 (message "(Zero length port file)")
1406 ;; the file may be in the filesystem but not yet written
1407 (unless retries (setq retries 3)))
1408 (assert (not slime-connect-retry-timer))
1409 (setq slime-connect-retry-timer
1410 (run-with-timer
1411 0.3 nil
1412 #'slime-timer-call #'slime-attempt-connection
1413 process (and retries (1- retries))
1414 (1+ attempt)))))))
1415
1416 (defun slime-timer-call (fun &rest args)
1417 "Call function FUN with ARGS, reporting all errors.
1418
1419 The default condition handler for timer functions (see
1420 `timer-event-handler') ignores errors."
1421 (condition-case data
1422 (apply fun args)
1423 ((debug error)
1424 (debug nil (list "Error in timer" fun args data)))))
1425
1426 (defun slime-cancel-connect-retry-timer ()
1427 (when slime-connect-retry-timer
1428 (cancel-timer slime-connect-retry-timer)
1429 (setq slime-connect-retry-timer nil)))
1430
1431 (defun slime-read-swank-port ()
1432 "Read the Swank server port number from the `slime-swank-port-file'."
1433 (save-excursion
1434 (with-temp-buffer
1435 (insert-file-contents (slime-swank-port-file))
1436 (goto-char (point-min))
1437 (let ((port (read (current-buffer))))
1438 (assert (integerp port))
1439 port))))
1440
1441 (defun slime-toggle-debug-on-swank-error ()
1442 (interactive)
1443 (if (slime-eval `(swank:toggle-debug-on-swank-error))
1444 (message "Debug on SWANK error enabled.")
1445 (message "Debug on SWANK error disabled.")))
1446
1447 ;;; Words of encouragement
1448
1449 (defun slime-user-first-name ()
1450 (let ((name (if (string= (user-full-name) "")
1451 (user-login-name)
1452 (user-full-name))))
1453 (string-match "^[^ ]*" name)
1454 (capitalize (match-string 0 name))))
1455
1456 (defvar slime-words-of-encouragement
1457 `("Let the hacking commence!"
1458 "Hacks and glory await!"
1459 "Hack and be merry!"
1460 "Your hacking starts... NOW!"
1461 "May the source be with you!"
1462 "Take this REPL, brother, and may it serve you well."
1463 "Lemonodor-fame is but a hack away!"
1464 ,(format "%s, this could be the start of a beautiful program."
1465 (slime-user-first-name)))
1466 "Scientifically-proven optimal words of hackerish encouragement.")
1467
1468 (defun slime-random-words-of-encouragement ()
1469 "Return a string of hackerish encouragement."
1470 (eval (nth (random (length slime-words-of-encouragement))
1471 slime-words-of-encouragement)))
1472
1473
1474 ;;;; Networking
1475 ;;;
1476 ;;; This section covers the low-level networking: establishing
1477 ;;; connections and encoding/decoding protocol messages.
1478 ;;;
1479 ;;; Each SLIME protocol message beings with a 6-byte header followed
1480 ;;; by an S-expression as text. The sexp must be readable both by
1481 ;;; Emacs and by Common Lisp, so if it contains any embedded code
1482 ;;; fragments they should be sent as strings:
1483 ;;;
1484 ;;; The set of meaningful protocol messages are not specified
1485 ;;; here. They are defined elsewhere by the event-dispatching
1486 ;;; functions in this file and in swank.lisp.
1487
1488 (defvar slime-net-processes nil
1489 "List of processes (sockets) connected to Lisps.")
1490
1491 (defvar slime-net-process-close-hooks '()
1492 "List of functions called when a slime network connection closes.
1493 The functions are called with the process as their argument.")
1494
1495 (defun slime-secret ()
1496 "Find the magic secret from the user's home directory.
1497 Return nil if the file doesn't exist or is empty; otherwise the
1498 first line of the file."
1499 (condition-case _err
1500 (with-temp-buffer
1501 (insert-file-contents "~/.slime-secret")
1502 (goto-char (point-min))
1503 (buffer-substring (point-min) (line-end-position)))
1504 (file-error nil)))
1505
1506 ;;; Interface
1507 (defun slime-net-connect (host port)
1508 "Establish a connection with a CL."
1509 (let* ((inhibit-quit nil)
1510 (proc (open-network-stream "SLIME Lisp" nil host port))
1511 (buffer (slime-make-net-buffer " *cl-connection*")))
1512 (push proc slime-net-processes)
1513 (set-process-buffer proc buffer)
1514 (set-process-filter proc 'slime-net-filter)
1515 (set-process-sentinel proc 'slime-net-sentinel)
1516 (slime-set-query-on-exit-flag proc)
1517 (when (fboundp 'set-process-coding-system)
1518 (set-process-coding-system proc 'binary 'binary))
1519 (when-let (secret (slime-secret))
1520 (slime-net-send secret proc))
1521 proc))
1522
1523 (defun slime-make-net-buffer (name)
1524 "Make a buffer suitable for a network process."
1525 (let ((buffer (generate-new-buffer name)))
1526 (with-current-buffer buffer
1527 (buffer-disable-undo)
1528 (set (make-local-variable 'kill-buffer-query-functions) nil))
1529 buffer))
1530
1531 (defun slime-set-query-on-exit-flag (process)
1532 "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'."
1533 (when slime-kill-without-query-p
1534 ;; avoid byte-compiler warnings
1535 (let ((fun (if (fboundp 'set-process-query-on-exit-flag)
1536 'set-process-query-on-exit-flag
1537 'process-kill-without-query)))
1538 (funcall fun process nil))))
1539
1540 ;;;;; Coding system madness
1541
1542 (defun slime-check-coding-system (coding-system)
1543 "Signal an error if CODING-SYSTEM isn't a valid coding system."
1544 (interactive)
1545 (let ((props (slime-find-coding-system coding-system)))
1546 (unless props
1547 (error "Invalid slime-net-coding-system: %s. %s"
1548 coding-system (mapcar #'car slime-net-valid-coding-systems)))
1549 (when (and (second props) (boundp 'default-enable-multibyte-characters))
1550 (assert default-enable-multibyte-characters))
1551 t))
1552
1553 (defun slime-coding-system-mulibyte-p (coding-system)
1554 (second (slime-find-coding-system coding-system)))
1555
1556 (defun slime-coding-system-cl-name (coding-system)
1557 (third (slime-find-coding-system coding-system)))
1558
1559 ;;; Interface
1560 (defun slime-net-send (sexp proc)
1561 "Send a SEXP to Lisp over the socket PROC.
1562 This is the lowest level of communication. The sexp will be READ and
1563 EVAL'd by Lisp."
1564 (let* ((payload (encode-coding-string
1565 (concat (slime-prin1-to-string sexp) "\n")
1566 'utf-8-unix))
1567 (string (concat (slime-net-encode-length (length payload))
1568 payload)))
1569 (slime-log-event sexp)
1570 (process-send-string proc string)))
1571
1572 (defun slime-safe-encoding-p (coding-system string)
1573 "Return true iff CODING-SYSTEM can safely encode STRING."
1574 (if (featurep 'xemacs)
1575 ;; FIXME: XEmacs encodes non-encodeable chars as ?~ automatically
1576 t
1577 (or (let ((candidates (find-coding-systems-string string))
1578 (base (coding-system-base coding-system)))
1579 (or (equal candidates '(undecided))
1580 (memq base candidates)))
1581 (and (not (multibyte-string-p string))
1582 (not (slime-coding-system-mulibyte-p coding-system))))))
1583
1584 (defun slime-net-close (process &optional debug)
1585 (setq slime-net-processes (remove process slime-net-processes))
1586 (when (eq process slime-default-connection)
1587 (setq slime-default-connection nil))
1588 (cond (debug
1589 (set-process-sentinel process 'ignore)
1590 (set-process-filter process 'ignore)
1591 (delete-process process))
1592 (t
1593 (run-hook-with-args 'slime-net-process-close-hooks process)
1594 ;; killing the buffer also closes the socket
1595 (kill-buffer (process-buffer process)))))
1596
1597 (defun slime-net-sentinel (process message)
1598 (message "Lisp connection closed unexpectedly: %s" message)
1599 (slime-net-close process))
1600
1601 ;;; Socket input is handled by `slime-net-filter', which decodes any
1602 ;;; complete messages and hands them off to the event dispatcher.
1603
1604 (defun slime-net-filter (process string)
1605 "Accept output from the socket and process all complete messages."
1606 (with-current-buffer (process-buffer process)
1607 (goto-char (point-max))
1608 (insert string))
1609 (slime-process-available-input process))
1610
1611 (defun slime-process-available-input (process)
1612 "Process all complete messages that have arrived from Lisp."
1613 (with-current-buffer (process-buffer process)
1614 (while (slime-net-have-input-p)
1615 (let ((event (slime-net-read-or-lose process))
1616 (ok nil))
1617 (slime-log-event event)
1618 (unwind-protect
1619 (save-current-buffer
1620 (slime-dispatch-event event process)
1621 (setq ok t))
1622 (unless ok
1623 (slime-run-when-idle 'slime-process-available-input process)))))))
1624
1625 (defun slime-net-have-input-p ()
1626 "Return true if a complete message is available."
1627 (goto-char (point-min))
1628 (and (>= (buffer-size) 6)
1629 (>= (- (buffer-size) 6) (slime-net-decode-length))))
1630
1631 (defun slime-run-when-idle (function &rest args)
1632 "Call FUNCTION as soon as Emacs is idle."
1633 (apply #'run-at-time
1634 (if (featurep 'xemacs) itimer-short-interval 0)
1635 nil function args))
1636
1637 (defun slime-handle-net-read-error (error)
1638 (let ((packet (buffer-string)))
1639 (slime-with-popup-buffer ((slime-buffer-name :error))
1640 (princ (format "%s\nin packet:\n%s" (error-message-string error) packet))
1641 (goto-char (point-min)))
1642 (cond ((y-or-n-p "Skip this packet? ")
1643 `(:emacs-skipped-packet ,packet))
1644 (t
1645 (when (y-or-n-p "Enter debugger instead? ")
1646 (debug 'error error))
1647 (signal (car error) (cdr error))))))
1648
1649 (defun slime-net-read-or-lose (process)
1650 (condition-case error
1651 (slime-net-read)
1652 (error
1653 (slime-net-close process t)
1654 (error "net-read error: %S" error))))
1655
1656 (defun slime-net-read ()
1657 "Read a message from the network buffer."
1658 (goto-char (point-min))
1659 (let* ((length (slime-net-decode-length))
1660 (start (+ (point) 6))
1661 (end (+ start length)))
1662 (assert (plusp length))
1663 (prog1 (save-restriction
1664 (narrow-to-region start end)
1665 (condition-case error
1666 (progn
1667 (decode-coding-region start end 'utf-8-unix)
1668 (setq end (point-max))
1669 (read (current-buffer)))
1670 (error
1671 (slime-handle-net-read-error error))))
1672 (delete-region (point-min) end))))
1673
1674 (defun slime-net-decode-length ()
1675 (string-to-number (buffer-substring-no-properties (point) (+ (point) 6))
1676 16))
1677
1678 (defun slime-net-encode-length (n)
1679 (format "%06x" n))
1680
1681 (defun slime-prin1-to-string (sexp)
1682 "Like `prin1-to-string' but don't octal-escape non-ascii characters.
1683 This is more compatible with the CL reader."
1684 (with-temp-buffer
1685 (let (print-escape-nonascii
1686 print-escape-newlines
1687 print-length
1688 print-level)
1689 (prin1 sexp (current-buffer))
1690 (buffer-string))))
1691
1692
1693 ;;;; Connections
1694 ;;;
1695 ;;; "Connections" are the high-level Emacs<->Lisp networking concept.
1696 ;;;
1697 ;;; Emacs has a connection to each Lisp process that it's interacting
1698 ;;; with. Typically there would only be one, but a user can choose to
1699 ;;; connect to many Lisps simultaneously.
1700 ;;;
1701 ;;; A connection consists of a control socket, optionally an extra
1702 ;;; socket dedicated to receiving Lisp output (an optimization), and a
1703 ;;; set of connection-local state variables.
1704 ;;;
1705 ;;; The state variables are stored as buffer-local variables in the
1706 ;;; control socket's process-buffer and are used via accessor
1707 ;;; functions. These variables include things like the *FEATURES* list
1708 ;;; and Unix Pid of the Lisp process.
1709 ;;;
1710 ;;; One connection is "current" at any given time. This is:
1711 ;;; `slime-dispatching-connection' if dynamically bound, or
1712 ;;; `slime-buffer-connection' if this is set buffer-local, or
1713 ;;; `slime-default-connection' otherwise.
1714 ;;;
1715 ;;; When you're invoking commands in your source files you'll be using
1716 ;;; `slime-default-connection'. This connection can be interactively
1717 ;;; reassigned via the connection-list buffer.
1718 ;;;
1719 ;;; When a command creates a new buffer it will set
1720 ;;; `slime-buffer-connection' so that commands in the new buffer will
1721 ;;; use the connection that the buffer originated from. For example,
1722 ;;; the apropos command creates the *Apropos* buffer and any command
1723 ;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the
1724 ;;; apropos search. REPL buffers are similarly tied to their
1725 ;;; respective connections.
1726 ;;;
1727 ;;; When Emacs is dispatching some network message that arrived from a
1728 ;;; connection it will dynamically bind `slime-dispatching-connection'
1729 ;;; so that the event will be processed in the context of that
1730 ;;; connection.
1731 ;;;
1732 ;;; This is mostly transparent. The user should be aware that he can
1733 ;;; set the default connection to pick which Lisp handles commands in
1734 ;;; Lisp-mode source buffers, and slime hackers should be aware that
1735 ;;; they can tie a buffer to a specific connection. The rest takes
1736 ;;; care of itself.
1737
1738 (defvar slime-dispatching-connection nil
1739 "Network process currently executing.
1740 This is dynamically bound while handling messages from Lisp; it
1741 overrides `slime-buffer-connection' and `slime-default-connection'.")
1742
1743 (make-variable-buffer-local
1744 (defvar slime-buffer-connection nil
1745 "Network connection to use in the current buffer.
1746 This overrides `slime-default-connection'."))
1747
1748 (defvar slime-default-connection nil
1749 "Network connection to use by default.
1750 Used for all Lisp communication, except when overridden by
1751 `slime-dispatching-connection' or `slime-buffer-connection'.")
1752
1753 (defun slime-current-connection ()
1754 "Return the connection to use for Lisp interaction.
1755 Return nil if there's no connection."
1756 (or slime-dispatching-connection
1757 slime-buffer-connection
1758 slime-default-connection))
1759
1760 (defun slime-connection ()
1761 "Return the connection to use for Lisp interaction.
1762 Signal an error if there's no connection."
1763 (let ((conn (slime-current-connection)))
1764 (cond ((and (not conn) slime-net-processes)
1765 (or (slime-auto-select-connection)
1766 (error "No default connection selected.")))
1767 ((not conn)
1768 (or (slime-auto-connect)
1769 (error "Not connected.")))
1770 ((not (eq (process-status conn) 'open))
1771 (error "Connection closed."))
1772 (t conn))))
1773
1774 ;; FIXME: should be called auto-start
1775 (defcustom slime-auto-connect 'never
1776 "Controls auto connection when information from lisp process is needed.
1777 This doesn't mean it will connect right after Slime is loaded."
1778 :group 'slime-mode
1779 :type '(choice (const never)
1780 (const always)
1781 (const ask)))
1782
1783 (defun slime-auto-connect ()
1784 (cond ((or (eq slime-auto-connect 'always)
1785 (and (eq slime-auto-connect 'ask)
1786 (y-or-n-p "No connection. Start Slime? ")))
1787 (save-window-excursion
1788 (slime)
1789 (while (not (slime-current-connection))
1790 (sleep-for 1))
1791 (slime-connection)))
1792 (t nil)))
1793
1794 (defcustom slime-auto-select-connection 'ask
1795 "Controls auto selection after the default connection was closed."
1796 :group 'slime-mode
1797 :type '(choice (const never)
1798 (const always)
1799 (const ask)))
1800
1801 (defun slime-auto-select-connection ()
1802 (let* ((c0 (car slime-net-processes))
1803 (c (cond ((eq slime-auto-select-connection 'always) c0)
1804 ((and (eq slime-auto-select-connection 'ask)
1805 (y-or-n-p
1806 (format "No default connection selected. %s %s? "
1807 "Switch to" (slime-connection-name c0))))
1808 c0))))
1809 (when c
1810 (slime-select-connection c)
1811 (message "Switching to connection: %s" (slime-connection-name c))
1812 c)))
1813
1814 (defun slime-select-connection (process)
1815 "Make PROCESS the default connection."
1816 (setq slime-default-connection process))
1817
1818 (defvar slime-cycle-connections-hook nil)
1819
1820 (defun slime-cycle-connections ()
1821 "Change current slime connection, cycling through all connections."
1822 (interactive)
1823 (let* ((tail (or (cdr (member (slime-current-connection)
1824 slime-net-processes))
1825 slime-net-processes))
1826 (p (car tail)))
1827 (slime-select-connection p)
1828 (run-hooks 'slime-cycle-connections-hook)
1829 (message "Lisp: %s %s" (slime-connection-name p) (process-contact p))))
1830
1831 (defmacro* slime-with-connection-buffer ((&optional process) &rest body)
1832 "Execute BODY in the process-buffer of PROCESS.
1833 If PROCESS is not specified, `slime-connection' is used.
1834
1835 \(fn (&optional PROCESS) &body BODY))"
1836 `(with-current-buffer
1837 (process-buffer (or ,process (slime-connection)
1838 (error "No connection")))
1839 ,@body))
1840
1841 (put 'slime-with-connection-buffer 'lisp-indent-function 1)
1842
1843 ;;; Connection-local variables:
1844
1845 (defmacro slime-def-connection-var (varname &rest initial-value-and-doc)
1846 "Define a connection-local variable.
1847 The value of the variable can be read by calling the function of the
1848 same name (it must not be accessed directly). The accessor function is
1849 setf-able.
1850
1851 The actual variable bindings are stored buffer-local in the
1852 process-buffers of connections. The accessor function refers to
1853 the binding for `slime-connection'."
1854 (let ((real-var (intern (format "%s:connlocal" varname))))
1855 `(progn
1856 ;; Variable
1857 (make-variable-buffer-local
1858 (defvar ,real-var ,@initial-value-and-doc))
1859 ;; Accessor
1860 (defun ,varname (&optional process)
1861 (slime-with-connection-buffer (process) ,real-var))
1862 ;; Setf
1863 (defsetf ,varname (&optional process) (store)
1864 `(slime-with-connection-buffer (,process)
1865 (setq (\, (quote (\, real-var))) (\, store))
1866 (\, store)))
1867 '(\, varname))))
1868
1869 (put 'slime-def-connection-var 'lisp-indent-function 2)
1870 (put 'slime-indulge-pretty-colors 'slime-def-connection-var t)
1871
1872 (slime-def-connection-var slime-connection-number nil
1873 "Serial number of a connection.
1874 Bound in the connection's process-buffer.")
1875
1876 (slime-def-connection-var slime-lisp-features '()
1877 "The symbol-names of Lisp's *FEATURES*.
1878 This is automatically synchronized from Lisp.")
1879
1880 (slime-def-connection-var slime-lisp-modules '()
1881 "The strings of Lisp's *MODULES*.")
1882
1883 (slime-def-connection-var slime-pid nil
1884 "The process id of the Lisp process.")
1885
1886 (slime-def-connection-var slime-lisp-implementation-type nil
1887 "The implementation type of the Lisp process.")
1888
1889 (slime-def-connection-var slime-lisp-implementation-version nil
1890 "The implementation type of the Lisp process.")
1891
1892 (slime-def-connection-var slime-lisp-implementation-name nil
1893 "The short name for the Lisp implementation.")
1894
1895 (slime-def-connection-var slime-lisp-implementation-program nil
1896 "The argv[0] of the process running the Lisp implementation.")
1897
1898 (slime-def-connection-var slime-connection-name nil
1899 "The short name for connection.")
1900
1901 (slime-def-connection-var slime-inferior-process nil
1902 "The inferior process for the connection if any.")
1903
1904 (slime-def-connection-var slime-communication-style nil
1905 "The communication style.")
1906
1907 (slime-def-connection-var slime-machine-instance nil
1908 "The name of the (remote) machine running the Lisp process.")
1909
1910 (slime-def-connection-var slime-connection-coding-systems nil
1911 "Coding systems supported by the Lisp process.")
1912
1913 ;;;;; Connection setup
1914
1915 (defvar slime-connection-counter 0
1916 "The number of SLIME connections made. For generating serial numbers.")
1917
1918 ;;; Interface
1919 (defun slime-setup-connection (process)
1920 "Make a connection out of PROCESS."
1921 (let ((slime-dispatching-connection process))
1922 (slime-init-connection-state process)
1923 (slime-select-connection process)
1924 process))
1925
1926 (defun slime-init-connection-state (proc)
1927 "Initialize connection state in the process-buffer of PROC."
1928 ;; To make life simpler for the user: if this is the only open
1929 ;; connection then reset the connection counter.
1930 (when (equal slime-net-processes (list proc))
1931 (setq slime-connection-counter 0))
1932 (slime-with-connection-buffer ()
1933 (setq slime-buffer-connection proc))
1934 (setf (slime-connection-number proc) (incf slime-connection-counter))
1935 ;; We do the rest of our initialization asynchronously. The current
1936 ;; function may be called from a timer, and if we setup the REPL
1937 ;; from a timer then it mysteriously uses the wrong keymap for the
1938 ;; first command.
1939 (let ((slime-current-thread t))
1940 (slime-eval-async '(swank:connection-info)
1941 (slime-curry #'slime-set-connection-info proc))))
1942
1943 (defun slime-set-connection-info (connection info)
1944 "Initialize CONNECTION with INFO received from Lisp."
1945 (let ((slime-dispatching-connection connection)
1946 (slime-current-thread t))
1947 (destructuring-bind (&key pid style lisp-implementation machine
1948 features version modules encoding
1949 &allow-other-keys) info
1950 (slime-check-version version connection)
1951 (setf (slime-pid) pid
1952 (slime-communication-style) style
1953 (slime-lisp-features) features
1954 (slime-lisp-modules) modules)
1955 (destructuring-bind (&key type name version program) lisp-implementation
1956 (setf (slime-lisp-implementation-type) type
1957 (slime-lisp-implementation-version) version
1958 (slime-lisp-implementation-name) name
1959 (slime-lisp-implementation-program) program
1960 (slime-connection-name) (slime-generate-connection-name name)))
1961 (destructuring-bind (&key instance ((:type _)) ((:version _))) machine
1962 (setf (slime-machine-instance) instance))
1963 (destructuring-bind (&key coding-systems) encoding
1964 (setf (slime-connection-coding-systems) coding-systems)))
1965 (let ((args (when-let (p (slime-inferior-process))
1966 (slime-inferior-lisp-args p))))
1967 (when-let (name (plist-get args ':name))
1968 (unless (string= (slime-lisp-implementation-name) name)
1969 (setf (slime-connection-name)
1970 (slime-generate-connection-name (symbol-name name)))))
1971 (slime-load-contribs)
1972 (run-hooks 'slime-connected-hook)
1973 (when-let (fun (plist-get args ':init-function))
1974 (funcall fun)))
1975 (message "Connected. %s" (slime-random-words-of-encouragement))))
1976
1977 (defun slime-check-version (version conn)
1978 (or (equal version slime-protocol-version)
1979 (equal slime-protocol-version 'ignore)
1980 (y-or-n-p
1981 (format "Versions differ: %s (slime) vs. %s (swank). Continue? "
1982 slime-protocol-version version))
1983 (slime-net-close conn)
1984 (top-level)))
1985
1986 (defun slime-generate-connection-name (lisp-name)
1987 (loop for i from 1
1988 for name = lisp-name then (format "%s<%d>" lisp-name i)
1989 while (find name slime-net-processes
1990 :key #'slime-connection-name :test #'equal)
1991 finally (return name)))
1992
1993 (defun slime-connection-close-hook (process)
1994 (when (eq process slime-default-connection)
1995 (when slime-net-processes
1996 (slime-select-connection (car slime-net-processes))
1997 (message "Default connection closed; switched to #%S (%S)"
1998 (slime-connection-number)
1999 (slime-connection-name)))))
2000
2001 (add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook)
2002
2003 ;;;;; Commands on connections
2004
2005 (defun slime-disconnect ()
2006 "Close the current connection."
2007 (interactive)
2008 (slime-net-close (slime-connection)))
2009
2010 (defun slime-disconnect-all ()
2011 "Disconnect all connections."
2012 (interactive)
2013 (mapc #'slime-net-close slime-net-processes))
2014
2015 (defun slime-connection-port (connection)
2016 "Return the remote port number of CONNECTION."
2017 (if (featurep 'xemacs)
2018 (car (process-id connection))
2019 (cadr (process-contact connection))))
2020
2021 (defun slime-process (&optional connection)
2022 "Return the Lisp process for CONNECTION (default `slime-connection').
2023 Return nil if there's no process object for the connection."
2024 (let ((proc (slime-inferior-process connection)))
2025 (if (and proc
2026 (memq (process-status proc) '(run stop)))
2027 proc)))
2028
2029 ;; Non-macro version to keep the file byte-compilable.
2030 (defun slime-set-inferior-process (connection process)
2031 (setf (slime-inferior-process connection) process))
2032
2033 (defun slime-use-sigint-for-interrupt (&optional connection)
2034 (let ((c (or connection (slime-connection))))
2035 (ecase (slime-communication-style c)
2036 ((:fd-handler nil) t)
2037 ((:spawn :sigio) nil))))
2038
2039 (defvar slime-inhibit-pipelining t
2040 "*If true, don't send background requests if Lisp is already busy.")
2041
2042 (defun slime-background-activities-enabled-p ()
2043 (and (let ((con (slime-current-connection)))
2044 (and con
2045 (eq (process-status con) 'open)))
2046 (or (not (slime-busy-p))
2047 (not slime-inhibit-pipelining))))
2048
2049
2050 ;;;; Communication protocol
2051
2052 ;;;;; Emacs Lisp programming interface
2053 ;;;
2054 ;;; The programming interface for writing Emacs commands is based on
2055 ;;; remote procedure calls (RPCs). The basic operation is to ask Lisp
2056 ;;; to apply a named Lisp function to some arguments, then to do
2057 ;;; something with the result.
2058 ;;;
2059 ;;; Requests can be either synchronous (blocking) or asynchronous
2060 ;;; (with the result passed to a callback/continuation function). If
2061 ;;; an error occurs during the request then the debugger is entered
2062 ;;; before the result arrives -- for synchronous evaluations this
2063 ;;; requires a recursive edit.
2064 ;;;
2065 ;;; You should use asynchronous evaluations (`slime-eval-async') for
2066 ;;; most things. Reserve synchronous evaluations (`slime-eval') for
2067 ;;; the cases where blocking Emacs is really appropriate (like
2068 ;;; completion) and that shouldn't trigger errors (e.g. not evaluate
2069 ;;; user-entered code).
2070 ;;;
2071 ;;; We have the concept of the "current Lisp package". RPC requests
2072 ;;; always say what package the user is making them from and the Lisp
2073 ;;; side binds that package to *BUFFER-PACKAGE* to use as it sees
2074 ;;; fit. The current package is defined as the buffer-local value of
2075 ;;; `slime-buffer-package' if set, and otherwise the package named by
2076 ;;; the nearest IN-PACKAGE as found by text search (first backwards,
2077 ;;; then forwards).
2078 ;;;
2079 ;;; Similarly we have the concept of the current thread, i.e. which
2080 ;;; thread in the Lisp process should handle the request. The current
2081 ;;; thread is determined solely by the buffer-local value of
2082 ;;; `slime-current-thread'. This is usually bound to t meaning "no
2083 ;;; particular thread", but can also be used to nominate a specific
2084 ;;; thread. The REPL and the debugger both use this feature to deal
2085 ;;; with specific threads.
2086
2087 (make-variable-buffer-local
2088 (defvar slime-current-thread t
2089 "The id of the current thread on the Lisp side.
2090 t means the \"current\" thread;
2091 :repl-thread the thread that executes REPL requests;
2092 fixnum a specific thread."))
2093
2094 (make-variable-buffer-local
2095 (defvar slime-buffer-package nil
2096 "The Lisp package associated with the current buffer.
2097 This is set only in buffers bound to specific packages."))
2098
2099 ;;; `slime-rex' is the RPC primitive which is used to implement both
2100 ;;; `slime-eval' and `slime-eval-async'. You can use it directly if
2101 ;;; you need to, but the others are usually more convenient.
2102
2103 (defmacro* slime-rex ((&rest saved-vars)
2104 (sexp &optional
2105 (package '(slime-current-package))
2106 (thread 'slime-current-thread))
2107 &rest continuations)
2108 "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)
2109
2110 Remote EXecute SEXP.
2111
2112 VARs are a list of saved variables visible in the other forms. Each
2113 VAR is either a symbol or a list (VAR INIT-VALUE).
2114
2115 SEXP is evaluated and the princed version is sent to Lisp.
2116
2117 PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
2118 The default value is (slime-current-package).
2119
2120 CLAUSES is a list of patterns with same syntax as
2121 `destructure-case'. The result of the evaluation of SEXP is
2122 dispatched on CLAUSES. The result is either a sexp of the
2123 form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed
2124 asynchronously.
2125
2126 Note: don't use backquote syntax for SEXP, because various Emacs
2127 versions cannot deal with that."
2128 (let ((result (gensym)))
2129 `(lexical-let ,(loop for var in saved-vars
2130 collect (etypecase var
2131 (symbol (list var var))
2132 (cons var)))
2133 (slime-dispatch-event
2134 (list :emacs-rex ,sexp ,package ,thread
2135 (lambda (,result)
2136 (destructure-case ,result
2137 ,@continuations)))))))
2138
2139 (put 'slime-rex 'lisp-indent-function 2)
2140
2141 ;;; Interface
2142 (defun slime-current-package ()
2143 "Return the Common Lisp package in the current context.
2144 If `slime-buffer-package' has a value then return that, otherwise
2145 search for and read an `in-package' form."
2146 (or slime-buffer-package
2147 (save-restriction
2148 (widen)
2149 (slime-find-buffer-package))))
2150
2151 (defvar slime-find-buffer-package-function 'slime-search-buffer-package
2152 "*Function to use for `slime-find-buffer-package'.
2153 The result should be the package-name (a string)
2154 or nil if nothing suitable can be found.")
2155
2156 (defun slime-find-buffer-package ()
2157 "Figure out which Lisp package the current buffer is associated with."
2158 (funcall slime-find-buffer-package-function))
2159
2160 (make-variable-buffer-local
2161 (defvar slime-package-cache nil
2162 "Cons of the form (buffer-modified-tick . package)"))
2163
2164 ;; When modifing this code consider cases like:
2165 ;; (in-package #.*foo*)
2166 ;; (in-package #:cl)
2167 ;; (in-package :cl)
2168 ;; (in-package "CL")
2169 ;; (in-package |CL|)
2170 ;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
2171
2172 (defun slime-search-buffer-package ()
2173 (let ((case-fold-search t)
2174 (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
2175 "\\([^)]+\\)[ \t]*)")))
2176 (save-excursion
2177 (when (or (re-search-backward regexp nil t)
2178 (re-search-forward regexp nil t))
2179 (match-string-no-properties 2)))))
2180
2181 ;;; Synchronous requests are implemented in terms of asynchronous
2182 ;;; ones. We make an asynchronous request with a continuation function
2183 ;;; that `throw's its result up to a `catch' and then enter a loop of
2184 ;;; handling I/O until that happens.
2185
2186 (defvar slime-stack-eval-tags nil
2187 "List of stack-tags of continuations waiting on the stack.")
2188
2189 (defun slime-eval (sexp &optional package)
2190 "Evaluate EXPR on the superior Lisp and return the result."
2191 (when (null package) (setq package (slime-current-package)))
2192 (let* ((tag (gensym (format "slime-result-%d-"
2193 (1+ (slime-continuation-counter)))))
2194 (slime-stack-eval-tags (cons tag slime-stack-eval-tags)))
2195 (apply
2196 #'funcall
2197 (catch tag
2198 (slime-rex (tag sexp)
2199 (sexp package)
2200 ((:ok value)
2201 (unless (member tag slime-stack-eval-tags)
2202 (error "Reply to canceled synchronous eval request tag=%S sexp=%S"
2203 tag sexp))
2204 (throw tag (list #'identity value)))
2205 ((:abort _condition)
2206 (throw tag (list #'error "Synchronous Lisp Evaluation aborted"))))
2207 (let ((debug-on-quit t)
2208 (inhibit-quit nil)
2209 (conn (slime-connection)))
2210 (while t
2211 (unless (eq (process-status conn) 'open)
2212 (error "Lisp connection closed unexpectedly"))
2213 (slime-accept-process-output nil 0.01)))))))
2214
2215 (defun slime-eval-async (sexp &optional cont package)
2216 "Evaluate EXPR on the superior Lisp and call CONT with the result."
2217 (slime-rex (cont (buffer (current-buffer)))
2218 (sexp (or package (slime-current-package)))
2219 ((:ok result)
2220 (when cont
2221 (set-buffer buffer)
2222 (funcall cont result)))
2223 ((:abort condition)
2224 (message "Evaluation aborted on %s." condition)))
2225 ;; Guard against arbitrary return values which once upon a time
2226 ;; showed up in the minibuffer spuriously (due to a bug in
2227 ;; slime-autodoc.) If this ever happens again, returning the
2228 ;; following will make debugging much easier:
2229 :slime-eval-async)
2230
2231 (put 'slime-eval-async 'lisp-indent-function 1)
2232
2233 ;;; These functions can be handy too:
2234
2235 (defun slime-connected-p ()
2236 "Return true if the Swank connection is open."
2237 (not (null slime-net-processes)))
2238
2239 (defun slime-check-connected ()
2240 "Signal an error if we are not connected to Lisp."
2241 (unless (slime-connected-p)
2242 (error "Not connected. Use `%s' to start a Lisp."
2243 (substitute-command-keys "\\[slime]"))))
2244
2245 ;; UNUSED
2246 (defun slime-debugged-connection-p (conn)
2247 ;; This previously was (AND (SLDB-DEBUGGED-CONTINUATIONS CONN) T),
2248 ;; but an SLDB buffer may exist without having continuations
2249 ;; attached to it, e.g. the one resulting from `slime-interrupt'.
2250 (loop for b in (sldb-buffers)
2251 thereis (with-current-buffer b
2252 (eq slime-buffer-connection conn))))
2253
2254 (defun slime-busy-p (&optional conn)
2255 "True if Lisp has outstanding requests.
2256 Debugged requests are ignored."
2257 (let ((debugged (sldb-debugged-continuations (or conn (slime-connection)))))
2258 (remove-if (lambda (id)
2259 (memq id debugged))
2260 (slime-rex-continuations)
2261 :key #'car)))
2262
2263 (defun slime-sync ()
2264 "Block until the most recent request has finished."
2265 (when (slime-rex-continuations)
2266 (let ((tag (caar (slime-rex-continuations))))
2267 (while (find tag (slime-rex-continuations) :key #'car)
2268 (slime-accept-process-output nil 0.1)))))
2269
2270 (defun slime-ping ()
2271 "Check that communication works."
2272 (interactive)
2273 (message "%s" (slime-eval "PONG")))
2274
2275 ;;;;; Protocol event handler (the guts)
2276 ;;;
2277 ;;; This is the protocol in all its glory. The input to this function
2278 ;;; is a protocol event that either originates within Emacs or arrived
2279 ;;; over the network from Lisp.
2280 ;;;
2281 ;;; Each event is a list beginning with a keyword and followed by
2282 ;;; arguments. The keyword identifies the type of event. Events
2283 ;;; originating from Emacs have names starting with :emacs- and events
2284 ;;; from Lisp don't.
2285
2286 (slime-def-connection-var slime-rex-continuations '()
2287 "List of (ID . FUNCTION) continuations waiting for RPC results.")
2288
2289 (slime-def-connection-var slime-continuation-counter 0
2290 "Continuation serial number counter.")
2291
2292 (defvar slime-event-hooks)
2293
2294 (defun slime-dispatch-event (event &optional process)
2295 (let ((slime-dispatching-connection (or process (slime-connection))))
2296 (or (run-hook-with-args-until-success 'slime-event-hooks event)
2297 (destructure-case event
2298 ((:emacs-rex form package thread continuation)
2299 (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
2300 (slime-display-oneliner "; pipelined request... %S" form))
2301 (let ((id (incf (slime-continuation-counter))))
2302 (slime-send `(:emacs-rex ,form ,package ,thread ,id))
2303 (push (cons id continuation) (slime-rex-continuations))
2304 (slime-recompute-modelines)))
2305 ((:return value id)
2306 (let ((rec (assq id (slime-rex-continuations))))
2307 (cond (rec (setf (slime-rex-continuations)
2308 (remove rec (slime-rex-continuations)))
2309 (slime-recompute-modelines)
2310 (funcall (cdr rec) value))
2311 (t
2312 (error "Unexpected reply: %S %S" id value)))))
2313 ((:debug-activate thread level &optional select)
2314 (assert thread)
2315 (sldb-activate thread level select))
2316 ((:debug thread level condition restarts frames conts)
2317 (assert thread)
2318 (sldb-setup thread level condition restarts frames conts))
2319 ((:debug-return thread level stepping)
2320 (assert thread)
2321 (sldb-exit thread level stepping))
2322 ((:emacs-interrupt thread)
2323 (slime-send `(:emacs-interrupt ,thread)))
2324 ((:channel-send id msg)
2325 (slime-channel-send (or (slime-find-channel id)
2326 (error "Invalid channel id: %S %S" id msg))
2327 msg))
2328 ((:emacs-channel-send id msg)
2329 (slime-send `(:emacs-channel-send ,id ,msg)))
2330 ((:read-from-minibuffer thread tag prompt initial-value)
2331 (slime-read-from-minibuffer-for-swank thread tag prompt
2332 initial-value))
2333 ((:y-or-n-p thread tag question)
2334 (slime-y-or-n-p thread tag question))
2335 ((:emacs-return-string thread tag string)
2336 (slime-send `(:emacs-return-string ,thread ,tag ,string)))
2337 ((:new-features features)
2338 (setf (slime-lisp-features) features))
2339 ((:indentation-update info)
2340 (slime-handle-indentation-update info))
2341 ((:eval-no-wait form)
2342 (slime-check-eval-in-emacs-enabled)
2343 (eval (read form)))
2344 ((:eval thread tag form-string)
2345 (slime-check-eval-in-emacs-enabled)
2346 (slime-eval-for-lisp thread tag form-string))
2347 ((:emacs-return thread tag value)
2348 (slime-send `(:emacs-return ,thread ,tag ,value)))
2349 ((:ed what)
2350 (slime-ed what))
2351 ((:inspect what thread tag)
2352 (let ((hook (when (and thread tag)
2353 (slime-curry #'slime-send
2354 `(:emacs-return ,thread ,tag nil)))))
2355 (slime-open-inspector what nil hook)))
2356 ((:background-message message)
2357 (slime-background-message "%s" message))
2358 ((:debug-condition thread message)
2359 (assert thread)
2360 (message "%s" message))
2361 ((:ping thread tag)
2362 (slime-send `(:emacs-pong ,thread ,tag)))
2363 ((:reader-error packet condition)
2364 (slime-with-popup-buffer ((slime-buffer-name :error))
2365 (princ (format "Invalid protocol message:\n%s\n\n%s"
2366 condition packet))
2367 (goto-char (point-min)))
2368 (error "Invalid protocol message"))
2369 ((:invalid-rpc id message)
2370 (setf (slime-rex-continuations)
2371 (remove* id (slime-rex-continuations) :key #'car))
2372 (error "Invalid rpc: %s" message))
2373 ((:emacs-skipped-packet _pkg))
2374 ((:test-delay seconds) ; for testing only
2375 (sit-for seconds))))))
2376
2377 (defun slime-send (sexp)
2378 "Send SEXP directly over the wire on the current connection."
2379 (slime-net-send sexp (slime-connection)))
2380
2381 (defun slime-reset ()
2382 "Clear all pending continuations and erase connection buffer."
2383 (interactive)
2384 (setf (slime-rex-continuations) '())
2385 (mapc #'kill-buffer (sldb-buffers))
2386 (slime-with-connection-buffer ()
2387 (erase-buffer)))
2388
2389 (defun slime-send-sigint ()
2390 (interactive)
2391 (signal-process (slime-pid) 'SIGINT))
2392
2393 ;;;;; Channels
2394
2395 ;;; A channel implements a set of operations. Those operations can be
2396 ;;; invoked by sending messages to the channel. Channels are used for
2397 ;;; protocols which can't be expressed naturally with RPCs, e.g. for
2398 ;;; streaming data over the wire.
2399 ;;;
2400 ;;; A channel can be "remote" or "local". Remote channels are
2401 ;;; represented by integers. Local channels are structures. Messages
2402 ;;; sent to a closed (remote) channel are ignored.
2403
2404 (slime-def-connection-var slime-channels '()
2405 "Alist of the form (ID . CHANNEL).")
2406
2407 (slime-def-connection-var slime-channels-counter 0
2408 "Channel serial number counter.")
2409
2410 (defstruct (slime-channel (:conc-name slime-channel.)
2411 (:constructor
2412 slime-make-channel% (operations name id plist)))
2413 operations name id plist)
2414
2415 (defun slime-make-channel (operations &optional name)
2416 (let* ((id (incf (slime-channels-counter)))
2417 (ch (slime-make-channel% operations name id nil)))
2418 (push (cons id ch) (slime-channels))
2419 ch))
2420
2421 (defun slime-close-channel (channel)
2422 (setf (slime-channel.operations channel) 'closed-channel)
2423 (let ((probe (assq (slime-channel.id channel) (slime-channels))))
2424 (cond (probe (setf (slime-channels) (delete probe (slime-channels))))
2425 (t (error "Invalid channel: %s" channel)))))
2426
2427 (defun slime-find-channel (id)
2428 (cdr (assq id (slime-channels))))
2429
2430 (defun slime-channel-send (channel message)
2431 (apply (or (gethash (car message) (slime-channel.operations channel))
2432 (error "Unsupported operation: %S %S" message channel))
2433 channel (cdr message)))
2434
2435 (defun slime-channel-put (channel prop value)
2436 (setf (slime-channel.plist channel)
2437 (plist-put (slime-channel.plist channel) prop value)))
2438
2439 (defun slime-channel-get (channel prop)
2440 (plist-get (slime-channel.plist channel) prop))
2441
2442 (eval-and-compile
2443 (defun slime-channel-method-table-name (type)
2444 (intern (format "slime-%s-channel-methods" type))))
2445
2446 (defmacro slime-define-channel-type (name)
2447 (let ((tab (slime-channel-method-table-name name)))
2448 `(progn
2449 (defvar ,tab)
2450 (setq ,tab (make-hash-table :size 10)))))
2451
2452 (put 'slime-indulge-pretty-colors 'slime-define-channel-type t)
2453
2454 (defmacro slime-define-channel-method (type method args &rest body)
2455 `(puthash ',method
2456 (lambda (self . ,args) . ,body)
2457 ,(slime-channel-method-table-name type)))
2458
2459 (put 'slime-define-channel-method 'lisp-indent-function 3)
2460 (put 'slime-indulge-pretty-colors 'slime-define-channel-method t)
2461
2462 (defun slime-send-to-remote-channel (channel-id msg)
2463 (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg)))
2464
2465 ;;;;; Event logging to *slime-events*
2466 ;;;
2467 ;;; The *slime-events* buffer logs all protocol messages for debugging
2468 ;;; purposes. Optionally you can enable outline-mode in that buffer,
2469 ;;; which is convenient but slows things down significantly.
2470
2471 (defvar slime-log-events t
2472 "*Log protocol events to the *slime-events* buffer.")
2473
2474 (defvar slime-outline-mode-in-events-buffer nil
2475 "*Non-nil means use outline-mode in *slime-events*.")
2476
2477 (defvar slime-event-buffer-name (slime-buffer-name :events)
2478 "The name of the slime event buffer.")
2479
2480 (defun slime-log-event (event)
2481 "Record the fact that EVENT occurred."
2482 (when slime-log-events
2483 (with-current-buffer (slime-events-buffer)
2484 ;; trim?
2485 (when (> (buffer-size) 100000)
2486 (goto-char (/ (buffer-size) 2))
2487 (re-search-forward "^(" nil t)
2488 (delete-region (point-min) (point)))
2489 (goto-char (point-max))
2490 (save-excursion
2491 (slime-pprint-event event (current-buffer)))
2492 (when (and (boundp 'outline-minor-mode)
2493 outline-minor-mode)
2494 (hide-entry))
2495 (goto-char (point-max)))))
2496
2497 (defun slime-pprint-event (event buffer)
2498 "Pretty print EVENT in BUFFER with limited depth and width."
2499 (let ((print-length 20)
2500 (print-level 6)
2501 (pp-escape-newlines t))
2502 (pp event buffer)))
2503
2504 (defun slime-events-buffer ()
2505 "Return or create the event log buffer."
2506 (or (get-buffer slime-event-buffer-name)
2507 (let ((buffer (get-buffer-create slime-event-buffer-name)))
2508 (with-current-buffer buffer
2509 (buffer-disable-undo)
2510 (set (make-local-variable 'outline-regexp) "^(")
2511 (set (make-local-variable 'comment-start) ";")
2512 (set (make-local-variable 'comment-end) "")
2513 (when slime-outline-mode-in-events-buffer
2514 (outline-minor-mode)))
2515 buffer)))
2516
2517
2518 ;;;;; Cleanup after a quit
2519
2520 (defun slime-restart-inferior-lisp ()
2521 "Kill and restart the Lisp subprocess."
2522 (interactive)
2523 (assert (slime-inferior-process) () "No inferior lisp process")
2524 (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t))
2525
2526 (defun slime-restart-sentinel (process _message)
2527 "Restart the inferior lisp process.
2528 Also rearrange windows."
2529 (assert (process-status process) 'closed)
2530 (let* ((proc (slime-inferior-process process))
2531 (args (slime-inferior-lisp-args proc))
2532 (buffer (buffer-name (process-buffer proc)))
2533 ;;(buffer-window (get-buffer-window buffer))
2534 (new-proc (slime-start-lisp (plist-get args :program)
2535 (plist-get args :program-args)
2536 (plist-get args :env)
2537 nil
2538 buffer)))
2539 (slime-net-close process)
2540 (slime-inferior-connect new-proc args)
2541 (switch-to-buffer buffer)
2542 (goto-char (point-max))))
2543
2544 ;; FIXME: move to slime-repl
2545 (defun slime-kill-all-buffers ()
2546 "Kill all the slime related buffers.
2547 This is only used by the repl command sayoonara."
2548 (dolist (buf (buffer-list))
2549 (when (or (string= (buffer-name buf) slime-event-buffer-name)
2550 (string-match "^\\*inferior-lisp*" (buffer-name buf))
2551 (string-match "^\\*slime-repl .*\\*$" (buffer-name buf))
2552 (string-match "^\\*sldb .*\\*$" (buffer-name buf))
2553 (string-match "^\\*SLIME.*\\*$" (buffer-name buf)))
2554 (kill-buffer buf))))
2555
2556
2557 ;;;; Compilation and the creation of compiler-note annotations
2558
2559 (defvar slime-highlight-compiler-notes t
2560 "*When non-nil annotate buffers with compilation notes etc.")
2561
2562 (defvar slime-before-compile-functions nil
2563 "A list of function called before compiling a buffer or region.
2564 The function receive two arguments: the beginning and the end of the
2565 region that will be compiled.")
2566
2567 ;; FIXME: remove some of the options
2568 (defcustom slime-compilation-finished-hook 'slime-maybe-show-compilation-log
2569 "Hook called with a list of compiler notes after a compilation."
2570 :group 'slime-mode
2571 :type 'hook
2572 :options '(slime-maybe-show-compilation-log
2573 slime-create-compilation-log
2574 slime-show-compilation-log
2575 slime-maybe-list-compiler-notes
2576 slime-list-compiler-notes
2577 slime-maybe-show-xrefs-for-notes
2578 slime-goto-first-note))
2579
2580 ;; FIXME: I doubt that anybody uses this directly and it seems to be
2581 ;; only an ugly way to pass arguments.
2582 (defvar slime-compilation-policy nil
2583 "When non-nil compile with these optimization settings.")
2584
2585 (defun slime-compute-policy (arg)
2586 "Return the policy for the prefix argument ARG."
2587 (let ((between (lambda (min n max)
2588 (cond ((< n min) min)
2589 ((> n max) max)
2590 (t n)))))
2591 (let ((n (prefix-numeric-value arg)))
2592 (cond ((not arg) slime-compilation-policy)
2593 ((plusp n) `((cl:debug . ,(funcall between 0 n 3))))
2594 ((eq arg '-) `((cl:speed . 3)))
2595 (t `((cl:speed . ,(funcall between 0 (abs n) 3))))))))
2596
2597 (defstruct (slime-compilation-result
2598 (:type list)
2599 (:conc-name slime-compilation-result.)
2600 (:constructor nil)
2601 (:copier nil))
2602 tag notes successp duration loadp faslfile)
2603
2604 (defvar slime-last-compilation-result nil
2605 "The result of the most recently issued compilation.")
2606
2607 (defun slime-compiler-notes ()
2608 "Return all compiler notes, warnings, and errors."
2609 (slime-compilation-result.notes slime-last-compilation-result))
2610
2611 (defun slime-compile-and-load-file (&optional policy)
2612 "Compile and load the buffer's file and highlight compiler notes.
2613
2614 With (positive) prefix argument the file is compiled with maximal
2615 debug settings (`C-u'). With negative prefix argument it is compiled for
2616 speed (`M--'). If a numeric argument is passed set debug or speed settings
2617 to it depending on its sign.
2618
2619 Each source location that is the subject of a compiler note is
2620 underlined and annotated with the relevant information. The commands
2621 `slime-next-note' and `slime-previous-note' can be used to navigate
2622 between compiler notes and to display their full details."
2623 (interactive "P")
2624 (slime-compile-file t (slime-compute-policy policy)))
2625
2626 ;;; FIXME: This should become a DEFCUSTOM
2627 (defvar slime-compile-file-options '()
2628 "Plist of additional options that C-c C-k should pass to Lisp.
2629 Currently only :fasl-directory is supported.")
2630
2631 (defun slime-compile-file (&optional load policy)
2632 "Compile current buffer's file and highlight resulting compiler notes.
2633
2634 See `slime-compile-and-load-file' for further details."
2635 (interactive)
2636 (unless buffer-file-name
2637 (error "Buffer %s is not associated with a file." (buffer-name)))
2638 (check-parens)
2639 (when (and (buffer-modified-p)
2640 (y-or-n-p (format "Save file %s? " (buffer-file-name))))
2641 (save-buffer))
2642 (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
2643 (let ((file (slime-to-lisp-filename (buffer-file-name)))
2644 (options (slime-simplify-plist `(,@slime-compile-file-options
2645 :policy ,policy))))
2646 (slime-eval-async
2647 `(swank:compile-file-for-emacs ,file ,(if load t nil)
2648 . ,(slime-hack-quotes options))
2649 #'slime-compilation-finished)
2650 (message "Compiling %s..." file)))
2651
2652 (defun slime-hack-quotes (arglist)
2653 ;; eval is the wrong primitive, we really want funcall
2654 (loop for arg in arglist collect `(quote ,arg)))
2655
2656 (defun slime-simplify-plist (plist)
2657 (loop for (key val) on plist by #'cddr
2658 append (cond ((null val) '())
2659 (t (list key val)))))
2660
2661 (defun slime-compile-defun (&optional raw-prefix-arg)
2662 "Compile the current toplevel form.
2663
2664 With (positive) prefix argument the form is compiled with maximal
2665 debug settings (`C-u'). With negative prefix argument it is compiled for
2666 speed (`M--'). If a numeric argument is passed set debug or speed settings
2667 to it depending on its sign."
2668 (interactive "P")
2669 (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
2670 (if (use-region-p)
2671 (slime-compile-region (region-beginning) (region-end))
2672 (apply #'slime-compile-region (slime-region-for-defun-at-point)))))
2673
2674 (defun slime-compile-region (start end)
2675 "Compile the region."
2676 (interactive "r")
2677 ;; Check connection before running hooks things like
2678 ;; slime-flash-region don't make much sense if there's no connection
2679 (slime-connection)
2680 (slime-flash-region start end)
2681 (run-hook-with-args 'slime-before-compile-functions start end)
2682 (slime-compile-string (buffer-substring-no-properties start end) start))
2683
2684 (defun slime-flash-region (start end &optional timeout)
2685 "Temporarily highlight region from START to END."
2686 (let ((overlay (make-overlay start end)))
2687 (overlay-put overlay 'face 'secondary-selection)
2688 (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay)))
2689
2690 (defun slime-compile-string (string start-offset)
2691 (let* ((line (save-excursion
2692 (goto-char start-offset)
2693 (list (line-number-at-pos) (1+ (current-column)))))
2694 (position `((:position ,start-offset) (:line ,@line))))
2695 (slime-eval-async
2696 `(swank:compile-string-for-emacs
2697 ,string
2698 ,(buffer-name)
2699 ',position
2700 ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name)))
2701 ',slime-compilation-policy)
2702 #'slime-compilation-finished)))
2703
2704 (defcustom slime-load-failed-fasl 'ask
2705 "Which action to take when COMPILE-FILE set FAILURE-P to T.
2706 NEVER doesn't load the fasl
2707 ALWAYS loads the fasl
2708 ASK asks the user."
2709 :type '(choice (const never)
2710 (const always)
2711 (const ask)))
2712
2713 (defun slime-load-failed-fasl-p ()
2714 (ecase slime-load-failed-fasl
2715 (never nil)
2716 (always t)
2717 (ask (y-or-n-p "Compilation failed. Load fasl file anyway? "))))
2718
2719 (defun slime-compilation-finished (result)
2720 (with-struct (slime-compilation-result. notes duration successp
2721 loadp faslfile) result
2722 (setf slime-last-compilation-result result)
2723 (slime-show-note-counts notes duration (cond ((not loadp) successp)
2724 (t (and faslfile successp))))
2725 (when slime-highlight-compiler-notes
2726 (slime-highlight-notes notes))
2727 (run-hook-with-args 'slime-compilation-finished-hook notes)
2728 (when (and loadp faslfile
2729 (or successp
2730 (slime-load-failed-fasl-p)))
2731 (slime-eval-async `(swank:load-file ,faslfile)))))
2732
2733 (defun slime-show-note-counts (notes secs successp)
2734 (message (concat
2735 (cond (successp "Compilation finished")
2736 (t (slime-add-face 'font-lock-warning-face
2737 "Compilation failed")))
2738 (if (null notes) ". (No warnings)" ": ")
2739 (mapconcat
2740 (lambda (messages)
2741 (destructuring-bind (sev . notes) messages
2742 (let ((len (length notes)))
2743 (format "%d %s%s" len (slime-severity-label sev)
2744 (if (= len 1) "" "s")))))
2745 (sort (slime-alistify notes #'slime-note.severity #'eq)
2746 (lambda (x y) (slime-severity< (car y) (car x))))
2747 " ")
2748 (if secs (format " [%.2f secs]" secs)))))
2749
2750 (defun slime-highlight-notes (notes)
2751 "Highlight compiler notes, warnings, and errors in the buffer."
2752 (interactive (list (slime-compiler-notes)))
2753 (with-temp-message "Highlighting notes..."
2754 (save-excursion
2755 (save-restriction
2756 (widen) ; highlight notes on the whole buffer
2757 (slime-remove-old-overlays)
2758 (mapc #'slime-overlay-note (slime-merge-notes-for-display notes))))))
2759
2760 (defvar slime-note-overlays '()
2761 "List of overlays created by `slime-make-note-overlay'")
2762
2763 (defun slime-remove-old-overlays ()
2764 "Delete the existing note overlays."
2765 (mapc #'delete-overlay slime-note-overlays)
2766 (setq slime-note-overlays '()))
2767
2768 (defun slime-filter-buffers (predicate)
2769 "Return a list of where PREDICATE returns true.
2770 PREDICATE is executed in the buffer to test."
2771 (remove-if-not (lambda (%buffer)
2772 (with-current-buffer %buffer
2773 (funcall predicate)))
2774 (buffer-list)))
2775
2776 ;;;;; Recompilation.
2777
2778 ;; FIXME: This whole idea is questionable since it depends so
2779 ;; crucially on precise source-locs.
2780
2781 (defun slime-recompile-location (location)
2782 (save-excursion
2783 (slime-goto-source-location location)
2784 (slime-compile-defun)))
2785
2786 (defun slime-recompile-locations (locations cont)
2787 (slime-eval-async
2788 `(swank:compile-multiple-strings-for-emacs
2789 ',(loop for loc in locations collect
2790 (save-excursion
2791 (slime-goto-source-location loc)
2792 (destructuring-bind (start end)
2793 (slime-region-for-defun-at-point)
2794 (list (buffer-substring-no-properties start end)
2795 (buffer-name)
2796 (slime-current-package)
2797 start
2798 (if (buffer-file-name)
2799 (file-name-directory (buffer-file-name))
2800 nil)))))
2801 ',slime-compilation-policy)
2802 cont))
2803
2804
2805 ;;;;; Merging together compiler notes in the same location.
2806
2807 (defun slime-merge-notes-for-display (notes)
2808 "Merge together notes that refer to the same location.
2809 This operation is \"lossy\" in the broad sense but not for display purposes."
2810 (mapcar #'slime-merge-notes
2811 (slime-group-similar 'slime-notes-in-same-location-p notes)))
2812
2813 (defun slime-merge-notes (notes)
2814 "Merge NOTES together. Keep the highest severity, concatenate the messages."
2815 (let* ((new-severity (reduce #'slime-most-severe notes
2816 :key #'slime-note.severity))
2817 (new-message (mapconcat #'slime-note.message notes "\n")))
2818 (let ((new-note (copy-list (car notes))))
2819 (setf (getf new-note :message) new-message)
2820 (setf (getf new-note :severity) new-severity)
2821 new-note)))
2822
2823 (defun slime-notes-in-same-location-p (a b)
2824 (equal (slime-note.location a) (slime-note.location b)))
2825
2826
2827 ;;;;; Compiler notes list
2828
2829 (defun slime-one-line-ify (string)
2830 "Return a single-line version of STRING.
2831 Each newlines and following indentation is replaced by a single space."
2832 (with-temp-buffer
2833 (insert string)
2834 (goto-char (point-min))
2835 (while (re-search-forward "\n[\n \t]*" nil t)
2836 (replace-match " "))
2837 (buffer-string)))
2838
2839 (defun slime-xrefs-for-notes (notes)
2840 (let ((xrefs))
2841 (dolist (note notes)
2842 (let* ((location (getf note :location))
2843 (fn (cadr (assq :file (cdr location))))
2844 (file (assoc fn xrefs))
2845 (node
2846 (list (format "%s: %s"
2847 (getf note :severity)
2848 (slime-one-line-ify (getf note :message)))
2849 location)))
2850 (when fn
2851 (if file
2852 (push node (cdr file))
2853 (setf xrefs (acons fn (list node) xrefs))))))
2854 xrefs))
2855
2856 (defun slime-maybe-show-xrefs-for-notes (notes)
2857 "Show the compiler notes NOTES if they come from more than one file."
2858 (let ((xrefs (slime-xrefs-for-notes notes)))
2859 (when (slime-length> xrefs 1) ; >1 file
2860 (slime-show-xrefs
2861 xrefs 'definition "Compiler notes" (slime-current-package)))))
2862
2863 (defun slime-note-has-location-p (note)
2864 (not (eq ':error (car (slime-note.location note)))))
2865
2866 (defun slime-redefinition-note-p (note)
2867 (eq (slime-note.severity note) :redefinition))
2868
2869 (defun slime-create-compilation-log (notes)
2870 "Create a buffer for `next-error' to use."
2871 (with-current-buffer (get-buffer-create (slime-buffer-name :compilation))
2872 (let ((inhibit-read-only t))
2873 (erase-buffer))
2874 (slime-insert-compilation-log notes)
2875 (compilation-mode)))
2876
2877 (defun slime-maybe-show-compilation-log (notes)
2878 "Display the log on failed compilations or if NOTES is non-nil."
2879 (slime-create-compilation-log notes)
2880 (with-struct (slime-compilation-result. notes duration successp)
2881 slime-last-compilation-result
2882 (unless successp
2883 (with-current-buffer (slime-buffer-name :compilation)
2884 (let ((inhibit-read-only t))
2885 (goto-char (point-max))
2886 (insert "Compilation " (if successp "succeeded." "failed."))
2887 (goto-char (point-min))
2888 (display-buffer (current-buffer)))))))
2889
2890 (defun slime-show-compilation-log (notes)
2891 "Create and display the compilation log buffer."
2892 (interactive (list (slime-compiler-notes)))
2893 (slime-with-popup-buffer ((slime-buffer-name :compilation)
2894 :mode 'compilation-mode)
2895 (slime-insert-compilation-log notes)))
2896
2897 (defun slime-insert-compilation-log (notes)
2898 "Insert NOTES in format suitable for `compilation-mode'."
2899 (multiple-value-bind (grouped-notes canonicalized-locs-table)
2900 (slime-group-and-sort-notes notes)
2901 (with-temp-message "Preparing compilation log..."
2902 (let ((inhibit-read-only t)
2903 (inhibit-modification-hooks t)) ; inefficient font-lock-hook
2904 (insert (format "cd %s\n%d compiler notes:\n\n"
2905 default-directory (length notes)))
2906 (dolist (notes grouped-notes)
2907 (let ((loc (gethash (first notes) canonicalized-locs-table))
2908 (start (point)))
2909 (insert (slime-canonicalized-location-to-string loc) ":")
2910 (slime-insert-note-group notes)
2911 (insert "\n")
2912 (slime-make-note-overlay (first notes) start (1- (point))))))
2913 (set (make-local-variable 'compilation-skip-threshold) 0)
2914 (setq next-error-last-buffer (current-buffer)))))
2915
2916 (defun slime-insert-note-group (notes)
2917 "Insert a group of compiler messages."
2918 (insert "\n")
2919 (dolist (note notes)
2920 (insert " " (slime-severity-label (slime-note.severity note)) ": ")
2921 (let ((start (point)))
2922 (insert (slime-note.message note))
2923 (let ((ctx (slime-note.source-context note)))
2924 (if ctx (insert "\n" ctx)))
2925 (slime-indent-block start 4))
2926 (insert "\n")))
2927
2928 (defun slime-indent-block (start column)
2929 "If the region back to START isn't a one-liner indent it."
2930 (when (< start (line-beginning-position))
2931 (save-excursion
2932 (goto-char start)
2933 (insert "\n"))
2934 (slime-indent-rigidly start (point) column)))
2935
2936 (defun slime-canonicalized-location (location)
2937 "Return a list (FILE LINE COLUMN) for slime-location LOCATION.
2938 This is quite an expensive operation so use carefully."
2939 (save-excursion
2940 (slime-goto-location-buffer (slime-location.buffer location))
2941 (save-excursion
2942 (slime-goto-source-location location)
2943 (list (or (buffer-file-name) (buffer-name))
2944 (save-restriction
2945 (widen)
2946 (line-number-at-pos))
2947 (1+ (current-column))))))
2948
2949 (defun slime-canonicalized-location-to-string (loc)
2950 (if loc
2951 (destructuring-bind (filename line col) loc
2952 (format "%s:%d:%d"
2953 (cond ((not filename) "")
2954 ((let ((rel (file-relative-name filename)))
2955 (if (< (length rel) (length filename))
2956 rel)))
2957 (t filename))
2958 line col))
2959 (format "Unknown location")))
2960
2961 (defun slime-goto-note-in-compilation-log (note)
2962 "Find `note' in the compilation log and display it."
2963 (with-current-buffer (get-buffer (slime-buffer-name :compilation))
2964 (let ((origin (point))
2965 (foundp nil))
2966 (goto-char (point-min))
2967 (let ((overlay))
2968 (while (and (setq overlay (slime-find-next-note))
2969 (not foundp))
2970 (let ((other-note (overlay-get overlay 'slime-note)))
2971 (when (slime-notes-in-same-location-p note other-note)
2972 (slime-show-buffer-position (overlay-start overlay) 'top)
2973 (setq foundp t)))))
2974 (unless foundp
2975 (goto-char origin)))))
2976
2977 (defun slime-group-and-sort-notes (notes)
2978 "First sort, then group NOTES according to their canonicalized locs."
2979 (let ((locs (make-hash-table :test #'eq)))
2980 (mapc (lambda (note)
2981 (let ((loc (slime-note.location note)))
2982 (when (slime-location-p loc)
2983 (puthash note (slime-canonicalized-location loc) locs))))
2984 notes)
2985 (values (slime-group-similar
2986 (lambda (n1 n2)
2987 (equal (gethash n1 locs nil) (gethash n2 locs t)))
2988 (let* ((bottom most-negative-fixnum)
2989 (+default+ (list "" bottom bottom)))
2990 (sort notes
2991 (lambda (n1 n2)
2992 (destructuring-bind (filename1 line1 col1)
2993 (gethash n1 locs +default+)
2994 (destructuring-bind (filename2 line2 col2)
2995 (gethash n2 locs +default+)
2996 (cond ((string-lessp filename1 filename2) t)
2997 ((string-lessp filename2 filename1) nil)
2998 ((< line1 line2) t)
2999 ((> line1 line2) nil)
3000 (t (< col1 col2)))))))))
3001 locs)))
3002
3003 (defun slime-note.severity (note)
3004 (plist-get note :severity))
3005
3006 (defun slime-note.message (note)
3007 (plist-get note :message))
3008
3009 (defun slime-note.source-context (note)
3010 (plist-get note :source-context))
3011
3012 (defun slime-note.location (note)
3013 (plist-get note :location))
3014
3015 (defun slime-severity-label (severity)
3016 (subseq (symbol-name severity) 1))
3017
3018
3019 ;;;;; Adding a single compiler note
3020
3021 (defun slime-overlay-note (note)
3022 "Add a compiler note to the buffer as an overlay.
3023 If an appropriate overlay for a compiler note in the same location
3024 already exists then the new information is merged into it. Otherwise a
3025 new overlay is created."
3026 (multiple-value-bind (start end) (slime-choose-overlay-region note)
3027 (when start
3028 (goto-char start)
3029 (let ((severity (plist-get note :severity))
3030 (message (plist-get note :message))
3031 (overlay (slime-note-at-point)))
3032 (if overlay
3033 (slime-merge-note-into-overlay overlay severity message)
3034 (slime-create-note-overlay note start end severity message))))))
3035
3036 (defun slime-make-note-overlay (note start end)
3037 (let ((overlay (make-overlay start end)))
3038 (overlay-put overlay 'slime-note note)
3039 (push overlay slime-note-overlays)
3040 overlay))
3041
3042 (defun slime-create-note-overlay (note start end severity message)
3043 "Create an overlay representing a compiler note.
3044 The overlay has several properties:
3045 FACE - to underline the relevant text.
3046 SEVERITY - for future reference :NOTE, :STYLE-WARNING, :WARNING, or :ERROR.
3047 MOUSE-FACE - highlight the note when the mouse passes over.
3048 HELP-ECHO - a string describing the note, both for future reference
3049 and for display as a tooltip (due to the special
3050 property name)."
3051 (let ((overlay (slime-make-note-overlay note start end)))
3052 (macrolet ((putp (name value) `(overlay-put overlay ,name ,value)))
3053 (putp 'face (slime-severity-face severity))
3054 (putp 'severity severity)
3055 (putp 'mouse-face 'highlight)
3056 (putp 'help-echo message)
3057 overlay)))
3058
3059 ;; XXX Obsolete due to `slime-merge-notes-for-display' doing the
3060 ;; work already -- unless we decide to put several sets of notes on a
3061 ;; buffer without clearing in between, which only this handles.
3062 (defun slime-merge-note-into-overlay (overlay severity message)
3063 "Merge another compiler note into an existing overlay.
3064 The help text describes both notes, and the highest of the severities
3065 is kept."
3066 (macrolet ((putp (name value) `(overlay-put overlay ,name ,value))
3067 (getp (name) `(overlay-get overlay ,name)))
3068 (putp 'severity (slime-most-severe severity (getp 'severity)))
3069 (putp 'face (slime-severity-face (getp 'severity)))
3070 (putp 'help-echo (concat (getp 'help-echo) "\n" message))))
3071
3072 (defun slime-choose-overlay-region (note)
3073 "Choose the start and end points for an overlay over NOTE.
3074 If the location's sexp is a list spanning multiple lines, then the
3075 region around the first element is used.
3076 Return nil if there's no useful source location."
3077 (let ((location (slime-note.location note)))
3078 (when location
3079 (destructure-case location
3080 ((:error _)) ; do nothing
3081 ((:location file pos _hints)
3082 (cond ((eq (car file) ':source-form) nil)
3083 ((eq (slime-note.severity note) :read-error)
3084 (slime-choose-overlay-for-read-error location))
3085 ((equal pos '(:eof))
3086 (values (1- (point-max)) (point-max)))
3087 (t
3088 (slime-choose-overlay-for-sexp location))))))))
3089
3090 (defun slime-choose-overlay-for-read-error (location)
3091 (let ((pos (slime-location-offset location)))
3092 (save-excursion
3093 (goto-char pos)
3094 (cond ((slime-symbol-at-point)
3095 ;; package not found, &c.
3096 (values (slime-symbol-start-pos) (slime-symbol-end-pos)))
3097 (t
3098 (values pos (1+ pos)))))))
3099
3100 (defun slime-choose-overlay-for-sexp (location)
3101 (slime-goto-source-location location)
3102 (skip-chars-forward "'#`")
3103 (let ((start (point)))
3104 (ignore-errors (slime-forward-sexp))
3105 (if (slime-same-line-p start (point))
3106 (values start (point))
3107 (values (1+ start)
3108 (progn (goto-char (1+ start))
3109 (ignore-errors (forward-sexp 1))
3110 (point))))))
3111
3112 (defun slime-same-line-p (pos1 pos2)
3113 "Return t if buffer positions POS1 and POS2 are on the same line."
3114 (save-excursion (goto-char (min pos1 pos2))
3115 (<= (max pos1 pos2) (line-end-position))))
3116
3117 (defvar slime-severity-face-plist
3118 '(:error slime-error-face
3119 :read-error slime-error-face
3120 :warning slime-warning-face
3121 :redefinition slime-style-warning-face
3122 :style-warning slime-style-warning-face
3123 :note slime-note-face))
3124
3125 (defun slime-severity-face (severity)
3126 "Return the name of the font-lock face representing SEVERITY."
3127 (or (plist-get slime-severity-face-plist severity)
3128 (error "No face for: %S" severity)))
3129
3130 (defvar slime-severity-order
3131 '(:note :style-warning :redefinition :warning :error :read-error))
3132
3133 (defun slime-severity< (sev1 sev2)
3134 "Return true if SEV1 is less severe than SEV2."
3135 (< (position sev1 slime-severity-order)
3136 (position sev2 slime-severity-order)))
3137
3138 (defun slime-most-severe (sev1 sev2)
3139 "Return the most servere of two conditions."
3140 (if (slime-severity< sev1 sev2) sev2 sev1))
3141
3142 ;; XXX: unused function
3143 (defun slime-visit-source-path (source-path)
3144 "Visit a full source path including the top-level form."
3145 (goto-char (point-min))
3146 (slime-forward-source-path source-path))
3147
3148 (defun slime-forward-positioned-source-path (source-path)
3149 "Move forward through a sourcepath from a fixed position.
3150 The point is assumed to already be at the outermost sexp, making the
3151 first element of the source-path redundant."
3152 (ignore-errors
3153 (slime-forward-sexp)
3154 (beginning-of-defun))
3155 (when-let (source-path (cdr source-path))
3156 (down-list 1)
3157 (slime-forward-source-path source-path)))
3158
3159 (defun slime-forward-source-path (source-path)
3160 (let ((origin (point)))
3161 (condition-case nil
3162 (progn
3163 (loop for (count . more) on source-path
3164 do (progn
3165 (slime-forward-sexp count)
3166 (when more (down-list 1))))
3167 ;; Align at beginning
3168 (slime-forward-sexp)
3169 (beginning-of-sexp))
3170 (error (goto-char origin)))))
3171
3172
3173 ;; FIXME: really fix this mess
3174 ;; FIXME: the check shouln't be done here anyway but by M-. itself.
3175
3176 (defun slime-filesystem-toplevel-directory ()
3177 ;; Windows doesn't have a true toplevel root directory, and all
3178 ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs
3179 ;; perspective anyway.
3180 (if (memq system-type '(ms-dos windows-nt))
3181 ""
3182 (file-name-as-directory "/")))
3183
3184 (defun slime-file-name-merge-source-root (target-filename buffer-filename)
3185 "Returns a filename where the source root directory of TARGET-FILENAME
3186 is replaced with the source root directory of BUFFER-FILENAME.
3187
3188 If no common source root could be determined, return NIL.
3189
3190 E.g. (slime-file-name-merge-source-root
3191 \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\"
3192 \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\")
3193
3194 ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\"
3195 "
3196 (let ((target-dirs (slime-split-string (file-name-directory target-filename)
3197 "/" t))
3198 (buffer-dirs (slime-split-string (file-name-directory buffer-filename)
3199 "/" t)))
3200 ;; Starting from the end, we look if one of the TARGET-DIRS exists
3201 ;; in BUFFER-FILENAME---if so, it and everything left from that dirname
3202 ;; is considered to be the source root directory of BUFFER-FILENAME.
3203 (loop with target-suffix-dirs = nil
3204 with buffer-dirs* = (reverse buffer-dirs)
3205 with target-dirs* = (reverse target-dirs)
3206 for target-dir in target-dirs*
3207 do (let ((concat-dirs (lambda (dirs)
3208 (apply #'concat
3209 (mapcar #'file-name-as-directory
3210 dirs))))
3211 (pos (position target-dir buffer-dirs* :test #'equal)))
3212 (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME?
3213 (push target-dir target-suffix-dirs)
3214 (let* ((target-suffix
3215 ; PUSH reversed for us!
3216 (funcall concat-dirs target-suffix-dirs))
3217 (buffer-root
3218 (funcall concat-dirs
3219 (reverse (nthcdr pos buffer-dirs*)))))
3220 (return (concat (slime-filesystem-toplevel-directory)
3221 buffer-root
3222 target-suffix
3223 (file-name-nondirectory
3224 target-filename)))))))))
3225
3226 (defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname)
3227 "Returns a copy of BASE-DIRNAME where all differences between
3228 BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a
3229 highlighting face."
3230 (setq base-dirname (file-name-as-directory base-dirname))
3231 (setq contrast-dirname (file-name-as-directory contrast-dirname