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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.741 - (show annotations)
Sun Mar 13 21:11:13 2011 UTC (3 years, 1 month ago) by sboukarev
Branch: MAIN
Changes since 1.740: +6 -2 lines
* swank.lisp (format-restarts-for-emacs): Add
without-printing-errors around restart printing.
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 (finish-output stream)
1129 (sleep *auto-flush-interval*)))
1130
1131 (defun find-repl-thread (connection)
1132 (cond ((not (use-threads-p))
1133 (current-thread))
1134 (t
1135 (let ((thread (connection.repl-thread connection)))
1136 (cond ((not thread) nil)
1137 ((thread-alive-p thread) thread)
1138 (t
1139 (setf (connection.repl-thread connection)
1140 (spawn-repl-thread connection "new-repl-thread"))))))))
1141
1142 (defun find-worker-thread (id)
1143 (etypecase id
1144 ((member t)
1145 (car *active-threads*))
1146 ((member :repl-thread)
1147 (find-repl-thread *emacs-connection*))
1148 (fixnum
1149 (find-thread id))))
1150
1151 (defun interrupt-worker-thread (id)
1152 (let ((thread (or (find-worker-thread id)
1153 (find-repl-thread *emacs-connection*)
1154 ;; FIXME: to something better here
1155 (spawn (lambda ()) :name "ephemeral"))))
1156 (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
1157 (assert thread)
1158 (cond ((use-threads-p)
1159 (interrupt-thread thread
1160 (lambda ()
1161 ;; safely interrupt THREAD
1162 (invoke-or-queue-interrupt #'simple-break))))
1163 (t (simple-break)))))
1164
1165 (defun thread-for-evaluation (id)
1166 "Find or create a thread to evaluate the next request."
1167 (let ((c *emacs-connection*))
1168 (etypecase id
1169 ((member t)
1170 (cond ((use-threads-p) (spawn-worker-thread c))
1171 (t (current-thread))))
1172 ((member :repl-thread)
1173 (find-repl-thread c))
1174 (fixnum
1175 (find-thread id)))))
1176
1177 (defun spawn-worker-thread (connection)
1178 (spawn (lambda ()
1179 (with-bindings *default-worker-thread-bindings*
1180 (with-top-level-restart (connection nil)
1181 (apply #'eval-for-emacs
1182 (cdr (wait-for-event `(:emacs-rex . _)))))))
1183 :name "worker"))
1184
1185 (defun spawn-repl-thread (connection name)
1186 (spawn (lambda ()
1187 (with-bindings *default-worker-thread-bindings*
1188 (repl-loop connection)))
1189 :name name))
1190
1191 (defun dispatch-event (event)
1192 "Handle an event triggered either by Emacs or within Lisp."
1193 (log-event "dispatch-event: ~s~%" event)
1194 (destructure-case event
1195 ((:emacs-rex form package thread-id id)
1196 (let ((thread (thread-for-evaluation thread-id)))
1197 (cond (thread
1198 (push thread *active-threads*)
1199 (send-event thread `(:emacs-rex ,form ,package ,id)))
1200 (t
1201 (encode-message
1202 (list :invalid-rpc id
1203 (format nil "Thread not found: ~s" thread-id))
1204 (current-socket-io))))))
1205 ((:return thread &rest args)
1206 (let ((tail (member thread *active-threads*)))
1207 (setq *active-threads* (nconc (ldiff *active-threads* tail)
1208 (cdr tail))))
1209 (encode-message `(:return ,@args) (current-socket-io)))
1210 ((:emacs-interrupt thread-id)
1211 (interrupt-worker-thread thread-id))
1212 (((:write-string
1213 :debug :debug-condition :debug-activate :debug-return :channel-send
1214 :presentation-start :presentation-end
1215 :new-package :new-features :ed :indentation-update
1216 :eval :eval-no-wait :background-message :inspect :ping
1217 :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
1218 &rest _)
1219 (declare (ignore _))
1220 (encode-message event (current-socket-io)))
1221 (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1222 (send-event (find-thread thread-id) (cons (car event) args)))
1223 ((:emacs-channel-send channel-id msg)
1224 (let ((ch (find-channel channel-id)))
1225 (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1226 ((:reader-error packet condition)
1227 (encode-message `(:reader-error ,packet
1228 ,(safe-condition-message condition))
1229 (current-socket-io)))))
1230
1231 (defvar *event-queue* '())
1232 (defvar *events-enqueued* 0)
1233
1234 (defun send-event (thread event)
1235 (log-event "send-event: ~s ~s~%" thread event)
1236 (cond ((use-threads-p) (send thread event))
1237 (t (setf *event-queue* (nconc *event-queue* (list event)))
1238 (setf *events-enqueued* (mod (1+ *events-enqueued*)
1239 most-positive-fixnum)))))
1240
1241 (defun send-to-emacs (event)
1242 "Send EVENT to Emacs."
1243 ;;(log-event "send-to-emacs: ~a" event)
1244 (cond ((use-threads-p)
1245 (send (connection.control-thread *emacs-connection*) event))
1246 (t (dispatch-event event))))
1247
1248 (defun wait-for-event (pattern &optional timeout)
1249 "Scan the event queue for PATTERN and return the event.
1250 If TIMEOUT is 'nil wait until a matching event is enqued.
1251 If TIMEOUT is 't only scan the queue without waiting.
1252 The second return value is t if the timeout expired before a matching
1253 event was found."
1254 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1255 (without-slime-interrupts
1256 (cond ((use-threads-p)
1257 (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1258 (t
1259 (wait-for-event/event-loop pattern timeout)))))
1260
1261 (defun wait-for-event/event-loop (pattern timeout)
1262 (assert (or (not timeout) (eq timeout t)))
1263 (loop
1264 (check-slime-interrupts)
1265 (let ((event (poll-for-event pattern)))
1266 (when event (return (car event))))
1267 (let ((events-enqueued *events-enqueued*)
1268 (ready (wait-for-input (list (current-socket-io)) timeout)))
1269 (cond ((and timeout (not ready))
1270 (return (values nil t)))
1271 ((or (/= events-enqueued *events-enqueued*)
1272 (eq ready :interrupt))
1273 ;; rescan event queue, interrupts may enqueue new events
1274 )
1275 (t
1276 (assert (equal ready (list (current-socket-io))))
1277 (dispatch-event (decode-message (current-socket-io))))))))
1278
1279 (defun poll-for-event (pattern)
1280 (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1281 *event-queue*)))
1282 (when tail
1283 (setq *event-queue* (nconc (ldiff *event-queue* tail)
1284 (cdr tail)))
1285 tail)))
1286
1287 ;;; FIXME: Make this use SWANK-MATCH.
1288 (defun event-match-p (event pattern)
1289 (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1290 (member pattern '(nil t)))
1291 (equal event pattern))
1292 ((symbolp pattern) t)
1293 ((consp pattern)
1294 (case (car pattern)
1295 ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1296 (t (and (consp event)
1297 (and (event-match-p (car event) (car pattern))
1298 (event-match-p (cdr event) (cdr pattern)))))))
1299 (t (error "Invalid pattern: ~S" pattern))))
1300
1301 (defun spawn-threads-for-connection (connection)
1302 (setf (connection.control-thread connection)
1303 (spawn (lambda () (control-thread connection))
1304 :name "control-thread"))
1305 connection)
1306
1307 (defun control-thread (connection)
1308 (with-struct* (connection. @ connection)
1309 (setf (@ control-thread) (current-thread))
1310 (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1311 :name "reader-thread"))
1312 (dispatch-loop connection)))
1313
1314 (defun cleanup-connection-threads (connection)
1315 (let ((threads (list (connection.repl-thread connection)
1316 (connection.reader-thread connection)
1317 (connection.control-thread connection)
1318 (connection.auto-flush-thread connection))))
1319 (dolist (thread threads)
1320 (when (and thread
1321 (thread-alive-p thread)
1322 (not (equal (current-thread) thread)))
1323 (kill-thread thread)))))
1324
1325 (defun repl-loop (connection)
1326 (handle-requests connection))
1327
1328 ;;;;;; Signal driven IO
1329
1330 (defun install-sigio-handler (connection)
1331 (add-sigio-handler (connection.socket-io connection)
1332 (lambda () (process-io-interrupt connection)))
1333 (handle-requests connection t))
1334
1335 (defvar *io-interupt-level* 0)
1336
1337 (defun process-io-interrupt (connection)
1338 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1339 (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1340 (invoke-or-queue-interrupt
1341 (lambda () (handle-requests connection t))))
1342 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1343
1344 (defun deinstall-sigio-handler (connection)
1345 (log-event "deinstall-sigio-handler...~%")
1346 (remove-sigio-handlers (connection.socket-io connection))
1347 (log-event "deinstall-sigio-handler...done~%"))
1348
1349 ;;;;;; SERVE-EVENT based IO
1350
1351 (defun install-fd-handler (connection)
1352 (add-fd-handler (connection.socket-io connection)
1353 (lambda () (handle-requests connection t)))
1354 (setf (connection.saved-sigint-handler connection)
1355 (install-sigint-handler
1356 (lambda ()
1357 (invoke-or-queue-interrupt
1358 (lambda () (dispatch-interrupt-event connection))))))
1359 (handle-requests connection t))
1360
1361 (defun dispatch-interrupt-event (connection)
1362 ;; This boils down to INTERRUPT-WORKER-THREAD which uses
1363 ;; USE-THREADS-P which needs *EMACS-CONNECTION*.
1364 (with-connection (connection)
1365 (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))
1366
1367 (defun deinstall-fd-handler (connection)
1368 (log-event "deinstall-fd-handler~%")
1369 (remove-fd-handlers (connection.socket-io connection))
1370 (install-sigint-handler (connection.saved-sigint-handler connection)))
1371
1372 ;;;;;; Simple sequential IO
1373
1374 (defun simple-serve-requests (connection)
1375 (unwind-protect
1376 (with-connection (connection)
1377 (call-with-user-break-handler
1378 (lambda ()
1379 (invoke-or-queue-interrupt
1380 (lambda () (dispatch-interrupt-event connection))))
1381 (lambda ()
1382 (with-simple-restart (close-connection "Close SLIME connection.")
1383 (let* ((stdin (real-input-stream *standard-input*))
1384 (*standard-input* (make-repl-input-stream connection
1385 stdin)))
1386 (tagbody toplevel
1387 (with-top-level-restart (connection (go toplevel))
1388 (simple-repl))))))))
1389 (close-connection connection nil (safe-backtrace))))
1390
1391 ;; this is signalled when our custom stream thinks the end-of-file is reached.
1392 ;; (not when the end-of-file on the socket is reached)
1393 (define-condition end-of-repl-input (end-of-file) ())
1394
1395 (defun simple-repl ()
1396 (loop
1397 (format t "~a> " (package-string-for-prompt *package*))
1398 (force-output)
1399 (let ((form (handler-case (read)
1400 (end-of-repl-input () (return)))))
1401 (let ((- form)
1402 (values (multiple-value-list (eval form))))
1403 (setq *** ** ** * * (car values)
1404 /// // // / / values
1405 +++ ++ ++ + + form)
1406 (cond ((null values) (format t "; No values~&"))
1407 (t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
1408
1409 (defun make-repl-input-stream (connection stdin)
1410 (make-input-stream
1411 (lambda () (repl-input-stream-read connection stdin))))
1412
1413 (defun repl-input-stream-read (connection stdin)
1414 (loop
1415 (let* ((socket (connection.socket-io connection))
1416 (inputs (list socket stdin))
1417 (ready (wait-for-input inputs)))
1418 (cond ((eq ready :interrupt)
1419 (check-slime-interrupts))
1420 ((member socket ready)
1421 ;; A Slime request from Emacs is pending; make sure to
1422 ;; redirect IO to the REPL buffer.
1423 (with-simple-restart (process-input "Continue reading input.")
1424 (let ((*sldb-quit-restart* (find-restart 'process-input)))
1425 (with-io-redirection (connection)
1426 (handle-requests connection t)))))
1427 ((member stdin ready)
1428 ;; User typed something into the *inferior-lisp* buffer,
1429 ;; so do not redirect.
1430 (return (read-non-blocking stdin)))
1431 (t (assert (null ready)))))))
1432
1433 (defun read-non-blocking (stream)
1434 (with-output-to-string (str)
1435 (handler-case
1436 (loop (let ((c (read-char-no-hang stream)))
1437 (unless c (return))
1438 (write-char c str)))
1439 (end-of-file () (error 'end-of-repl-input :stream stream)))))
1440
1441
1442 ;;;; IO to Emacs
1443 ;;;
1444 ;;; This code handles redirection of the standard I/O streams
1445 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1446 ;;; contains the appropriate streams, so all we have to do is make the
1447 ;;; right bindings.
1448
1449 ;;;;; Global I/O redirection framework
1450 ;;;
1451 ;;; Optionally, the top-level global bindings of the standard streams
1452 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1453 ;;; redirect the streams into the connection, and they keep going into
1454 ;;; that connection even if more are established. If the connection
1455 ;;; handling the streams closes then another is chosen, or if there
1456 ;;; are no connections then we revert to the original (real) streams.
1457 ;;;
1458 ;;; It is slightly tricky to assign the global values of standard
1459 ;;; streams because they are often shadowed by dynamic bindings. We
1460 ;;; solve this problem by introducing an extra indirection via synonym
1461 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1462 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1463 ;;; variables, so they can always be assigned to affect a global
1464 ;;; change.
1465
1466 (defvar *globally-redirect-io* nil
1467 "When non-nil globally redirect all standard streams to Emacs.")
1468
1469 ;;;;; Global redirection setup
1470
1471 (defvar *saved-global-streams* '()
1472 "A plist to save and restore redirected stream objects.
1473 E.g. the value for '*standard-output* holds the stream object
1474 for *standard-output* before we install our redirection.")
1475
1476 (defun setup-stream-indirection (stream-var &optional stream)
1477 "Setup redirection scaffolding for a global stream variable.
1478 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1479
1480 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1481
1482 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1483 *STANDARD-INPUT*.
1484
1485 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1486 *CURRENT-STANDARD-INPUT*.
1487
1488 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1489 effective global value for *STANDARD-INPUT*. This way we can assign
1490 the effective global value even when *STANDARD-INPUT* is shadowed by a
1491 dynamic binding."
1492 (let ((current-stream-var (prefixed-var '#:current stream-var))
1493 (stream (or stream (symbol-value stream-var))))
1494 ;; Save the real stream value for the future.
1495 (setf (getf *saved-global-streams* stream-var) stream)
1496 ;; Define a new variable for the effective stream.
1497 ;; This can be reassigned.
1498 (proclaim `(special ,current-stream-var))
1499 (set current-stream-var stream)
1500 ;; Assign the real binding as a synonym for the current one.
1501 (let ((stream (make-synonym-stream current-stream-var)))
1502 (set stream-var stream)
1503 (set-default-initial-binding stream-var `(quote ,stream)))))
1504
1505 (defun prefixed-var (prefix variable-symbol)
1506 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1507 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1508 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1509
1510 (defvar *standard-output-streams*
1511 '(*standard-output* *error-output* *trace-output*)
1512 "The symbols naming standard output streams.")
1513
1514 (defvar *standard-input-streams*
1515 '(*standard-input*)
1516 "The symbols naming standard input streams.")
1517
1518 (defvar *standard-io-streams*
1519 '(*debug-io* *query-io* *terminal-io*)
1520 "The symbols naming standard io streams.")
1521
1522 (defun init-global-stream-redirection ()
1523 (when *globally-redirect-io*
1524 (cond (*saved-global-streams*
1525 (warn "Streams already redirected."))
1526 (t
1527 (mapc #'setup-stream-indirection
1528 (append *standard-output-streams*
1529 *standard-input-streams*
1530 *standard-io-streams*))))))
1531
1532 (add-hook *after-init-hook* 'init-global-stream-redirection)
1533
1534 (defun globally-redirect-io-to-connection (connection)
1535 "Set the standard I/O streams to redirect to CONNECTION.
1536 Assigns *CURRENT-<STREAM>* for all standard streams."
1537 (dolist (o *standard-output-streams*)
1538 (set (prefixed-var '#:current o)
1539 (connection.user-output connection)))
1540 ;; FIXME: If we redirect standard input to Emacs then we get the
1541 ;; regular Lisp top-level trying to read from our REPL.
1542 ;;
1543 ;; Perhaps the ideal would be for the real top-level to run in a
1544 ;; thread with local bindings for all the standard streams. Failing
1545 ;; that we probably would like to inhibit it from reading while
1546 ;; Emacs is connected.
1547 ;;
1548 ;; Meanwhile we just leave *standard-input* alone.
1549 #+NIL
1550 (dolist (i *standard-input-streams*)
1551 (set (prefixed-var '#:current i)
1552 (connection.user-input connection)))
1553 (dolist (io *standard-io-streams*)
1554 (set (prefixed-var '#:current io)
1555 (connection.user-io connection))))
1556
1557 (defun revert-global-io-redirection ()
1558 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1559 (dolist (stream-var (append *standard-output-streams*
1560 *standard-input-streams*
1561 *standard-io-streams*))
1562 (set (prefixed-var '#:current stream-var)
1563 (getf *saved-global-streams* stream-var))))
1564
1565 ;;;;; Global redirection hooks
1566
1567 (defvar *global-stdio-connection* nil
1568 "The connection to which standard I/O streams are globally redirected.
1569 NIL if streams are not globally redirected.")
1570
1571 (defun maybe-redirect-global-io (connection)
1572 "Consider globally redirecting to CONNECTION."
1573 (when (and *globally-redirect-io* (null *global-stdio-connection*)
1574 (connection.user-io connection))
1575 (setq *global-stdio-connection* connection)
1576 (globally-redirect-io-to-connection connection)))
1577
1578 (defun update-redirection-after-close (closed-connection)
1579 "Update redirection after a connection closes."
1580 (check-type closed-connection connection)
1581 (when (eq *global-stdio-connection* closed-connection)
1582 (if (and (default-connection) *globally-redirect-io*)
1583 ;; Redirect to another connection.
1584 (globally-redirect-io-to-connection (default-connection))
1585 ;; No more connections, revert to the real streams.
1586 (progn (revert-global-io-redirection)
1587 (setq *global-stdio-connection* nil)))))
1588
1589 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1590
1591 ;;;;; Redirection during requests
1592 ;;;
1593 ;;; We always redirect the standard streams to Emacs while evaluating
1594 ;;; an RPC. This is done with simple dynamic bindings.
1595
1596 (defslimefun create-repl (target)
1597 (assert (eq target nil))
1598 (let ((conn *emacs-connection*))
1599 (initialize-streams-for-connection conn)
1600 (with-struct* (connection. @ conn)
1601 (setf (@ env)
1602 `((*standard-output* . ,(@ user-output))
1603 (*standard-input* . ,(@ user-input))
1604 (*trace-output* . ,(or (@ trace-output) (@ user-output)))
1605 (*error-output* . ,(@ user-output))
1606 (*debug-io* . ,(@ user-io))
1607 (*query-io* . ,(@ user-io))
1608 (*terminal-io* . ,(@ user-io))))
1609 (maybe-redirect-global-io conn)
1610 (when (use-threads-p)
1611 (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
1612 (list (package-name *package*)
1613 (package-string-for-prompt *package*)))))
1614
1615 (defun initialize-streams-for-connection (connection)
1616 (multiple-value-bind (dedicated in out io repl-results)
1617 (open-streams connection)
1618 (setf (connection.dedicated-output connection) dedicated
1619 (connection.user-io connection) io
1620 (connection.user-output connection) out
1621 (connection.user-input connection) in
1622 (connection.repl-results connection) repl-results)
1623 connection))
1624
1625
1626 ;;; Channels
1627
1628 (defvar *channels* '())
1629 (defvar *channel-counter* 0)
1630
1631 (defclass channel ()
1632 ((id :reader channel-id)
1633 (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1634 (name :initarg :name :initform nil)))
1635
1636 (defmethod initialize-instance ((ch channel) &rest initargs)
1637 (declare (ignore initargs))
1638 (call-next-method)
1639 (with-slots (id) ch
1640 (setf id (incf *channel-counter*))
1641 (push (cons id ch) *channels*)))
1642
1643 (defmethod print-object ((c channel) stream)
1644 (print-unreadable-object (c stream :type t)
1645 (with-slots (id name) c
1646 (format stream "~d ~a" id name))))
1647
1648 (defun find-channel (id)
1649 (cdr (assoc id *channels*)))
1650
1651 (defgeneric channel-send (channel selector args))
1652
1653 (defmacro define-channel-method (selector (channel &rest args) &body body)
1654 `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1655 (destructuring-bind ,args args
1656 . ,body)))
1657
1658 (defun send-to-remote-channel (channel-id msg)
1659 (send-to-emacs `(:channel-send ,channel-id ,msg)))
1660
1661 (defclass listener-channel (channel)
1662 ((remote :initarg :remote)
1663 (env :initarg :env)))
1664
1665 (defslimefun create-listener (remote)
1666 (let* ((pkg *package*)
1667 (conn *emacs-connection*)
1668 (ch (make-instance 'listener-channel
1669 :remote remote
1670 :env (initial-listener-bindings remote))))
1671
1672 (with-slots (thread id) ch
1673 (when (use-threads-p)
1674 (setf thread (spawn-listener-thread ch conn)))
1675 (list id
1676 (thread-id thread)
1677 (package-name pkg)
1678 (package-string-for-prompt pkg)))))
1679
1680 (defun initial-listener-bindings (remote)
1681 `((*package* . ,*package*)
1682 (*standard-output*
1683 . ,(make-listener-output-stream remote))
1684 (*standard-input*
1685 . ,(make-listener-input-stream remote))))
1686
1687 (defun spawn-listener-thread (channel connection)
1688 (spawn (lambda ()
1689 (with-connection (connection)
1690 (loop
1691 (destructure-case (wait-for-event `(:emacs-channel-send . _))
1692 ((:emacs-channel-send c (selector &rest args))
1693 (assert (eq c channel))
1694 (channel-send channel selector args))))))
1695 :name "swank-listener-thread"))
1696
1697 (define-channel-method :eval ((c listener-channel) string)
1698 (with-slots (remote env) c
1699 (let ((aborted t))
1700 (with-bindings env
1701 (unwind-protect
1702 (let* ((form (read-from-string string))
1703 (value (eval form)))
1704 (send-to-remote-channel remote
1705 `(:write-result
1706 ,(prin1-to-string value)))
1707 (setq aborted nil))
1708 (force-output)
1709 (setf env (loop for (sym) in env
1710 collect (cons sym (symbol-value sym))))
1711 (let ((pkg (package-name *package*))
1712 (prompt (package-string-for-prompt *package*)))
1713 (send-to-remote-channel remote
1714 (if aborted
1715 `(:evaluation-aborted ,pkg ,prompt)
1716 `(:prompt ,pkg ,prompt)))))))))
1717
1718 (defun make-listener-output-stream (remote)
1719 (make-output-stream (lambda (string)
1720 (send-to-remote-channel remote
1721 `(:write-string ,string)))))
1722
1723 (defun make-listener-input-stream (remote)
1724 (make-input-stream
1725 (lambda ()
1726 (force-output)
1727 (let ((tag (make-tag)))
1728 (send-to-remote-channel remote
1729 `(:read-string ,(current-thread-id) ,tag))
1730 (let ((ok nil))
1731 (unwind-protect
1732 (prog1 (caddr (wait-for-event
1733 `(:emacs-return-string ,tag value)))
1734 (setq ok t))
1735 (unless ok
1736 (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
1737
1738
1739
1740 (defun input-available-p (stream)
1741 ;; return true iff we can read from STREAM without waiting or if we
1742 ;; hit EOF
1743 (let ((c (read-char-no-hang stream nil :eof)))
1744 (cond ((not c) nil)
1745 ((eq c :eof) t)
1746 (t
1747 (unread-char c stream)
1748 t))))
1749
1750 (defvar *slime-features* nil
1751 "The feature list that has been sent to Emacs.")
1752
1753 (defun send-oob-to-emacs (object)
1754 (send-to-emacs object))
1755
1756 (defun force-user-output ()
1757 (force-output (connection.user-io *emacs-connection*)))
1758
1759 (add-hook *pre-reply-hook* 'force-user-output)
1760
1761 (defun clear-user-input ()
1762 (clear-input (connection.user-input *emacs-connection*)))
1763
1764 (defvar *tag-counter* 0)
1765
1766 (defun make-tag ()
1767 (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1768
1769 (defun read-user-input-from-emacs ()
1770 (let ((tag (make-tag)))
1771 (force-output)
1772 (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
1773 (let ((ok nil))
1774 (unwind-protect
1775 (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
1776 (setq ok t))
1777 (unless ok
1778 (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
1779
1780 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1781 "Like y-or-n-p, but ask in the Emacs minibuffer."
1782 (let ((tag (make-tag))
1783 (question (apply #'format nil format-string arguments)))
1784 (force-output)
1785 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1786 (third (wait-for-event `(:emacs-return ,tag result)))))
1787
1788 (defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
1789 "Ask user a question in Emacs' minibuffer. Returns \"\" when user
1790 entered nothing, returns NIL when user pressed C-g."
1791 (check-type prompt string) (check-type initial-value (or null string))
1792 (let ((tag (make-tag)))
1793 (force-output)
1794 (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
1795 ,prompt ,initial-value))
1796 (third (wait-for-event `(:emacs-return ,tag result)))))
1797
1798
1799 (defun process-form-for-emacs (form)
1800 "Returns a string which emacs will read as equivalent to
1801 FORM. FORM can contain lists, strings, characters, symbols and
1802 numbers.
1803
1804 Characters are converted emacs' ?<char> notaion, strings are left
1805 as they are (except for espacing any nested \" chars, numbers are
1806 printed in base 10 and symbols are printed as their symbol-name
1807 converted to lower case."
1808 (etypecase form
1809 (string (format nil "~S" form))
1810 (cons (format nil "(~A . ~A)"
1811 (process-form-for-emacs (car form))
1812 (process-form-for-emacs (cdr form))))
1813 (character (format nil "?~C" form))
1814 (symbol (concatenate 'string (when (eq (symbol-package form)
1815 #.(find-package "KEYWORD"))
1816 ":")
1817 (string-downcase (symbol-name form))))
1818 (number (let ((*print-base* 10))
1819 (princ-to-string form)))))
1820
1821 (defun eval-in-emacs (form &optional nowait)
1822 "Eval FORM in Emacs.
1823 `slime-enable-evaluate-in-emacs' should be set to T on the Emacs side."
1824 (cond (nowait
1825 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1826 (t
1827 (force-output)
1828 (let ((tag (make-tag)))
1829 (send-to-emacs `(:eval ,(current-thread-id) ,tag
1830 ,(process-form-for-emacs form)))
1831 (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1832 (destructure-case value
1833 ((:ok value) value)
1834 ((:error kind . data) (error "~a: ~{~a~}" kind data))
1835 ((:abort) (abort))))))))
1836
1837 (defvar *swank-wire-protocol-version* nil
1838 "The version of the swank/slime communication protocol.")
1839
1840 (defslimefun connection-info ()
1841 "Return a key-value list of the form:
1842 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1843 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1844 STYLE: the communication style
1845 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1846 FEATURES: a list of keywords
1847 PACKAGE: a list (&key NAME PROMPT)
1848 VERSION: the protocol version"
1849 (let ((c *emacs-connection*))
1850 (setq *slime-features* *features*)
1851 `(:pid ,(getpid) :style ,(connection.communication-style c)
1852 :encoding (:coding-system ,(connection.coding-system c)
1853 ;; external-formats are totally implementation-dependent,
1854 ;; so better play safe.
1855 :external-format ,(princ-to-string
1856 (connection.external-format c)))
1857 :lisp-implementation (:type ,(lisp-implementation-type)
1858 :name ,(lisp-implementation-type-name)
1859 :version ,(lisp-implementation-version)
1860 :program ,(lisp-implementation-program))
1861 :machine (:instance ,(machine-instance)
1862 :type ,(machine-type)
1863 :version ,(machine-version))
1864 :features ,(features-for-emacs)
1865 :modules ,*modules*
1866 :package (:name ,(package-name *package*)
1867 :prompt ,(package-string-for-prompt *package*))
1868 :version ,*swank-wire-protocol-version*)))
1869
1870 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1871 (let* ((s *standard-output*)
1872 (*trace-output* (make-broadcast-stream s *log-output*)))
1873 (time (progn
1874 (dotimes (i n)
1875 (format s "~D abcdefghijklm~%" i)
1876 (when (zerop (mod n m))
1877 (finish-output s)))
1878 (finish-output s)
1879 (when *emacs-connection*
1880 (eval-in-emacs '(message "done.")))))
1881 (terpri *trace-output*)
1882 (finish-output *trace-output*)
1883 nil))
1884
1885 (defun debug-on-swank-error ()
1886 (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
1887 *debug-on-swank-protocol-error*)
1888
1889 (defun (setf debug-on-swank-error) (new-value)
1890 (setf *debug-on-swank-protocol-error* new-value)
1891 (setf *debug-swank-backend* new-value))
1892
1893 (defslimefun toggle-debug-on-swank-error ()
1894 (setf (debug-on-swank-error) (not (debug-on-swank-error))))
1895
1896
1897 ;;;; Reading and printing
1898
1899 (define-special *buffer-package*
1900 "Package corresponding to slime-buffer-package.
1901
1902 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1903 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1904
1905 (define-special *buffer-readtable*
1906 "Readtable associated with the current buffer")
1907
1908 (defmacro with-buffer-syntax ((&optional package) &body body)
1909 "Execute BODY with appropriate *package* and *readtable* bindings.
1910
1911 This should be used for code that is conceptionally executed in an
1912 Emacs buffer."
1913 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1914
1915 (defun call-with-buffer-syntax (package fun)
1916 (let ((*package* (if package
1917 (guess-buffer-package package)
1918 *buffer-package*)))
1919 ;; Don't shadow *readtable* unnecessarily because that prevents
1920 ;; the user from assigning to it.
1921 (if (eq *readtable* *buffer-readtable*)
1922 (call-with-syntax-hooks fun)
1923 (let ((*readtable* *buffer-readtable*))
1924 (call-with-syntax-hooks fun)))))
1925
1926 (defmacro without-printing-errors ((&key object stream
1927 (msg "<<error printing object>>"))
1928 &body body)
1929 "Catches errors during evaluation of BODY and prints MSG instead."
1930 `(handler-case (progn ,@body)
1931 (serious-condition ()
1932 ,(cond ((and stream object)
1933 (let ((gstream (gensym "STREAM+")))
1934 `(let ((,gstream ,stream))
1935 (print-unreadable-object (,object ,gstream :type t :identity t)
1936 (write-string ,msg ,gstream)))))
1937 (stream
1938 `(write-string ,msg ,stream))
1939 (object
1940 `(with-output-to-string (s)
1941 (print-unreadable-object (,object s :type t :identity t)
1942 (write-string ,msg s))))
1943 (t msg)))))
1944
1945 (defun to-string (object)
1946 "Write OBJECT in the *BUFFER-PACKAGE*.
1947 The result may not be readable. Handles problems with PRINT-OBJECT methods
1948 gracefully."
1949 (with-buffer-syntax ()
1950 (let ((*print-readably* nil))
1951 (without-printing-errors (:object object :stream nil)
1952 (prin1-to-string object)))))
1953
1954 (defun from-string (string)
1955 "Read string in the *BUFFER-PACKAGE*"
1956 (with-buffer-syntax ()
1957 (let ((*read-suppress* nil))
1958 (values (read-from-string string)))))
1959
1960 (defun parse-string (string package)
1961 "Read STRING in PACKAGE."
1962 (with-buffer-syntax (package)
1963 (let ((*read-suppress* nil))
1964 (read-from-string string))))
1965
1966 ;; FIXME: deal with #\| etc. hard to do portably.
1967 (defun tokenize-symbol (string)
1968 "STRING is interpreted as the string representation of a symbol
1969 and is tokenized accordingly. The result is returned in three
1970 values: The package identifier part, the actual symbol identifier
1971 part, and a flag if the STRING represents a symbol that is
1972 internal to the package identifier part. (Notice that the flag is
1973 also true with an empty package identifier part, as the STRING is
1974 considered to represent a symbol internal to some current package.)"
1975 (let ((package (let ((pos (position #\: string)))
1976 (if pos (subseq string 0 pos) nil)))
1977 (symbol (let ((pos (position #\: string :from-end t)))
1978 (if pos (subseq string (1+ pos)) string)))
1979 (internp (not (= (count #\: string) 1))))
1980 (values symbol package internp)))
1981
1982 (defun tokenize-symbol-thoroughly (string)
1983 "This version of TOKENIZE-SYMBOL handles escape characters."
1984 (let ((package nil)
1985 (token (make-array (length string) :element-type 'character
1986 :fill-pointer 0))
1987 (backslash nil)
1988 (vertical nil)
1989 (internp nil))
1990 (loop for char across string do
1991 (cond
1992 (backslash
1993 (vector-push-extend char token)
1994 (setq backslash nil))
1995 ((char= char #\\) ; Quotes next character, even within |...|
1996 (setq backslash t))
1997 ((char= char #\|)
1998 (setq vertical (not vertical)))
1999 (vertical
2000 (vector-push-extend char token))
2001 ((char= char #\:)
2002 (cond ((and package internp)
2003 (return-from tokenize-symbol-thoroughly))
2004 (package
2005 (setq internp t))
2006 (t
2007 (setq package token
2008 token (make-array (length string)
2009 :element-type 'character
2010 :fill-pointer 0)))))
2011 (t
2012 (vector-push-extend (casify-char char) token))))
2013 (unless vertical
2014 (values token package (or (not package) internp)))))
2015
2016 (defun untokenize-symbol (package-name internal-p symbol-name)
2017 "The inverse of TOKENIZE-SYMBOL.
2018
2019 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
2020 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
2021 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
2022 "
2023 (cond ((not package-name) symbol-name)
2024 (internal-p (cat package-name "::" symbol-name))
2025 (t (cat package-name ":" symbol-name))))
2026
2027 (defun casify-char (char)
2028 "Convert CHAR accoring to readtable-case."
2029 (ecase (readtable-case *readtable*)
2030 (:preserve char)
2031 (:upcase (char-upcase char))
2032 (:downcase (char-downcase char))
2033 (:invert (if (upper-case-p char)
2034 (char-downcase char)
2035 (char-upcase char)))))
2036
2037
2038 (defun find-symbol-with-status (symbol-name status
2039 &optional (package *package*))
2040 (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
2041 (if (and flag (eq flag status))
2042 (values symbol flag)
2043 (values nil nil))))
2044
2045 (defun parse-symbol (string &optional (package *package*))
2046 "Find the symbol named STRING.
2047 Return the symbol and a flag indicating whether the symbols was found."
2048 (multiple-value-bind (sname pname internalp)
2049 (tokenize-symbol-thoroughly string)
2050 (when sname
2051 (let ((package (cond ((string= pname "") keyword-package)
2052 (pname (find-package pname))
2053 (t package))))
2054 (if package
2055 (multiple-value-bind (symbol flag)
2056 (if internalp
2057 (find-symbol sname package)
2058 (find-symbol-with-status sname ':external package))
2059 (values symbol flag sname package))
2060 (values nil nil nil nil))))))
2061
2062 (defun parse-symbol-or-lose (string &optional (package *package*))
2063 (multiple-value-bind (symbol status) (parse-symbol string package)
2064 (if status
2065 (values symbol status)
2066 (error "Unknown symbol: ~A [in ~A]" string package))))
2067
2068 (defun parse-package (string)
2069 "Find the package named STRING.
2070 Return the package or nil."
2071 ;; STRING comes usually from a (in-package STRING) form.
2072 (ignore-errors
2073 (find-package (let ((*package* *swank-io-package*))
2074 (read-from-string string)))))
2075
2076 (defun unparse-name (string)
2077 "Print the name STRING according to the current printer settings."
2078 ;; this is intended for package or symbol names
2079 (subseq (prin1-to-string (make-symbol string)) 2))
2080
2081 (defun guess-package (string)
2082 "Guess which package corresponds to STRING.
2083 Return nil if no package matches."
2084 (when string
2085 (or (find-package string)
2086 (parse-package string)
2087 (if (find #\! string) ; for SBCL
2088 (guess-package (substitute #\- #\! string))))))
2089
2090 (defvar *readtable-alist* (default-readtable-alist)
2091 "An alist mapping package names to readtables.")
2092
2093 (defun guess-buffer-readtable (package-name)
2094 (let ((package (guess-package package-name)))
2095 (or (and package
2096 (cdr (assoc (package-name package) *readtable-alist*
2097 :test #'string=)))
2098 *readtable*)))
2099
2100
2101 ;;;; Evaluation
2102
2103 (defvar *pending-continuations* '()
2104 "List of continuations for Emacs. (thread local)")
2105
2106 (defun guess-buffer-package (string)
2107 "Return a package for STRING.
2108 Fall back to the the current if no such package exists."
2109 (or (and string (guess-package string))
2110 *package*))
2111
2112 (defun eval-for-emacs (form buffer-package id)
2113 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2114 Return the result to the continuation ID.
2115 Errors are trapped and invoke our debugger."
2116 (let (ok result condition)
2117 (unwind-protect
2118 (let ((*buffer-package* (guess-buffer-package buffer-package))
2119 (*buffer-readtable* (guess-buffer-readtable buffer-package))
2120 (*pending-continuations* (cons id *pending-continuations*)))
2121 (check-type *buffer-package* package)
2122 (check-type *buffer-readtable* readtable)
2123 ;; APPLY would be cleaner than EVAL.
2124 ;; (setq result (apply (car form) (cdr form)))
2125 (handler-bind ((t (lambda (c) (setf condition c))))
2126 (setq result (with-slime-interrupts (eval form))))
2127 (run-hook *pre-reply-hook*)
2128 (setq ok t))
2129 (send-to-emacs `(:return ,(current-thread)
2130 ,(if ok
2131 `(:ok ,result)
2132 `(:abort ,(prin1-to-string condition)))
2133 ,id)))))
2134
2135 (defvar *echo-area-prefix* "=> "
2136 "A prefix that `format-values-for-echo-area' should use.")
2137
2138 (defun format-values-for-echo-area (values)
2139 (with-buffer-syntax ()
2140 (let ((*print-readably* nil))
2141 (cond ((null values) "; No value")
2142 ((and (integerp (car values)) (null (cdr values)))
2143 (let ((i (car values)))
2144 (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)"
2145 *echo-area-prefix*
2146 i (integer-length i) i i i)))
2147 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
2148
2149 (defmacro values-to-string (values)
2150 `(format-values-for-echo-area (multiple-value-list ,values)))
2151
2152 (defslimefun interactive-eval (string)
2153 (with-buffer-syntax ()
2154 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2155 (let ((values (multiple-value-list (eval (from-string string)))))
2156 (finish-output)
2157 (format-values-for-echo-area values)))))
2158
2159 (defslimefun eval-and-grab-output (string)
2160 (with-buffer-syntax ()
2161 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2162 (let* ((s (make-string-output-stream))
2163 (*standard-output* s)
2164 (values (multiple-value-list (eval (from-string string)))))
2165 (list (get-output-stream-string s)
2166 (format nil "~{~S~^~%~}" values))))))
2167
2168 (defun eval-region (string)
2169 "Evaluate STRING.
2170 Return the results of the last form as a list and as secondary value the
2171 last form."
2172 (with-input-from-string (stream string)
2173 (let (- values)
2174 (loop
2175 (let ((form (read stream nil stream)))
2176 (when (eq form stream)
2177 (finish-output)
2178 (return (values values -)))
2179 (setq - form)
2180 (setq values (multiple-value-list (eval form)))
2181 (finish-output))))))
2182
2183 (defslimefun interactive-eval-region (string)
2184 (with-buffer-syntax ()
2185 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2186 (format-values-for-echo-area (eval-region string)))))
2187
2188 (defslimefun re-evaluate-defvar (form)
2189 (with-buffer-syntax ()
2190 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2191 (let ((form (read-from-string form)))
2192 (destructuring-bind (dv name &optional value doc) form
2193 (declare (ignore value doc))
2194 (assert (eq dv 'defvar))
2195 (makunbound name)
2196 (prin1-to-string (eval form)))))))
2197
2198 (defvar *swank-pprint-bindings*
2199 `((*print-pretty* . t)
2200 (*print-level* . nil)
2201 (*print-length* . nil)
2202 (*print-circle* . t)
2203 (*print-gensym* . t)
2204 (*print-readably* . nil))
2205 "A list of variables bindings during pretty printing.
2206 Used by pprint-eval.")
2207
2208 (defun swank-pprint (values)
2209 "Bind some printer variables and pretty print each object in VALUES."
2210 (with-buffer-syntax ()
2211 (with-bindings *swank-pprint-bindings*
2212 (cond ((null values) "; No value")
2213 (t (with-output-to-string (*standard-output*)
2214 (dolist (o values)
2215 (pprint o)
2216 (terpri))))))))
2217
2218 (defslimefun pprint-eval (string)
2219 (with-buffer-syntax ()
2220 (let* ((s (make-string-output-stream))
2221 (values
2222 (let ((*standard-output* s)
2223 (*trace-output* s))
2224 (multiple-value-list (eval (read-from-string string))))))
2225 (cat (get-output-stream-string s)
2226 (swank-pprint values)))))
2227
2228 (defslimefun set-package (name)
2229 "Set *package* to the package named NAME.
2230 Return the full package-name and the string to use in the prompt."
2231 (let ((p (guess-package name)))
2232 (assert (packagep p) nil "Package ~a doesn't exist." name)
2233 (setq *package* p)
2234 (list (package-name p) (package-string-for-prompt p))))
2235
2236 ;;;;; Listener eval
2237
2238 (defvar *listener-eval-function* 'repl-eval)
2239
2240 (defslimefun listener-eval (string)
2241 (funcall *listener-eval-function* string))
2242
2243 (defvar *send-repl-results-function* 'send-repl-results-to-emacs)
2244
2245 (defun repl-eval (string)
2246 (clear-user-input)
2247 (with-buffer-syntax ()
2248 (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
2249 (track-package
2250 (lambda ()
2251 (multiple-value-bind (values last-form) (eval-region string)
2252 (setq *** ** ** * * (car values)
2253 /// // // / / values
2254 +++ ++ ++ + + last-form)
2255 (funcall *send-repl-results-function* values))))))
2256 nil)
2257
2258 (defun track-package (fun)
2259 (let ((p *package*))
2260 (unwind-protect (funcall fun)
2261 (unless (eq *package* p)
2262 (send-to-emacs (list :new-package (package-name *package*)
2263 (package-string-for-prompt *package*)))))))
2264
2265 (defun send-repl-results-to-emacs (values)
2266 (finish-output)
2267 (if (null values)
2268 (send-to-emacs `(:write-string "; No value" :repl-result))
2269 (dolist (v values)
2270 (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
2271 :repl-result)))))
2272
2273 (defun cat (&rest strings)
2274 "Concatenate all arguments and make the result a string."
2275 (with-output-to-string (out)
2276 (dolist (s strings)
2277 (etypecase s
2278 (string (write-string s out))
2279 (character (write-char s out))))))
2280
2281 (defun truncate-string (string width &optional ellipsis)
2282 (let ((len (length string)))
2283 (cond ((< len width) string)
2284 (ellipsis (cat (subseq string 0 width) ellipsis))
2285 (t (subseq string 0 width)))))
2286
2287 (defun call/truncated-output-to-string (length function
2288 &optional (ellipsis ".."))
2289 "Call FUNCTION with a new stream, return the output written to the stream.
2290 If FUNCTION tries to write more than LENGTH characters, it will be
2291 aborted and return immediately with the output written so far."
2292 (let ((buffer (make-string (+ length (length ellipsis))))
2293 (fill-pointer 0))
2294 (block buffer-full
2295 (flet ((write-output (string)
2296 (let* ((free (- length fill-pointer))
2297 (count (min free (length string))))
2298 (replace buffer string :start1 fill-pointer :end2 count)
2299 (incf fill-pointer count)
2300 (when (> (length string) free)
2301 (replace buffer ellipsis :start1 fill-pointer)
2302 (return-from buffer-full buffer)))))
2303 (let ((stream (make-output-stream #'write-output)))
2304 (funcall function stream)
2305 (finish-output stream)
2306 (subseq buffer 0 fill-pointer))))))
2307
2308 (defmacro with-string-stream ((var &key length bindings)
2309 &body body)
2310 (cond ((and (not bindings) (not length))
2311 `(with-output-to-string (,var) . ,body))
2312 ((not bindings)
2313 `(call/truncated-output-to-string
2314 ,length (lambda (,var) . ,body)))
2315 (t
2316 `(with-bindings ,bindings
2317 (with-string-stream (,var :length ,length)
2318 . ,body)))))
2319
2320 (defun to-line (object &optional (width 75))
2321 "Print OBJECT to a single line. Return the string."
2322 (without-printing-errors (:object object :stream nil)
2323 (with-string-stream (stream :length width)
2324 (write object :stream stream :right-margin width :lines 1))))
2325
2326 (defun escape-string (string stream &key length (map '((#\" . "\\\"")
2327 (#\\ . "\\\\"))))
2328 "Write STRING to STREAM surronded by double-quotes.
2329 LENGTH -- if non-nil truncate output after LENGTH chars.
2330 MAP -- rewrite the chars in STRING according to this alist."
2331 (let ((limit (or length array-dimension-limit)))
2332 (write-char #\" stream)
2333 (loop for c across string
2334 for i from 0 do
2335 (when (= i limit)
2336 (write-string "..." stream)
2337 (return))
2338 (let ((probe (assoc c map)))
2339 (cond (probe (write-string (cdr probe) stream))
2340 (t (write-char c stream)))))
2341 (write-char #\" stream)))
2342
2343 (defun package-string-for-prompt (package)
2344 "Return the shortest nickname (or canonical name) of PACKAGE."
2345 (unparse-name
2346 (or (canonical-package-nickname package)
2347 (auto-abbreviated-package-name package)
2348 (shortest-package-nickname package))))
2349
2350 (defun canonical-package-nickname (package)
2351 "Return the canonical package nickname, if any, of PACKAGE."
2352 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2353 :test #'string=))))
2354 (and name (string name))))
2355
2356 (defun auto-abbreviated-package-name (package)
2357 "Return an abbreviated 'name' for PACKAGE.
2358
2359 N.B. this is not an actual package name or nickname."
2360 (when *auto-abbreviate-dotted-packages*
2361 (loop with package-name = (package-name package)
2362 with offset = nil
2363 do (let ((last-dot-pos (position #\. package-name :end offset :from-end t)))
2364 (unless last-dot-pos
2365 (return nil))
2366 ;; If a dot chunk contains only numbers, that chunk most
2367 ;; likely represents a version number; so we collect the
2368 ;; next chunks, too, until we find one with meat.
2369 (let ((name (subseq package-name (1+ last-dot-pos) offset)))
2370 (if (notevery #'digit-char-p name)
2371 (return (subseq package-name (1+ last-dot-pos)))
2372 (setq offset last-dot-pos)))))))
2373
2374 (defun shortest-package-nickname (package)
2375 "Return the shortest nickname of PACKAGE."
2376 (loop for name in (cons (package-name package) (package-nicknames package))
2377 for shortest = name then (if (< (length name) (length shortest))
2378 name
2379 shortest)
2380 finally (return shortest)))
2381
2382 (defslimefun ed-in-emacs (&optional what)
2383 "Edit WHAT in Emacs.
2384
2385 WHAT can be:
2386 A pathname or a string,
2387 A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION),
2388 A function name (symbol or cons),
2389 NIL. "
2390 (flet ((canonicalize-filename (filename)
2391 (pathname-to-filename (or (probe-file filename) filename))))
2392 (let ((target
2393 (etypecase what
2394 (null nil)
2395 ((or string pathname)
2396 `(:filename ,(canonicalize-filename what)))
2397 ((cons (or string pathname) *)
2398 `(:filename ,(canonicalize-filename (car what)) ,@(cdr what)))
2399 ((or symbol cons)
2400 `(:function-name ,(prin1-to-string what))))))
2401 (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
2402 ((default-connection)
2403 (with-connection ((default-connection))
2404 (send-oob-to-emacs `(:ed ,target))))
2405 (t (error "No connection"))))))
2406
2407 (defslimefun inspect-in-emacs (what &key wait)
2408 "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the
2409 inspector has been closed in Emacs."
2410 (flet ((send-it ()
2411 (let ((tag (when wait (make-tag)))
2412 (thread (when wait (current-thread-id))))
2413 (with-buffer-syntax ()
2414 (reset-inspector)
2415 (send-oob-to-emacs `(:inspect ,(inspect-object what)
2416 ,thread
2417 ,tag)))
2418 (when wait
2419 (wait-for-event `(:emacs-return ,tag result))))))
2420 (cond
2421 (*emacs-connection*
2422 (send-it))
2423 ((default-connection)
2424 (with-connection ((default-connection))
2425 (send-it))))
2426 what))
2427
2428 (defslimefun value-for-editing (form)
2429 "Return a readable value of FORM for editing in Emacs.
2430 FORM is expected, but not required, to be SETF'able."
2431 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2432 (with-buffer-syntax ()
2433 (let* ((value (eval (read-from-string form)))
2434 (*print-length* nil))
2435 (prin1-to-string value))))
2436
2437 (defslimefun commit-edited-value (form value)
2438 "Set the value of a setf'able FORM to VALUE.
2439 FORM and VALUE are both strings from Emacs."
2440 (with-buffer-syntax ()
2441 (eval `(setf ,(read-from-string form)
2442 ,(read-from-string (concatenate 'string "`" value))))
2443 t))
2444
2445 (defun background-message (format-string &rest args)
2446 "Display a message in Emacs' echo area.
2447
2448 Use this function for informative messages only. The message may even
2449 be dropped, if we are too busy with other things."
2450 (when *emacs-connection*
2451 (send-to-emacs `(:background-message
2452 ,(apply #'format nil format-string args)))))
2453
2454 ;; This is only used by the test suite.
2455 (defun sleep-for (seconds)
2456 "Sleep for at least SECONDS seconds.
2457 This is just like cl:sleep but guarantees to sleep
2458 at least SECONDS."
2459 (let* ((start (get-internal-real-time))
2460 (end (+ start
2461 (* seconds internal-time-units-per-second))))
2462 (loop
2463 (let ((now (get-internal-real-time)))
2464 (cond ((< end now) (return))
2465 (t (sleep (/ (- end now)
2466 internal-time-units-per-second))))))))
2467
2468
2469 ;;;; Debugger
2470
2471 (defun invoke-slime-debugger (condition)
2472 "Sends a message to Emacs declaring that the debugger has been entered,
2473 then waits to handle further requests from Emacs. Eventually returns
2474 after Emacs causes a restart to be invoked."
2475 (without-slime-interrupts
2476 (cond (*emacs-connection*
2477 (debug-in-emacs condition))
2478 ((default-connection)
2479 (with-connection ((default-connection))
2480 (debug-in-emacs condition))))))
2481
2482 (define-condition invoke-default-debugger () ())
2483
2484 (defun swank-debugger-hook (condition hook)
2485 "Debugger function for binding *DEBUGGER-HOOK*."
2486 (declare (ignore hook))
2487 (handler-case
2488 (call-with-debugger-hook #'swank-debugger-hook
2489 (lambda () (invoke-slime-debugger condition)))
2490 (invoke-default-debugger ()
2491 (invoke-default-debugger condition))))
2492
2493 (defun invoke-default-debugger (condition)
2494 (call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
2495
2496 (defvar *global-debugger* t
2497 "Non-nil means the Swank debugger hook will be installed globally.")
2498
2499 (add-hook *new-connection-hook* 'install-debugger)
2500 (defun install-debugger (connection)
2501 (declare (ignore connection))
2502 (when *global-debugger*
2503 (install-debugger-globally #'swank-debugger-hook)))
2504
2505 ;;;;; Debugger loop
2506 ;;;
2507 ;;; These variables are dynamically bound during debugging.
2508 ;;;
2509 (defvar *swank-debugger-condition* nil
2510 "The condition being debugged.")
2511
2512 (defvar *sldb-level* 0
2513 "The current level of recursive debugging.")
2514
2515 (defvar *sldb-initial-frames* 20
2516 "The initial number of backtrace frames to send to Emacs.")
2517
2518 (defvar *sldb-restarts* nil
2519 "The list of currenlty active restarts.")
2520
2521 (defvar *sldb-stepping-p* nil
2522 "True during execution of a step command.")
2523
2524 (defun debug-in-emacs (condition)
2525 (let ((*swank-debugger-condition* condition)
2526 (*sldb-restarts* (compute-restarts condition))
2527 (*sldb-quit-restart* (and *sldb-quit-restart*
2528 (find-restart *sldb-quit-restart*)))
2529 (*package* (or (and (boundp '*buffer-package*)
2530 (symbol-value '*buffer-package*))
2531 *package*))
2532 (*sldb-level* (1+ *sldb-level*))
2533 (*sldb-stepping-p* nil))
2534 (force-user-output)
2535 (call-with-debugging-environment
2536 (lambda ()
2537 ;; We used to have (WITH-BINDING *SLDB-PRINTER-BINDINGS* ...)
2538 ;; here, but that truncated the result of an eval-in-frame.
2539 (sldb-loop *sldb-level*)))))
2540
2541 (defun sldb-loop (level)
2542 (unwind-protect
2543 (loop
2544 (with-simple-restart (abort "Return to sldb level ~D." level)
2545 (send-to-emacs
2546 (list* :debug (current-thread-id) level
2547 (with-bindings *sldb-printer-bindings*
2548 (debugger-info-for-emacs 0 *sldb-initial-frames*))))
2549 (send-to-emacs
2550 (list :debug-activate (current-thread-id) level nil))
2551 (loop
2552 (handler-case
2553 (destructure-case (wait-for-event
2554 `(or (:emacs-rex . _)
2555 (:sldb-return ,(1+ level))))
2556 ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
2557 ((:sldb-return _) (declare (ignore _)) (return nil)))
2558 (sldb-condition (c)
2559 (handle-sldb-condition c))))))
2560 (send-to-emacs `(:debug-return
2561 ,(current-thread-id) ,level ,*sldb-stepping-p*))
2562 (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
2563 (when (> level 1)
2564 (send-event (current-thread) `(:sldb-return ,level)))))
2565
2566 (defun handle-sldb-condition (condition)
2567 "Handle an internal debugger condition.
2568 Rather than recursively debug the debugger (a dangerous idea!), these
2569 conditions are simply reported."
2570 (let ((real-condition (original-condition condition)))
2571 (send-to-emacs `(:debug-condition ,(current-thread-id)
2572 ,(princ-to-string real-condition)))))
2573
2574 (defvar *sldb-condition-printer* #'format-sldb-condition
2575 "Function called to print a condition to an SLDB buffer.")
2576
2577 (defun safe-condition-message (condition)
2578 "Safely print condition to a string, handling any errors during
2579 printing."
2580 (let ((*print-pretty* t) (*print-right-margin* 65))
2581 (handler-case
2582 (funcall *sldb-condition-printer* condition)
2583 (error (cond)
2584 ;; Beware of recursive errors in printing, so only use the condition
2585 ;; if it is printable itself:
2586 (format nil "Unable to display error condition~@[: ~A~]"
2587 (ignore-errors (princ-to-string cond)))))))
2588
2589 (defun debugger-condition-for-emacs ()
2590 (list (safe-condition-message *swank-debugger-condition*)
2591 (format nil " [Condition of type ~S]"
2592 (type-of *swank-debugger-condition*))
2593 (condition-extras *swank-debugger-condition*)))
2594
2595 (defun format-restarts-for-emacs ()
2596 "Return a list of restarts for *swank-debugger-condition* in a
2597 format suitable for Emacs."
2598 (let ((*print-right-margin* most-positive-fixnum))
2599 (loop for restart in *sldb-restarts* collect
2600 (list (format nil "~:[~;*~]~a"
2601 (eq restart *sldb-quit-restart*)
2602 (restart-name restart))
2603 (with-output-to-string (stream)
2604 (without-printing-errors (:object restart
2605 :stream stream
2606 :msg "<<error printing restart>>")
2607 (princ restart stream)))))))
2608
2609 ;;;;; SLDB entry points
2610
2611 (defslimefun sldb-break-with-default-debugger (dont-unwind)
2612 "Invoke the default debugger."
2613 (cond (dont-unwind
2614 (invoke-default-debugger *swank-debugger-condition*))
2615 (t
2616 (signal 'invoke-default-debugger))))
2617
2618 (defslimefun backtrace (start end)
2619 "Return a list ((I FRAME PLIST) ...) of frames from START to END.
2620
2621 I is an integer, and can be used to reference the corresponding frame
2622 from Emacs; FRAME is a string representation of an implementation's
2623 frame."
2624 (loop for frame in (compute-backtrace start end)
2625 for i from start collect
2626 (list* i (frame-to-string frame)
2627 (ecase (frame-restartable-p frame)
2628 ((nil) nil)
2629 ((t) `((:restartable t)))))))
2630
2631 (defun frame-to-string (frame)
2632 (with-string-stream (stream :length (* (or *print-lines* 1)
2633 (or *print-right-margin* 100))
2634 :bindings *backtrace-printer-bindings*)
2635 (handler-case (print-frame frame stream)
2636 (serious-condition ()
2637 (format stream "[error printing frame]")))))
2638
2639 (defslimefun debugger-info-for-emacs (start end)
2640 "Return debugger state, with stack frames from START to END.
2641 The result is a list:
2642 (condition ({restart}*) ({stack-frame}*) (cont*))
2643 where
2644 condition ::= (description type [extra])
2645 restart ::= (name description)
2646 stack-frame ::= (number description [plist])
2647 extra ::= (:references and other random things)
2648 cont ::= continutation
2649 plist ::= (:restartable {nil | t | :unknown})
2650
2651 condition---a pair of strings: message, and type. If show-source is
2652 not nil it is a frame number for which the source should be displayed.
2653
2654 restart---a pair of strings: restart name, and description.
2655
2656 stack-frame---a number from zero (the top), and a printed
2657 representation of the frame's call.
2658
2659 continutation---the id of a pending Emacs continuation.
2660
2661 Below is an example return value. In this case the condition was a
2662 division by zero (multi-line description), and only one frame is being
2663 fetched (start=0, end=1).
2664
2665 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2666 Operation was KERNEL::DIVISION, operands (1 0).\"
2667 \"[Condition of type DIVISION-BY-ZERO]\")
2668 ((\"ABORT\" \"Return to Slime toplevel.\")
2669 (\"ABORT\" \"Return to Top-Level.\"))
2670 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
2671 (4))"
2672 (list (debugger-condition-for-emacs)
2673 (format-restarts-for-emacs)
2674 (backtrace start end)
2675 *pending-continuations*))
2676
2677 (defun nth-restart (index)
2678 (nth index *sldb-restarts*))
2679
2680 (defslimefun invoke-nth-restart (index)
2681 (let ((restart (nth-restart index)))
2682 (when restart
2683 (invoke-restart-interactively restart))))
2684
2685 (defslimefun sldb-abort ()
2686 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2687
2688 (defslimefun sldb-continue ()
2689 (continue))
2690
2691 (defun coerce-to-condition (datum args)
2692 (etypecase datum
2693 (string (make-condition 'simple-error :format-control datum
2694 :format-arguments args))
2695 (symbol (apply #'make-condition datum args))))
2696
2697 (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
2698 (with-simple-restart (continue "Continue from break.")
2699 (invoke-slime-debugger (coerce-to-condition datum args))))
2700
2701 (defslimefun throw-to-toplevel ()
2702 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2703 If we are not evaluating an RPC then ABORT instead."
2704 (let ((restart (and *sldb-quit-restart* (find-restart *sldb-quit-restart*))))
2705 (cond (restart (invoke-restart restart))
2706 (t (format nil "Restart not active [~s]" *sldb-quit-restart*)))))
2707
2708 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2709 "Invoke the Nth available restart.
2710 SLDB-LEVEL is the debug level when the request was made. If this
2711 has changed, ignore the request."
2712 (when (= sldb-level *sldb-level*)
2713 (invoke-nth-restart n)))
2714
2715 (defun wrap-sldb-vars (form)
2716 `(let ((*sldb-level* ,*sldb-level*))
2717 ,form))
2718
2719 (defslimefun eval-string-in-frame (string index)
2720 (values-to-string
2721 (eval-in-frame (wrap-sldb-vars (from-string string))
2722 index)))
2723
2724 (defslimefun pprint-eval-string-in-frame (string index)