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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.748 - (show annotations)
Thu Jun 16 08:29:17 2011 UTC (2 years, 10 months ago) by nsiivola
Branch: MAIN
Changes since 1.747: +3 -16 lines
macro-indentation: try to sort it out

 * Restore old default.

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