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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.735 - (show annotations)
Wed Jan 26 07:17:51 2011 UTC (3 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.734: +7 -5 lines
Allow tail-merging in call-with-bindings.

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