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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.543 - (show annotations)
Thu Apr 17 14:56:43 2008 UTC (6 years ago) by heller
Branch: MAIN
Changes since 1.542: +3 -2 lines
C-c C-c with prefix args now uses the maximal debug level.  (By Zach Beane.)
Only implemented for SBCL.

* slime.el (slime-compile-with-maximum-debug): New variable.
(slime-compile-defun, slime-compile-region): Use it.

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