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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.509 - (show annotations)
Tue Sep 4 10:32:05 2007 UTC (6 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.508: +0 -44 lines
Move asdf support to contrib.

* swank-backend.lisp (operate-on-system): Moved to
swank-asdf.lisp. It wasn't specialized in any backend.

* swank.lisp (operate-on-system-for-emacs)
(list-all-systems-known-to-asdf, list-asdf-systems): Moved to
swank-asdf.lisp.

* slime.el: Move asdf commands to contrib slime-adsf.el.

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