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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.556 - (show annotations)
Fri Aug 8 19:42:51 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.555: +126 -167 lines
Unify event dispatching for single and multi-threaded cases.

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