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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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