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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.553 - (show annotations)
Wed Aug 6 19:51:29 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.552: +71 -34 lines
Queue interrupts in various places.

* swank-backend.lisp (*pending-slime-interrupts*): New variable.
(check-slime-interrupts): New function.

* swank-lispworks.lisp (receive-if): Use it.

* swank-sbcl.lisp, swank-openmcl.lisp: Ditto.

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