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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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