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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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