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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.517 - (show annotations)
Sat Nov 24 08:04:27 2007 UTC (6 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.516: +4 -14 lines
* swank.lisp (parse-package): The old version didn't pass the
test-suite.  Now use the reader directly instead of emulating it
half-heartedly.

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