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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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