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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.692 - (show annotations)
Wed Mar 3 11:56:35 2010 UTC (4 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.691: +12 -11 lines
Make eval-in-frame display multiple values; not only the first.

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