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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.514 - (show annotations)
Thu Nov 22 22:33:39 2007 UTC (6 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.513: +2 -1 lines
* swank.lisp (swank-require): Don't search the file if the
module-name is present in *modules*. That should avoid problems if
swank is included in a core file and moved to a different
location.  Reported by John Wiegley.
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* . 70))
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 (flet ((start-server-aux ()
586 (setup-server 0 (lambda (port)
587 (announce-server-port port-file port))
588 style dont-close
589 (find-external-format-or-lose coding-system))))
590 (if (eq style :spawn)
591 (initialize-multiprocessing #'start-server-aux)
592 (start-server-aux))))
593
594 (defun create-server (&key (port default-server-port)
595 (style *communication-style*)
596 (dont-close *dont-close*)
597 (coding-system *coding-system*))
598 "Start a SWANK server on PORT running in STYLE.
599 If DONT-CLOSE is true then the listen socket will accept multiple
600 connections, otherwise it will be closed after the first."
601 (setup-server port #'simple-announce-function style dont-close
602 (find-external-format-or-lose coding-system)))
603
604 (defun find-external-format-or-lose (coding-system)
605 (or (find-external-format coding-system)
606 (error "Unsupported coding system: ~s" coding-system)))
607
608 (defparameter *loopback-interface* "127.0.0.1")
609
610 (defun setup-server (port announce-fn style dont-close external-format)
611 (declare (type function announce-fn))
612 (let* ((socket (create-socket *loopback-interface* port))
613 (port (local-port socket)))
614 (funcall announce-fn port)
615 (flet ((serve ()
616 (serve-connection socket style dont-close external-format)))
617 (ecase style
618 (:spawn
619 (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))
620 :name "Swank"))
621 ((:fd-handler :sigio)
622 (add-fd-handler socket (lambda () (serve))))
623 ((nil) (loop do (serve) while dont-close)))
624 port)))
625
626 (defun serve-connection (socket style dont-close external-format)
627 (let ((closed-socket-p nil))
628 (unwind-protect
629 (let ((client (accept-authenticated-connection
630 socket :external-format external-format)))
631 (unless dont-close
632 (close-socket socket)
633 (setf closed-socket-p t))
634 (let ((connection (create-connection client style)))
635 (run-hook *new-connection-hook* connection)
636 (push connection *connections*)
637 (serve-requests connection)))
638 (unless (or dont-close closed-socket-p)
639 (close-socket socket)))))
640
641 (defun accept-authenticated-connection (&rest args)
642 (let ((new (apply #'accept-connection args))
643 (success nil))
644 (unwind-protect
645 (let ((secret (slime-secret)))
646 (when secret
647 (set-stream-timeout new 20)
648 (let ((first-val (decode-message new)))
649 (unless (and (stringp first-val) (string= first-val secret))
650 (error "Incoming connection doesn't know the password."))))
651 (set-stream-timeout new nil)
652 (setf success t))
653 (unless success
654 (close new :abort t)))
655 new))
656
657 (defun slime-secret ()
658 "Finds the magic secret from the user's home directory. Returns nil
659 if the file doesn't exist; otherwise the first line of the file."
660 (with-open-file (in
661 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
662 :if-does-not-exist nil)
663 (and in (read-line in nil ""))))
664
665 (defun serve-requests (connection)
666 "Read and process all requests on connections."
667 (funcall (connection.serve-requests connection) connection))
668
669 (defun announce-server-port (file port)
670 (with-open-file (s file
671 :direction :output
672 :if-exists :error
673 :if-does-not-exist :create)
674 (format s "~S~%" port))
675 (simple-announce-function port))
676
677 (defun simple-announce-function (port)
678 (when *swank-debug-p*
679 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
680 (force-output *log-output*)))
681
682 (defun open-streams (connection)
683 "Return the 5 streams for IO redirection:
684 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
685 (multiple-value-bind (output-fn dedicated-output)
686 (make-output-function connection)
687 (let ((input-fn
688 (lambda ()
689 (with-connection (connection)
690 (with-simple-restart (abort-read
691 "Abort reading input from Emacs.")
692 (read-user-input-from-emacs))))))
693 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
694 (let ((out (or dedicated-output out)))
695 (let ((io (make-two-way-stream in out)))
696 (mapc #'make-stream-interactive (list in out io))
697 (let ((repl-results
698 (make-output-stream-for-target connection :repl-result)))
699 (values dedicated-output in out io repl-results))))))))
700
701 (defun make-output-function (connection)
702 "Create function to send user output to Emacs.
703 This function may open a dedicated socket to send output. It
704 returns two values: the output function, and the dedicated
705 stream (or NIL if none was created)."
706 (if *use-dedicated-output-stream*
707 (let ((stream (open-dedicated-output-stream
708 (connection.socket-io connection))))
709 (values (lambda (string)
710 (write-string string stream)
711 (force-output stream))
712 stream))
713 (values (lambda (string)
714 (with-connection (connection)
715 (with-simple-restart
716 (abort "Abort sending output to Emacs.")
717 (send-to-emacs `(:write-string ,string)))))
718 nil)))
719
720 (defun make-output-function-for-target (connection target)
721 "Create a function to send user output to a specific TARGET in Emacs."
722 (lambda (string)
723 (with-connection (connection)
724 (with-simple-restart
725 (abort "Abort sending output to Emacs.")
726 (send-to-emacs `(:write-string ,string ,target))))))
727
728 (defun make-output-stream-for-target (connection target)
729 "Create a stream that sends output to a specific TARGET in Emacs."
730 (nth-value 1 (make-fn-streams
731 (lambda ()
732 (error "Should never be called"))
733 (make-output-function-for-target connection target))))
734
735 (defun open-dedicated-output-stream (socket-io)
736 "Open a dedicated output connection to the Emacs on SOCKET-IO.
737 Return an output stream suitable for writing program output.
738
739 This is an optimized way for Lisp to deliver output to Emacs."
740 (let ((socket (create-socket *loopback-interface*
741 *dedicated-output-stream-port*)))
742 (unwind-protect
743 (let ((port (local-port socket)))
744 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
745 (let ((dedicated (accept-authenticated-connection
746 socket
747 :external-format
748 (or (ignore-errors
749 (stream-external-format socket-io))
750 :default)
751 :buffering *dedicated-output-stream-buffering*
752 :timeout 30)))
753 (close-socket socket)
754 (setf socket nil)
755 dedicated))
756 (when socket
757 (close-socket socket)))))
758
759 (defvar *sldb-quit-restart* 'abort
760 "What restart should swank attempt to invoke when the user sldb-quits.")
761
762 (defun handle-request (connection)
763 "Read and process one request. The processing is done in the extent
764 of the toplevel restart."
765 (assert (null *swank-state-stack*))
766 (let ((*swank-state-stack* '(:handle-request)))
767 (with-connection (connection)
768 (with-simple-restart (abort "Return to SLIME's top level.")
769 (let ((*sldb-quit-restart* (find-restart 'abort)))
770 (read-from-emacs))))))
771
772 (defun current-socket-io ()
773 (connection.socket-io *emacs-connection*))
774
775 (defun close-connection (c &optional condition backtrace)
776 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
777 (let ((cleanup (connection.cleanup c)))
778 (when cleanup
779 (funcall cleanup c)))
780 (close (connection.socket-io c))
781 (when (connection.dedicated-output c)
782 (close (connection.dedicated-output c)))
783 (setf *connections* (remove c *connections*))
784 (run-hook *connection-closed-hook* c)
785 (when (and condition (not (typep condition 'end-of-file)))
786 (finish-output *log-output*)
787 (format *log-output* "~&;; Event history start:~%")
788 (dump-event-history *log-output*)
789 (format *log-output* ";; Event history end.~%~
790 ;; Backtrace:~%~{~A~%~}~
791 ;; Connection to Emacs lost. [~%~
792 ;; condition: ~A~%~
793 ;; type: ~S~%~
794 ;; encoding: ~A style: ~S dedicated: ~S]~%"
795 backtrace
796 (escape-non-ascii (safe-condition-message condition) )
797 (type-of condition)
798 (ignore-errors (stream-external-format (connection.socket-io c)))
799 (connection.communication-style c)
800 *use-dedicated-output-stream*)
801 (finish-output *log-output*)))
802
803 (defvar *debug-on-swank-error* nil
804 "When non-nil internal swank errors will drop to a
805 debugger (not an sldb buffer). Do not set this to T unless you
806 want to debug swank internals.")
807
808 (defmacro with-reader-error-handler ((connection) &body body)
809 (let ((con (gensym))
810 (blck (gensym)))
811 `(let ((,con ,connection))
812 (block ,blck
813 (handler-bind ((swank-error
814 (lambda (e)
815 (if *debug-on-swank-error*
816 (invoke-debugger e)
817 (return-from ,blck
818 (close-connection
819 ,con
820 (swank-error.condition e)
821 (swank-error.backtrace e)))))))
822 (progn ,@body))))))
823
824 (defslimefun simple-break ()
825 (with-simple-restart (continue "Continue from interrupt.")
826 (call-with-debugger-hook
827 #'swank-debugger-hook
828 (lambda ()
829 (invoke-debugger
830 (make-condition 'simple-error
831 :format-control "Interrupt from Emacs")))))
832 nil)
833
834 ;;;;;; Thread based communication
835
836 (defvar *active-threads* '())
837
838 (defun read-loop (control-thread input-stream connection)
839 (with-reader-error-handler (connection)
840 (loop (send control-thread (decode-message input-stream)))))
841
842 (defun dispatch-loop (socket-io connection)
843 (let ((*emacs-connection* connection))
844 (handler-bind ((error (lambda (e)
845 (if *debug-on-swank-error*
846 (invoke-debugger e)
847 (return-from dispatch-loop
848 (close-connection connection e))))))
849 (loop (dispatch-event (receive) socket-io)))))
850
851 (defun repl-thread (connection)
852 (let ((thread (connection.repl-thread connection)))
853 (when (not thread)
854 (log-event "ERROR: repl-thread is nil"))
855 (assert thread)
856 (cond ((thread-alive-p thread)
857 thread)
858 (t
859 (setf (connection.repl-thread connection)
860 (spawn-repl-thread connection "new-repl-thread"))))))
861
862 (defun find-worker-thread (id)
863 (etypecase id
864 ((member t)
865 (car *active-threads*))
866 ((member :repl-thread)
867 (repl-thread *emacs-connection*))
868 (fixnum
869 (find-thread id))))
870
871 (defun interrupt-worker-thread (id)
872 (let ((thread (or (find-worker-thread id)
873 (repl-thread *emacs-connection*))))
874 (interrupt-thread thread #'simple-break)))
875
876 (defun thread-for-evaluation (id)
877 "Find or create a thread to evaluate the next request."
878 (let ((c *emacs-connection*))
879 (etypecase id
880 ((member t)
881 (spawn-worker-thread c))
882 ((member :repl-thread)
883 (repl-thread c))
884 (fixnum
885 (find-thread id)))))
886
887 (defun spawn-worker-thread (connection)
888 (spawn (lambda ()
889 (with-bindings *default-worker-thread-bindings*
890 (handle-request connection)))
891 :name "worker"))
892
893 (defun spawn-repl-thread (connection name)
894 (spawn (lambda ()
895 (with-bindings *default-worker-thread-bindings*
896 (repl-loop connection)))
897 :name name))
898
899 (defun dispatch-event (event socket-io)
900 "Handle an event triggered either by Emacs or within Lisp."
901 (log-event "DISPATCHING: ~S~%" event)
902 (destructure-case event
903 ((:emacs-rex form package thread-id id)
904 (let ((thread (thread-for-evaluation thread-id)))
905 (push thread *active-threads*)
906 (send thread `(eval-for-emacs ,form ,package ,id))))
907 ((:return thread &rest args)
908 (let ((tail (member thread *active-threads*)))
909 (setq *active-threads* (nconc (ldiff *active-threads* tail)
910 (cdr tail))))
911 (encode-message `(:return ,@args) socket-io))
912 ((:emacs-interrupt thread-id)
913 (interrupt-worker-thread thread-id))
914 (((:debug :debug-condition :debug-activate :debug-return)
915 thread &rest args)
916 (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
917 ((:read-string thread &rest args)
918 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
919 ((:y-or-n-p thread &rest args)
920 (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
921 ((:read-aborted thread &rest args)
922 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
923 ((:emacs-return-string thread-id tag string)
924 (send (find-thread thread-id) `(take-input ,tag ,string)))
925 ((:eval thread &rest args)
926 (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
927 ((:emacs-return thread-id tag value)
928 (send (find-thread thread-id) `(take-input ,tag ,value)))
929 (((:write-string :presentation-start :presentation-end
930 :new-package :new-features :ed :%apply :indentation-update
931 :eval-no-wait :background-message :inspect)
932 &rest _)
933 (declare (ignore _))
934 (encode-message event socket-io))))
935
936 (defun spawn-threads-for-connection (connection)
937 (macrolet ((without-debugger-hook (&body body)
938 `(call-with-debugger-hook nil (lambda () ,@body))))
939 (let* ((socket-io (connection.socket-io connection))
940 (control-thread (spawn (lambda ()
941 (without-debugger-hook
942 (dispatch-loop socket-io connection)))
943 :name "control-thread")))
944 (setf (connection.control-thread connection) control-thread)
945 (let ((reader-thread (spawn (lambda ()
946 (let ((go (receive)))
947 (assert (eq go 'accept-input)))
948 (without-debugger-hook
949 (read-loop control-thread socket-io
950 connection)))
951 :name "reader-thread"))
952 (repl-thread (spawn-repl-thread connection "repl-thread")))
953 (setf (connection.repl-thread connection) repl-thread)
954 (setf (connection.reader-thread connection) reader-thread)
955 (send reader-thread 'accept-input)
956 connection))))
957
958 (defun cleanup-connection-threads (connection)
959 (let ((threads (list (connection.repl-thread connection)
960 (connection.reader-thread connection)
961 (connection.control-thread connection))))
962 (dolist (thread threads)
963 (when (and thread
964 (thread-alive-p thread)
965 (not (equal (current-thread) thread)))
966 (kill-thread thread)))))
967
968 (defun repl-loop (connection)
969 (loop (handle-request connection)))
970
971 (defun process-available-input (stream fn)
972 (loop while (input-available-p stream)
973 do (funcall fn)))
974
975 (defun input-available-p (stream)
976 ;; return true iff we can read from STREAM without waiting or if we
977 ;; hit EOF
978 (let ((c (read-char-no-hang stream nil :eof)))
979 (cond ((not c) nil)
980 ((eq c :eof) t)
981 (t
982 (unread-char c stream)
983 t))))
984
985 ;;;;;; Signal driven IO
986
987 (defun install-sigio-handler (connection)
988 (let ((client (connection.socket-io connection)))
989 (flet ((handler ()
990 (cond ((null *swank-state-stack*)
991 (with-reader-error-handler (connection)
992 (process-available-input
993 client (lambda () (handle-request connection)))))
994 ((eq (car *swank-state-stack*) :read-next-form))
995 (t (process-available-input client #'read-from-emacs)))))
996 (add-sigio-handler client #'handler)
997 (handler))))
998
999 (defun deinstall-sigio-handler (connection)
1000 (remove-sigio-handlers (connection.socket-io connection)))
1001
1002 ;;;;;; SERVE-EVENT based IO
1003
1004 (defun install-fd-handler (connection)
1005 (let ((client (connection.socket-io connection)))
1006 (flet ((handler ()
1007 (cond ((null *swank-state-stack*)
1008 (with-reader-error-handler (connection)
1009 (process-available-input
1010 client (lambda () (handle-request connection)))))
1011 ((eq (car *swank-state-stack*) :read-next-form))
1012 (t
1013 (process-available-input client #'read-from-emacs)))))
1014 ;;;; handle sigint
1015 ;;(install-debugger-globally
1016 ;; (lambda (c h)
1017 ;; (with-reader-error-handler (connection)
1018 ;; (block debugger
1019 ;; (with-connection (connection)
1020 ;; (swank-debugger-hook c h)
1021 ;; (return-from debugger))
1022 ;; (abort)))))
1023 (add-fd-handler client #'handler)
1024 (handler))))
1025
1026 (defun deinstall-fd-handler (connection)
1027 (remove-fd-handlers (connection.socket-io connection)))
1028
1029 ;;;;;; Simple sequential IO
1030
1031 (defun simple-serve-requests (connection)
1032 (unwind-protect
1033 (with-simple-restart (close-connection "Close SLIME connection")
1034 (with-reader-error-handler (connection)
1035 (loop
1036 (handle-request connection))))
1037 (close-connection connection)))
1038
1039 (defun read-from-socket-io ()
1040 (let ((event (decode-message (current-socket-io))))
1041 (log-event "DISPATCHING: ~S~%" event)
1042 (destructure-case event
1043 ((:emacs-rex form package thread id)
1044 (declare (ignore thread))
1045 `(eval-for-emacs ,form ,package ,id))
1046 ((:emacs-interrupt thread)
1047 (declare (ignore thread))
1048 '(simple-break))
1049 ((:emacs-return-string thread tag string)
1050 (declare (ignore thread))
1051 `(take-input ,tag ,string))
1052 ((:emacs-return thread tag value)
1053 (declare (ignore thread))
1054 `(take-input ,tag ,value)))))
1055
1056 (defun send-to-socket-io (event)
1057 (log-event "DISPATCHING: ~S~%" event)
1058 (flet ((send (o)
1059 (without-interrupts
1060 (encode-message o (current-socket-io)))))
1061 (destructure-case event
1062 (((:debug-activate :debug :debug-return :read-string :read-aborted
1063 :y-or-n-p :eval)
1064 thread &rest args)
1065 (declare (ignore thread))
1066 (send `(,(car event) 0 ,@args)))
1067 ((:return thread &rest args)
1068 (declare (ignore thread))
1069 (send `(:return ,@args)))
1070 (((:write-string :new-package :new-features :debug-condition
1071 :presentation-start :presentation-end
1072 :indentation-update :ed :%apply :eval-no-wait
1073 :background-message :inspect)
1074 &rest _)
1075 (declare (ignore _))
1076 (send event)))))
1077
1078 (defun initialize-streams-for-connection (connection)
1079 (multiple-value-bind (dedicated in out io repl-results)
1080 (open-streams connection)
1081 (setf (connection.dedicated-output connection) dedicated
1082 (connection.user-io connection) io
1083 (connection.user-output connection) out
1084 (connection.user-input connection) in
1085 (connection.repl-results connection) repl-results)
1086 connection))
1087
1088 (defun create-connection (socket-io style)
1089 (let ((success nil))
1090 (unwind-protect
1091 (let ((c (ecase style
1092 (:spawn
1093 (make-connection :socket-io socket-io
1094 :read #'read-from-control-thread
1095 :send #'send-to-control-thread
1096 :serve-requests #'spawn-threads-for-connection
1097 :cleanup #'cleanup-connection-threads))
1098 (:sigio
1099 (make-connection :socket-io socket-io
1100 :read #'read-from-socket-io
1101 :send #'send-to-socket-io
1102 :serve-requests #'install-sigio-handler
1103 :cleanup #'deinstall-sigio-handler))
1104 (:fd-handler
1105 (make-connection :socket-io socket-io
1106 :read #'read-from-socket-io
1107 :send #'send-to-socket-io
1108 :serve-requests #'install-fd-handler
1109 :cleanup #'deinstall-fd-handler))
1110 ((nil)
1111 (make-connection :socket-io socket-io
1112 :read #'read-from-socket-io
1113 :send #'send-to-socket-io
1114 :serve-requests #'simple-serve-requests)))))
1115 (setf (connection.communication-style c) style)
1116 (initialize-streams-for-connection c)
1117 (setf success t)
1118 c)
1119 (unless success
1120 (close socket-io :abort t)))))
1121
1122
1123 ;;;; IO to Emacs
1124 ;;;
1125 ;;; This code handles redirection of the standard I/O streams
1126 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1127 ;;; contains the appropriate streams, so all we have to do is make the
1128 ;;; right bindings.
1129
1130 ;;;;; Global I/O redirection framework
1131 ;;;
1132 ;;; Optionally, the top-level global bindings of the standard streams
1133 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1134 ;;; redirect the streams into the connection, and they keep going into
1135 ;;; that connection even if more are established. If the connection
1136 ;;; handling the streams closes then another is chosen, or if there
1137 ;;; are no connections then we revert to the original (real) streams.
1138 ;;;
1139 ;;; It is slightly tricky to assign the global values of standard
1140 ;;; streams because they are often shadowed by dynamic bindings. We
1141 ;;; solve this problem by introducing an extra indirection via synonym
1142 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1143 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1144 ;;; variables, so they can always be assigned to affect a global
1145 ;;; change.
1146
1147 (defvar *globally-redirect-io* nil
1148 "When non-nil globally redirect all standard streams to Emacs.")
1149
1150 ;;;;; Global redirection setup
1151
1152 (defvar *saved-global-streams* '()
1153 "A plist to save and restore redirected stream objects.
1154 E.g. the value for '*standard-output* holds the stream object
1155 for *standard-output* before we install our redirection.")
1156
1157 (defun setup-stream-indirection (stream-var &optional stream)
1158 "Setup redirection scaffolding for a global stream variable.
1159 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1160
1161 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1162
1163 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1164 *STANDARD-INPUT*.
1165
1166 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1167 *CURRENT-STANDARD-INPUT*.
1168
1169 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1170 effective global value for *STANDARD-INPUT*. This way we can assign
1171 the effective global value even when *STANDARD-INPUT* is shadowed by a
1172 dynamic binding."
1173 (let ((current-stream-var (prefixed-var '#:current stream-var))
1174 (stream (or stream (symbol-value stream-var))))
1175 ;; Save the real stream value for the future.
1176 (setf (getf *saved-global-streams* stream-var) stream)
1177 ;; Define a new variable for the effective stream.
1178 ;; This can be reassigned.
1179 (proclaim `(special ,current-stream-var))
1180 (set current-stream-var stream)
1181 ;; Assign the real binding as a synonym for the current one.
1182 (set stream-var (make-synonym-stream current-stream-var))))
1183
1184 (defun prefixed-var (prefix variable-symbol)
1185 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1186 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1187 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1188
1189 (defvar *standard-output-streams*
1190 '(*standard-output* *error-output* *trace-output*)
1191 "The symbols naming standard output streams.")
1192
1193 (defvar *standard-input-streams*
1194 '(*standard-input*)
1195 "The symbols naming standard input streams.")
1196
1197 (defvar *standard-io-streams*
1198 '(*debug-io* *query-io* *terminal-io*)
1199 "The symbols naming standard io streams.")
1200
1201 (defun init-global-stream-redirection ()
1202 (when *globally-redirect-io*
1203 (mapc #'setup-stream-indirection
1204 (append *standard-output-streams*
1205 *standard-input-streams*
1206 *standard-io-streams*))))
1207
1208 (add-hook *after-init-hook* 'init-global-stream-redirection)
1209
1210 (defun globally-redirect-io-to-connection (connection)
1211 "Set the standard I/O streams to redirect to CONNECTION.
1212 Assigns *CURRENT-<STREAM>* for all standard streams."
1213 (dolist (o *standard-output-streams*)
1214 (set (prefixed-var '#:current o)
1215 (connection.user-output connection)))
1216 ;; FIXME: If we redirect standard input to Emacs then we get the
1217 ;; regular Lisp top-level trying to read from our REPL.
1218 ;;
1219 ;; Perhaps the ideal would be for the real top-level to run in a
1220 ;; thread with local bindings for all the standard streams. Failing
1221 ;; that we probably would like to inhibit it from reading while
1222 ;; Emacs is connected.
1223 ;;
1224 ;; Meanwhile we just leave *standard-input* alone.
1225 #+NIL
1226 (dolist (i *standard-input-streams*)
1227 (set (prefixed-var '#:current i)
1228 (connection.user-input connection)))
1229 (dolist (io *standard-io-streams*)
1230 (set (prefixed-var '#:current io)
1231 (connection.user-io connection))))
1232
1233 (defun revert-global-io-redirection ()
1234 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1235 (dolist (stream-var (append *standard-output-streams*
1236 *standard-input-streams*
1237 *standard-io-streams*))
1238 (set (prefixed-var '#:current stream-var)
1239 (getf *saved-global-streams* stream-var))))
1240
1241 ;;;;; Global redirection hooks
1242
1243 (defvar *global-stdio-connection* nil
1244 "The connection to which standard I/O streams are globally redirected.
1245 NIL if streams are not globally redirected.")
1246
1247 (defun maybe-redirect-global-io (connection)
1248 "Consider globally redirecting to a newly-established CONNECTION."
1249 (when (and *globally-redirect-io* (null *global-stdio-connection*))
1250 (setq *global-stdio-connection* connection)
1251 (globally-redirect-io-to-connection connection)))
1252
1253 (defun update-redirection-after-close (closed-connection)
1254 "Update redirection after a connection closes."
1255 (check-type closed-connection connection)
1256 (when (eq *global-stdio-connection* closed-connection)
1257 (if (and (default-connection) *globally-redirect-io*)
1258 ;; Redirect to another connection.
1259 (globally-redirect-io-to-connection (default-connection))
1260 ;; No more connections, revert to the real streams.
1261 (progn (revert-global-io-redirection)
1262 (setq *global-stdio-connection* nil)))))
1263
1264 (add-hook *new-connection-hook* 'maybe-redirect-global-io)
1265 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1266
1267 ;;;;; Redirection during requests
1268 ;;;
1269 ;;; We always redirect the standard streams to Emacs while evaluating
1270 ;;; an RPC. This is done with simple dynamic bindings.
1271
1272 (defun call-with-redirected-io (connection function)
1273 "Call FUNCTION with I/O streams redirected via CONNECTION."
1274 (declare (type function function))
1275 (let* ((io (connection.user-io connection))
1276 (in (connection.user-input connection))
1277 (out (connection.user-output connection))
1278 (trace (or (connection.trace-output connection) out))
1279 (*standard-output* out)
1280 (*error-output* out)
1281 (*trace-output* trace)
1282 (*debug-io* io)
1283 (*query-io* io)
1284 (*standard-input* in)
1285 (*terminal-io* io))
1286 (funcall function)))
1287
1288 (defun read-from-emacs ()
1289 "Read and process a request from Emacs."
1290 (apply #'funcall (funcall (connection.read *emacs-connection*))))
1291
1292 (defun read-from-control-thread ()
1293 (receive))
1294
1295 (defun decode-message (stream)
1296 "Read an S-expression from STREAM using the SLIME protocol."
1297 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1298 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1299 (let* ((length (decode-message-length stream))
1300 (string (make-string length))
1301 (pos (read-sequence string stream)))
1302 (assert (= pos length) ()
1303 "Short read: length=~D pos=~D" length pos)
1304 (log-event "READ: ~S~%" string)
1305 (read-form string)))))
1306
1307 (defun decode-message-length (stream)
1308 (let ((buffer (make-string 6)))
1309 (dotimes (i 6)
1310 (setf (aref buffer i) (read-char stream)))
1311 (parse-integer buffer :radix #x10)))
1312
1313 (defun read-form (string)
1314 (with-standard-io-syntax
1315 (let ((*package* *swank-io-package*))
1316 (read-from-string string))))
1317
1318 (defvar *slime-features* nil
1319 "The feature list that has been sent to Emacs.")
1320
1321 (defun send-to-emacs (object)
1322 "Send OBJECT to Emacs."
1323 (funcall (connection.send *emacs-connection*) object))
1324
1325 (defun send-oob-to-emacs (object)
1326 (send-to-emacs object))
1327
1328 (defun send-to-control-thread (object)
1329 (send (connection.control-thread *emacs-connection*) object))
1330
1331 (defun encode-message (message stream)
1332 (let* ((string (prin1-to-string-for-emacs message))
1333 (length (length string)))
1334 (log-event "WRITE: ~A~%" string)
1335 (let ((*print-pretty* nil))
1336 (format stream "~6,'0x" length))
1337 (write-string string stream)
1338 ;;(terpri stream)
1339 (finish-output stream)))
1340
1341 (defun prin1-to-string-for-emacs (object)
1342 (with-standard-io-syntax
1343 (let ((*print-case* :downcase)
1344 (*print-readably* nil)
1345 (*print-pretty* nil)
1346 (*package* *swank-io-package*))
1347 (prin1-to-string object))))
1348
1349 (defun force-user-output ()
1350 (force-output (connection.user-io *emacs-connection*))
1351 (finish-output (connection.user-output *emacs-connection*)))
1352
1353 (defun clear-user-input ()
1354 (clear-input (connection.user-input *emacs-connection*)))
1355
1356 (defvar *read-input-catch-tag* 0)
1357
1358 (defun intern-catch-tag (tag)
1359 ;; fixnums aren't eq in ABCL, so we use intern to create tags
1360 (intern (format nil "~D" tag) :swank))
1361
1362 (defun read-user-input-from-emacs ()
1363 (let ((tag (incf *read-input-catch-tag*)))
1364 (force-output)
1365 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1366 (let ((ok nil))
1367 (unwind-protect
1368 (prog1 (catch (intern-catch-tag tag)
1369 (loop (read-from-emacs)))
1370 (setq ok t))
1371 (unless ok
1372 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1373
1374 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1375 "Like y-or-n-p, but ask in the Emacs minibuffer."
1376 (let ((tag (incf *read-input-catch-tag*))
1377 (question (apply #'format nil format-string arguments)))
1378 (force-output)
1379 (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1380 (catch (intern-catch-tag tag)
1381 (loop (read-from-emacs)))))
1382
1383 (defslimefun take-input (tag input)
1384 "Return the string INPUT to the continuation TAG."
1385 (throw (intern-catch-tag tag) input))
1386
1387 (defun process-form-for-emacs (form)
1388 "Returns a string which emacs will read as equivalent to
1389 FORM. FORM can contain lists, strings, characters, symbols and
1390 numbers.
1391
1392 Characters are converted emacs' ?<char> notaion, strings are left
1393 as they are (except for espacing any nested \" chars, numbers are
1394 printed in base 10 and symbols are printed as their symbol-name
1395 converted to lower case."
1396 (etypecase form
1397 (string (format nil "~S" form))
1398 (cons (format nil "(~A . ~A)"
1399 (process-form-for-emacs (car form))
1400 (process-form-for-emacs (cdr form))))
1401 (character (format nil "?~C" form))
1402 (symbol (concatenate 'string (when (eq (symbol-package form)
1403 #.(find-package "KEYWORD"))
1404 ":")
1405 (string-downcase (symbol-name form))))
1406 (number (let ((*print-base* 10))
1407 (princ-to-string form)))))
1408
1409 (defun eval-in-emacs (form &optional nowait)
1410 "Eval FORM in Emacs."
1411 (cond (nowait
1412 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1413 (t
1414 (force-output)
1415 (let* ((tag (incf *read-input-catch-tag*))
1416 (value (catch (intern-catch-tag tag)
1417 (send-to-emacs
1418 `(:eval ,(current-thread) ,tag
1419 ,(process-form-for-emacs form)))
1420 (loop (read-from-emacs)))))
1421 (destructure-case value
1422 ((:ok value) value)
1423 ((:abort) (abort)))))))
1424
1425 (defvar *swank-wire-protocol-version* nil
1426 "The version of the swank/slime communication protocol.")
1427
1428 (defslimefun connection-info ()
1429 "Return a key-value list of the form:
1430 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1431 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1432 STYLE: the communication style
1433 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1434 FEATURES: a list of keywords
1435 PACKAGE: a list (&key NAME PROMPT)
1436 VERSION: the protocol version"
1437 (setq *slime-features* *features*)
1438 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1439 :lisp-implementation (:type ,(lisp-implementation-type)
1440 :name ,(lisp-implementation-type-name)
1441 :version ,(lisp-implementation-version))
1442 :machine (:instance ,(machine-instance)
1443 :type ,(machine-type)
1444 :version ,(machine-version))
1445 :features ,(features-for-emacs)
1446 :package (:name ,(package-name *package*)
1447 :prompt ,(package-string-for-prompt *package*))
1448 :version ,*swank-wire-protocol-version*))
1449
1450 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1451 (let* ((s *standard-output*)
1452 (*trace-output* (make-broadcast-stream s *log-output*)))
1453 (time (progn
1454 (dotimes (i n)
1455 (format s "~D abcdefghijklm~%" i)
1456 (when (zerop (mod n m))
1457 (force-output s)))
1458 (finish-output s)
1459 (when *emacs-connection*
1460 (eval-in-emacs '(message "done.")))))
1461 (terpri *trace-output*)
1462 (finish-output *trace-output*)
1463 nil))
1464
1465
1466 ;;;; Reading and printing
1467
1468 (defmacro define-special (name doc)
1469 "Define a special variable NAME with doc string DOC.
1470 This is like defvar, but NAME will not be initialized."
1471 `(progn
1472 (defvar ,name)
1473 (setf (documentation ',name 'variable) ,doc)))
1474
1475 (define-special *buffer-package*
1476 "Package corresponding to slime-buffer-package.
1477
1478 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1479 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1480
1481 (define-special *buffer-readtable*
1482 "Readtable associated with the current buffer")
1483
1484 (defmacro with-buffer-syntax ((&rest _) &body body)
1485 "Execute BODY with appropriate *package* and *readtable* bindings.
1486
1487 This should be used for code that is conceptionally executed in an
1488 Emacs buffer."
1489 (destructuring-bind () _
1490 `(call-with-buffer-syntax (lambda () ,@body))))
1491
1492 (defun call-with-buffer-syntax (fun)
1493 (let ((*package* *buffer-package*))
1494 ;; Don't shadow *readtable* unnecessarily because that prevents
1495 ;; the user from assigning to it.
1496 (if (eq *readtable* *buffer-readtable*)
1497 (call-with-syntax-hooks fun)
1498 (let ((*readtable* *buffer-readtable*))
1499 (call-with-syntax-hooks fun)))))
1500
1501 (defun to-string (object)
1502 "Write OBJECT in the *BUFFER-PACKAGE*.
1503 The result may not be readable. Handles problems with PRINT-OBJECT methods
1504 gracefully."
1505 (with-buffer-syntax ()
1506 (let ((*print-readably* nil))
1507 (handler-case
1508 (prin1-to-string object)
1509 (error ()
1510 (with-output-to-string (s)
1511 (print-unreadable-object (object s :type t :identity t)
1512 (princ "<<error printing object>>" s))))))))
1513
1514 (defun from-string (string)
1515 "Read string in the *BUFFER-PACKAGE*"
1516 (with-buffer-syntax ()
1517 (let ((*read-suppress* nil))
1518 (read-from-string string))))
1519
1520 (defun read-softly-from-string (string)
1521 "Returns three values:
1522
1523 1. the object resulting from READing STRING.
1524
1525 2. The index of the first character in STRING that was not read.
1526
1527 3. T if the object is a symbol that had to be newly interned
1528 in some package. (This does not work for symbols in
1529 compound forms like lists or vectors.)"
1530 (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string)
1531 (if found?
1532 (values symbol nil)
1533 (multiple-value-bind (sexp pos) (read-from-string string)
1534 (values sexp pos
1535 (when (symbolp sexp)
1536 (prog1 t
1537 ;; assert that PARSE-SYMBOL didn't parse incorrectly.
1538 (assert (and (equal symbol-name (symbol-name sexp))
1539 (eq package (symbol-package sexp)))))))))))
1540
1541 (defun unintern-in-home-package (symbol)
1542 (unintern symbol (symbol-package symbol)))
1543
1544 ;; FIXME: deal with #\| etc. hard to do portably.
1545 (defun tokenize-symbol (string)
1546 "STRING is interpreted as the string representation of a symbol
1547 and is tokenized accordingly. The result is returned in three
1548 values: The package identifier part, the actual symbol identifier
1549 part, and a flag if the STRING represents a symbol that is
1550 internal to the package identifier part. (Notice that the flag is
1551 also true with an empty package identifier part, as the STRING is
1552 considered to represent a symbol internal to some current package.)"
1553 (let ((package (let ((pos (position #\: string)))
1554 (if pos (subseq string 0 pos) nil)))
1555 (symbol (let ((pos (position #\: string :from-end t)))
1556 (if pos (subseq string (1+ pos)) string)))
1557 (internp (not (= (count #\: string) 1))))
1558 (values symbol package internp)))
1559
1560 (defun tokenize-symbol-thoroughly (string)
1561 "This version of TOKENIZE-SYMBOL handles escape characters."
1562 (let ((package nil)
1563 (token (make-array (length string) :element-type 'character
1564 :fill-pointer 0))
1565 (backslash nil)
1566 (vertical nil)
1567 (internp nil))
1568 (loop for char across string
1569 do (cond
1570 (backslash
1571 (vector-push-extend char token)
1572 (setq backslash nil))
1573 ((char= char #\\) ; Quotes next character, even within |...|
1574 (setq backslash t))
1575 ((char= char #\|)
1576 (setq vertical t))
1577 (vertical
1578 (vector-push-extend char token))
1579 ((char= char #\:)
1580 (if package
1581 (setq internp t)
1582 (setq package token
1583 token (make-array (length string)
1584 :element-type 'character
1585 :fill-pointer 0))))
1586 (t
1587 (vector-push-extend (casify-char char) token))))
1588 (values token package (or (not package) internp))))
1589
1590 (defun untokenize-symbol (package-name internal-p symbol-name)
1591 "The inverse of TOKENIZE-SYMBOL.
1592
1593 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1594 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1595 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1596 "
1597 (cond ((not package-name) symbol-name)
1598 (internal-p (cat package-name "::" symbol-name))
1599 (t (cat package-name ":" symbol-name))))
1600
1601 (defun casify-char (char)
1602 "Convert CHAR accoring to readtable-case."
1603 (ecase (readtable-case *readtable*)
1604 (:preserve char)
1605 (:upcase (char-upcase char))
1606 (:downcase (char-downcase char))
1607 (:invert (if (upper-case-p char)
1608 (char-downcase char)
1609 (char-upcase char)))))
1610
1611 (defun parse-symbol (string &optional (package *package*))
1612 "Find the symbol named STRING.
1613 Return the symbol and a flag indicating whether the symbols was found."
1614 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1615 (let ((package (cond ((string= pname "") keyword-package)
1616 (pname (find-package pname))
1617 (t package))))
1618 (if package
1619 (multiple-value-bind (symbol flag) (find-symbol sname package)
1620 (values symbol flag sname package))
1621 (values nil nil nil nil)))))
1622
1623 (defun parse-symbol-or-lose (string &optional (package *package*))
1624 (multiple-value-bind (symbol status) (parse-symbol string package)
1625 (if status
1626 (values symbol status)
1627 (error "Unknown symbol: ~A [in ~A]" string package))))
1628
1629 (defun parse-package (string)
1630 "Find the package named STRING.
1631 Return the package or nil."
1632 (check-type string (or string null))
1633 (if (zerop (length string))
1634 nil
1635 (multiple-value-bind (name pos interned?)
1636 (let ((*package* *swank-io-package*))
1637 (ignore-errors (read-softly-from-string string)))
1638 (unwind-protect
1639 (and name
1640 (or (symbolp name)
1641 (stringp name))
1642 (= (length string) pos)
1643 (find-package name))
1644 (when interned?
1645 (unintern-in-home-package name))))))
1646
1647 (defun unparse-name (string)
1648 "Print the name STRING according to the current printer settings."
1649 ;; this is intended for package or symbol names
1650 (subseq (prin1-to-string (make-symbol string)) 2))
1651
1652 (defun guess-package (string)
1653 "Guess which package corresponds to STRING.
1654 Return nil if no package matches."
1655 (or (find-package string)
1656 (parse-package string)
1657 (if (find #\! string) ; for SBCL
1658 (guess-package (substitute #\- #\! string)))))
1659
1660 (defvar *readtable-alist* (default-readtable-alist)
1661 "An alist mapping package names to readtables.")
1662
1663 (defun guess-buffer-readtable (package-name)
1664 (let ((package (guess-package package-name)))
1665 (or (and package
1666 (cdr (assoc (package-name package) *readtable-alist*
1667 :test #'string=)))
1668 *readtable*)))
1669
1670
1671 ;;;; Evaluation
1672
1673 (defvar *pending-continuations* '()
1674 "List of continuations for Emacs. (thread local)")
1675
1676 (defun guess-buffer-package (string)
1677 "Return a package for STRING.
1678 Fall back to the the current if no such package exists."
1679 (or (and string (guess-package string))
1680 *package*))
1681
1682 (defun eval-for-emacs (form buffer-package id)
1683 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
1684 Return the result to the continuation ID.
1685 Errors are trapped and invoke our debugger."
1686 (call-with-debugger-hook
1687 #'swank-debugger-hook
1688 (lambda ()
1689 (let (ok result)
1690 (unwind-protect
1691 (let ((*buffer-package* (guess-buffer-package buffer-package))
1692 (*buffer-readtable* (guess-buffer-readtable buffer-package))
1693 (*pending-continuations* (cons id *pending-continuations*)))
1694 (check-type *buffer-package* package)
1695 (check-type *buffer-readtable* readtable)
1696 ;; APPLY would be cleaner than EVAL.
1697 ;;(setq result (apply (car form) (cdr form)))
1698 (setq result (eval form))
1699 (run-hook *pre-reply-hook*)
1700 (finish-output)
1701 (setq ok t))
1702 (force-user-output)
1703 (send-to-emacs `(:return ,(current-thread)
1704 ,(if ok
1705 `(:ok ,result)
1706 `(:abort))
1707 ,id)))))))
1708
1709 (defvar *echo-area-prefix* "=> "
1710 "A prefix that `format-values-for-echo-area' should use.")
1711
1712 (defun format-values-for-echo-area (values)
1713 (with-buffer-syntax ()
1714 (let ((*print-readably* nil))
1715 (cond ((null values) "; No value")
1716 ((and (length= values 1) (integerp (car values)))
1717 (let ((i (car values)))
1718 (format nil "~A~D (#x~X, #o~O, #b~B)"
1719 *echo-area-prefix* i i i i)))
1720 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
1721
1722 (defslimefun interactive-eval (string)
1723 (with-buffer-syntax ()
1724 (let ((values (multiple-value-list (eval (from-string string)))))
1725 (fresh-line)
1726 (finish-output)
1727 (format-values-for-echo-area values))))
1728
1729 (defslimefun eval-and-grab-output (string)
1730 (with-buffer-syntax ()
1731 (let* ((s (make-string-output-stream))
1732 (*standard-output* s)
1733 (values (multiple-value-list (eval (from-string string)))))
1734 (list (get-output-stream-string s)
1735 (format nil "~{~S~^~%~}" values)))))
1736
1737 (defun eval-region (string)
1738 "Evaluate STRING.
1739 Return the results of the last form as a list and as secondary value the
1740 last form."
1741 (with-input-from-string (stream string)
1742 (let (- values)
1743 (loop
1744 (let ((form (read stream nil stream)))
1745 (when (eq form stream)
1746 (return (values values -)))
1747 (setq - form)
1748 (setq values (multiple-value-list (eval form)))
1749 (finish-output))))))
1750
1751 (defslimefun interactive-eval-region (string)
1752 (with-buffer-syntax ()
1753 (format-values-for-echo-area (eval-region string))))
1754
1755 (defslimefun re-evaluate-defvar (form)
1756 (with-buffer-syntax ()
1757 (let ((form (read-from-string form)))
1758 (destructuring-bind (dv name &optional value doc) form
1759 (declare (ignore value doc))
1760 (assert (eq dv 'defvar))
1761 (makunbound name)
1762 (prin1-to-string (eval form))))))
1763
1764 (defvar *swank-pprint-bindings*
1765 `((*print-pretty* . t)
1766 (*print-level* . nil)
1767 (*print-length* . nil)
1768 (*print-circle* . t)
1769 (*print-gensym* . t)
1770 (*print-readably* . nil))
1771 "A list of variables bindings during pretty printing.
1772 Used by pprint-eval.")
1773
1774 (defun swank-pprint (list)
1775 "Bind some printer variables and pretty print each object in LIST."
1776 (with-buffer-syntax ()
1777 (with-bindings *swank-pprint-bindings*
1778 (cond ((null list) "; No value")
1779 (t (with-output-to-string (*standard-output*)
1780 (dolist (o list)
1781 (pprint o)
1782 (terpri))))))))
1783
1784 (defslimefun pprint-eval (string)
1785 (with-buffer-syntax ()
1786 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1787
1788 (defslimefun set-package (name)
1789 "Set *package* to the package named NAME.
1790 Return the full package-name and the string to use in the prompt."
1791 (let ((p (guess-package name)))
1792 (assert (packagep p))
1793 (setq *package* p)
1794 (list (package-name p) (package-string-for-prompt p))))
1795
1796 ;;;;; Listener eval
1797
1798 (defvar *listener-eval-function* 'repl-eval)
1799
1800 (defslimefun listener-eval (string)
1801 (funcall *listener-eval-function* string))
1802
1803 (defvar *send-repl-results-function* 'send-repl-results-to-emacs)
1804
1805 (defun repl-eval (string)
1806 (clear-user-input)
1807 (with-buffer-syntax ()
1808 (track-package
1809 (lambda ()
1810 (multiple-value-bind (values last-form) (eval-region string)
1811 (setq *** ** ** * * (car values)
1812 /// // // / / values
1813 +++ ++ ++ + + last-form)
1814 (funcall *send-repl-results-function* values)))))
1815 nil)
1816
1817 (defun track-package (fun)
1818 (let ((p *package*))
1819 (unwind-protect (funcall fun)
1820 (unless (eq *package* p)
1821 (send-to-emacs (list :new-package (package-name *package*)
1822 (package-string-for-prompt *package*)))))))
1823
1824 (defun send-repl-results-to-emacs (values)
1825 (fresh-line)
1826 (finish-output)
1827 (if (null values)
1828 (send-to-emacs `(:write-string "; No value" :repl-result))
1829 (dolist (v values)
1830 (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
1831 :repl-result)))))
1832
1833 (defun cat (&rest strings)
1834 "Concatenate all arguments and make the result a string."
1835 (with-output-to-string (out)
1836 (dolist (s strings)
1837 (etypecase s
1838 (string (write-string s out))
1839 (character (write-char s out))))))
1840
1841 (defun package-string-for-prompt (package)
1842 "Return the shortest nickname (or canonical name) of PACKAGE."
1843 (unparse-name
1844 (or (canonical-package-nickname package)
1845 (auto-abbreviated-package-name package)
1846 (shortest-package-nickname package))))
1847
1848 (defun canonical-package-nickname (package)
1849 "Return the canonical package nickname, if any, of PACKAGE."
1850 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
1851 :test #'string=))))
1852 (and name (string name))))
1853
1854 (defun auto-abbreviated-package-name (package)
1855 "Return an abbreviated 'name' for PACKAGE.
1856
1857 N.B. this is not an actual package name or nickname."
1858 (when *auto-abbreviate-dotted-packages*
1859 (let ((last-dot (position #\. (package-name package) :from-end t)))
1860 (when last-dot (subseq (package-name package) (1+ last-dot))))))
1861
1862 (defun shortest-package-nickname (package)
1863 "Return the shortest nickname (or canonical name) of PACKAGE."
1864 (loop for name in (cons (package-name package) (package-nicknames package))
1865 for shortest = name then (if (< (length name) (length shortest))
1866 name
1867 shortest)
1868 finally (return shortest)))
1869
1870 (defslimefun ed-in-emacs (&optional what)
1871 "Edit WHAT in Emacs.
1872
1873 WHAT can be:
1874 A pathname or a string,
1875 A list (PATHNAME-OR-STRING LINE [COLUMN]),
1876 A function name (symbol or cons),
1877 NIL.
1878
1879 Returns true if it actually called emacs, or NIL if not."
1880 (flet ((pathname-or-string-p (thing)
1881 (or (pathnamep thing) (typep thing 'string))))
1882 (let ((target
1883 (cond ((and (listp what) (pathname-or-string-p (first what)))
1884 (cons (canonicalize-filename (car what)) (cdr what)))
1885 ((pathname-or-string-p what)
1886 (canonicalize-filename what))
1887 ((symbolp what) what)
1888 ((consp what) what)
1889 (t (return-from ed-in-emacs nil)))))
1890 (cond
1891 (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
1892 ((default-connection)
1893 (with-connection ((default-connection))
1894 (send-oob-to-emacs `(:ed ,target))))
1895 (t nil)))))
1896
1897 (defslimefun inspect-in-emacs (what)
1898 "Inspect WHAT in Emacs."
1899 (flet ((send-it ()
1900 (with-buffer-syntax ()
1901 (reset-inspector)
1902 (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
1903 (cond
1904 (*emacs-connection*
1905 (send-it))
1906 ((default-connection)
1907 (with-connection ((default-connection))
1908 (send-it))))
1909 what))
1910
1911 (defslimefun value-for-editing (form)
1912 "Return a readable value of FORM for editing in Emacs.
1913 FORM is expected, but not required, to be SETF'able."
1914 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
1915 (with-buffer-syntax ()
1916 (prin1-to-string (eval (read-from-string form)))))
1917
1918 (defslimefun commit-edited-value (form value)
1919 "Set the value of a setf'able FORM to VALUE.
1920 FORM and VALUE are both strings from Emacs."
1921 (with-buffer-syntax ()
1922 (eval `(setf ,(read-from-string form)
1923 ,(read-from-string (concatenate 'string "`" value))))
1924 t))
1925
1926 (defun background-message (format-string &rest args)
1927 "Display a message in Emacs' echo area.
1928
1929 Use this function for informative messages only. The message may even
1930 be dropped, if we are too busy with other things."
1931 (when *emacs-connection*
1932 (send-to-emacs `(:background-message
1933 ,(apply #'format nil format-string args)))))
1934
1935
1936 ;;;; Debugger
1937
1938 (defun swank-debugger-hook (condition hook)
1939 "Debugger function for binding *DEBUGGER-HOOK*.
1940 Sends a message to Emacs declaring that the debugger has been entered,
1941 then waits to handle further requests from Emacs. Eventually returns
1942 after Emacs causes a restart to be invoked."
1943 (declare (ignore hook))
1944 (cond (*emacs-connection*
1945 (debug-in-emacs condition))
1946 ((default-connection)
1947 (with-connection ((default-connection))
1948 (debug-in-emacs condition)))))
1949
1950 (defvar *global-debugger* t
1951 "Non-nil means the Swank debugger hook will be installed globally.")
1952
1953 (add-hook *new-connection-hook* 'install-debugger)
1954 (defun install-debugger (connection)
1955 (declare (ignore connection))
1956 (when *global-debugger*
1957 (install-debugger-globally #'swank-debugger-hook)))
1958
1959 ;;;;; Debugger loop
1960 ;;;
1961 ;;; These variables are dynamically bound during debugging.
1962 ;;;
1963 (defvar *swank-debugger-condition* nil
1964 "The condition being debugged.")
1965
1966 (defvar *sldb-level* 0
1967 "The current level of recursive debugging.")
1968
1969 (defvar *sldb-initial-frames* 20
1970 "The initial number of backtrace frames to send to Emacs.")
1971
1972 (defvar *sldb-restarts* nil
1973 "The list of currenlty active restarts.")
1974
1975 (defvar *sldb-stepping-p* nil
1976 "True during execution of a step command.")
1977
1978 (defun debug-in-emacs (condition)
1979 (let ((*swank-debugger-condition* condition)
1980 (*sldb-restarts* (compute-sane-restarts condition))
1981 (*package* (or (and (boundp '*buffer-package*)
1982 (symbol-value '*buffer-package*))
1983 *package*))
1984 (*sldb-level* (1+ *sldb-level*))
1985 (*sldb-stepping-p* nil)
1986 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
1987 (force-user-output)
1988 (call-with-debugging-environment
1989 (lambda ()
1990 (with-bindings *sldb-printer-bindings*
1991 (sldb-loop *sldb-level*))))))
1992
1993 (defun sldb-loop (level)
1994 (unwind-protect
1995 (catch 'sldb-enter-default-debugger
1996 (send-to-emacs
1997 (list* :debug (current-thread) level
1998 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
1999 (loop (catch 'sldb-loop-catcher
2000 (with-simple-restart (abort "Return to sldb level ~D." level)
2001 (send-to-emacs (list :debug-activate (current-thread)
2002 level))
2003 (handler-bind ((sldb-condition #'handle-sldb-condition))
2004 (read-from-emacs))))))
2005 (send-to-emacs `(:debug-return
2006 ,(current-thread) ,level ,*sldb-stepping-p*))))
2007
2008 (defun handle-sldb-condition (condition)
2009 "Handle an internal debugger condition.
2010 Rather than recursively debug the debugger (a dangerous idea!), these
2011 conditions are simply reported."
2012 (let ((real-condition (original-condition condition)))
2013 (send-to-emacs `(:debug-condition ,(current-thread)
2014 ,(princ-to-string real-condition))))
2015 (throw 'sldb-loop-catcher nil))
2016
2017 (defun safe-condition-message (condition)
2018 "Safely print condition to a string, handling any errors during
2019 printing."
2020 (let ((*print-pretty* t))
2021 (handler-case
2022 (format-sldb-condition condition)
2023 (error (cond)
2024 ;; Beware of recursive errors in printing, so only use the condition
2025 ;; if it is printable itself:
2026 (format nil "Unable to display error condition~@[: ~A~]"
2027 (ignore-errors (princ-to-string cond)))))))
2028
2029 (defun debugger-condition-for-emacs ()
2030 (list (safe-condition-message *swank-debugger-condition*)
2031 (format nil " [Condition of type ~S]"
2032 (type-of *swank-debugger-condition*))
2033 (condition-extras *swank-debugger-condition*)))
2034
2035 (defun format-restarts-for-emacs ()
2036 "Return a list of restarts for *swank-debugger-condition* in a
2037 format suitable for Emacs."
2038 (let ((*print-right-margin* most-positive-fixnum))
2039 (loop for restart in *sldb-restarts*
2040 collect (list (princ-to-string (restart-name restart))
2041 (princ-to-string restart)))))
2042
2043
2044 ;;;;; SLDB entry points
2045
2046 (defslimefun sldb-break-with-default-debugger ()
2047 "Invoke the default debugger by returning from our debugger-loop."
2048 (throw 'sldb-enter-default-debugger nil))
2049
2050 (defslimefun backtrace (start end)
2051 "Return a list ((I FRAME) ...) of frames from START to END.
2052 I is an integer describing and FRAME a string."
2053 (loop for frame in (compute-backtrace start end)
2054 for i from start
2055 collect (list i (with-output-to-string (stream)
2056 (handler-case
2057 (print-frame frame stream)
2058 (t ()
2059 (format stream "[error printing frame]")))))))
2060
2061 (defslimefun debugger-info-for-emacs (start end)
2062 "Return debugger state, with stack frames from START to END.
2063 The result is a list:
2064 (condition ({restart}*) ({stack-frame}*) (cont*))
2065 where
2066 condition ::= (description type [extra])
2067 restart ::= (name description)
2068 stack-frame ::= (number description)
2069 extra ::= (:references and other random things)
2070 cont ::= continutation
2071 condition---a pair of strings: message, and type. If show-source is
2072 not nil it is a frame number for which the source should be displayed.
2073
2074 restart---a pair of strings: restart name, and description.
2075
2076 stack-frame---a number from zero (the top), and a printed
2077 representation of the frame's call.
2078
2079 continutation---the id of a pending Emacs continuation.
2080
2081 Below is an example return value. In this case the condition was a
2082 division by zero (multi-line description), and only one frame is being
2083 fetched (start=0, end=1).
2084
2085 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2086 Operation was KERNEL::DIVISION, operands (1 0).\"
2087 \"[Condition of type DIVISION-BY-ZERO]\")
2088 ((\"ABORT\" \"Return to Slime toplevel.\")
2089 (\"ABORT\" \"Return to Top-Level.\"))
2090 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
2091 (4))"
2092 (list (debugger-condition-for-emacs)
2093 (format-restarts-for-emacs)
2094 (backtrace start end)
2095 *pending-continuations*))
2096
2097 (defun nth-restart (index)
2098 (nth index *sldb-restarts*))
2099
2100 (defslimefun invoke-nth-restart (index)
2101 (invoke-restart-interactively (nth-restart index)))
2102
2103 (defslimefun sldb-abort ()
2104 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2105
2106 (defslimefun sldb-continue ()
2107 (continue))
2108
2109 (defslimefun throw-to-toplevel ()
2110 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2111 If we are not evaluating an RPC then ABORT instead."
2112 (let ((restart (find-restart *sldb-quit-restart*)))
2113 (cond (restart (invoke-restart restart))
2114 (t (format nil
2115 "Restart not found: ~a"
2116 *sldb-quit-restart*)))))
2117
2118 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2119 "Invoke the Nth available restart.
2120 SLDB-LEVEL is the debug level when the request was made. If this
2121 has changed, ignore the request."
2122 (when (= sldb-level *sldb-level*)
2123 (invoke-nth-restart n)))
2124
2125 (defun wrap-sldb-vars (form)
2126 `(let ((*sldb-level* ,*sldb-level*))
2127 ,form))
2128
2129 (defslimefun eval-string-in-frame (string index)
2130 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
2131 index)))
2132
2133 (defslimefun pprint-eval-string-in-frame (string index)
2134 (swank-pprint
2135 (multiple-value-list
2136 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
2137
2138 (defslimefun frame-locals-for-emacs (index)
2139 "Return a property list ((&key NAME ID VALUE) ...) describing
2140 the local variables in the frame INDEX."
2141 (mapcar (lambda (frame-locals)
2142 (destructuring-bind (&key name id value) frame-locals
2143 (list :name (prin1-to-string name) :id id
2144 :value (to-string value))))
2145 (frame-locals index)))
2146
2147 (defslimefun frame-catch-tags-for-emacs (frame-index)
2148 (mapcar #'to-string (frame-catch-tags frame-index)))
2149
2150 (defslimefun sldb-disassemble (index)
2151 (with-output-to-string (*standard-output*)
2152 (disassemble-frame index)))
2153
2154 (defslimefun sldb-return-from-frame (index string)
2155 (let ((form (from-string string)))
2156 (to-string (multiple-value-list (return-from-frame index form)))))
2157
2158 (defslimefun sldb-break (name)
2159 (with-buffer-syntax ()
2160 (sldb-break-at-start (read-from-string name))))
2161
2162 (defmacro define-stepper-function (name backend-function-name)
2163 `(defslimefun ,name (frame)
2164 (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
2165 (setq *sldb-stepping-p* t)
2166 (,backend-function-name))
2167 ((find-restart 'continue)
2168 (activate-stepping frame)
2169 (setq *sldb-stepping-p* t)
2170 (continue))
2171 (t
2172 (error "Not currently single-stepping, and no continue restart available.")))))
2173
2174 (define-stepper-function sldb-step sldb-step-into)
2175 (define-stepper-function sldb-next sldb-step-next)
2176 (define-stepper-function sldb-out sldb-step-out)
2177
2178
2179 ;;;; Compilation Commands.
2180
2181 (defvar *compiler-notes* '()
2182 "List of compiler notes for the last compilation unit.")
2183
2184 (defun clear-compiler-notes ()
2185 (setf *compiler-notes* '()))
2186
2187 (defun canonicalize-filename (filename)
2188 (namestring (truename filename)))
2189
2190 (defslimefun compiler-notes-for-emacs ()
2191 "Return the list of compiler notes for the last compilation unit."
2192 (reverse *compiler-notes*))
2193
2194 (defun measure-time-interval (fn)
2195 "Call FN and return the first return value and the elapsed time.
2196 The time is measured in microseconds."
2197 (declare (type function fn))
2198 (let ((before (get-internal-real-time)))
2199 (values
2200 (funcall fn)
2201 (* (- (get-internal-real-time) before)
2202 (/ 1000000 internal-time-units-per-second)))))
2203
2204 (defun record-note-for-condition (condition)
2205 "Record a note for a compiler-condition."
2206 (push (make-compiler-note condition) *compiler-notes*))
2207
2208 (defun make-compiler-note (condition)
2209 "Make a compiler note data structure from a compiler-condition."
2210 (declare (type compiler-condition condition))
2211 (list* :message (message condition)
2212 :severity (severity condition)
2213 :location (location condition)
2214 :references (references condition)
2215 (let ((s (short-message condition)))
2216 (if s (list :short-message s)))))
2217
2218 (defun swank-compiler (function)
2219 (clear-compiler-notes)
2220 (multiple-value-bind (result usecs)
2221 (with-simple-restart (abort "Abort SLIME compilation.")
2222 (handler-bind ((compiler-condition #'record-note-for-condition))
2223 (measure-time-interval function)))
2224 ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
2225 ;; unfortunately the SWANK protocol doesn't support returning multiple
2226 ;; values, so we gotta convert it explicitely to a list in either case.
2227 (if (and (not result) (eq usecs 't))
2228 (list nil nil)
2229 (list (to-string result)
2230 (format nil "~,2F" (/ usecs 1000000.0))))))
2231
2232 (defslimefun compile-file-for-emacs (filename load-p)
2233 "Compile FILENAME and, when LOAD-P, load the result.
2234 Record compiler notes signalled as `compiler-condition's."
2235 (with-buffer-syntax ()
2236 (let ((*compile-print* nil))
2237 (swank-compiler
2238 (lambda ()
2239 (swank-compile-file filename load-p
2240 (or (guess-external-format filename)
2241 :default)))))))
2242
2243 (defslimefun compile-string-for-emacs (string buffer position directory)
2244 "Compile STRING (exerpted from BUFFER at POSITION).
2245 Record compiler notes signalled as `compiler-condition's."
2246 (with-buffer-syntax ()
2247 (swank-compiler
2248 (lambda ()
2249 (let ((*compile-print* nil) (*compile-verbose* t))
2250 (swank-compile-string string :buffer buffer :position position
2251 :directory directory))))))
2252
2253 (defun file-newer-p (new-file old-file)
2254 "Returns true if NEW-FILE is newer than OLD-FILE."
2255 (> (file-write-date new-file) (file-write-date old-file)))
2256
2257 (defun requires-compile-p (source-file)
2258 (let ((fasl-file (probe-file (compile-file-pathname source-file))))
2259 (or (not fasl-file)
2260 (file-newer-p source-file fasl-file))))
2261
2262 (defslimefun compile-file-if-needed (filename loadp)
2263 (cond ((requires-compile-p filename)
2264 (compile-file-for-emacs filename loadp))
2265 (loadp
2266 (load (compile-file-pathname filename))
2267 nil)))
2268
2269
2270 ;;;; Loading
2271
2272 (defslimefun load-file (filename)
2273 (to-string (load filename)))
2274
2275 (defslimefun load-file-set-package (filename &optional package)
2276 (load-file filename)
2277 (if package
2278 (set-package package)))
2279
2280
2281 ;;;;; swank-require
2282
2283 (defslimefun swank-require (module &optional filename)
2284 "Load the module MODULE."
2285 (unless (member (string module) *modules* :key #'string=)
2286 (require module (or filename (module-filename module))))
2287 nil)
2288
2289 (defvar *find-module* 'find-module
2290 "Pluggable function to locate modules.
2291 The function receives a module name as argument and should return
2292 the filename of the module (or nil if the file doesn't exist).")
2293
2294 (defun module-filename (module)
2295 "Return the filename for the module MODULE."
2296 (or (funcall *find-module* module)
2297 (error "Can't locate module: ~s" module)))
2298
2299 ;;;;;; Simple *find-module* function.
2300
2301 (defun merged-directory (dirname defaults)
2302 (pathname-directory
2303 (merge-pathnames
2304 (make-pathname :directory `(:relative ,dirname) :defaults defaults)
2305 defaults)))
2306
2307 (defvar *load-path*
2308 (list (make-pathname :directory (merged-directory "contrib" *load-truename*)
2309 :name nil :type nil :version nil
2310 :defaults *load-truename*))
2311 "A list of directories to search for modules.")
2312
2313 (defun module-canditates (name dir)
2314 (list (compile-file-pathname (make-pathname :name name :defaults dir))
2315 (make-pathname :name name :type "lisp" :defaults dir)))
2316
2317 (defun find-module (module)
2318 (let ((name (string-downcase module)))
2319 (some (lambda (dir) (some #'probe-file (module-canditates name dir)))
2320 *load-path*)))
2321
2322
2323 ;;;; Macroexpansion
2324
2325 (defvar *macroexpand-printer-bindings*
2326 '((*print-circle* . nil)
2327 (*print-pretty* . t)
2328 (*print-escape* . t)
2329 (*print-lines* . nil)
2330 (*print-level* . nil)
2331 (*print-length* . nil)))
2332
2333 (defun apply-macro-expander (expander string)
2334 (with-buffer-syntax ()
2335 (with-bindings *macroexpand-printer-bindings*
2336 (prin1-to-string (funcall expander (from-string string))))))
2337
2338 (defslimefun swank-macroexpand-1 (string)
2339 (apply-macro-expander #'macroexpand-1 string))
2340
2341 (defslimefun swank-macroexpand (string)
2342 (apply-macro-expander #'macroexpand string))
2343
2344 (defslimefun swank-macroexpand-all (string)
2345 (apply-macro-expander #'macroexpand-all string))
2346
2347 (defslimefun swank-compiler-macroexpand-1 (string)
2348 (apply-macro-expander #'compiler-macroexpand-1 string))
2349
2350 (defslimefun swank-compiler-macroexpand (string)
2351 (apply-macro-expander #'compiler-macroexpand string))
2352
2353 (defslimefun disassemble-symbol (name)
2354 (with-buffer-syntax ()
2355 (with-output-to-string (*standard-output*)
2356 (let ((*print-readably* nil))
2357 (disassemble (fdefinition (from-string name)))))))
2358
2359
2360 ;;;; Simple completion
2361
2362 (defslimefun simple-completions (string buffer-package)
2363 "Return a list of completions for the string STRING."
2364 (let ((strings (all-completions string buffer-package #'prefix-match-p)))
2365 (list strings (longest-common-prefix strings))))
2366
2367 (defun all-completions (string buffer-package test)
2368 (multiple-value-bind (name pname intern) (tokenize-symbol string)
2369 (let* ((extern (and pname (not intern)))
2370 (pack (cond ((equal pname "") keyword-package)
2371 ((not pname) (guess-buffer-package buffer-package))
2372 (t (guess-package pname))))
2373 (test (lambda (sym) (funcall test name (unparse-symbol sym))))
2374 (syms (and pack (matching-symbols pack extern test))))
2375 (format-completion-set (mapcar #'unparse-symbol syms) intern pname))))
2376
2377 (defun matching-symbols (package external test)
2378 (let ((test (if external
2379 (lambda (s)
2380 (and (symbol-external-p s package)
2381 (funcall test s)))
2382 test))
2383 (result '()))
2384 (do-symbols (s package)
2385 (when (funcall test s)
2386 (push s result)))
2387 (remove-duplicates result)))
2388
2389 (defun unparse-symbol (symbol)
2390 (let ((*print-case* (case (readtable-case *readtable*)
2391 (:downcase :upcase)
2392 (t :downcase))))
2393 (unparse-name (symbol-name symbol))))
2394
2395 (defun prefix-match-p (prefix string)
2396 "Return true if PREFIX is a prefix of STRING."
2397 (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
2398
2399 (defun longest-common-prefix (strings)
2400 "Return the longest string that is a common prefix of STRINGS."
2401 (if (null strings)
2402 ""
2403 (flet ((common-prefix (s1 s2)
2404 (let ((diff-pos (mismatch s1 s2)))
2405 (if diff-pos (subseq s1 0 diff-pos) s1))))
2406 (reduce #'common-prefix strings))))
2407
2408 (defun format-completion-set (strings internal-p package-name)
2409 "Format a set of completion strings.
2410 Returns a list of completions with package qualifiers if needed."
2411 (mapcar (lambda (string) (untokenize-symbol package-name internal-p string))
2412 (sort strings #'string<)))
2413
2414
2415 ;;;; Simple arglist display
2416
2417 (defslimefun operator-arglist (name package)
2418 (ignore-errors
2419 (let ((args (arglist (parse-symbol name (guess-buffer-package package))))
2420 (*print-escape* nil))
2421 (cond ((eq args :not-available) nil)
2422 (t (format nil "(~a ~/pprint-fill/)" name args))))))
2423
2424
2425 ;;;; Documentation
2426
2427 (defslimefun apropos-list-for-emacs (name &optional external-only
2428 case-sensitive package)
2429 "Make an apropos search for Emacs.
2430 The result is a list of property lists."
2431 (let ((package (if package
2432 (or (parse-package package)
2433 (error "No such package: ~S" package)))))
2434 ;; The MAPCAN will filter all uninteresting symbols, i.e. those
2435 ;; who cannot be meaningfully described.
2436 (mapcan (listify #'briefly-describe-symbol-for-emacs)
2437 (sort (remove-duplicates
2438 (apropos-symbols name external-only case-sensitive package))
2439 #'present-symbol-before-p))))
2440
2441 (defun briefly-describe-symbol-for-emacs (symbol)
2442 "Return a property list describing SYMBOL.
2443 Like `describe-symbol-for-emacs' but with at most one line per item."
2444 (flet ((first-line (string)
2445 (let ((pos (position #\newline string)))
2446 (if (null pos) string (subseq string 0 pos)))))
2447 (let ((desc (map-if #'stringp #'first-line
2448 (describe-symbol-for-emacs symbol))))
2449 (if desc
2450 (list* :designator (to-string symbol) desc)))))
2451
2452 (defun map-if (test fn &rest lists)
2453 "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
2454 Example:
2455 \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
2456 (apply #'mapcar
2457 (lambda (x) (if (funcall test x) (funcall fn x) x))
2458 lists))
2459
2460 (defun listify (f)
2461 "Return a function like F, but which returns any non-null value
2462 wrapped in a list."
2463 (lambda (x)
2464 (let ((y (funcall f x)))
2465 (and y (list y)))))
2466
2467 (defun present-symbol-before-p (x y)
2468 "Return true if X belongs before Y in a printed summary of symbols.
2469 Sorted alphabetically by package name and then symbol name, except
2470 that symbols accessible in the current package go first."
2471 (declare (type symbol x y))
2472 (flet ((accessible (s)
2473 ;; Test breaks on NIL for package that does not inherit it
2474 (eq (find-symbol (symbol-name s) *buffer-package*) s)))
2475 (let ((ax (accessible x)) (ay (accessible y)))
2476 (cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
2477 (ax t)
2478 (ay nil)
2479 (t (let ((px (symbol-package x)) (py (symbol-package y)))
2480 (if (eq px py)
2481 (string< (symbol-name x) (symbol-name y))
2482 (string< (package-name px) (package-name py)))))))))
2483
2484 (let ((regex-hash (make-hash-table :test #'equal)))
2485 (defun compiled-regex (regex-string)
2486 (or (gethash regex-string regex-hash)
2487 (setf (gethash regex-string regex-hash)
2488 (if (zerop (length regex-string))
2489 (lambda (s) (check-type s string) t)
2490 (compile nil (slime-nregex:regex-compile regex-string)))))))
2491
2492 (defun make-regexp-matcher (string case-sensitive)
2493 (let* ((case-modifier (if case-sensitive #'string #'string-upcase))
2494 (regex (compiled-regex (funcall case-modifier string))))
2495 (lambda (symbol)
2496 (funcall regex (funcall case-modifier symbol)))))
2497
2498 (defun apropos-symbols (string external-only case-sensitive package)
2499 (let ((packages (or package (remove (find-package :keyword)
2500 (list-all-packages))))
2501 (matcher (make-regexp-matcher string case-sensitive))
2502 (result))
2503 (with-package-iterator (next packages :external :internal)
2504 (loop (multiple-value-bind (morep symbol) (next)
2505 (cond ((not morep) (return))
2506 ((and (if external-only (symbol-external-p symbol) t)
2507 (funcall matcher symbol))
2508 (push symbol result))))))
2509 result))
2510
2511 (defun call-with-describe-settings (fn)
2512 (let ((*print-readably* nil))
2513 (funcall fn)))
2514
2515 (defmacro with-describe-settings ((&rest _) &body body)
2516 (declare (ignore _))
2517 `(call-with-describe-settings (lambda () ,@body)))
2518
2519 (defun describe-to-string (object)
2520 (with-describe-settings ()
2521 (with-output-to-string (*standard-output*)
2522 (describe object))))
2523
2524 (defslimefun describe-symbol (symbol-name)
2525 (with-buffer-syntax ()
2526 (describe-to-string (parse-symbol-or-lose symbol-name))))
2527
2528 (defslimefun describe-function (name)
2529 (with-buffer-syntax ()
2530 (let ((symbol (parse-symbol-or-lose name)))
2531 (describe-to-string (or (macro-function symbol)
2532 (symbol-function symbol))))))
2533
2534 (defslimefun describe-definition-for-emacs (name kind)
2535 (with-buffer-syntax ()
2536 (with-describe-settings ()
2537 (with-output-to-string (*standard-output*)
2538 (describe-definition (parse-symbol-or-lose name) kind)))))
2539
2540 (defslimefun documentation-symbol (symbol-name &optional default)
2541 (with-buffer-syntax ()
2542 (multiple-value-bind (sym foundp) (parse-symbol symbol-name)
2543 (if foundp
2544 (let ((vdoc (documentation sym 'variable))
2545 (fdoc (documentation sym 'function)))
2546 (or (and (or vdoc fdoc)
2547 (concatenate 'string
2548 fdoc
2549 (and vdoc fdoc '(#\Newline #\Newline))
2550 vdoc))
2551 default))
2552 default))))
2553
2554
2555 ;;;; Package Commands
2556
2557 (defslimefun list-all-package-names (&optional nicknames)
2558 "Return a list of all package names.
2559 Include the nicknames if NICKNAMES is true."
2560 (mapcar #'unparse-name
2561 (if nicknames
2562 (mapcan #'package-names (list-all-packages))
2563 (mapcar #'package-name (list-all-packages)))))
2564
2565
2566 ;;;; Tracing
2567
2568 ;; Use eval for the sake of portability...
2569 (defun tracedp (fspec)
2570 (member fspec (eval '(trace))))
2571
2572 (defslimefun swank-toggle-trace (spec-string)
2573 (let ((spec (from-string spec-string)))
2574 (cond ((consp spec) ; handle complicated cases in the backend
2575 (toggle-trace spec))
2576 ((tracedp spec)
2577 (eval `(untrace ,spec))
2578 (format nil "~S is now untraced." spec))
2579 (t
2580 (eval `(trace ,spec))
2581 (format nil "~S is now traced." spec)))))
2582
2583 (defslimefun untrace-all ()
2584 (untrace))
2585
2586 (defslimefun redirect-trace-output (target)
2587 (setf (connection.trace-output *emacs-connection*)
2588 (make-output-stream-for-target *emacs-connection* target))
2589 nil)
2590
2591
2592 ;;;; Undefing
2593
2594 (defslimefun undefine-function (fname-string)
2595 (let ((fname (from-string fname-string)))
2596 (format nil "~S" (fmakunbound fname))))
2597
2598
2599 ;;;; Profiling
2600
2601 (defun profiledp (fspec)
2602 (member fspec (profiled-functions)))
2603
2604 (defslimefun toggle-profile-fdefinition (fname-string)
2605 (let ((fname (from-string fname-string)))
2606 (cond ((profiledp fname)
2607 (unprofile fname)
2608 (format nil "~S is now unprofiled." fname))
2609 (t
2610 (profile fname)
2611 (format nil "~S is now profiled." fname)))))
2612
2613
2614 ;;;; Source Locations
2615
2616 (defslimefun find-definitions-for-emacs (name)
2617 "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
2618 DSPEC is a string and LOCATION a source location. NAME is a string."
2619 (multiple-value-bind (sexp error)
2620 (ignore-errors (values (from-string name)))
2621 (unless error
2622 (loop for (dspec loc) in (find-definitions sexp)
2623 collect (list (to-string dspec) loc)))))
2624
2625 (defun alistify (list key test)
2626 "Partition the elements of LIST into an alist. KEY extracts the key
2627 from an element and TEST is used to compare keys."
2628 (declare (type function key))
2629 (let ((alist '()))
2630 (dolist (e list)
2631 (let* ((k (funcall key e))
2632 (probe (assoc k alist :test test)))
2633 (if probe
2634 (push e (cdr probe))
2635 (push (cons k (list e)) alist))))
2636 alist))
2637
2638 (defun location-position< (pos1 pos2)
2639 (cond ((and (position-p pos1) (position-p pos2))
2640 (< (position-pos pos1)
2641 (position-pos pos2)))
2642 (t nil)))
2643
2644 (defun partition (list test key)
2645 (declare (type function test key))
2646 (loop for e in list
2647 if (funcall test (funcall key e)) collect e into yes
2648 else collect e into no
2649 finally (return (values yes no))))
2650
2651 (defstruct (xref (:conc-name xref.)
2652 (:type list))
2653 dspec location)
2654
2655 (defun location-valid-p (location)
2656 (eq (car location) :location))
2657
2658 (defun xref-buffer (xref)
2659 (location-buffer (xref.location xref)))
2660
2661 (defun xref-position (xref)
2662 (location-buffer (xref.location xref)))
2663
2664 (defun group-xrefs (xrefs)
2665 "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
2666 The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
2667 (multiple-value-bind (resolved errors)
2668 (partition xrefs #'location-valid-p #'xref.location)
2669 (let ((alist (alistify resolved #'xref-buffer #'equal)))
2670 (append
2671 (loop for (buffer . list) in alist
2672 collect (cons (second buffer)
2673 (mapcar (lambda (xref)
2674 (cons (to-string (xref.dspec xref))
2675 (xref.location xref)))
2676 (sort list #'location-position<
2677 :key #'xref-position))))
2678 (if errors
2679 (list (cons "Unresolved"
2680 (mapcar (lambda (xref)
2681 (cons (to-string (xref.dspec xref))
2682 (xref.location xref)))
2683 errors))))))))
2684
2685 (defslimefun xref (type symbol-name)
2686 (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
2687 (group-xrefs
2688 (ecase type
2689 (:calls (who-calls symbol))
2690 (:calls-who (calls-who symbol))
2691 (:references (who-references symbol))
2692 (:binds (who-binds symbol))
2693 (:sets (who-sets symbol))
2694 (:macroexpands (who-macroexpands symbol))
2695 (:specializes (who-specializes symbol))
2696 (:callers (list-callers symbol))
2697 (:callees (list-callees symbol))))))
2698
2699
2700 ;;;; Inspecting
2701
2702 (defun common-seperated-spec (list &optional (callback (lambda (v)
2703 `(:value ,v))))
2704 (butlast
2705 (loop
2706 for i in list
2707 collect (funcall callback i)
2708 collect ", ")))
2709
2710 (defun inspector-princ (list)
2711 "Like princ-to-string, but don't rewrite (function foo) as #'foo.
2712 Do NOT pass circular lists to this function."
2713 (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
2714 (set-pprint-dispatch '(cons (member function)) nil)
2715 (princ-to-string list)))
2716
2717 (defmethod inspect-for-emacs ((object cons) inspector)
2718 (declare (ignore inspector))
2719 (if (consp (cdr object))
2720 (inspect-for-emacs-list object)
2721 (inspect-for-emacs-simple-cons object)))
2722
2723 (defun inspect-for-emacs-simple-cons (cons)
2724 (values "A cons cell."
2725 (label-value-line*
2726 ('car (car cons))
2727 ('cdr (cdr cons)))))
2728
2729 (defun inspect-for-emacs-list (list)
2730 (let ((maxlen 40))
2731 (multiple-value-bind (length tail) (safe-length list)
2732 (flet ((frob (title list)
2733 (let (lines)
2734 (loop for i from 0 for rest on list do
2735 (if (consp (cdr rest)) ; e.g. (A . (B . ...))
2736 (push (label-value-line i (car rest)) lines)
2737 (progn ; e.g. (A . NIL) or (A . B)
2738 (push (label-value-line i (car rest) :newline nil) lines)
2739 (when (cdr rest)
2740 (push '((:newline)) lines)
2741 (push (label-value-line ':tail () :newline nil) lines))
2742 (loop-finish)))
2743 finally
2744 (setf lines (reduce #'append (nreverse lines) :from-end t)))
2745 (values title (append '("Elements:" (:newline)) lines)))))
2746
2747 (cond ((not length) ; circular
2748 (frob "A circular list."
2749 (cons (car list)
2750 (ldiff (cdr list) list))))
2751 ((and (<= length maxlen) (not tail))
2752 (frob "A proper list." list))
2753 (tail
2754 (frob "An improper list." list))
2755 (t
2756