/[slime]/slime/swank.lisp
ViewVC logotype

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.527 - (show annotations)
Mon Feb 4 20:35:11 2008 UTC (6 years, 2 months ago) by mbaringer
Branch: MAIN
Changes since 1.526: +0 -1 lines
*** empty log message ***
1 ;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
2 ;;;
3 ;;; This code has been placed in the Public Domain. All warranties
4 ;;; are disclaimed.
5 ;;;
6 ;;;; swank.lisp
7 ;;;
8 ;;; This file defines the "Swank" TCP server for Emacs to talk to. The
9 ;;; code in this file is purely portable Common Lisp. We do require a
10 ;;; smattering of non-portable functions in order to write the server,
11 ;;; so we have defined them in `swank-backend.lisp' and implemented
12 ;;; them separately for each Lisp implementation. These extensions are
13 ;;; available to us here via the `SWANK-BACKEND' package.
14
15 (defpackage :swank
16 (:use :common-lisp :swank-backend)
17 (:export #:startup-multiprocessing
18 #:start-server
19 #:create-server
20 #:stop-server
21 #:restart-server
22 #:ed-in-emacs
23 #:inspect-in-emacs
24 #:print-indentation-lossage
25 #:swank-debugger-hook
26 #:run-after-init-hook
27 #:inspect-for-emacs
28 #:inspect-slot-for-emacs
29 ;; These are user-configurable variables:
30 #:*communication-style*
31 #:*dont-close*
32 #:*log-events*
33 #:*log-output*
34 #:*use-dedicated-output-stream*
35 #:*dedicated-output-stream-port*
36 #:*configure-emacs-indentation*
37 #:*readtable-alist*
38 #:*globally-redirect-io*
39 #:*global-debugger*
40 #:*sldb-printer-bindings*
41 #:*swank-pprint-bindings*
42 #:*default-worker-thread-bindings*
43 #:*macroexpand-printer-bindings*
44 #:*record-repl-results*
45 #:*debug-on-swank-error*
46 ;; These are re-exported directly from the backend:
47 #:buffer-first-change
48 #:frame-source-location-for-emacs
49 #:restart-frame
50 #:sldb-step
51 #:sldb-break
52 #:sldb-break-on-return
53 #:profiled-functions
54 #:profile-report
55 #:profile-reset
56 #:unprofile-all
57 #:profile-package
58 #:default-directory
59 #:set-default-directory
60 #:quit-lisp))
61
62 (in-package :swank)
63
64
65 ;;;; Top-level variables, constants, macros
66
67 (defconstant cl-package (find-package :cl)
68 "The COMMON-LISP package.")
69
70 (defconstant keyword-package (find-package :keyword)
71 "The KEYWORD package.")
72
73 (defvar *canonical-package-nicknames*
74 `((:common-lisp-user . :cl-user))
75 "Canonical package names to use instead of shortest name/nickname.")
76
77 (defvar *auto-abbreviate-dotted-packages* t
78 "Abbreviate dotted package names to their last component if T.")
79
80 (defvar *swank-io-package*
81 (let ((package (make-package :swank-io-package :use '())))
82 (import '(nil t quote) package)
83 package))
84
85 (defconstant default-server-port 4005
86 "The default TCP port for the server (when started manually).")
87
88 (defvar *swank-debug-p* t
89 "When true, print extra debugging information.")
90
91 (defvar *redirect-io* t
92 "When non-nil redirect Lisp standard I/O to Emacs.
93 Redirection is done while Lisp is processing a request for Emacs.")
94
95 (defvar *sldb-printer-bindings*
96 `((*print-pretty* . t)
97 (*print-level* . 4)
98 (*print-length* . 10)
99 (*print-circle* . t)
100 (*print-readably* . nil)
101 (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil))
102 (*print-gensym* . t)
103 (*print-base* . 10)
104 (*print-radix* . nil)
105 (*print-array* . t)
106 (*print-lines* . 10)
107 (*print-escape* . t)
108 (*print-right-margin* . 65))
109 "A set of printer variables used in the debugger.")
110
111 (defvar *backtrace-printer-bindings*
112 `((*print-pretty* . nil)
113 (*print-level* . 4)
114 (*print-length* . 6))
115 "Pretter settings for printing backtraces.")
116
117 (defvar *default-worker-thread-bindings* '()
118 "An alist to initialize dynamic variables in worker threads.
119 The list has the form ((VAR . VALUE) ...). Each variable VAR will be
120 bound to the corresponding VALUE.")
121
122 (defun call-with-bindings (alist fun)
123 "Call FUN with variables bound according to ALIST.
124 ALIST is a list of the form ((VAR . VAL) ...)."
125 (let* ((rlist (reverse alist))
126 (vars (mapcar #'car rlist))
127 (vals (mapcar #'cdr rlist)))
128 (progv vars vals
129 (funcall fun))))
130
131 (defmacro with-bindings (alist &body body)
132 "See `call-with-bindings'."
133 `(call-with-bindings ,alist (lambda () ,@body)))
134
135 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
136 ;;; RPC.
137
138 (defmacro defslimefun (name arglist &body rest)
139 "A DEFUN for functions that Emacs can call by RPC."
140 `(progn
141 (defun ,name ,arglist ,@rest)
142 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
143 (eval-when (:compile-toplevel :load-toplevel :execute)
144 (export ',name :swank))))
145
146 (defun missing-arg ()
147 "A function that the compiler knows will never to return a value.
148 You can use (MISSING-ARG) as the initform for defstruct slots that
149 must always be supplied. This way the :TYPE slot option need not
150 include some arbitrary initial value like NIL."
151 (error "A required &KEY or &OPTIONAL argument was not supplied."))
152
153
154 ;;;; Hooks
155 ;;;
156 ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
157 ;;; simple indirection. The interface is more CLish than the Emacs
158 ;;; Lisp one.
159
160 (defmacro add-hook (place function)
161 "Add FUNCTION to the list of values on PLACE."
162 `(pushnew ,function ,place))
163
164 (defun run-hook (functions &rest arguments)
165 "Call each of FUNCTIONS with ARGUMENTS."
166 (dolist (function functions)
167 (apply function arguments)))
168
169 (defvar *new-connection-hook* '()
170 "This hook is run each time a connection is established.
171 The connection structure is given as the argument.
172 Backend code should treat the connection structure as opaque.")
173
174 (defvar *connection-closed-hook* '()
175 "This hook is run when a connection is closed.
176 The connection as passed as an argument.
177 Backend code should treat the connection structure as opaque.")
178
179 (defvar *pre-reply-hook* '()
180 "Hook run (without arguments) immediately before replying to an RPC.")
181
182 (defvar *after-init-hook* '()
183 "Hook run after user init files are loaded.")
184
185 (defun run-after-init-hook ()
186 (run-hook *after-init-hook*))
187
188
189 ;;;; Connections
190 ;;;
191 ;;; Connection structures represent the network connections between
192 ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
193 ;;; streams that redirect to Emacs, and optionally a second socket
194 ;;; used solely to pipe user-output to Emacs (an optimization).
195 ;;;
196
197 (defstruct (connection
198 (:conc-name connection.)
199 (:print-function print-connection))
200 ;; Raw I/O stream of socket connection.
201 (socket-io (missing-arg) :type stream :read-only t)
202 ;; Optional dedicated output socket (backending `user-output' slot).
203 ;; Has a slot so that it can be closed with the connection.
204 (dedicated-output nil :type (or stream null))
205 ;; Streams that can be used for user interaction, with requests
206 ;; redirected to Emacs.
207 (user-input nil :type (or stream null))
208 (user-output nil :type (or stream null))
209 (user-io nil :type (or stream null))
210 ;; A stream that we use for *trace-output*; if nil, we user user-output.
211 (trace-output nil :type (or stream null))
212 ;; A stream where we send REPL results.
213 (repl-results nil :type (or stream null))
214 ;; In multithreaded systems we delegate certain tasks to specific
215 ;; threads. The `reader-thread' is responsible for reading network
216 ;; requests from Emacs and sending them to the `control-thread'; the
217 ;; `control-thread' is responsible for dispatching requests to the
218 ;; threads that should handle them; the `repl-thread' is the one
219 ;; that evaluates REPL expressions. The control thread dispatches
220 ;; all REPL evaluations to the REPL thread and for other requests it
221 ;; spawns new threads.
222 reader-thread
223 control-thread
224 repl-thread
225 ;; Callback functions:
226 ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
227 ;; from Emacs.
228 (serve-requests (missing-arg) :type function)
229 ;; (READ) is called to read and return one message from Emacs.
230 (read (missing-arg) :type function)
231 ;; (SEND OBJECT) is called to send one message to Emacs.
232 (send (missing-arg) :type function)
233 ;; (CLEANUP <this-connection>) is called when the connection is
234 ;; closed.
235 (cleanup nil :type (or null function))
236 ;; Cache of macro-indentation information that has been sent to Emacs.
237 ;; This is used for preparing deltas to update Emacs's knowledge.
238 ;; Maps: symbol -> indentation-specification
239 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
240 ;; The list of packages represented in the cache:
241 (indentation-cache-packages '())
242 ;; The communication style used.
243 (communication-style nil :type (member nil :spawn :sigio :fd-handler))
244 ;; The coding system for network streams.
245 (coding-system ))
246
247 (defun print-connection (conn stream depth)
248 (declare (ignore depth))
249 (print-unreadable-object (conn stream :type t :identity t)))
250
251 (defvar *connections* '()
252 "List of all active connections, with the most recent at the front.")
253
254 (defvar *emacs-connection* nil
255 "The connection to Emacs currently in use.")
256
257 (defvar *swank-state-stack* '()
258 "A list of symbols describing the current state. Used for debugging
259 and to detect situations where interrupts can be ignored.")
260
261 (defun default-connection ()
262 "Return the 'default' Emacs connection.
263 This connection can be used to talk with Emacs when no specific
264 connection is in use, i.e. *EMACS-CONNECTION* is NIL.
265
266 The default connection is defined (quite arbitrarily) as the most
267 recently established one."
268 (first *connections*))
269
270 (defslimefun state-stack ()
271 "Return the value of *SWANK-STATE-STACK*."
272 *swank-state-stack*)
273
274 ;; A conditions to include backtrace information
275 (define-condition swank-error (error)
276 ((condition :initarg :condition :reader swank-error.condition)
277 (backtrace :initarg :backtrace :reader swank-error.backtrace))
278 (:report (lambda (condition stream)
279 (princ (swank-error.condition condition) stream))))
280
281 (defun make-swank-error (condition)
282 (let ((bt (ignore-errors
283 (call-with-debugging-environment
284 (lambda () (backtrace 0 nil))))))
285 (make-condition 'swank-error :condition condition :backtrace bt)))
286
287 (add-hook *new-connection-hook* 'notify-backend-of-connection)
288 (defun notify-backend-of-connection (connection)
289 (declare (ignore connection))
290 (emacs-connected))
291
292
293 ;;;; Utilities
294
295 ;;;;; Helper macros
296
297 (defmacro with-io-redirection ((connection) &body body)
298 "Execute BODY I/O redirection to CONNECTION.
299 If *REDIRECT-IO* is true then all standard I/O streams are redirected."
300 `(maybe-call-with-io-redirection ,connection (lambda () ,@body)))
301
302 (defun maybe-call-with-io-redirection (connection fun)
303 (if *redirect-io*
304 (call-with-redirected-io connection fun)
305 (funcall fun)))
306
307 (defmacro with-connection ((connection) &body body)
308 "Execute BODY in the context of CONNECTION."
309 `(call-with-connection ,connection (lambda () ,@body)))
310
311 (defun call-with-connection (connection fun)
312 (let ((*emacs-connection* connection))
313 (with-io-redirection (*emacs-connection*)
314 (call-with-debugger-hook #'swank-debugger-hook fun))))
315
316 (defmacro without-interrupts (&body body)
317 `(call-without-interrupts (lambda () ,@body)))
318
319 (defmacro destructure-case (value &rest patterns)
320 "Dispatch VALUE to one of PATTERNS.
321 A cross between `case' and `destructuring-bind'.
322 The pattern syntax is:
323 ((HEAD . ARGS) . BODY)
324 The list of patterns is searched for a HEAD `eq' to the car of
325 VALUE. If one is found, the BODY is executed with ARGS bound to the
326 corresponding values in the CDR of VALUE."
327 (let ((operator (gensym "op-"))
328 (operands (gensym "rand-"))
329 (tmp (gensym "tmp-")))
330 `(let* ((,tmp ,value)
331 (,operator (car ,tmp))
332 (,operands (cdr ,tmp)))
333 (case ,operator
334 ,@(loop for (pattern . body) in patterns collect
335 (if (eq pattern t)
336 `(t ,@body)
337 (destructuring-bind (op &rest rands) pattern
338 `(,op (destructuring-bind ,rands ,operands
339 ,@body)))))
340 ,@(if (eq (caar (last patterns)) t)
341 '()
342 `((t (error "destructure-case failed: ~S" ,tmp))))))))
343
344 (defmacro with-temp-package (var &body body)
345 "Execute BODY with VAR bound to a temporary package.
346 The package is deleted before returning."
347 `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
348 (unwind-protect (progn ,@body)
349 (delete-package ,var))))
350
351 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
352 "Just like do-symbols, but makes sure a symbol is visited only once."
353 (let ((seen-ht (gensym "SEEN-HT")))
354 `(let ((,seen-ht (make-hash-table :test #'eq)))
355 (do-symbols (,var ,package ,result-form)
356 (unless (gethash ,var ,seen-ht)
357 (setf (gethash ,var ,seen-ht) t)
358 ,@body)))))
359
360
361 ;;;;; Logging
362
363 (defvar *log-events* nil)
364 (defvar *log-output* *error-output*)
365 (defvar *event-history* (make-array 40 :initial-element nil)
366 "A ring buffer to record events for better error messages.")
367 (defvar *event-history-index* 0)
368 (defvar *enable-event-history* t)
369
370 (defun log-event (format-string &rest args)
371 "Write a message to *terminal-io* when *log-events* is non-nil.
372 Useful for low level debugging."
373 (with-standard-io-syntax
374 (let ((*print-readably* nil)
375 (*print-pretty* nil)
376 (*package* *swank-io-package*))
377 (when *enable-event-history*
378 (setf (aref *event-history* *event-history-index*)
379 (format nil "~?" format-string args))
380 (setf *event-history-index*
381 (mod (1+ *event-history-index*) (length *event-history*))))
382 (when *log-events*
383 (apply #'format *log-output* format-string args)
384 (force-output *log-output*)))))
385
386 (defun event-history-to-list ()
387 "Return the list of events (older events first)."
388 (let ((arr *event-history*)
389 (idx *event-history-index*))
390 (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
391
392 (defun dump-event-history (stream)
393 (dolist (e (event-history-to-list))
394 (dump-event e stream)))
395
396 (defun dump-event (event stream)
397 (cond ((stringp event)
398 (write-string (escape-non-ascii event) stream))
399 ((null event))
400 (t (format stream "Unexpected event: ~A~%" event))))
401
402 (defun escape-non-ascii (string)
403 "Return a string like STRING but with non-ascii chars escaped."
404 (cond ((ascii-string-p string) string)
405 (t (with-output-to-string (out)
406 (loop for c across string do
407 (cond ((ascii-char-p c) (write-char c out))
408 (t (format out "\\x~4,'0X" (char-code c)))))))))
409
410 (defun ascii-string-p (o)
411 (and (stringp o)
412 (every #'ascii-char-p o)))
413
414 (defun ascii-char-p (c)
415 (<= (char-code c) 127))
416
417
418 ;;;;; Symbols
419
420 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
421 "Returns one of
422
423 :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
424
425 :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
426
427 :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
428 but is not _present_ in PACKAGE,
429
430 or NIL if SYMBOL is not _accessible_ in PACKAGE.
431
432
433 Be aware not to get confused with :INTERNAL and how \"internal
434 symbols\" are defined in the spec; there is a slight mismatch of
435 definition with the Spec and what's commonly meant when talking
436 about internal symbols most times. As the spec says:
437
438 In a package P, a symbol S is
439
440 _accessible_ if S is either _present_ in P itself or was
441 inherited from another package Q (which implies
442 that S is _external_ in Q.)
443
444 You can check that with: (AND (SYMBOL-STATUS S P) T)
445
446
447 _present_ if either P is the /home package/ of S or S has been
448 imported into P or exported from P by IMPORT, or
449 EXPORT respectively.
450
451 Or more simply, if S is not _inherited_.
452
453 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
454 (AND STATUS
455 (NOT (EQ STATUS :INHERITED))))
456
457
458 _external_ if S is going to be inherited into any package that
459 /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
460 DEFPACKAGE.
461
462 Note that _external_ implies _present_, since to
463 make a symbol _external_, you'd have to use EXPORT
464 which will automatically make the symbol _present_.
465
466 You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
467
468
469 _internal_ if S is _accessible_ but not _external_.
470
471 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
472 (AND STATUS
473 (NOT (EQ STATUS :EXTERNAL))))
474
475
476 Notice that this is *different* to
477 (EQ (SYMBOL-STATUS S P) :INTERNAL)
478 because what the spec considers _internal_ is split up into two
479 explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
480 CL:FIND-SYMBOL does.
481
482 The rationale is that most times when you speak about \"internal\"
483 symbols, you're actually not including the symbols inherited
484 from other packages, but only about the symbols directly specific
485 to the package in question.
486 "
487 (when package ; may be NIL when symbol is completely uninterned.
488 (check-type symbol symbol) (check-type package package)
489 (multiple-value-bind (present-symbol status)
490 (find-symbol (symbol-name symbol) package)
491 (and (eq symbol present-symbol) status))))
492
493 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
494 "True if SYMBOL is external in PACKAGE.
495 If PACKAGE is not specified, the home package of SYMBOL is used."
496 (eq (symbol-status symbol package) :external))
497
498
499 (defun classify-symbol (symbol)
500 "Returns a list of classifiers that classify SYMBOL according
501 to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a
502 special variable.) The list may contain the following classification
503 keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO,
504 :SPECIAL-OPERATOR, and/or :PACKAGE"
505 (check-type symbol symbol)
506 (let (result)
507 (when (boundp symbol) (push :boundp result))
508 (when (fboundp symbol) (push :fboundp result))
509 (when (find-class symbol nil) (push :class result))
510 (when (macro-function symbol) (push :macro result))
511 (when (special-operator-p symbol) (push :special-operator result))
512 (when (find-package symbol) (push :package result))
513 (when (typep (ignore-errors (fdefinition symbol))
514 'generic-function)
515 (push :generic-function result))
516 result))
517
518 (defun symbol-classification->string (flags)
519 (format nil "~A~A~A~A~A~A~A"
520 (if (member :boundp flags) "b" "-")
521 (if (member :fboundp flags) "f" "-")
522 (if (member :generic-function flags) "g" "-")
523 (if (member :class flags) "c" "-")
524 (if (member :macro flags) "m" "-")
525 (if (member :special-operator flags) "s" "-")
526 (if (member :package flags) "p" "-")))
527
528
529 ;;;; TCP Server
530
531 (defvar *use-dedicated-output-stream* nil
532 "When T swank will attempt to create a second connection to
533 Emacs which is used just to send output.")
534
535 (defvar *dedicated-output-stream-port* 0
536 "Which port we should use for the dedicated output stream.")
537
538 (defvar *communication-style* (preferred-communication-style))
539
540 (defvar *dont-close* nil
541 "Default value of :dont-close argument to start-server and
542 create-server.")
543
544 (defvar *dedicated-output-stream-buffering*
545 (if (eq *communication-style* :spawn) :full :none)
546 "The buffering scheme that should be used for the output stream.
547 Valid values are :none, :line, and :full.")
548
549 (defvar *coding-system* "iso-latin-1-unix")
550
551 (defvar *listener-sockets* nil
552 "A property list of lists containing style, socket pairs used
553 by swank server listeners, keyed on socket port number. They
554 are used to close sockets on server shutdown or restart.")
555
556 (defun start-server (port-file &key (style *communication-style*)
557 (dont-close *dont-close*)
558 (coding-system *coding-system*))
559 "Start the server and write the listen port number to PORT-FILE.
560 This is the entry point for Emacs."
561 (setup-server 0 (lambda (port)
562 (announce-server-port port-file port))
563 style dont-close
564 (find-external-format-or-lose coding-system)))
565
566 (defun create-server (&key (port default-server-port)
567 (style *communication-style*)
568 (dont-close *dont-close*)
569 (coding-system *coding-system*))
570 "Start a SWANK server on PORT running in STYLE.
571 If DONT-CLOSE is true then the listen socket will accept multiple
572 connections, otherwise it will be closed after the first."
573 (setup-server port #'simple-announce-function style dont-close
574 (find-external-format-or-lose coding-system)))
575
576 (defun find-external-format-or-lose (coding-system)
577 (or (find-external-format coding-system)
578 (error "Unsupported coding system: ~s" coding-system)))
579
580 (defparameter *loopback-interface* "127.0.0.1")
581
582 (defun setup-server (port announce-fn style dont-close external-format)
583 (declare (type function announce-fn))
584 (let* ((socket (create-socket *loopback-interface* port))
585 (local-port (local-port socket)))
586 (funcall announce-fn local-port)
587 (flet ((serve ()
588 (serve-connection socket style dont-close external-format)))
589 (ecase style
590 (:spawn
591 (initialize-multiprocessing
592 (lambda ()
593 (spawn (lambda ()
594 (loop do (ignore-errors (serve)) while dont-close))
595 :name (concatenate 'string "Swank "
596 (princ-to-string port))))))
597 ((:fd-handler :sigio)
598 (add-fd-handler socket (lambda () (serve))))
599 ((nil) (loop do (serve) while dont-close)))
600 (setf (getf *listener-sockets* port) (list style socket))
601 local-port)))
602
603 (defun stop-server (port)
604 "Stop server running on PORT."
605 (let* ((socket-description (getf *listener-sockets* port))
606 (style (first socket-description))
607 (socket (second socket-description)))
608 (ecase style
609 (:spawn
610 (let ((thread-position
611 (position-if
612 (lambda (x)
613 (string-equal (first x)
614 (concatenate 'string "Swank "
615 (princ-to-string port))))
616 (list-threads))))
617 (when thread-position
618 (kill-nth-thread thread-position)
619 (close-socket socket)
620 (remf *listener-sockets* port))))
621 ((:fd-handler :sigio)
622 (remove-fd-handlers socket)
623 (close-socket socket)
624 (remf *listener-sockets* port)))))
625
626 (defun restart-server (&key (port default-server-port)
627 (style *communication-style*)
628 (dont-close *dont-close*)
629 (coding-system *coding-system*))
630 "Stop the server listening on PORT, then start a new SWANK server
631 on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
632 will accept multiple connections, otherwise it will be closed after the
633 first."
634 (stop-server port)
635 (sleep 5)
636 (create-server :port port :style style :dont-close dont-close
637 :coding-system coding-system))
638
639
640 (defun serve-connection (socket style dont-close external-format)
641 (let ((closed-socket-p nil))
642 (unwind-protect
643 (let ((client (accept-authenticated-connection
644 socket :external-format external-format)))
645 (unless dont-close
646 (close-socket socket)
647 (setf closed-socket-p t))
648 (let ((connection (create-connection client style)))
649 (run-hook *new-connection-hook* connection)
650 (push connection *connections*)
651 (serve-requests connection)))
652 (unless (or dont-close closed-socket-p)
653 (close-socket socket)))))
654
655 (defun accept-authenticated-connection (&rest args)
656 (let ((new (apply #'accept-connection args))
657 (success nil))
658 (unwind-protect
659 (let ((secret (slime-secret)))
660 (when secret
661 (set-stream-timeout new 20)
662 (let ((first-val (decode-message new)))
663 (unless (and (stringp first-val) (string= first-val secret))
664 (error "Incoming connection doesn't know the password."))))
665 (set-stream-timeout new nil)
666 (setf success t))
667 (unless success
668 (close new :abort t)))
669 new))
670
671 (defun slime-secret ()
672 "Finds the magic secret from the user's home directory. Returns nil
673 if the file doesn't exist; otherwise the first line of the file."
674 (with-open-file (in
675 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
676 :if-does-not-exist nil)
677 (and in (read-line in nil ""))))
678
679 (defun serve-requests (connection)
680 "Read and process all requests on connections."
681 (funcall (connection.serve-requests connection) connection))
682
683 (defun announce-server-port (file port)
684 (with-open-file (s file
685 :direction :output
686 :if-exists :error
687 :if-does-not-exist :create)
688 (format s "~S~%" port))
689 (simple-announce-function port))
690
691 (defun simple-announce-function (port)
692 (when *swank-debug-p*
693 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
694 (force-output *log-output*)))
695
696 (defun open-streams (connection)
697 "Return the 5 streams for IO redirection:
698 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
699 (multiple-value-bind (output-fn dedicated-output)
700 (make-output-function connection)
701 (let ((input-fn
702 (lambda ()
703 (with-connection (connection)
704 (with-simple-restart (abort-read
705 "Abort reading input from Emacs.")
706 (read-user-input-from-emacs))))))
707 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
708 (let ((out (or dedicated-output out)))
709 (let ((io (make-two-way-stream in out)))
710 (mapc #'make-stream-interactive (list in out io))
711 (let ((repl-results
712 (make-output-stream-for-target connection :repl-result)))
713 (values dedicated-output in out io repl-results))))))))
714
715 (defun make-output-function (connection)
716 "Create function to send user output to Emacs.
717 This function may open a dedicated socket to send output. It
718 returns two values: the output function, and the dedicated
719 stream (or NIL if none was created)."
720 (if *use-dedicated-output-stream*
721 (let ((stream (open-dedicated-output-stream
722 (connection.socket-io connection))))
723 (values (lambda (string)
724 (write-string string stream)
725 (force-output stream))
726 stream))
727 (values (lambda (string)
728 (with-connection (connection)
729 (with-simple-restart
730 (abort "Abort sending output to Emacs.")
731 (send-to-emacs `(:write-string ,string)))))
732 nil)))
733
734 (defun make-output-function-for-target (connection target)
735 "Create a function to send user output to a specific TARGET in Emacs."
736 (lambda (string)
737 (with-connection (connection)
738 (with-simple-restart
739 (abort "Abort sending output to Emacs.")
740 (send-to-emacs `(:write-string ,string ,target))))))
741
742 (defun make-output-stream-for-target (connection target)
743 "Create a stream that sends output to a specific TARGET in Emacs."
744 (nth-value 1 (make-fn-streams
745 (lambda ()
746 (error "Should never be called"))
747 (make-output-function-for-target connection target))))
748
749 (defun open-dedicated-output-stream (socket-io)
750 "Open a dedicated output connection to the Emacs on SOCKET-IO.
751 Return an output stream suitable for writing program output.
752
753 This is an optimized way for Lisp to deliver output to Emacs."
754 (let ((socket (create-socket *loopback-interface*
755 *dedicated-output-stream-port*)))
756 (unwind-protect
757 (let ((port (local-port socket)))
758 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
759 (let ((dedicated (accept-authenticated-connection
760 socket
761 :external-format
762 (or (ignore-errors
763 (stream-external-format socket-io))
764 :default)
765 :buffering *dedicated-output-stream-buffering*
766 :timeout 30)))
767 (close-socket socket)
768 (setf socket nil)
769 dedicated))
770 (when socket
771 (close-socket socket)))))
772
773 (defvar *sldb-quit-restart* 'abort
774 "What restart should swank attempt to invoke when the user sldb-quits.")
775
776 (defun handle-request (connection)
777 "Read and process one request. The processing is done in the extent
778 of the toplevel restart."
779 (assert (null *swank-state-stack*))
780 (let ((*swank-state-stack* '(:handle-request)))
781 (with-connection (connection)
782 (with-simple-restart (abort "Return to SLIME's top level.")
783 (let ((*sldb-quit-restart* (find-restart 'abort)))
784 (read-from-emacs))))))
785
786 (defun current-socket-io ()
787 (connection.socket-io *emacs-connection*))
788
789 (defun close-connection (c &optional condition backtrace)
790 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
791 (let ((cleanup (connection.cleanup c)))
792 (when cleanup
793 (funcall cleanup c)))
794 (close (connection.socket-io c))
795 (when (connection.dedicated-output c)
796 (close (connection.dedicated-output c)))
797 (setf *connections* (remove c *connections*))
798 (run-hook *connection-closed-hook* c)
799 (when (and condition (not (typep condition 'end-of-file)))
800 (finish-output *log-output*)
801 (format *log-output* "~&;; Event history start:~%")
802 (dump-event-history *log-output*)
803 (format *log-output* ";; Event history end.~%~
804 ;; Backtrace:~%~{~A~%~}~
805 ;; Connection to Emacs lost. [~%~
806 ;; condition: ~A~%~
807 ;; type: ~S~%~
808 ;; encoding: ~A style: ~S dedicated: ~S]~%"
809 backtrace
810 (escape-non-ascii (safe-condition-message condition) )
811 (type-of condition)
812 (ignore-errors (stream-external-format (connection.socket-io c)))
813 (connection.communication-style c)
814 *use-dedicated-output-stream*)
815 (finish-output *log-output*)))
816
817 (defvar *debug-on-swank-error* nil
818 "When non-nil internal swank errors will drop to a
819 debugger (not an sldb buffer). Do not set this to T unless you
820 want to debug swank internals.")
821
822 (defmacro with-reader-error-handler ((connection) &body body)
823 (let ((con (gensym))
824 (blck (gensym)))
825 `(let ((,con ,connection))
826 (block ,blck
827 (handler-bind ((swank-error
828 (lambda (e)
829 (if *debug-on-swank-error*
830 (invoke-debugger e)
831 (return-from ,blck
832 (close-connection
833 ,con
834 (swank-error.condition e)
835 (swank-error.backtrace e)))))))
836 (progn ,@body))))))
837
838 (defslimefun simple-break ()
839 (with-simple-restart (continue "Continue from interrupt.")
840 (call-with-debugger-hook
841 #'swank-debugger-hook
842 (lambda ()
843 (invoke-debugger
844 (make-condition 'simple-error
845 :format-control "Interrupt from Emacs")))))
846 nil)
847
848 ;;;;;; Thread based communication
849
850 (defvar *active-threads* '())
851
852 (defun read-loop (control-thread input-stream connection)
853 (with-reader-error-handler (connection)
854 (loop (send control-thread (decode-message input-stream)))))
855
856 (defun dispatch-loop (socket-io connection)
857 (let ((*emacs-connection* connection))
858 (handler-bind ((error (lambda (e)
859 (if *debug-on-swank-error*
860 (invoke-debugger e)
861 (return-from dispatch-loop
862 (close-connection connection e))))))
863 (loop (dispatch-event (receive) socket-io)))))
864
865 (defun repl-thread (connection)
866 (let ((thread (connection.repl-thread connection)))
867 (when (not thread)
868 (log-event "ERROR: repl-thread is nil"))
869 (assert thread)
870 (cond ((thread-alive-p thread)
871 thread)
872 (t
873 (setf (connection.repl-thread connection)
874 (spawn-repl-thread connection "new-repl-thread"))))))
875
876 (defun find-worker-thread (id)
877 (etypecase id
878 ((member t)
879 (car *active-threads*))
880 ((member :repl-thread)
881 (repl-thread *emacs-connection*))
882 (fixnum
883 (find-thread id))))
884
885 (defun interrupt-worker-thread (id)
886 (let ((thread (or (find-worker-thread id)
887 (repl-thread *emacs-connection*))))
888 (interrupt-thread thread #'simple-break)))
889
890 (defun thread-for-evaluation (id)
891 "Find or create a thread to evaluate the next request."
892 (let ((c *emacs-connection*))
893 (etypecase id
894 ((member t)
895 (spawn-worker-thread c))
896 ((member :repl-thread)
897 (repl-thread c))
898 (fixnum
899 (find-thread id)))))
900
901 (defun spawn-worker-thread (connection)
902 (spawn (lambda ()
903 (with-bindings *default-worker-thread-bindings*
904 (handle-request connection)))
905 :name "worker"))
906
907 (defun spawn-repl-thread (connection name)
908 (spawn (lambda ()
909 (with-bindings *default-worker-thread-bindings*
910 (repl-loop connection)))
911 :name name))
912
913 (defun dispatch-event (event socket-io)
914 "Handle an event triggered either by Emacs or within Lisp."
915 (log-event "DISPATCHING: ~S~%" event)
916 (destructure-case event
917 ((:emacs-rex form package thread-id id)
918 (let ((thread (thread-for-evaluation thread-id)))
919 (push thread *active-threads*)
920 (send thread `(eval-for-emacs ,form ,package ,id))))
921 ((:return thread &rest args)
922 (let ((tail (member thread *active-threads*)))
923 (setq *active-threads* (nconc (ldiff *active-threads* tail)
924 (cdr tail))))
925 (encode-message `(:return ,@args) socket-io))
926 ((:emacs-interrupt thread-id)
927 (interrupt-worker-thread thread-id))
928 (((:debug :debug-condition :debug-activate :debug-return)
929 thread &rest args)
930 (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
931 ((:read-string thread &rest args)
932 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
933 ((:y-or-n-p thread &rest args)
934 (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
935 ((:read-aborted thread &rest args)
936 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
937 ((:emacs-return-string thread-id tag string)
938 (send (find-thread thread-id) `(take-input ,tag ,string)))
939 ((:eval thread &rest args)
940 (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
941 ((:emacs-return thread-id tag value)
942 (send (find-thread thread-id) `(take-input ,tag ,value)))
943 (((:write-string :presentation-start :presentation-end
944 :new-package :new-features :ed :%apply :indentation-update
945 :eval-no-wait :background-message :inspect)
946 &rest _)
947 (declare (ignore _))
948 (encode-message event socket-io))))
949
950 (defun spawn-threads-for-connection (connection)
951 (macrolet ((without-debugger-hook (&body body)
952 `(call-with-debugger-hook nil (lambda () ,@body))))
953 (let* ((socket-io (connection.socket-io connection))
954 (control-thread (spawn (lambda ()
955 (without-debugger-hook
956 (dispatch-loop socket-io connection)))
957 :name "control-thread")))
958 (setf (connection.control-thread connection) control-thread)
959 (let ((reader-thread (spawn (lambda ()
960 (let ((go (receive)))
961 (assert (eq go 'accept-input)))
962 (without-debugger-hook
963 (read-loop control-thread socket-io
964 connection)))
965 :name "reader-thread"))
966 (repl-thread (spawn-repl-thread connection "repl-thread")))
967 (setf (connection.repl-thread connection) repl-thread)
968 (setf (connection.reader-thread connection) reader-thread)
969 (send reader-thread 'accept-input)
970 connection))))
971
972 (defun cleanup-connection-threads (connection)
973 (let ((threads (list (connection.repl-thread connection)
974 (connection.reader-thread connection)
975 (connection.control-thread connection))))
976 (dolist (thread threads)
977 (when (and thread
978 (thread-alive-p thread)
979 (not (equal (current-thread) thread)))
980 (kill-thread thread)))))
981
982 (defun repl-loop (connection)
983 (loop (handle-request connection)))
984
985 (defun process-available-input (stream fn)
986 (loop while (input-available-p stream)
987 do (funcall fn)))
988
989 (defun input-available-p (stream)
990 ;; return true iff we can read from STREAM without waiting or if we
991 ;; hit EOF
992 (let ((c (read-char-no-hang stream nil :eof)))
993 (cond ((not c) nil)
994 ((eq c :eof) t)
995 (t
996 (unread-char c stream)
997 t))))
998
999 ;;;;;; Signal driven IO
1000
1001 (defun install-sigio-handler (connection)
1002 (let ((client (connection.socket-io connection)))
1003 (flet ((handler ()
1004 (cond ((null *swank-state-stack*)
1005 (with-reader-error-handler (connection)
1006 (process-available-input
1007 client (lambda () (handle-request connection)))))
1008 ((eq (car *swank-state-stack*) :read-next-form))
1009 (t (process-available-input client #'read-from-emacs)))))
1010 (add-sigio-handler client #'handler)
1011 (handler))))
1012
1013 (defun deinstall-sigio-handler (connection)
1014 (remove-sigio-handlers (connection.socket-io connection)))
1015
1016 ;;;;;; SERVE-EVENT based IO
1017
1018 (defun install-fd-handler (connection)
1019 (let ((client (connection.socket-io connection)))
1020 (flet ((handler ()
1021 (cond ((null *swank-state-stack*)
1022 (with-reader-error-handler (connection)
1023 (process-available-input
1024 client (lambda () (handle-request connection)))))
1025 ((eq (car *swank-state-stack*) :read-next-form))
1026 (t
1027 (process-available-input client #'read-from-emacs)))))
1028 ;;;; handle sigint
1029 ;;(install-debugger-globally
1030 ;; (lambda (c h)
1031 ;; (with-reader-error-handler (connection)
1032 ;; (block debugger
1033 ;; (with-connection (connection)
1034 ;; (swank-debugger-hook c h)
1035 ;; (return-from debugger))
1036 ;; (abort)))))
1037 (add-fd-handler client #'handler)
1038 (handler))))
1039
1040 (defun deinstall-fd-handler (connection)
1041 (remove-fd-handlers (connection.socket-io connection)))
1042
1043 ;;;;;; Simple sequential IO
1044
1045 (defun simple-serve-requests (connection)
1046 (unwind-protect
1047 (with-simple-restart (close-connection "Close SLIME connection")
1048 (with-reader-error-handler (connection)
1049 (loop
1050 (handle-request connection))))
1051 (close-connection connection)))
1052
1053 (defun read-from-socket-io ()
1054 (let ((event (decode-message (current-socket-io))))
1055 (log-event "DISPATCHING: ~S~%" event)
1056 (destructure-case event
1057 ((:emacs-rex form package thread id)
1058 (declare (ignore thread))
1059 `(eval-for-emacs ,form ,package ,id))
1060 ((:emacs-interrupt thread)
1061 (declare (ignore thread))
1062 '(simple-break))
1063 ((:emacs-return-string thread tag string)
1064 (declare (ignore thread))
1065 `(take-input ,tag ,string))
1066 ((:emacs-return thread tag value)
1067 (declare (ignore thread))
1068 `(take-input ,tag ,value)))))
1069
1070 (defun send-to-socket-io (event)
1071 (log-event "DISPATCHING: ~S~%" event)
1072 (flet ((send (o)
1073 (without-interrupts
1074 (encode-message o (current-socket-io)))))
1075 (destructure-case event
1076 (((:debug-activate :debug :debug-return :read-string :read-aborted
1077 :y-or-n-p :eval)
1078 thread &rest args)
1079 (declare (ignore thread))
1080 (send `(,(car event) 0 ,@args)))
1081 ((:return thread &rest args)
1082 (declare (ignore thread))
1083 (send `(:return ,@args)))
1084 (((:write-string :new-package :new-features :debug-condition
1085 :presentation-start :presentation-end
1086 :indentation-update :ed :%apply :eval-no-wait
1087 :background-message :inspect)
1088 &rest _)
1089 (declare (ignore _))
1090 (send event)))))
1091
1092 (defun initialize-streams-for-connection (connection)
1093 (multiple-value-bind (dedicated in out io repl-results)
1094 (open-streams connection)
1095 (setf (connection.dedicated-output connection) dedicated
1096 (connection.user-io connection) io
1097 (connection.user-output connection) out
1098 (connection.user-input connection) in
1099 (connection.repl-results connection) repl-results)
1100 connection))
1101
1102 (defun create-connection (socket-io style)
1103 (let ((success nil))
1104 (unwind-protect
1105 (let ((c (ecase style
1106 (:spawn
1107 (make-connection :socket-io socket-io
1108 :read #'read-from-control-thread
1109 :send #'send-to-control-thread
1110 :serve-requests #'spawn-threads-for-connection
1111 :cleanup #'cleanup-connection-threads))
1112 (:sigio
1113 (make-connection :socket-io socket-io
1114 :read #'read-from-socket-io
1115 :send #'send-to-socket-io
1116 :serve-requests #'install-sigio-handler
1117 :cleanup #'deinstall-sigio-handler))
1118 (:fd-handler
1119 (make-connection :socket-io socket-io
1120 :read #'read-from-socket-io
1121 :send #'send-to-socket-io
1122 :serve-requests #'install-fd-handler
1123 :cleanup #'deinstall-fd-handler))
1124 ((nil)
1125 (make-connection :socket-io socket-io
1126 :read #'read-from-socket-io
1127 :send #'send-to-socket-io
1128 :serve-requests #'simple-serve-requests)))))
1129 (setf (connection.communication-style c) style)
1130 (initialize-streams-for-connection c)
1131 (setf success t)
1132 c)
1133 (unless success
1134 (close socket-io :abort t)))))
1135
1136
1137 ;;;; IO to Emacs
1138 ;;;
1139 ;;; This code handles redirection of the standard I/O streams
1140 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1141 ;;; contains the appropriate streams, so all we have to do is make the
1142 ;;; right bindings.
1143
1144 ;;;;; Global I/O redirection framework
1145 ;;;
1146 ;;; Optionally, the top-level global bindings of the standard streams
1147 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1148 ;;; redirect the streams into the connection, and they keep going into
1149 ;;; that connection even if more are established. If the connection
1150 ;;; handling the streams closes then another is chosen, or if there
1151 ;;; are no connections then we revert to the original (real) streams.
1152 ;;;
1153 ;;; It is slightly tricky to assign the global values of standard
1154 ;;; streams because they are often shadowed by dynamic bindings. We
1155 ;;; solve this problem by introducing an extra indirection via synonym
1156 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1157 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1158 ;;; variables, so they can always be assigned to affect a global
1159 ;;; change.
1160
1161 (defvar *globally-redirect-io* nil
1162 "When non-nil globally redirect all standard streams to Emacs.")
1163
1164 ;;;;; Global redirection setup
1165
1166 (defvar *saved-global-streams* '()
1167 "A plist to save and restore redirected stream objects.
1168 E.g. the value for '*standard-output* holds the stream object
1169 for *standard-output* before we install our redirection.")
1170
1171 (defun setup-stream-indirection (stream-var &optional stream)
1172 "Setup redirection scaffolding for a global stream variable.
1173 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1174
1175 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1176
1177 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1178 *STANDARD-INPUT*.
1179
1180 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1181 *CURRENT-STANDARD-INPUT*.
1182
1183 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1184 effective global value for *STANDARD-INPUT*. This way we can assign
1185 the effective global value even when *STANDARD-INPUT* is shadowed by a
1186 dynamic binding."
1187 (let ((current-stream-var (prefixed-var '#:current stream-var))
1188 (stream (or stream (symbol-value stream-var))))
1189 ;; Save the real stream value for the future.
1190 (setf (getf *saved-global-streams* stream-var) stream)
1191 ;; Define a new variable for the effective stream.
1192 ;; This can be reassigned.
1193 (proclaim `(special ,current-stream-var))
1194 (set current-stream-var stream)
1195 ;; Assign the real binding as a synonym for the current one.
1196 (set stream-var (make-synonym-stream current-stream-var))))
1197
1198 (defun prefixed-var (prefix variable-symbol)
1199 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1200 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1201 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1202
1203 (defvar *standard-output-streams*
1204 '(*standard-output* *error-output* *trace-output*)
1205 "The symbols naming standard output streams.")
1206
1207 (defvar *standard-input-streams*
1208 '(*standard-input*)
1209 "The symbols naming standard input streams.")
1210
1211 (defvar *standard-io-streams*
1212 '(*debug-io* *query-io* *terminal-io*)
1213 "The symbols naming standard io streams.")
1214
1215 (defun init-global-stream-redirection ()
1216 (when *globally-redirect-io*
1217 (mapc #'setup-stream-indirection
1218 (append *standard-output-streams*
1219 *standard-input-streams*
1220 *standard-io-streams*))))
1221
1222 (add-hook *after-init-hook* 'init-global-stream-redirection)
1223
1224 (defun globally-redirect-io-to-connection (connection)
1225 "Set the standard I/O streams to redirect to CONNECTION.
1226 Assigns *CURRENT-<STREAM>* for all standard streams."
1227 (dolist (o *standard-output-streams*)
1228 (set (prefixed-var '#:current o)
1229 (connection.user-output connection)))
1230 ;; FIXME: If we redirect standard input to Emacs then we get the
1231 ;; regular Lisp top-level trying to read from our REPL.
1232 ;;
1233 ;; Perhaps the ideal would be for the real top-level to run in a
1234 ;; thread with local bindings for all the standard streams. Failing
1235 ;; that we probably would like to inhibit it from reading while
1236 ;; Emacs is connected.
1237 ;;
1238 ;; Meanwhile we just leave *standard-input* alone.
1239 #+NIL
1240 (dolist (i *standard-input-streams*)
1241 (set (prefixed-var '#:current i)
1242 (connection.user-input connection)))
1243 (dolist (io *standard-io-streams*)
1244 (set (prefixed-var '#:current io)
1245 (connection.user-io connection))))
1246
1247 (defun revert-global-io-redirection ()
1248 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1249 (dolist (stream-var (append *standard-output-streams*
1250 *standard-input-streams*
1251 *standard-io-streams*))
1252 (set (prefixed-var '#:current stream-var)
1253 (getf *saved-global-streams* stream-var))))
1254
1255 ;;;;; Global redirection hooks
1256
1257 (defvar *global-stdio-connection* nil
1258 "The connection to which standard I/O streams are globally redirected.
1259 NIL if streams are not globally redirected.")
1260
1261 (defun maybe-redirect-global-io (connection)
1262 "Consider globally redirecting to a newly-established CONNECTION."
1263 (when (and *globally-redirect-io* (null *global-stdio-connection*))
1264 (setq *global-stdio-connection* connection)
1265 (globally-redirect-io-to-connection connection)))
1266
1267 (defun update-redirection-after-close (closed-connection)
1268 "Update redirection after a connection closes."
1269 (check-type closed-connection connection)
1270 (when (eq *global-stdio-connection* closed-connection)
1271 (if (and (default-connection) *globally-redirect-io*)
1272 ;; Redirect to another connection.
1273 (globally-redirect-io-to-connection (default-connection))
1274 ;; No more connections, revert to the real streams.
1275 (progn (revert-global-io-redirection)
1276 (setq *global-stdio-connection* nil)))))
1277
1278 (add-hook *new-connection-hook* 'maybe-redirect-global-io)
1279 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1280
1281 ;;;;; Redirection during requests
1282 ;;;
1283 ;;; We always redirect the standard streams to Emacs while evaluating
1284 ;;; an RPC. This is done with simple dynamic bindings.
1285
1286 (defun call-with-redirected-io (connection function)
1287 "Call FUNCTION with I/O streams redirected via CONNECTION."
1288 (declare (type function function))
1289 (let* ((io (connection.user-io connection))
1290 (in (connection.user-input connection))
1291 (out (connection.user-output connection))
1292 (trace (or (connection.trace-output connection) out))
1293 (*standard-output* out)
1294 (*error-output* out)
1295 (*trace-output* trace)
1296 (*debug-io* io)
1297 (*query-io* io)
1298 (*standard-input* in)
1299 (*terminal-io* io))
1300 (funcall function)))
1301
1302 (defun read-from-emacs ()
1303 "Read and process a request from Emacs."
1304 (apply #'funcall (funcall (connection.read *emacs-connection*))))
1305
1306 (defun read-from-control-thread ()
1307 (receive))
1308
1309 (defun decode-message (stream)
1310 "Read an S-expression from STREAM using the SLIME protocol."
1311 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1312 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1313 (let* ((length (decode-message-length stream))
1314 (string (make-string length))
1315 (pos (read-sequence string stream)))
1316 (assert (= pos length) ()
1317 "Short read: length=~D pos=~D" length pos)
1318 (log-event "READ: ~S~%" string)
1319 (read-form string)))))
1320
1321 (defun decode-message-length (stream)
1322 (let ((buffer (make-string 6)))
1323 (dotimes (i 6)
1324 (setf (aref buffer i) (read-char stream)))
1325 (parse-integer buffer :radix #x10)))
1326
1327 (defun read-form (string)
1328 (with-standard-io-syntax
1329 (let ((*package* *swank-io-package*))
1330 (read-from-string string))))
1331
1332 (defvar *slime-features* nil
1333 "The feature list that has been sent to Emacs.")
1334
1335 (defun send-to-emacs (object)
1336 "Send OBJECT to Emacs."
1337 (funcall (connection.send *emacs-connection*) object))
1338
1339 (defun send-oob-to-emacs (object)
1340 (send-to-emacs object))
1341
1342 (defun send-to-control-thread (object)
1343 (send (connection.control-thread *emacs-connection*) object))
1344
1345 (defun encode-message (message stream)
1346 (let* ((string (prin1-to-string-for-emacs message))
1347 (length (length string)))
1348 (log-event "WRITE: ~A~%" string)
1349 (let ((*print-pretty* nil))
1350 (format stream "~6,'0x" length))
1351 (write-string string stream)
1352 ;;(terpri stream)
1353 (finish-output stream)))
1354
1355 (defun prin1-to-string-for-emacs (object)
1356 (with-standard-io-syntax
1357 (let ((*print-case* :downcase)
1358 (*print-readably* nil)
1359 (*print-pretty* nil)
1360 (*package* *swank-io-package*))
1361 (prin1-to-string object))))
1362
1363 (defun force-user-output ()
1364 (force-output (connection.user-io *emacs-connection*))
1365 (finish-output (connection.user-output *emacs-connection*)))
1366
1367 (defun clear-user-input ()
1368 (clear-input (connection.user-input *emacs-connection*)))
1369
1370 (defvar *read-input-catch-tag* 0)
1371
1372 (defun intern-catch-tag (tag)
1373 ;; fixnums aren't eq in ABCL, so we use intern to create tags
1374 (intern (format nil "~D" tag) :swank))
1375
1376 (defun read-user-input-from-emacs ()
1377 (let ((tag (incf *read-input-catch-tag*)))
1378 (force-output)
1379 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1380 (let ((ok nil))
1381 (unwind-protect
1382 (prog1 (catch (intern-catch-tag tag)
1383 (loop (read-from-emacs)))
1384 (setq ok t))
1385 (unless ok
1386 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1387
1388 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1389 "Like y-or-n-p, but ask in the Emacs minibuffer."
1390 (let ((tag (incf *read-input-catch-tag*))
1391 (question (apply #'format nil format-string arguments)))
1392 (force-output)
1393 (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1394 (catch (intern-catch-tag tag)
1395 (loop (read-from-emacs)))))
1396
1397 (defslimefun take-input (tag input)
1398 "Return the string INPUT to the continuation TAG."
1399 (throw (intern-catch-tag tag) input))
1400
1401 (defun process-form-for-emacs (form)
1402 "Returns a string which emacs will read as equivalent to
1403 FORM. FORM can contain lists, strings, characters, symbols and
1404 numbers.
1405
1406 Characters are converted emacs' ?<char> notaion, strings are left
1407 as they are (except for espacing any nested \" chars, numbers are
1408 printed in base 10 and symbols are printed as their symbol-name
1409 converted to lower case."
1410 (etypecase form
1411 (string (format nil "~S" form))
1412 (cons (format nil "(~A . ~A)"
1413 (process-form-for-emacs (car form))
1414 (process-form-for-emacs (cdr form))))
1415 (character (format nil "?~C" form))
1416 (symbol (concatenate 'string (when (eq (symbol-package form)
1417 #.(find-package "KEYWORD"))
1418 ":")
1419 (string-downcase (symbol-name form))))
1420 (number (let ((*print-base* 10))
1421 (princ-to-string form)))))
1422
1423 (defun eval-in-emacs (form &optional nowait)
1424 "Eval FORM in Emacs."
1425 (cond (nowait
1426 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1427 (t
1428 (force-output)
1429 (let* ((tag (incf *read-input-catch-tag*))
1430 (value (catch (intern-catch-tag tag)
1431 (send-to-emacs
1432 `(:eval ,(current-thread) ,tag
1433 ,(process-form-for-emacs form)))
1434 (loop (read-from-emacs)))))
1435 (destructure-case value
1436 ((:ok value) value)
1437 ((:abort) (abort)))))))
1438
1439 (defvar *swank-wire-protocol-version* nil
1440 "The version of the swank/slime communication protocol.")
1441
1442 (defslimefun connection-info ()
1443 "Return a key-value list of the form:
1444 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1445 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1446 STYLE: the communication style
1447 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1448 FEATURES: a list of keywords
1449 PACKAGE: a list (&key NAME PROMPT)
1450 VERSION: the protocol version"
1451 (setq *slime-features* *features*)
1452 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1453 :lisp-implementation (:type ,(lisp-implementation-type)
1454 :name ,(lisp-implementation-type-name)
1455 :version ,(lisp-implementation-version))
1456 :machine (:instance ,(machine-instance)
1457 :type ,(machine-type)
1458 :version ,(machine-version))
1459 :features ,(features-for-emacs)
1460 :modules ,*modules*
1461 :package (:name ,(package-name *package*)
1462 :prompt ,(package-string-for-prompt *package*))
1463 :version ,*swank-wire-protocol-version*))
1464
1465 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1466 (let* ((s *standard-output*)
1467 (*trace-output* (make-broadcast-stream s *log-output*)))
1468 (time (progn
1469 (dotimes (i n)
1470 (format s "~D abcdefghijklm~%" i)
1471 (when (zerop (mod n m))
1472 (force-output s)))
1473 (finish-output s)
1474 (when *emacs-connection*
1475 (eval-in-emacs '(message "done.")))))
1476 (terpri *trace-output*)
1477 (finish-output *trace-output*)
1478 nil))
1479
1480
1481 ;;;; Reading and printing
1482
1483 (defmacro define-special (name doc)
1484 "Define a special variable NAME with doc string DOC.
1485 This is like defvar, but NAME will not be initialized."
1486 `(progn
1487 (defvar ,name)
1488 (setf (documentation ',name 'variable) ,doc)))
1489
1490 (define-special *buffer-package*
1491 "Package corresponding to slime-buffer-package.
1492
1493 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1494 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1495
1496 (define-special *buffer-readtable*
1497 "Readtable associated with the current buffer")
1498
1499 (defmacro with-buffer-syntax ((&rest _) &body body)
1500 "Execute BODY with appropriate *package* and *readtable* bindings.
1501
1502 This should be used for code that is conceptionally executed in an
1503 Emacs buffer."
1504 (destructuring-bind () _
1505 `(call-with-buffer-syntax (lambda () ,@body))))
1506
1507 (defun call-with-buffer-syntax (fun)
1508 (let ((*package* *buffer-package*))
1509 ;; Don't shadow *readtable* unnecessarily because that prevents
1510 ;; the user from assigning to it.
1511 (if (eq *readtable* *buffer-readtable*)
1512 (call-with-syntax-hooks fun)
1513 (let ((*readtable* *buffer-readtable*))
1514 (call-with-syntax-hooks fun)))))
1515
1516 (defun to-string (object)
1517 "Write OBJECT in the *BUFFER-PACKAGE*.
1518 The result may not be readable. Handles problems with PRINT-OBJECT methods
1519 gracefully."
1520 (with-buffer-syntax ()
1521 (let ((*print-readably* nil))
1522 (handler-case
1523 (prin1-to-string object)
1524 (error ()
1525 (with-output-to-string (s)
1526 (print-unreadable-object (object s :type t :identity t)
1527 (princ "<<error printing object>>" s))))))))
1528
1529 (defun from-string (string)
1530 "Read string in the *BUFFER-PACKAGE*"
1531 (with-buffer-syntax ()
1532 (let ((*read-suppress* nil))
1533 (read-from-string string))))
1534
1535 ;; FIXME: deal with #\| etc. hard to do portably.
1536 (defun tokenize-symbol (string)
1537 "STRING is interpreted as the string representation of a symbol
1538 and is tokenized accordingly. The result is returned in three
1539 values: The package identifier part, the actual symbol identifier
1540 part, and a flag if the STRING represents a symbol that is
1541 internal to the package identifier part. (Notice that the flag is
1542 also true with an empty package identifier part, as the STRING is
1543 considered to represent a symbol internal to some current package.)"
1544 (let ((package (let ((pos (position #\: string)))
1545 (if pos (subseq string 0 pos) nil)))
1546 (symbol (let ((pos (position #\: string :from-end t)))
1547 (if pos (subseq string (1+ pos)) string)))
1548 (internp (not (= (count #\: string) 1))))
1549 (values symbol package internp)))
1550
1551 (defun tokenize-symbol-thoroughly (string)
1552 "This version of TOKENIZE-SYMBOL handles escape characters."
1553 (let ((package nil)
1554 (token (make-array (length string) :element-type 'character
1555 :fill-pointer 0))
1556 (backslash nil)
1557 (vertical nil)
1558 (internp nil))
1559 (loop for char across string
1560 do (cond
1561 (backslash
1562 (vector-push-extend char token)
1563 (setq backslash nil))
1564 ((char= char #\\) ; Quotes next character, even within |...|
1565 (setq backslash t))
1566 ((char= char #\|)
1567 (setq vertical t))
1568 (vertical
1569 (vector-push-extend char token))
1570 ((char= char #\:)
1571 (if package
1572 (setq internp t)
1573 (setq package token
1574 token (make-array (length string)
1575 :element-type 'character
1576 :fill-pointer 0))))
1577 (t
1578 (vector-push-extend (casify-char char) token))))
1579 (values token package (or (not package) internp))))
1580
1581 (defun untokenize-symbol (package-name internal-p symbol-name)
1582 "The inverse of TOKENIZE-SYMBOL.
1583
1584 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1585 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1586 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1587 "
1588 (cond ((not package-name) symbol-name)
1589 (internal-p (cat package-name "::" symbol-name))
1590 (t (cat package-name ":" symbol-name))))
1591
1592 (defun casify-char (char)
1593 "Convert CHAR accoring to readtable-case."
1594 (ecase (readtable-case *readtable*)
1595 (:preserve char)
1596 (:upcase (char-upcase char))
1597 (:downcase (char-downcase char))
1598 (:invert (if (upper-case-p char)
1599 (char-downcase char)
1600 (char-upcase char)))))
1601
1602 (defun parse-symbol (string &optional (package *package*))
1603 "Find the symbol named STRING.
1604 Return the symbol and a flag indicating whether the symbols was found."
1605 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1606 (let ((package (cond ((string= pname "") keyword-package)
1607 (pname (find-package pname))
1608 (t package))))
1609 (if package
1610 (multiple-value-bind (symbol flag) (find-symbol sname package)
1611 (values symbol flag sname package))
1612 (values nil nil nil nil)))))
1613
1614 (defun parse-symbol-or-lose (string &optional (package *package*))
1615 (multiple-value-bind (symbol status) (parse-symbol string package)
1616 (if status
1617 (values symbol status)
1618 (error "Unknown symbol: ~A [in ~A]" string package))))
1619
1620 (defun parse-package (string)
1621 "Find the package named STRING.
1622 Return the package or nil."
1623 ;; STRING comes usually from a (in-package STRING) form.
1624 (ignore-errors
1625 (find-package (let ((*package* *swank-io-package*))
1626 (read-from-string string)))))
1627
1628 (defun unparse-name (string)
1629 "Print the name STRING according to the current printer settings."
1630 ;; this is intended for package or symbol names
1631 (subseq (prin1-to-string (make-symbol string)) 2))
1632
1633 (defun guess-package (string)
1634 "Guess which package corresponds to STRING.
1635 Return nil if no package matches."
1636 (or (find-package string)
1637 (parse-package string)
1638 (if (find #\! string) ; for SBCL
1639 (guess-package (substitute #\- #\! string)))))
1640
1641 (defvar *readtable-alist* (default-readtable-alist)
1642 "An alist mapping package names to readtables.")
1643
1644 (defun guess-buffer-readtable (package-name)
1645 (let ((package (guess-package package-name)))
1646 (or (and package
1647 (cdr (assoc (package-name package) *readtable-alist*
1648 :test #'string=)))
1649 *readtable*)))
1650
1651
1652 ;;;; Evaluation
1653
1654 (defvar *pending-continuations* '()
1655 "List of continuations for Emacs. (thread local)")
1656
1657 (defun guess-buffer-package (string)
1658 "Return a package for STRING.
1659 Fall back to the the current if no such package exists."
1660 (or (and string (guess-package string))
1661 *package*))
1662
1663 (defun eval-for-emacs (form buffer-package id)
1664 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
1665 Return the result to the continuation ID.
1666 Errors are trapped and invoke our debugger."
1667 (call-with-debugger-hook
1668 #'swank-debugger-hook
1669 (lambda ()
1670 (let (ok result)
1671 (unwind-protect
1672 (let ((*buffer-package* (guess-buffer-package buffer-package))
1673 (*buffer-readtable* (guess-buffer-readtable buffer-package))
1674 (*pending-continuations* (cons id *pending-continuations*)))
1675 (check-type *buffer-package* package)
1676 (check-type *buffer-readtable* readtable)
1677 ;; APPLY would be cleaner than EVAL.
1678 ;;(setq result (apply (car form) (cdr form)))
1679 (setq result (eval form))
1680 (run-hook *pre-reply-hook*)
1681 (finish-output)
1682 (setq ok t))
1683 (force-user-output)
1684 (send-to-emacs `(:return ,(current-thread)
1685 ,(if ok
1686 `(:ok ,result)
1687 `(:abort))
1688 ,id)))))))
1689
1690 (defvar *echo-area-prefix* "=> "
1691 "A prefix that `format-values-for-echo-area' should use.")
1692
1693 (defun format-values-for-echo-area (values)
1694 (with-buffer-syntax ()
1695 (let ((*print-readably* nil))
1696 (cond ((null values) "; No value")
1697 ((and (integerp (car values)) (null (cdr values)))
1698 (let ((i (car values)))
1699 (format nil "~A~D (#x~X, #o~O, #b~B)"
1700 *echo-area-prefix* i i i i)))
1701 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
1702
1703 (defslimefun interactive-eval (string)
1704 (with-buffer-syntax ()
1705 (let ((values (multiple-value-list (eval (from-string string)))))
1706 (fresh-line)
1707 (finish-output)
1708 (format-values-for-echo-area values))))
1709
1710 (defslimefun eval-and-grab-output (string)
1711 (with-buffer-syntax ()
1712 (let* ((s (make-string-output-stream))
1713 (*standard-output* s)
1714 (values (multiple-value-list (eval (from-string string)))))
1715 (list (get-output-stream-string s)
1716 (format nil "~{~S~^~%~}" values)))))
1717
1718 (defun eval-region (string)
1719 "Evaluate STRING.
1720 Return the results of the last form as a list and as secondary value the
1721 last form."
1722 (with-input-from-string (stream string)
1723 (let (- values)
1724 (loop
1725 (let ((form (read stream nil stream)))
1726 (when (eq form stream)
1727 (return (values values -)))
1728 (setq - form)
1729 (setq values (multiple-value-list (eval form)))
1730 (finish-output))))))
1731
1732 (defslimefun interactive-eval-region (string)
1733 (with-buffer-syntax ()
1734 (format-values-for-echo-area (eval-region string))))
1735
1736 (defslimefun re-evaluate-defvar (form)
1737 (with-buffer-syntax ()
1738 (let ((form (read-from-string form)))
1739 (destructuring-bind (dv name &optional value doc) form
1740 (declare (ignore value doc))
1741 (assert (eq dv 'defvar))
1742 (makunbound name)
1743 (prin1-to-string (eval form))))))
1744
1745 (defvar *swank-pprint-bindings*
1746 `((*print-pretty* . t)
1747 (*print-level* . nil)
1748 (*print-length* . nil)
1749 (*print-circle* . t)
1750 (*print-gensym* . t)
1751 (*print-readably* . nil))
1752 "A list of variables bindings during pretty printing.
1753 Used by pprint-eval.")
1754
1755 (defun swank-pprint (list)
1756 "Bind some printer variables and pretty print each object in LIST."
1757 (with-buffer-syntax ()
1758 (with-bindings *swank-pprint-bindings*
1759 (cond ((null list) "; No value")
1760 (t (with-output-to-string (*standard-output*)
1761 (dolist (o list)
1762 (pprint o)
1763 (terpri))))))))
1764
1765 (defslimefun pprint-eval (string)
1766 (with-buffer-syntax ()
1767 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1768
1769 (defslimefun set-package (name)
1770 "Set *package* to the package named NAME.
1771 Return the full package-name and the string to use in the prompt."
1772 (let ((p (guess-package name)))
1773 (assert (packagep p))
1774 (setq *package* p)
1775 (list (package-name p) (package-string-for-prompt p))))
1776
1777 ;;;;; Listener eval
1778
1779 (defvar *listener-eval-function* 'repl-eval)
1780
1781 (defslimefun listener-eval (string)
1782 (funcall *listener-eval-function* string))
1783
1784 (defvar *send-repl-results-function* 'send-repl-results-to-emacs)
1785
1786 (defun repl-eval (string)
1787 (clear-user-input)
1788 (with-buffer-syntax ()
1789 (track-package
1790 (lambda ()
1791 (multiple-value-bind (values last-form) (eval-region string)
1792 (setq *** ** ** * * (car values)
1793 /// // // / / values
1794 +++ ++ ++ + + last-form)
1795 (funcall *send-repl-results-function* values)))))
1796 nil)
1797
1798 (defun track-package (fun)
1799 (let ((p *package*))
1800 (unwind-protect (funcall fun)
1801 (unless (eq *package* p)
1802 (send-to-emacs (list :new-package (package-name *package*)
1803 (package-string-for-prompt *package*)))))))
1804
1805 (defun send-repl-results-to-emacs (values)
1806 (fresh-line)
1807 (finish-output)
1808 (if (null values)
1809 (send-to-emacs `(:write-string "; No value" :repl-result))
1810 (dolist (v values)
1811 (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
1812 :repl-result)))))
1813
1814 (defun cat (&rest strings)
1815 "Concatenate all arguments and make the result a string."
1816 (with-output-to-string (out)
1817 (dolist (s strings)
1818 (etypecase s
1819 (string (write-string s out))
1820 (character (write-char s out))))))
1821
1822 (defun package-string-for-prompt (package)
1823 "Return the shortest nickname (or canonical name) of PACKAGE."
1824 (unparse-name
1825 (or (canonical-package-nickname package)
1826 (auto-abbreviated-package-name package)
1827 (shortest-package-nickname package))))
1828
1829 (defun canonical-package-nickname (package)
1830 "Return the canonical package nickname, if any, of PACKAGE."
1831 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
1832 :test #'string=))))
1833 (and name (string name))))
1834
1835 (defun auto-abbreviated-package-name (package)
1836 "Return an abbreviated 'name' for PACKAGE.
1837
1838 N.B. this is not an actual package name or nickname."
1839 (when *auto-abbreviate-dotted-packages*
1840 (let ((last-dot (position #\. (package-name package) :from-end t)))
1841 (when last-dot (subseq (package-name package) (1+ last-dot))))))
1842
1843 (defun shortest-package-nickname (package)
1844 "Return the shortest nickname (or canonical name) of PACKAGE."
1845 (loop for name in (cons (package-name package) (package-nicknames package))
1846 for shortest = name then (if (< (length name) (length shortest))
1847 name
1848 shortest)
1849 finally (return shortest)))
1850
1851 (defslimefun ed-in-emacs (&optional what)
1852 "Edit WHAT in Emacs.
1853
1854 WHAT can be:
1855 A pathname or a string,
1856 A list (PATHNAME-OR-STRING LINE [COLUMN]),
1857 A function name (symbol or cons),
1858 NIL.
1859
1860 Returns true if it actually called emacs, or NIL if not."
1861 (flet ((pathname-or-string-p (thing)
1862 (or (pathnamep thing) (typep thing 'string))))
1863 (let ((target
1864 (cond ((and (listp what) (pathname-or-string-p (first what)))
1865 (cons (canonicalize-filename (car what)) (cdr what)))
1866 ((pathname-or-string-p what)
1867 (canonicalize-filename what))
1868 ((symbolp what) what)
1869 ((consp what) what)
1870 (t (return-from ed-in-emacs nil)))))
1871 (cond
1872 (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
1873 ((default-connection)
1874 (with-connection ((default-connection))
1875 (send-oob-to-emacs `(:ed ,target))))
1876 (t nil)))))
1877
1878 (defslimefun inspect-in-emacs (what)
1879 "Inspect WHAT in Emacs."
1880 (flet ((send-it ()
1881 (with-buffer-syntax ()
1882 (reset-inspector)
1883 (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
1884 (cond
1885 (*emacs-connection*
1886 (send-it))
1887 ((default-connection)
1888 (with-connection ((default-connection))
1889 (send-it))))
1890 what))
1891
1892 (defslimefun value-for-editing (form)
1893 "Return a readable value of FORM for editing in Emacs.
1894 FORM is expected, but not required, to be SETF'able."
1895 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
1896 (with-buffer-syntax ()
1897 (prin1-to-string (eval (read-from-string form)))))
1898
1899 (defslimefun commit-edited-value (form value)
1900 "Set the value of a setf'able FORM to VALUE.
1901 FORM and VALUE are both strings from Emacs."
1902 (with-buffer-syntax ()
1903 (eval `(setf ,(read-from-string form)
1904 ,(read-from-string (concatenate 'string "`" value))))
1905 t))
1906
1907 (defun background-message (format-string &rest args)
1908 "Display a message in Emacs' echo area.
1909
1910 Use this function for informative messages only. The message may even
1911 be dropped, if we are too busy with other things."
1912 (when *emacs-connection*
1913 (send-to-emacs `(:background-message
1914 ,(apply #'format nil format-string args)))))
1915
1916
1917 ;;;; Debugger
1918
1919 (defun swank-debugger-hook (condition hook)
1920 "Debugger function for binding *DEBUGGER-HOOK*.
1921 Sends a message to Emacs declaring that the debugger has been entered,
1922 then waits to handle further requests from Emacs. Eventually returns
1923 after Emacs causes a restart to be invoked."
1924 (declare (ignore hook))
1925 (cond (*emacs-connection*
1926 (debug-in-emacs condition))
1927 ((default-connection)
1928 (with-connection ((default-connection))
1929 (debug-in-emacs condition)))))
1930
1931 (defvar *global-debugger* t
1932 "Non-nil means the Swank debugger hook will be installed globally.")
1933
1934 (add-hook *new-connection-hook* 'install-debugger)
1935 (defun install-debugger (connection)
1936 (declare (ignore connection))
1937 (when *global-debugger*
1938 (install-debugger-globally #'swank-debugger-hook)))
1939
1940 ;;;;; Debugger loop
1941 ;;;
1942 ;;; These variables are dynamically bound during debugging.
1943 ;;;
1944 (defvar *swank-debugger-condition* nil
1945 "The condition being debugged.")
1946
1947 (defvar *sldb-level* 0
1948 "The current level of recursive debugging.")
1949
1950 (defvar *sldb-initial-frames* 20
1951 "The initial number of backtrace frames to send to Emacs.")
1952
1953 (defvar *sldb-restarts* nil
1954 "The list of currenlty active restarts.")
1955
1956 (defvar *sldb-stepping-p* nil
1957 "True during execution of a step command.")
1958
1959 (defun debug-in-emacs (condition)
1960 (let ((*swank-debugger-condition* condition)
1961 (*sldb-restarts* (compute-sane-restarts condition))
1962 (*package* (or (and (boundp '*buffer-package*)
1963 (symbol-value '*buffer-package*))
1964 *package*))
1965 (*sldb-level* (1+ *sldb-level*))
1966 (*sldb-stepping-p* nil)
1967 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
1968 (force-user-output)
1969 (call-with-debugging-environment
1970 (lambda ()
1971 (with-bindings *sldb-printer-bindings*
1972 (sldb-loop *sldb-level*))))))
1973
1974 (defun sldb-loop (level)
1975 (unwind-protect
1976 (catch 'sldb-enter-default-debugger
1977 (send-to-emacs
1978 (list* :debug (current-thread) level
1979 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
1980 (loop (catch 'sldb-loop-catcher
1981 (with-simple-restart (abort "Return to sldb level ~D." level)
1982 (send-to-emacs (list :debug-activate (current-thread)
1983 level))
1984 (handler-bind ((sldb-condition #'handle-sldb-condition))
1985 (read-from-emacs))))))
1986 (send-to-emacs `(:debug-return
1987 ,(current-thread) ,level ,*sldb-stepping-p*))))
1988
1989 (defun handle-sldb-condition (condition)
1990 "Handle an internal debugger condition.
1991 Rather than recursively debug the debugger (a dangerous idea!), these
1992 conditions are simply reported."
1993 (let ((real-condition (original-condition condition)))
1994 (send-to-emacs `(:debug-condition ,(current-thread)
1995 ,(princ-to-string real-condition))))
1996 (throw 'sldb-loop-catcher nil))
1997
1998 (defvar *sldb-condition-printer* #'format-sldb-condition
1999 "Function called to print a condition to an SLDB buffer.")
2000
2001 (defun safe-condition-message (condition)
2002 "Safely print condition to a string, handling any errors during
2003 printing."
2004 (let ((*print-pretty* t) (*print-right-margin* 65))
2005 (handler-case
2006 (funcall *sldb-condition-printer* condition)
2007 (error (cond)
2008 ;; Beware of recursive errors in printing, so only use the condition
2009 ;; if it is printable itself:
2010 (format nil "Unable to display error condition~@[: ~A~]"
2011 (ignore-errors (princ-to-string cond)))))))
2012
2013 (defun debugger-condition-for-emacs ()
2014 (list (safe-condition-message *swank-debugger-condition*)
2015 (format nil " [Condition of type ~S]"
2016 (type-of *swank-debugger-condition*))
2017 (condition-extras *swank-debugger-condition*)))
2018
2019 (defun format-restarts-for-emacs ()
2020 "Return a list of restarts for *swank-debugger-condition* in a
2021 format suitable for Emacs."
2022 (let ((*print-right-margin* most-positive-fixnum))
2023 (loop for restart in *sldb-restarts*
2024 collect (list (princ-to-string (restart-name restart))
2025 (princ-to-string restart)))))
2026
2027
2028 ;;;;; SLDB entry points
2029
2030 (defslimefun sldb-break-with-default-debugger ()
2031 "Invoke the default debugger by returning from our debugger-loop."
2032 (throw 'sldb-enter-default-debugger nil))
2033
2034 (defslimefun backtrace (start end)
2035 "Return a list ((I FRAME) ...) of frames from START to END.
2036 I is an integer describing and FRAME a string."
2037 (loop for frame in (compute-backtrace start end)
2038 for i from start
2039 collect (list i (with-output-to-string (stream)
2040 (handler-case
2041 (with-bindings *backtrace-printer-bindings*
2042 (print-frame frame stream))
2043 (t ()
2044 (format stream "[error printing frame]")))))))
2045
2046 (defslimefun debugger-info-for-emacs (start end)
2047 "Return debugger state, with stack frames from START to END.
2048 The result is a list:
2049 (condition ({restart}*) ({stack-frame}*) (cont*))
2050 where
2051 condition ::= (description type [extra])
2052 restart ::= (name description)
2053 stack-frame ::= (number description)
2054 extra ::= (:references and other random things)
2055 cont ::= continutation
2056 condition---a pair of strings: message, and type. If show-source is
2057 not nil it is a frame number for which the source should be displayed.
2058
2059 restart---a pair of strings: restart name, and description.
2060
2061 stack-frame---a number from zero (the top), and a printed
2062 representation of the frame's call.
2063
2064 continutation---the id of a pending Emacs continuation.
2065
2066 Below is an example return value. In this case the condition was a
2067 division by zero (multi-line description), and only one frame is being
2068 fetched (start=0, end=1).
2069
2070 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2071 Operation was KERNEL::DIVISION, operands (1 0).\"
2072 \"[Condition of type DIVISION-BY-ZERO]\")
2073 ((\"ABORT\" \"Return to Slime toplevel.\")
2074 (\"ABORT\" \"Return to Top-Level.\"))
2075 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
2076 (4))"
2077 (list (debugger-condition-for-emacs)
2078 (format-restarts-for-emacs)
2079 (backtrace start end)
2080 *pending-continuations*))
2081
2082 (defun nth-restart (index)
2083 (nth index *sldb-restarts*))
2084
2085 (defslimefun invoke-nth-restart (index)
2086 (invoke-restart-interactively (nth-restart index)))
2087
2088 (defslimefun sldb-abort ()
2089 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2090
2091 (defslimefun sldb-continue ()
2092 (continue))
2093
2094 (defslimefun throw-to-toplevel ()
2095 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2096 If we are not evaluating an RPC then ABORT instead."
2097 (let ((restart (find-restart *sldb-quit-restart*)))
2098 (cond (restart (invoke-restart restart))
2099 (t (format nil
2100 "Restart not found: ~a"
2101 *sldb-quit-restart*)))))
2102
2103 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2104 "Invoke the Nth available restart.
2105 SLDB-LEVEL is the debug level when the request was made. If this
2106 has changed, ignore the request."
2107 (when (= sldb-level *sldb-level*)
2108 (invoke-nth-restart n)))
2109
2110 (defun wrap-sldb-vars (form)
2111 `(let ((*sldb-level* ,*sldb-level*))
2112 ,form))
2113
2114 (defslimefun eval-string-in-frame (string index)
2115 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
2116 index)))
2117
2118 (defslimefun pprint-eval-string-in-frame (string index)
2119 (swank-pprint
2120 (multiple-value-list
2121 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
2122
2123 (defslimefun frame-locals-for-emacs (index)
2124 "Return a property list ((&key NAME ID VALUE) ...) describing
2125 the local variables in the frame INDEX."
2126 (with-bindings *backtrace-printer-bindings*
2127 (mapcar (lambda (frame-locals)
2128 (destructuring-bind (&key name id value) frame-locals
2129 (list :name (prin1-to-string name) :id id
2130 :value (to-string value))))
2131 (frame-locals index))))
2132
2133 (defslimefun frame-catch-tags-for-emacs (frame-index)
2134 (mapcar #'to-string (frame-catch-tags frame-index)))
2135
2136 (defslimefun sldb-disassemble (index)
2137 (with-output-to-string (*standard-output*)
2138 (disassemble-frame index)))
2139
2140 (defslimefun sldb-return-from-frame (index string)
2141 (let ((form (from-string string)))
2142 (to-string (multiple-value-list (return-from-frame index form)))))
2143
2144 (defslimefun sldb-break (name)
2145 (with-buffer-syntax ()
2146 (sldb-break-at-start (read-from-string name))))
2147
2148 (defmacro define-stepper-function (name backend-function-name)
2149 `(defslimefun ,name (frame)
2150 (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
2151 (setq *sldb-stepping-p* t)
2152 (,backend-function-name))
2153 ((find-restart 'continue)
2154 (activate-stepping frame)
2155 (setq *sldb-stepping-p* t)
2156 (continue))
2157 (t
2158 (error "Not currently single-stepping, and no continue restart available.")))))
2159
2160 (define-stepper-function sldb-step sldb-step-into)
2161 (define-stepper-function sldb-next sldb-step-next)
2162 (define-stepper-function sldb-out sldb-step-out)
2163
2164
2165 ;;;; Compilation Commands.
2166
2167 (defvar *compiler-notes* '()
2168 "List of compiler notes for the last compilation unit.")
2169
2170 (defun clear-compiler-notes ()
2171 (setf *compiler-notes* '()))
2172
2173 (defun canonicalize-filename (filename)
2174 (namestring (truename filename)))
2175
2176 (defslimefun compiler-notes-for-emacs ()
2177 "Return the list of compiler notes for the last compilation unit."
2178 (reverse *compiler-notes*))
2179
2180 (defun measure-time-interval (fn)
2181 "Call FN and return the first return value and the elapsed time.
2182 The time is measured in microseconds."
2183 (declare (type function fn))
2184 (let ((before (get-internal-real-time)))
2185 (values
2186 (funcall fn)
2187 (* (- (get-internal-real-time) before)
2188 (/ 1000000 internal-time-units-per-second)))))
2189
2190 (defun record-note-for-condition (condition)
2191 "Record a note for a compiler-condition."
2192 (push (make-compiler-note condition) *compiler-notes*))
2193
2194 (defun make-compiler-note (condition)
2195 "Make a compiler note data structure from a compiler-condition."
2196 (declare (type compiler-condition condition))
2197 (list* :message (message condition)
2198 :severity (severity condition)
2199 :location (location condition)
2200 :references (references condition)
2201 (let ((s (short-message condition)))
2202 (if s (list :short-message s)))))
2203
2204 (defun swank-compiler (function)
2205 (clear-compiler-notes)
2206 (multiple-value-bind (result usecs)
2207 (with-simple-restart (abort "Abort SLIME compilation.")
2208 (handler-bind ((compiler-condition #'record-note-for-condition))
2209 (measure-time-interval function)))
2210 ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
2211 ;; unfortunately the SWANK protocol doesn't support returning multiple
2212 ;; values, so we gotta convert it explicitely to a list in either case.
2213 (if (and (not result) (eq usecs 't))
2214 (list nil nil)
2215 (list (to-string result)
2216 (format nil "~,2F" (/ usecs 1000000.0))))))
2217
2218 (defslimefun compile-file-for-emacs (filename load-p)
2219 "Compile FILENAME and, when LOAD-P, load the result.
2220 Record compiler notes signalled as `compiler-condition's."
2221 (with-buffer-syntax ()
2222 (let ((*compile-print* nil))
2223 (swank-compiler
2224 (lambda ()
2225 (swank-compile-file filename load-p
2226 (or (guess-external-format filename)
2227 :default)))))))
2228
2229 (defslimefun compile-string-for-emacs (string buffer position directory)
2230 "Compile STRING (exerpted from BUFFER at POSITION).
2231 Record compiler notes signalled as `compiler-condition's."
2232 (with-buffer-syntax ()
2233 (swank-compiler
2234 (lambda ()
2235 (let ((*compile-print* nil) (*compile-verbose* t))
2236 (swank-compile-string string :buffer buffer :position position
2237 :directory directory))))))
2238
2239 (defun file-newer-p (new-file old-file)
2240 "Returns true if NEW-FILE is newer than OLD-FILE."
2241 (> (file-write-date new-file) (file-write-date old-file)))
2242
2243 (defun requires-compile-p (source-file)
2244 (let ((fasl-file (probe-file (compile-file-pathname source-file))))
2245 (or (not fasl-file)
2246 (file-newer-p source-file fasl-file))))
2247
2248 (defslimefun compile-file-if-needed (filename loadp)
2249 (cond ((requires-compile-p filename)
2250 (compile-file-for-emacs filename loadp))
2251 (loadp
2252 (load (compile-file-pathname filename))
2253 nil)))
2254
2255
2256 ;;;; Loading
2257
2258 (defslimefun load-file (filename)
2259 (to-string (load filename)))
2260
2261 (defslimefun load-file-set-package (filename &optional package)
2262 (load-file filename)
2263 (if package
2264 (set-package package)))
2265
2266
2267 ;;;;; swank-require
2268
2269 (defslimefun swank-require (modules &optional filename)
2270 "Load the module MODULE."
2271 (dolist (module (if (listp modules) modules (list modules)))
2272 (unless (member (string module) *modules* :test #'string=)
2273 (require module (or filename (module-filename module)))))
2274 *modules*)
2275
2276 (defvar *find-module* 'find-module
2277 "Pluggable function to locate modules.
2278 The function receives a module name as argument and should return
2279 the filename of the module (or nil if the file doesn't exist).")
2280
2281 (defun module-filename (module)
2282 "Return the filename for the module MODULE."
2283 (or (funcall *find-module* module)
2284 (error "Can't locate module: ~s" module)))
2285
2286 ;;;;;; Simple *find-module* function.
2287
2288 (defun merged-directory (dirname defaults)
2289 (pathname-directory
2290 (merge-pathnames
2291 (make-pathname :directory `(:relative ,dirname) :defaults defaults)
2292 defaults)))
2293
2294 (defvar *load-path*
2295 (list (make-pathname :directory (merged-directory "contrib" *load-truename*)
2296 :name nil :type nil :version nil
2297 :defaults *load-truename*))
2298 "A list of directories to search for modules.")
2299
2300 (defun module-canditates (name dir)
2301 (list (compile-file-pathname (make-pathname :name name :defaults dir))
2302 (make-pathname :name name :type "lisp" :defaults dir)))
2303
2304 (defun find-module (module)
2305 (let ((name (string-downcase module)))
2306 (some (lambda (dir) (some #'probe-file (module-canditates name dir)))
2307 *load-path*)))
2308
2309
2310 ;;;; Macroexpansion
2311
2312 (defvar *macroexpand-printer-bindings*
2313 '((*print-circle* . nil)
2314 (*print-pretty* . t)
2315 (*print-escape* . t)
2316 (*print-lines* . nil)
2317 (*print-level* . nil)
2318 (*print-length* . nil)))
2319
2320 (defun apply-macro-expander (expander string)
2321 (with-buffer-syntax ()
2322 (with-bindings *macroexpand-printer-bindings*
2323 (prin1-to-string (funcall expander (from-string string))))))
2324
2325 (defslimefun swank-macroexpand-1 (string)
2326 (apply-macro-expander #'macroexpand-1 string))
2327
2328 (defslimefun swank-macroexpand (string)
2329 (apply-macro-expander #'macroexpand string))
2330
2331 (defslimefun swank-macroexpand-all (string)
2332 (apply-macro-expander #'macroexpand-all string))
2333
2334 (defslimefun swank-compiler-macroexpand-1 (string)
2335 (apply-macro-expander #'compiler-macroexpand-1 string))
2336
2337 (defslimefun swank-compiler-macroexpand (string)
2338 (apply-macro-expander #'compiler-macroexpand string))
2339
2340 (defslimefun disassemble-symbol (name)
2341 (with-buffer-syntax ()
2342 (with-output-to-string (*standard-output*)
2343 (let ((*print-readably* nil))
2344 (disassemble (fdefinition (from-string name)))))))
2345
2346
2347 ;;;; Simple completion
2348
2349 (defslimefun simple-completions (string package)
2350 "Return a list of completions for the string STRING."
2351 (let ((strings (all-completions string package #'prefix-match-p)))
2352 (list strings (longest-common-prefix strings))))
2353
2354 (defun all-completions (string package test)
2355 (multiple-value-bind (name pname intern) (tokenize-symbol string)
2356 (let* ((extern (and pname (not intern)))
2357 (pack (cond ((equal pname "") keyword-package)
2358 ((not pname) (guess-buffer-package package))
2359 (t (guess-package pname))))
2360 (test (lambda (sym) (funcall test name (unparse-symbol sym))))
2361 (syms (and pack (matching-symbols pack extern test))))
2362 (format-completion-set (mapcar #'unparse-symbol syms) intern pname))))
2363
2364 (defun matching-symbols (package external test)
2365 (let ((test (if external
2366 (lambda (s)
2367 (and (symbol-external-p s package)
2368 (funcall test s)))
2369 test))
2370 (result '()))
2371 (do-symbols (s package)
2372 (when (funcall test s)
2373 (push s result)))
2374 (remove-duplicates result)))
2375
2376 (defun unparse-symbol (symbol)
2377 (let ((*print-case* (case (readtable-case *readtable*)
2378 (:downcase :upcase)
2379 (t :downcase))))
2380 (unparse-name (symbol-name symbol))))
2381
2382 (defun prefix-match-p (prefix string)
2383 "Return true if PREFIX is a prefix of STRING."
2384 (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
2385
2386 (defun longest-common-prefix (strings)
2387 "Return the longest string that is a common prefix of STRINGS."
2388 (if (null strings)
2389 ""
2390 (flet ((common-prefix (s1 s2)
2391 (let ((diff-pos (mismatch s1 s2)))
2392 (if diff-pos (subseq s1 0 diff-pos) s1))))
2393 (reduce #'common-prefix strings))))
2394
2395 (defun format-completion-set (strings internal-p package-name)
2396 "Format a set of completion strings.
2397 Returns a list of completions with package qualifiers if needed."
2398 (mapcar (lambda (string) (untokenize-symbol package-name internal-p string))
2399 (sort strings #'string<)))
2400
2401
2402 ;;;; Simple arglist display
2403
2404 (defslimefun operator-arglist (name package)
2405 (ignore-errors
2406 (let ((args (arglist (parse-symbol name (guess-buffer-package package))))
2407 (*print-escape* nil))
2408 (cond ((eq args :not-available) nil)
2409 (t (format nil "(~a ~/pprint-fill/)" name args))))))
2410
2411
2412 ;;;; Documentation
2413
2414 (defslimefun apropos-list-for-emacs (name &optional external-only
2415 case-sensitive package)
2416 "Make an apropos search for Emacs.
2417 The result is a list of property lists."
2418 (let ((package (if package
2419 (or (parse-package package)
2420 (error "No such package: ~S" package)))))
2421 ;; The MAPCAN will filter all uninteresting symbols, i.e. those
2422 ;; who cannot be meaningfully described.
2423 (mapcan (listify #'briefly-describe-symbol-for-emacs)
2424 (sort (remove-duplicates
2425 (apropos-symbols name external-only case-sensitive package))
2426 #'present-symbol-before-p))))
2427
2428 (defun briefly-describe-symbol-for-emacs (symbol)
2429 "Return a property list describing SYMBOL.
2430 Like `describe-symbol-for-emacs' but with at most one line per item."
2431 (flet ((first-line (string)
2432 (let ((pos (position #\newline string)))
2433 (if (null pos) string (subseq string 0 pos)))))
2434 (let ((desc (map-if #'stringp #'first-line
2435 (describe-symbol-for-emacs symbol))))
2436 (if desc
2437 (list* :designator (to-string symbol) desc)))))
2438
2439 (defun map-if (test fn &rest lists)
2440 "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
2441 Example:
2442 \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
2443 (apply #'mapcar
2444 (lambda (x) (if (funcall test x) (funcall fn x) x))
2445 lists))
2446
2447 (defun listify (f)
2448 "Return a function like F, but which returns any non-null value
2449 wrapped in a list."
2450 (lambda (x)
2451 (let ((y (funcall f x)))
2452 (and y (list y)))))
2453
2454 (defun present-symbol-before-p (x y)
2455 "Return true if X belongs before Y in a printed summary of symbols.
2456 Sorted alphabetically by package name and then symbol name, except
2457 that symbols accessible in the current package go first."
2458 (declare (type symbol x y))
2459 (flet ((accessible (s)
2460 ;; Test breaks on NIL for package that does not inherit it
2461 (eq (find-symbol (symbol-name s) *buffer-package*) s)))
2462 (let ((ax (accessible x)) (ay (accessible y)))
2463 (cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
2464 (ax t)
2465 (ay nil)
2466 (t (let ((px (symbol-package x)) (py (symbol-package y)))
2467 (if (eq px py)
2468 (string< (symbol-name x) (symbol-name y))
2469 (string< (package-name px) (package-name py)))))))))
2470
2471 (defun make-apropos-matcher (pattern case-sensitive)
2472 (let ((chr= (if case-sensitive #'char= #'char-equal)))
2473 (lambda (symbol)
2474 (search pattern (string symbol) :test chr=))))
2475
2476 (defun apropos-symbols (string external-only case-sensitive package)
2477 (let ((packages (or package (remove (find-package :keyword)
2478 (list-all-packages))))
2479 (matcher (make-apropos-matcher string case-sensitive))
2480 (result))
2481 (with-package-iterator (next packages :external :internal)
2482 (loop (multiple-value-bind (morep symbol) (next)
2483 (cond ((not morep) (return))
2484 ((and (if external-only (symbol-external-p symbol) t)
2485 (funcall matcher symbol))
2486 (push symbol result))))))
2487 result))
2488
2489 (defun call-with-describe-settings (fn)
2490 (let ((*print-readably* nil))
2491 (funcall fn)))
2492
2493 (defmacro with-describe-settings ((&rest _) &body body)
2494 (declare (ignore _))
2495 `(call-with-describe-settings (lambda () ,@body)))
2496
2497 (defun describe-to-string (object)
2498 (with-describe-settings ()
2499 (with-output-to-string (*standard-output*)
2500 (describe object))))
2501
2502 (defslimefun describe-symbol (symbol-name)
2503 (with-buffer-syntax ()
2504 (describe-to-string (parse-symbol-or-lose symbol-name))))
2505
2506 (defslimefun describe-function (name)
2507 (with-buffer-syntax ()
2508 (let ((symbol (parse-symbol-or-lose name)))
2509 (describe-to-string (or (macro-function symbol)
2510 (symbol-function symbol))))))
2511
2512 (defslimefun describe-definition-for-emacs (name kind)
2513 (with-buffer-syntax ()
2514 (with-describe-settings ()
2515 (with-output-to-string (*standard-output*)
2516 (describe-definition (parse-symbol-or-lose name) kind)))))
2517
2518 (defslimefun documentation-symbol (symbol-name &optional default)
2519 (with-buffer-syntax ()
2520 (multiple-value-bind (sym foundp) (parse-symbol symbol-name)
2521 (if foundp
2522 (let ((vdoc (documentation sym 'variable))
2523 (fdoc (documentation sym 'function)))
2524 (or (and (or vdoc fdoc)
2525 (concatenate 'string
2526 fdoc
2527 (and vdoc fdoc '(#\Newline #\Newline))
2528 vdoc))
2529 default))
2530 default))))
2531
2532
2533 ;;;; Package Commands
2534
2535 (defslimefun list-all-package-names (&optional nicknames)
2536 "Return a list of all package names.
2537 Include the nicknames if NICKNAMES is true."
2538 (mapcar #'unparse-name
2539 (if nicknames
2540 (mapcan #'package-names (list-all-packages))
2541 (mapcar #'package-name (list-all-packages)))))
2542
2543
2544 ;;;; Tracing
2545
2546 ;; Use eval for the sake of portability...
2547 (defun tracedp (fspec)
2548 (member fspec (eval '(trace))))
2549
2550 (defslimefun swank-toggle-trace (spec-string)
2551 (let ((spec (from-string spec-string)))
2552 (cond ((consp spec) ; handle complicated cases in the backend
2553 (toggle-trace spec))
2554 ((tracedp spec)
2555 (eval `(untrace ,spec))
2556 (format nil "~S is now untraced." spec))
2557 (t
2558 (eval `(trace ,spec))
2559 (format nil "~S is now traced." spec)))))
2560
2561 (defslimefun untrace-all ()
2562 (untrace))
2563
2564 (defslimefun redirect-trace-output (target)
2565 (setf (connection.trace-output *emacs-connection*)
2566 (make-output-stream-for-target *emacs-connection* target))
2567 nil)
2568
2569
2570 ;;;; Undefing
2571
2572 (defslimefun undefine-function (fname-string)
2573 (let ((fname (from-string fname-string)))
2574 (format nil "~S" (fmakunbound fname))))
2575
2576
2577 ;;;; Profiling
2578
2579 (defun profiledp (fspec)
2580 (member fspec (profiled-functions)))
2581
2582 (defslimefun toggle-profile-fdefinition (fname-string)
2583 (let ((fname (from-string fname-string)))
2584 (cond ((profiledp fname)
2585 (unprofile fname)
2586 (format nil "~S is now unprofiled." fname))
2587 (t
2588 (profile fname)
2589 (format nil "~S is now profiled." fname)))))
2590
2591
2592 ;;;; Source Locations
2593
2594 (defslimefun find-definitions-for-emacs (name)
2595 "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
2596 DSPEC is a string and LOCATION a source location. NAME is a string."
2597 (multiple-value-bind (sexp error)
2598 (ignore-errors (values (from-string name)))
2599 (unless error
2600 (loop for (dspec loc) in (find-definitions sexp)
2601 collect (list (to-string dspec) loc)))))
2602
2603 (defun alistify (list key test)
2604 "Partition the elements of LIST into an alist. KEY extracts the key
2605 from an element and TEST is used to compare keys."
2606 (declare (type function key))
2607 (let ((alist '()))
2608 (dolist (e list)
2609 (let* ((k (funcall key e))
2610 (probe (assoc k alist :test test)))
2611 (if probe
2612 (push e (cdr probe))
2613 (push (cons k (list e)) alist))))
2614 alist))
2615
2616 (defun location-position< (pos1 pos2)
2617 (cond ((and (position-p pos1) (position-p pos2))
2618 (< (position-pos pos1)
2619 (position-pos pos2)))
2620 (t nil)))
2621
2622 (defun partition (list test key)
2623 (declare (type function test key))
2624 (loop for e in list
2625 if (funcall test (funcall key e)) collect e into yes
2626 else collect e into no
2627 finally (return (values yes no))))
2628
2629 (defstruct (xref (:conc-name xref.)
2630 (:type list))
2631 dspec location)
2632
2633 (defun location-valid-p (location)
2634 (eq (car location) :location))
2635
2636 (defun xref-buffer (xref)
2637 (location-buffer (xref.location xref)))
2638
2639 (defun xref-position (xref)
2640 (location-buffer (xref.location xref)))
2641
2642 (defun group-xrefs (xrefs)
2643 "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
2644 The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
2645 (multiple-value-bind (resolved errors)
2646 (partition xrefs #'location-valid-p #'xref.location)
2647 (let ((alist (alistify resolved #'xref-buffer #'equal)))
2648 (append
2649 (loop for (buffer . list) in alist
2650 collect (cons (second buffer)
2651 (mapcar (lambda (xref)
2652 (cons (to-string (xref.dspec xref))
2653 (xref.location xref)))
2654 (sort list #'location-position<
2655 :key #'xref-position))))
2656 (if errors
2657 (list (cons "Unresolved"
2658 (mapcar (lambda (xref)
2659 (cons (to-string (xref.dspec xref))
2660 (xref.location xref)))
2661 errors))))))))
2662
2663 (defslimefun xref (type symbol-name)
2664 (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
2665 (group-xrefs
2666 (ecase type
2667 (:calls (who-calls symbol))
2668 (:calls-who (calls-who symbol))
2669 (:references (who-references symbol))
2670 (:binds (who-binds symbol))
2671 (:sets (who-sets symbol))
2672 (:macroexpands (who-macroexpands symbol))
2673 (:specializes (who-specializes symbol))
2674 (:callers (list-callers symbol))
2675 (:callees (list-callees symbol))))))
2676
2677
2678 ;;;; Inspecting
2679
2680 (defun common-seperated-spec (list &optional (callback (lambda (v)
2681 `(:value ,v))))
2682 (butlast
2683 (loop
2684 for i in list
2685 collect (funcall callback i)
2686 collect ", ")))
2687
2688 (defun inspector-princ (list)
2689 "Like princ-to-string, but don't rewrite (function foo) as #'foo.
2690 Do NOT pass circular lists to this function."
2691 (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
2692 (set-pprint-dispatch '(cons (member function)) nil)
2693 (princ-to-string list)))
2694
2695 (defmethod inspect-for-emacs ((object cons))
2696 (if (consp (cdr object))
2697 (inspect-for-emacs-list object)
2698 (inspect-for-emacs-simple-cons object)))
2699
2700 (defun inspect-for-emacs-simple-cons (cons)
2701 (values "A cons cell."
2702 (label-value-line*
2703 ('car (car cons))
2704 ('cdr (cdr cons)))))
2705
2706 (defun inspect-for-emacs-list (list)
2707 (let ((maxlen 40))
2708 (multiple-value-bind (length tail) (safe-length list)
2709 (flet ((frob (title list)
2710 (let (lines)
2711 (loop for i from 0 for rest on list do
2712 (if (consp (cdr rest)) ; e.g. (A . (B . ...))
2713 (push (label-value-line i (car rest)) lines)
2714 (progn ; e.g. (A . NIL) or (A . B)
2715 (push (label-value-line i (car rest) :newline nil) lines)
2716 (when (cdr rest)
2717 (push '((:newline)) lines)
2718 (push (label-value-line ':tail () :newline nil) lines))
2719 (loop-finish)))
2720 finally
2721 (setf lines (reduce #'append (nreverse lines) :from-end t)))
2722 (values title (append '("Elements:" (:newline)) lines)))))
2723
2724 (cond ((not length) ; circular
2725 (frob "A circular list."
2726 (cons (car list)
2727 (ldiff (cdr list) list))))
2728 ((and (<= length maxlen) (not tail))
2729 (frob "A proper list." list))
2730 (tail
2731 (frob "An improper list." list))
2732 (t
2733 (frob "A proper list." list)))))))
2734
2735 ;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
2736
2737 (defun safe-length (list)
2738 "Similar to `list-length', but avoid errors on improper lists.
2739 Return two values: the length of the list and the last cdr.
2740 NIL is returned if the list is circular."
2741 (do ((n 0 (+ n 2)) ;Counter.
2742 (fast list (cddr fast)) ;Fast pointer: leaps by 2.
2743 (slow list (cdr slow))) ;Slow pointer: leaps by 1.
2744 (nil)
2745 (cond ((null fast) (return (values n nil)))
2746 ((not (consp fast)) (return (values n fast)))
2747 ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
2748 ((and (eq fast slow) (> n 0)) (return nil))
2749 ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
2750
2751 (defvar *slime-inspect-contents-limit* nil "How many elements of
2752 a hash table or array to show by default. If table has more than
2753 this then offer actions to view more. Set to nil for no limit." )
2754
2755 (defmethod inspect-for-emacs ((ht hash-table))
2756 (values (prin1-to-string ht)
2757 (append
2758 (label-value-line*
2759 ("Count" (hash-table-count ht))